Hmpf (empty) → 0.1
raw patch · 20 files changed
+2024/−0 lines, 20 filesdep +ConfigFiledep +Cryptodep +HTTPbuild-type:Customsetup-changed
Dependencies added: ConfigFile, Crypto, HTTP, base, mtl, network, time, unix, utf8-string
Files
- Hmpf.cabal +25/−0
- LICENCE +25/−0
- README +29/−0
- Setup.lhs +4/−0
- hmpf.conf.sample +11/−0
- src/Hmpf/ApplicationTypes.hs +75/−0
- src/Hmpf/AudioScrobbler.hs +181/−0
- src/Hmpf/Config.hs +105/−0
- src/Hmpf/Control.hs +137/−0
- src/Hmpf/Keys.hs +70/−0
- src/Hmpf/LCDProc.hs +249/−0
- src/Hmpf/LIRC.hs +87/−0
- src/Hmpf/MPD.hs +301/−0
- src/Hmpf/MPDSession.hs +115/−0
- src/Hmpf/Monitor.hs +70/−0
- src/Hmpf/RelatedArtist.hs +131/−0
- src/Hmpf/Tree.hs +104/−0
- src/Hmpf/UTF8Stream.hs +34/−0
- src/Hmpf/Util.hs +63/−0
- src/Main.hs +208/−0
+ Hmpf.cabal view
@@ -0,0 +1,25 @@+Name: Hmpf+Version: 0.1+License: GPL+Maintainer: Thomas L. Bevan <thomas.bevan@gmail.com>+Author: Thomas L. Bevan+License-file: LICENCE+extra-source-files: README, hmpf.conf.sample, src/Hmpf/ApplicationTypes.hs, src/Hmpf/AudioScrobbler.hs, + src/Hmpf/Config.hs, src/Hmpf/Control.hs, src/Hmpf/Keys.hs, src/Hmpf/LCDProc.hs, + src/Hmpf/LIRC.hs, src/Hmpf/MPD.hs, src/Hmpf/MPDSession.hs, src/Hmpf/Monitor.hs, + src/Hmpf/RelatedArtist.hs, src/Hmpf/Tree.hs, src/Hmpf/UTF8Stream.hs, src/Hmpf/Util.hs+Category: Application+Build-Depends: base, Crypto, time, HTTP, network, ConfigFile, mtl, unix,+ utf8-string+Synopsis: An MPD client designed for a Home Theatre PC+Description: An MPD client designed to be used on a Home Theatre PC equipt with an infrared remote+ and VDU display. + .+ Hmpf is designed to allow the user to navigate through a large digital music collection with+ a standard infrared remote and VDU. The client does not need or accept input from the keyboard+ .+ Hmpf also implements the LastFM protocol and is able to intelligently generate dynamic playlists++Executable: hmpf+Main-is: Main.hs+hs-source-dirs: src
+ LICENCE view
@@ -0,0 +1,25 @@+Hmpf+Copyright (C) 2007 Thomas L. Bevan <thomas.bevan@gmail.com>++All code is under the following license unless otherwise noted:+ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU Lesser General Public License as published by+ the Free Software Foundation; either version 2.1 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA++The GNU Lesser General Public License is available in the file COPYING in the+source distribution. Debian GNU/Linux users may find this in+/usr/share/common-licenses/GPL-2.++If the LGPL is unacceptable for your uses, please e-mail me; alternative+terms can be negotiated for your project.+
+ README view
@@ -0,0 +1,29 @@+Description:++Hmpf is an MPD client designed to play music on a Home Theatre PC.+The PC should have an infrared remote and VDU display.++Hmpf allows a large music collection to be browsed with a standard remote.+It also contains a LastFM client to update your listening history to the LastFM+servers. Finally, as a last touch Hmpf is able to dynamically generate new entries+for a playlist based on style of tracks already selected.++Dependencies:++Hmpf relies on a running MPD server, LIRC and LCDProc.++Configuration:++Hmpf is configured by a configuration file that is expected to be place at /etc/hmpf.conf+Look at the sample configuration for more details.++To Do:++Hmpf works nicely for me and seems fairly robust. However, more documentation+of the source files is required. The code which manages the display also+assumes a 2 x 16 display window. Finally, the way the input code is organised+it is fairly specific to the LIRC configuration I have chosen for my reomte. If+any interest is shown in the application I might rectify these shortcomings.+++Hope you enjoy it.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ hmpf.conf.sample view
@@ -0,0 +1,11 @@+#Location and port of the MPD server+mpd.host = 10.1.1.4+mpd.port = 6600+#Location and port of the LCDProc daemon+lcd.port = 13666+lcd.host = 10.1.1.4+#LastFM credentials+lastfm.uid = youruser+lastfm.pwd = yourpassword+#The lirc device node+lirc.socket = /dev/lircd
+ src/Hmpf/ApplicationTypes.hs view
@@ -0,0 +1,75 @@+{- Defines a number of types used throughout the application.+ - Also overides the 'get' and 'set' functions from the + - Control.Monad.State package to allow transparent access+ - to the state MVar+ -}+module Hmpf.ApplicationTypes where ++import Control.Concurrent (ThreadId,myThreadId)+import Control.Concurrent.MVar+import qualified Control.Monad.State as S+import System.Posix.Types (EpochTime)+import System.IO (Handle,stdin)+import Network.URI ( URI )+import Network.Socket ( PortNumber )++data AppState = State {+ lcdSocket :: Handle+ ,scheduler :: MVar MonitorState+ ,musicMonitor :: ThreadId + ,scrobble :: Maybe Scrobble+ ,generate :: Bool+ ,cache :: MVar ([String],[String],[String])+ ,mpdConf :: MVar (String,PortNumber)+ ,lcdConf :: (String,PortNumber)+ ,lastfmUser :: Maybe (String, String)+ ,lircConf :: FilePath+ ,timer :: Int+ }++type Session a = S.StateT (MVar AppState) IO a++type Action = ( EpochTime , ( String , Session ()) )++data MonitorState = MonitorState {+ pending :: [Action]+ , thread :: ThreadId+ }++-- uri , token , interval+type Scrobble = ( URI , String , Int )+++mpdConfDefault = ("10.1.1.4", toEnum 6600 :: PortNumber )+lcdConfDefault = ("10.1.1.4", toEnum 13666 :: PortNumber )++empty :: IO (MVar AppState)+empty = do+ threadid <- myThreadId+ m <- newMVar (MonitorState [] threadid)+ cch <- newMVar ([],[],[])+ mpdC <- newMVar mpdConfDefault+ newMVar (State stdin m threadid Nothing False cch mpdC lcdConfDefault Nothing "/dev/lircd" 0 )++lower :: Session a -> Session ( IO a )+lower fn = do+ mvar <- S.get+ return ( ( S.runStateT fn mvar) >>= (return . fst) )++get :: Session AppState+get = do+ mvar <- S.get+ S.lift $ readMVar mvar++put :: AppState -> Session ()+put st = do+ mvar <- S.get+ S.lift $ swapMVar mvar st+ return ()++lift :: IO a -> Session a+lift = S.lift+++data Switch = Off | On+ deriving ( Show , Eq , Enum )
+ src/Hmpf/AudioScrobbler.hs view
@@ -0,0 +1,181 @@+{- Implements the AudioScrobbler HTTP protocol 1.1.+ - The function scrobbler monitor starts a thread which+ - monitors the MPD player and sends new songs to MPD + - as per the protocol.+ -}+module Hmpf.AudioScrobbler (scrobblermonitor) where+++import Network.Browser+import Network.HTTP+import Network.URI+import Numeric+import Data.Maybe+import Data.Digest.MD5+import Codec.Utils+import Data.List (intersperse, splitAt)+import Data.Char (toLower)+import System.Locale (defaultTimeLocale)+import Data.Time hiding ( utc )+import Hmpf.MPDSession+import Control.Concurrent ( threadDelay)+import Hmpf.ApplicationTypes+++scrobblermonitor :: Session ()+scrobblermonitor = do+ st <- get+ case ( lastfmUser st ) of+ Nothing -> lift ( putStrLn "No Last.Fm user configured. Playlist will not be sent to Last.Fm" )+ Just uid -> (lift (putStrLn $ "Playlist will be sent to Last.Fm for '"++(fst uid)++"'" )) >> (scrobblermonitor' Nothing)++scrobblermonitor' :: Maybe Int -> Session ()+scrobblermonitor' ms = do+ lift $ threadDelay 10000000+ st <- status + let sid = songid $ st+ e = elapsed $ st+ d = duration $ st+ diff = do -- Is the current song and last song updated different?+ i <- ms+ i' <- sid+ if( i /= i' )+ then return i'+ else fail "No new song"+ cond = do -- Is the current song ready to be updated?+ e' <- e+ d' <- d+ if ( e' > 240 || ( e' >0 && d' `div` e' < 2 && d' > 30 ) )+ then return True+ else fail "Not ready to be updated"+ if ( isNothing ms ) + then if ( isNothing cond )+ then scrobblermonitor' Nothing+ else do + Just cs <- currentsong+ tm <- lift getCurrentTime+ b <- submit [(cs,tm)]+ let t = title cs+ a = artist cs+ lift . putStrLn $ a ++ "/" ++ t ++ ": submitted - " ++ ( show b )+ scrobblermonitor' sid + else if ( isNothing diff )+ then scrobblermonitor' ms+ else scrobblermonitor' Nothing+++submit :: [(Song,UTCTime)] -> Session Bool+submit songs = do+ st <- get+ case ( scrobble st) of + Nothing -> ( handshake >> (submit' songs) )+ _ -> submit' songs++utc :: FormatTime a => a -> String+utc = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"++host = "post.audioscrobbler.com"++server = fromJust . parseURI $ "http://post.audioscrobbler.com/?hs=true&p=1.1&c=tst&v=1.0&u=mihochan"++req = Request server GET [] ""+++submit' :: [ (Song, UTCTime) ] -> Session Bool+submit' songs = do+ st <- get+ let + Just (uri,tkn,i) = scrobble st+ Just (uid,passwd) = lastfmUser st+ headers = [ Header HdrContentType "application/x-www-form-urlencoded"+ , Header HdrContentLength (show . length $ query)+ ]+ params = p ++ (concatMap mkParams (zip [0..] songs) )+ query = concat . intersperse "&" . map (\(a,b) -> (a ++ "=" ++ b)) $ params+ f = escapeURIString isUnreserved+ p = [ ( "u" , uid ), ( "s" , tkn ) ]+ mkParams :: (Int, ( Song , UTCTime)) -> [ (String,String) ]+ mkParams (i, (song,t)) = + [ ( "a[" ++ (show i) ++ "]" , art )+ , ( "t[" ++ (show i) ++ "]" , trck )+ , ( "b[" ++ (show i) ++ "]" , alb )+ , ( "m[" ++ (show i) ++ "]" , "" )+ , ( "l[" ++ (show i) ++ "]" , lngth )+ , ( "i[" ++ (show i) ++ "]" , tm ) ]+ where+ tm = f $ utc t+ art = f $ artist song+ alb = f $ album song+ trck = f $ title song+ lngth = show . time $ song+ lift ( threadDelay (i * 1000000 ) )+ result <- lift $ simpleHTTP ( Request uri POST headers query )+ case result of + Left err -> (lift . putStrLn . show $ err) >> return False+ Right resp -> do+ let ls = lines . rspBody $ resp+ newinterval = (read . last . words $ ( ls !! 1)) :: Int+ outcome = head . words . head $ ls + msg = unwords . tail . words . head $ ls + case ( head . words . head $ ls ) of+ "OK" -> put ( st { scrobble = Just (uri,tkn,i) } ) >> return True+ "FAILED" -> (lift . putStrLn $ msg ) >> put ( st { scrobble = Just (uri,tkn,i) } ) >> return False+ "BADAUTH" -> (lift . putStrLn $ "BADAUTH" ) >> put ( st { scrobble = Nothing } ) >> return False+ _ -> (lift. mapM_ putStrLn $ ls ) >> put ( st { scrobble = Nothing } ) >> return False++++handshake :: Session ()+handshake = do + st <- get+ result <- lift (simpleHTTP req)+ case result of+ Left err -> do+ put ( st { scrobble = Nothing } )+ lift . putStrLn . show $ err+ return ()+ Right resp -> do+ let challenge = body !! 1+ uri = fromJust . parseURI . ( !!2 ) $ body+ body = lines . rspBody $ resp+ interval = read . last . words $ ( body !! 3 )+ tkn = token challenge (snd . fromJust . lastfmUser $ st)+ put ( st { scrobble = Just ( uri , tkn , interval ) } )+ lift . putStrLn $ "Completed handshake"+++--Generate a token for a given password and challenge+token :: String -> String -> String+token challenge password = + let md5 = map toLower . toHex . hash . convert+ p = md5 password+ in md5 $ p ++ challenge+++--Converts an ordinary string into a list of Octets+convert :: String -> [Octet]+convert = map (toEnum . fromEnum) ++--Converts a HEX representation into a list of Octets+fromHex :: String -> [Octet]+fromHex = foldr ( \i -> \lst -> (f i) : lst ) [] . pair+ where+ f :: String -> Octet+ f n = let result = readHex n+ in case result of+ [(val,"")] -> toEnum val+ _ -> error "Failed to parse"++--Convert a list of Octets into a HEX string representation+toHex :: [Octet] -> String+toHex = foldr (f.fromEnum) []+ where+ f x = let f' = showHex x+ in \i -> if x < 0x10+ then '0' : f' i+ else f' i++pair :: [a] -> [[a]]+pair [] = []+pair xs | length xs `mod` 2 == 1 = [head xs] : ( pair . tail $ xs )+pair (x:y:xs) = [x,y] : ( pair xs )
+ src/Hmpf/Config.hs view
@@ -0,0 +1,105 @@+{-+ - Load application configuration from a config file.+ -}++module Hmpf.Config ( load ) where++import Data.ConfigFile+import Control.Concurrent.MVar (swapMVar)+import Control.Monad.Error+import Network.Socket (PortNumber)+import qualified Hmpf.ApplicationTypes as S+++defaultlocations = [ "~/.hmpf.conf" , "/etc/hmpf.conf" ]+++--Known properties+lirc = "lirc.socket"+mpdhost = "mpd.host"+mpdport = "mpd.port"+lcdhost = "lcd.host"+lcdport = "lcd.port"+lastuid = "lastfm.uid"+lastpass = "lastfm.pwd"+++load :: FilePath -> S.Session ()+load f = do+ st <- S.get+ m' <- m+ case m' of+ Left _ -> lift $ putStrLn "MPD not configured. Using defaults"+ Right x -> do+ let mv = S.mpdConf st+ lift (swapMVar mv x)+ return ()+ --S.put st { S.mpdConf = }+ l' <- l+ case l' of+ Left _ -> lift $ putStrLn "LCD not configured. Using defaults"+ Right x -> S.put st { S.lcdConf = x }+ r' <- r+ case r' of+ Left _ -> lift $ putStrLn "LIRC not configured. Using defaults"+ Right x -> S.put st { S.lircConf = x }+ lf' <- lf+ case lf' of+ Left _ -> lift $ putStrLn "Last.FM user not configured."+ Right x -> S.put st { S.lastfmUser = x }+ + where+ m = lift $ runErrorT ( getMPDConfig f )+ l = lift $ runErrorT ( getLCDConfig f )+ r = lift $ runErrorT ( getLIRCConfig f )+ lf = lift $ runErrorT ( getLastFM f )+++--getProperty p = msum . map (getProperty' p) +getProperty p [f] = (getProperty' p f)+getProperty p (f:fs) = + (getProperty' p f) `mplus` (getProperty p fs)++getProperty' p f = do+ load'+ where+ loadFile = catch (readFile f >>= return . Right )+ (\e -> return . Left . show $ e )+ load' = do + cts <- liftIO loadFile+ case cts of+ Right cp -> do+ cp <- readstring emptyCP cp+ val <- get cp "DEFAULT" p+ -- lift (putStr p >> putStrLn (show val) )+ return val+ Left err -> do+ -- lift (putStr p >> putStrLn err)+ fail err++getLIRCConfig file = do+ dev <- getProperty lirc files+ return (dev :: FilePath )+ where+ files = ( file : defaultlocations )++getLastFM file = do+ uid <- getProperty lastuid files+ pwd <- getProperty lastpass files+ return $ Just (uid :: String , pwd :: String)+ where+ files = ( file : defaultlocations )++getLCDConfig file = do+ host <- getProperty lcdhost files+ port <- getProperty lcdport files+ return (host :: String , (toEnum port) :: PortNumber)+ where+ files = ( file : defaultlocations )++getMPDConfig file = do+ host <- getProperty mpdhost files+ port <- getProperty mpdport files+ return (host :: String , (toEnum port) :: PortNumber)+ where+ files = ( file : defaultlocations )
+ src/Hmpf/Control.hs view
@@ -0,0 +1,137 @@+{-+ - Exports a number of functions for selecting from a list+ - using a remote control as the input and a LIRC display.+ - 'selectByList' allows the using to scroll through a list+ - of values.+ - 'selector' uses a more sophisticated predictive text method.+ -}+module Hmpf.Control ( selectByList + , songMonitor + , selector ) where++import Hmpf.MPDSession+import Hmpf.Tree+import Hmpf.LIRC+import Hmpf.LCDProc+import Hmpf.Keys+import Hmpf.ApplicationTypes+import Data.Maybe (isNothing,fromJust)+import Control.Concurrent+import Hmpf.Monitor+import qualified Hmpf.Util as U+++eol = (toEnum 0) :: Char++selector :: [String] -> Session (Maybe String)+selector xs = do+ let lst = map ( ++ [eol,eol] ) xs+ select . nextChoice . mkTree build $ lst++selectByList :: [String] -> Session (Maybe Int)+--selectByList :: [String] -> Session (Maybe String)+selectByList = sl 0+ where+ sl i lst = do+ selectList lst i + k <- lirc+ case k of + VolUp -> sl next lst+ VolDown -> sl previous lst+ Enter -> (return . Just $ i )+ -- Enter -> (return . Just . ( !! i ) $ lst)+ Esc -> (return Nothing)+ _ -> sl i lst+ where+ next = (i+1) `mod` l+ previous = (l + i - 1) `mod` l+ l = length lst++select :: Tree Char -> Session (Maybe String)+select tree | isRoot tree = return Nothing+select tree | isLeaf tree = do+ let selected = reverse . tail . tail . path $ tree+ general selected "=========================="+ lift ( putStr ">>" )+ lift (putStrLn selected )+ k <- lirc+ case k of+ Esc -> select (previousChoice tree)+ Enter -> (return . Just $ selected)+ _ -> select tree+select tree | otherwise = do+ let selected = reverse . tail . path $ tree+ choices = map ( fromEOL . fromJust . val) . branches . up $ tree+ i = index tree+ l = (length . branches . up $ tree )+ next = ( i + 1 ) `mod` l+ previous = ( l + i - 1 ) `mod` l+ fromEOL = \c -> case c == eol of+ True -> '^'+ False -> c+ lift ( putStrLn selected )+ let (left,right) = splitAt i choices+ lift ( putStr left )+ lift ( putStr $ '[':(head right):"]" )+ lift ( putStrLn . tail $ right )+ alphabet selected choices i + k <- lirc+ case k of+ Esc -> select (previousChoice tree)+ Enter -> select (nextChoice tree)+ VolUp -> select . ( !! next ) . branches . up $ tree+ VolDown -> select . ( !! previous ) . branches . up $ tree+ MultiMon -> do + let lst = subset . up $ tree+ result <- selectByList lst+ let val = do+ i <- result+ return ( lst !! i )+ case val of+ Nothing -> select tree+ x -> return x+ _ -> select tree+ +nextChoice :: Tree a -> Tree a +nextChoice tree | isLeaf tree = tree+nextChoice tree | (length . branches $ tree) == 1 = nextChoice . head . branches $ tree+ | otherwise = head . branches $ tree++previousChoice :: Tree a -> Tree a+previousChoice = pc . up + where + pc tree | isRoot tree = tree+ pc tree | (length . branches . up $ tree) < 2 = previousChoice tree+ pc tree | otherwise = tree+ + +-- Generate a list of possible entries from this point in the tree+subset :: Tree a -> [[a]]+subset tr = + case branches tr of+ [] -> [ reverse . tail . tail . path $ tr ]+ xs -> concat . map subset $ xs++-- Update the music screen continuously+songMonitor :: Session ()+songMonitor = do+ st <- status+ case (state st) of+ "play" -> do+ Just sng <- currentsong+ music (artist sng) + (title sng) + (maybe 0 id (elapsed $ st) )+ (maybe 0 id (duration $ st) )+ ((+1) . maybe 0 id . song $ st) + (maybe 1 id (playlistlength $ st) )+ "pause" -> return ()+ "stop" -> do+ t <- lift U.time+ musicBanner "" (" " ++ t)+ return ()+ lift . threadDelay $ 300000+ songMonitor+++
+ src/Hmpf/Keys.hs view
@@ -0,0 +1,70 @@+{-+ - All the keys defined by the LIRC remote control+ - This is specific to the configuration of my remote.+ -}+module Hmpf.Keys where+ +data Key = + One |+ Two |+ Three | + Four |+ Five |+ Six |+ Seven |+ Eight |+ Nine |+ Zero |+ AppExit | + Power | + Record | + Play | + Open | + Rewind | + Pause | + FastForward | + PrevChapter | + Stop | + NextChapter | + Esc | + Eject | + AppLauncher | + MultiMon | + TaskSwitcher | + Mute | + VolUp | + VolDown | + ChUp | + ChDown | + Timer | + ShiftTab | + Tab | + Red | + Green | + Blue | + Yellow | + Bookmark | + Thumbnail | + AspectRatio | + FullScreen | + Purple | + Menu | + Caption | + Language | + MouseKeyboard | + SelectSpace | + MouseMenu | + MouseRightClick | + Enter | + MouseLeftClick | + WindowsKey | + Backspace | + Mouse_N | + Mouse_S | + Mouse_W | + Mouse_E |+ Clockwise |+ AntiClockwise |+ Wheel |+ DoubleWheel+ deriving (Eq , Show , Read )
+ src/Hmpf/LCDProc.hs view
@@ -0,0 +1,249 @@+{-+ - Module responsible for managing the LCD display.+ - 'initialize' registers a number of different screens+ - with the LCDProc daemon.+ -}+module Hmpf.LCDProc (initialize+ , selectList + , closeSession+ , music + , musicBanner + , showMusic+ , percent+ , alphabet+ , general+ , alert ) where++import Hmpf.Util (clock)+import Hmpf.ApplicationTypes+import Network+import System.IO+import Control.Concurrent.MVar+import Data.List+import Control.Concurrent+import System.Posix.Time+import System.Posix.Types+import System.Time+import Control.Concurrent.MVar ( newEmptyMVar )+import qualified Hmpf.Monitor as M++-- host = "10.1.1.4"+-- port = PortNumber 13666+++initialize :: Session ()+initialize = do+ state <- get+ let (host, port) = lcdConf state+ h <- lift (connectTo host (PortNumber port))+ lift (hSetBuffering h LineBuffering)+ lift (hPutStrLn h "hello")+ resp <- lift (hGetLine h)+ {-+ let ws = words resp+ width = read . ( !! 7 ) $ ws+ height = read . ( !! 9 ) $ ws+ -}+ put (state { lcdSocket = h })+ mkAlert >> mkSelectList >> mkMusic >> mkPercent >> mkAlphabet >> mkGeneral++closeSession :: a -> Session a+closeSession x = do+ get >>= ( lift . hClose . lcdSocket )+ return x+++send :: String -> Session ()+send cmd = do+ putLCDLn cmd++putLCDLn :: String -> Session () +putLCDLn cmd = do+ h <- get >>= ( return . lcdSocket )+ lift $ hPutStrLn h cmd+ resp <- getLCDLn+ return ()++getLCDLn :: Session String+getLCDLn = do+ h <- get >>= ( return . lcdSocket )+ lift $ hGetLine h++-- Converts a list into a string suitable for display on the marquee scroller+marquee :: [String] -> String+marquee [x] | length x < 14 = x+ | otherwise = x ++ " + "+marquee lst = concat . foldr (\(b,a) -> \lst -> (a:(b:lst)) ) [] .zip ( Data.List.repeat " + " ) $ lst ++--Create general screen+mkGeneral :: Session ()+mkGeneral = mapM_ send mkScreen+ where mkScreen = [ "screen_add general"+ , "widget_add general ln1 scroller"+ , "widget_add general ln2 string"+ , "screen_set general -priority hidden"+ , "screen_set general -heartbeat off" ]++--Create music screen+mkMusic :: Session ()+mkMusic = mapM_ send mkScreen+ where mkScreen = [ "screen_add music"+ , "widget_add music ln1 scroller"+ , "widget_add music ln2 string"+ , "widget_add music b1 string"+ , "widget_add music b2 string"+ , "screen_set music -priority foreground"+ , "screen_set music -heartbeat off" ]++--Create alert screen+mkAlert :: Session ()+mkAlert = mapM_ send mkScreen+ where mkScreen = [ "screen_add alert"+ , "widget_add alert ln1 string"+ , "widget_add alert ln2 string"+ , "screen_set alert -priority hidden"+ , "screen_set alert -heartbeat off" ]++--Create the selectList screen+mkSelectList :: Session ()+mkSelectList = mapM_ send mkScreen+ where mkScreen = [ "screen_add selectlist"+ , "widget_add selectlist s1 string"+ , "widget_add selectlist s2 string"+ , "widget_add selectlist ln1 scroller"+ , "widget_add selectlist ln2 string"+ -- , "widget_add selectlist ln2 scroller"+ , "screen_set selectlist -priority hidden"+ , "screen_set selectlist -heartbeat off" ]++mkPercent :: Session()+mkPercent = mapM_ send mkScreen+ where mkScreen = [ "screen_add percent"+ , "widget_add percent val string"+ , "widget_add percent bar hbar"+ , "screen_set percent -priority hidden"+ , "screen_set percent -heartbeat off" ]++--Create the Alphabet Selector screen+mkAlphabet :: Session ()+mkAlphabet = mapM_ send mkScreen+ where mkScreen = [ "screen_add alphabet"+ , "widget_add alphabet ln1 string"+ , "widget_add alphabet ln2 string"+ , "screen_set alphabet -priority hidden"+ , "screen_set alphabet -heartbeat off" ]++--General screen+general :: String -> String -> Session ()+general top bottom = do + mapM_ send commands+ raise "general"+ where+ commands = [ "widget_set general ln1 1 1 16 1 m 3 \"" ++ ( marquee [top] ) ++ "\""+ , "widget_set general ln2 1 2 \"" ++ bottom ++ "\"" ]++--Display alphabet selector+alphabet :: String -> String -> Int -> Session ()+alphabet selected choices i = do+ mapM_ send commands+ raise "alphabet"+ where+ ln1 = selected+ ln2 = drop ( i - ( i `mod` 16 ) ) choices+ x_cursor = show . (+1) . ( `mod` 16 ) $ i+ commands = [ "screen_set alphabet -cursor on"+ , "widget_set alphabet ln1 1 1 \"" ++ ln1 ++ "\""+ , "widget_set alphabet ln2 1 2 \"" ++ ln2 ++ "\"" + , "screen_set alphabet -cursor_y 2 -cursor_x " ++ x_cursor ]++--Refresh music screen +music :: String -> String -> Int -> Int -> Int -> Int -> Session ()+music artist title elapsed duration number playlist = + mapM_ send commands+ where+ ln1 = marquee [ artist , title ]+ ln2 = (clock elapsed) ++ " (" ++ (show number) ++"/" ++ (show playlist) ++ ") " ++ (clock ( duration - elapsed ) )+ commands = [ "widget_set music ln1 1 1 16 1 m 3 \"" ++ ln1 ++ "\""+ , "widget_set music ln2 1 2 \"" ++ ln2 ++ "\"" + , "widget_set music b1 1 1 \"\""+ , "widget_set music b2 1 1 \"\""+ ]++musicBanner :: String -> String -> Session ()+musicBanner top bottom = + mapM_ send commands+ where+ commands = [ "widget_set music ln1 1 1 1 1 m 3 \"\""+ , "widget_set music ln2 1 2 \"\"" + , "widget_set music b1 1 1 \"" ++ top ++ "\""+ , "widget_set music b2 1 2 \"" ++ bottom ++ "\""+ ]++showMusic :: Session ()+showMusic = raise "music"++--Display a selected item in a list+selectList :: [String] -> Int -> Session ()+selectList [] _ = return ()+selectList [x,y] i = (selectBinary x y i) >> (raise "selectlist")+selectList lst item = (mapM_ send commands) >> (raise "selectlist")+ where + ln1 = lst !! ( item `mod` (length lst) ) + ln2 = lst !! ( (item + 1) `mod` (length lst) )+ commands = [ "widget_set selectlist s1 1 1 \">>\""+ , "widget_set selectlist s2 1 2 \" \""+ , "widget_set selectlist ln1 3 1 16 1 h 2 \"" ++ ln1 ++ " \""+ , "widget_set selectlist ln2 3 2 \"" ++ ln2 ++ " \"" ]++selectBinary :: String -> String -> Int -> Session ()+selectBinary one two i = mapM_ send commands+ where+ commands = case i `mod` 2 of+ 0 -> [ "widget_set selectlist s1 1 1 \">>\""+ , "widget_set selectlist s2 1 2 \" \""+ , "widget_set selectlist ln1 3 1 16 1 h 2 \"" ++ one ++ " \""+ , "widget_set selectlist ln2 3 2 \"" ++ two ++ " \"" ]+ 1 -> [ "widget_set selectlist s1 1 1 \" \""+ , "widget_set selectlist s2 1 2 \">>\""+ , "widget_set selectlist ln1 3 2 16 2 h 2 \"" ++ two ++ " \""+ , "widget_set selectlist ln2 3 1 \"" ++ one ++ " \"" ]++--Briefly display a status bar with message+percent :: String -> Int -> Session ()+percent title percentage = do+ M.unscheduleAction "hidepercent"+ mapM_ send commands+ M.scheduleAction "hidepercent" 4 (hideScreen "percent")+ where commands = [ "screen_set percent -priority 5"+ , "widget_set percent val 1 1 \"" ++ ln1 ++ "\""+ , "widget_set percent bar 1 2 " ++ (show percentage) ]+ ln1 = title ++ ": " ++ (show percentage) ++ "%"++++--Display a two line message briefly+alert :: String -> String -> Session ()+alert ln1 ln2 = do+ M.unscheduleAction "hidealert"+ mapM_ send commands+ M.scheduleAction "hidealert" 4 (hideScreen "alert")+ where commands = [ "screen_set alert -priority 5"+ , "widget_set alert ln1 1 1 \"" ++ ln1 ++ "\""+ , "widget_set alert ln2 1 2 \"" ++ ln2 ++ "\"" ]++-- Hide a particular screen+hideScreen :: String -> Session ()+hideScreen scr = send ("screen_set "++ scr ++ " -priority hidden")+++permanentscreens = [ "music"+ , "general"+ , "selectlist"+ , "alphabet"+ ]+ +raise :: String -> Session ()+raise scr = do+ let xs = filter (/=scr) permanentscreens+ send ("screen_set "++ scr ++ " -priority foreground")+ mapM_ hideScreen xs
+ src/Hmpf/LIRC.hs view
@@ -0,0 +1,87 @@+{-+ - Connect to the LIRC socket and convert + - the input into Keys+ -}+module Hmpf.LIRC (clear, lirc, testLirc ) where++import Control.Concurrent (threadDelay)+import qualified Data.ByteString as B+import Data.Word (Word8)+import Network.Socket {- network package -}+import System.IO+import qualified Control.Exception as E ( catch , throw )+import Hmpf.Keys+import Hmpf.ApplicationTypes+--import Control.Monad.State (lift)++-- Exception: bind: resource busy (Address already in use)+--addr :: SockAddr+--addr = SockAddrUnix "/dev/lircd"++lirc :: Session Key+lirc = do+ st <- get+ lift . lirc' . lircConf $ st+++lirc' :: String -> IO Key+lirc' dev = input + where+ problem e = do+ let msg = "Unable to connect to LIRC: " ++ (show e)+ putStrLn msg+ E.throw e+ connection = + do let addr = SockAddrUnix dev+ sock <- socket AF_UNIX Stream {-protocol-} 0+ connect sock addr+ h <- socketToHandle sock ReadMode + return h+ input =+ do h <- E.catch connection problem+ key <- B.hGetLine h >>= return . getCommand . B.unpack + if key == Wheel+ then do+ threadDelay 200000 >> clearBuffer h >> threadDelay 100000+ bs <- B.hGetNonBlocking h 1+ case B.null bs of + True -> return Wheel+ _ -> threadDelay 200000 >> clearBuffer h >> return DoubleWheel+ else return key+++getCommand :: [Word8] -> Key+getCommand xs = + read. (!! 2) . words . map (toChar.fromEnum) $ xs+ --read. (!! 2) . words . head . lines . map (toChar.fromEnum) $ xs++toChar = toEnum :: Int -> Char++testLirc :: IO ()+testLirc = do+ key <- lirc' "/dev/lircd"+ putStrLn . show $ key+ testLirc+++clearBuffer :: Handle -> IO ()+clearBuffer h = do+ bs <- B.hGetNonBlocking h 1 + case B.null bs of + True -> return ()+ _ -> clearBuffer h+++clear :: Session ()+clear = do+ st <- get+ lift . clear' . lircConf $ st++clear' :: String -> IO ()+clear' dev = catch input (\e -> return ())+ where + input = + do let addr = SockAddrUnix dev+ sock <- socket AF_UNIX Stream {-protocol-} 0+ connect sock addr+ socketToHandle sock ReadMode >>= clearBuffer
+ src/Hmpf/MPD.hs view
@@ -0,0 +1,301 @@+{-+ - The modules implements the MPD protocol for interfacing + - with the MPD daemon.+ -}+module Hmpf.MPD + ( albums + , artists + , tracks+ , albumByTrack+ , tracksByArtist+ , status + , MPDStatus (..) + , currentsong + , Song (..) + , playAlbum+ , vol+ , pause+ , nextSong+ , previousSong+ , play+ , stop+ , fastforward+ , rewind+ , command+ , updatedb+ , clear+ , addSongs+ , playlistinfo + , playlistinfoAt+ , albumByArtist ) where++import Network+import System.IO (hFlush, hClose , Handle , hSetBuffering , BufferMode(..) )+import System.IO.Error (catch)+import Data.List+import Data.Maybe+import Data.Char+import Hmpf.Util+import Hmpf.UTF8Stream+import Control.Exception+import Network (PortID)++--host = "10.1.1.4"+--port = PortNumber 6600++playAlbum conf alb = do+ putStrLn "playing new album"+ response <- command conf ("find album " ++ (quote alb) )+ case response of + OK resp -> do+ let files = map snd . filter file . map property $ resp+ cmdLst = "stop":"clear":((map (("add " ++) . quote ) files) ++ ["play"])+ commands conf cmdLst+ return ()+ ACK resp -> putStrLn resp+ where+ file = \(a,_) -> a == "file"++vol conf i = do+ case i > 0 of + True -> command conf $ "volume +" ++ (show i)+ False -> command conf $ "volume " ++ (show i)+ status conf >>= ( return . volume )++albums :: (String,PortNumber) -> IO [String]+albums conf = listByProperty conf "album"++listByProperty :: (String,PortNumber) -> String -> IO [String]+listByProperty conf prop = do+ OK lst <- command conf ( "list " ++ prop ) + let albs = sort . map ( snd . property ) $ lst+ return albs++tracks :: (String,PortNumber) -> IO [String]+tracks conf = listByProperty conf "title"++clear :: (String,PortNumber) -> IO ()+clear conf = do+ st <- status conf+ let lst = do+ s <- song st+ len <- playlistlength st+ return . reverse . filter (/=s) $ [0..(len-1)]+ case lst of+ Nothing -> putStrLn "Clear all" >> command conf "clear" >> return ()+ Just is -> (commands conf . map ( (\s -> "delete " ++ s ) . show ) $ is) >> return ()++artists :: (String,PortNumber) ->IO [String]+artists conf = do+ OK lst <- command conf "list artist"+ return . sort . map ( snd . property ) $ lst++albumByTrack :: (String,PortNumber) ->String -> IO [String]+albumByTrack conf art = do+ let cmdstr = "list album title " ++ (quote art )+ OK lst <- command conf cmdstr+ return . map (snd.property) $ lst++albumByArtist :: (String,PortNumber) ->String -> IO [String]+albumByArtist conf art = do+ let cmdstr = "list album artist " ++ (quote art )+ OK lst <- command conf cmdstr+ return . map (snd.property) $ lst++data MPDStatus = MPDStatus {+ volume :: Int+ ,repeat :: Int+ ,random :: Int+ ,playlist :: Maybe Int+ ,playlistlength :: Maybe Int+ ,state :: String+ ,song :: Maybe Int+ ,elapsed :: Maybe Int+ ,duration :: Maybe Int+ ,songid :: Maybe Int+ }+ deriving Show++tracksByArtist :: (String,PortNumber) ->String -> IO [Song]+tracksByArtist conf art = do+ let req = "find artist \"" ++ art ++ "\"" + putStr req+ --resp <- command conf ("search artist \"" ++ art ++ "\"" )+ resp <- command conf req+ case resp of+ OK xs -> found xs >> (return . f $ xs)+ _ -> return []+ where+ found [] = putStrLn ""+ found _ = putStrLn " - found!"+ f [] = []+ f (y:ys) = let (a,b) = break ( `startsWith` "file:" ) ys+ in ( readSong (y:a)) : ( f b )++currentsong :: (String,PortNumber) -> IO (Maybe Song)+currentsong conf = do+ resp <- command conf "currentsong"+ case resp of + OK xs -> do+ return . Just . readSong $ xs+ _ -> return Nothing+++playlistinfo :: (String,PortNumber) -> IO [Song]+playlistinfo conf = do+ resp <- command conf ("playlistinfo")+ case resp of+ OK xs -> (return . f $ xs)+ _ -> return []+ where+ f [] = []+ f (y:ys) = let (a,b) = break ( `startsWith` "file:" ) ys+ in ( readSong (y:a)) : ( f b )++playlistinfoAt :: (String,PortNumber) ->Int -> IO (Maybe Song)+playlistinfoAt conf i = do+ resp <- command conf ("playlistinfo " ++ ( show i ))+ case resp of + OK xs -> return . Just . readSong $ xs+ _ -> return Nothing++readSong :: [String] -> Song+readSong (x:xs) = + Song f tm al a t g sid + where m = map property (x:xs)+ t = maybe "notfound" id (lookup "Title" $ m)+ a = maybe "notfound" id (lookup "Artist" $ m)+ al = maybe "notfound" id (lookup "Album" $ m)+ g = maybe "notfound" id (lookup "Genre" $ m)+ f = maybe "notfound" id (lookup "file" $ m)+ tm = maybe 0 read (lookup "Time" $ m)+ sid = maybe 0 read (lookup "Id" $ m)+data Song = Song {+ file :: String+ , time :: Int+ , album :: String+ , artist :: String+ , title :: String+ , genre :: String+ , songId :: Int+ }+ deriving (Show,Eq)++status :: (String,PortNumber) -> IO MPDStatus+status conf = do+ OK lst <- command conf "status"+ let m = map property lst+ v = maybe 0 read (lookup "volume" $ m)+ rp = maybe 0 read (lookup "repeat" $ m)+ ran = maybe 0 read (lookup "random" $ m)+ pl = lookup "playlist" m >>= (return . read)+ pll = lookup "playlistlength" m >>= (return . read)+ st = maybe "stop" id (lookup "state" m)+ s = lookup "song" m >>= (return . read)+ e = lookup "time" m >>= (return . read . takeWhile isDigit)+ d = lookup "time" m >>= (return . read . reverse . takeWhile isDigit . reverse )+ sid = lookup "songid" m >>= ( return . read )+ return (MPDStatus v rp ran pl pll st s e d sid)+++command = command'+{-+ catch (command' (host,port) cmd)+ (\e -> do+ let msg = "MPD - " ++ (show e)+ putStrLn msg+ return (ACK msg)+ )+-}++command' :: (String, PortNumber) -> String -> IO Response+command' (host,port) cmd = do+ h <- connectTo host (PortNumber port)+ finally (sendCmd h) (hFlush h >> hClose h ) -- >> (putStrLn " - closed") )+ where + sendCmd h = do + -- putStr $ "MPD Command : " ++ cmd+ ln <- hGetLine h+ hPutStrLn h cmd+ resp <- mpdResp [] h+ -- putStrLn $ "MPD Response : " ++ ( show resp )+ return resp+++commands = commands'+--commands conf lst = +-- sequence . map ( command conf ) $ lst++commands' :: (String , PortNumber) -> [String] -> IO Response+commands' (host, port) clst = do+ h <- connectTo host (PortNumber port)+ finally (sendCmds h) (hFlush h >> hClose h ) -- >> (putStrLn " - closed") )+ where+ sendCmds h = do+ -- hSetBuffering h NoBuffering+ hGetLine h+ --putStr "MPD Commands:"+ --mapM_ putStrLn clst+ hPutStrLn h "command_list_begin"+ mapM_ (hPutStrLn h) clst+ hPutStrLn h "command_list_end"+ resp <- mpdResp [] h+ hPutStrLn h "close"+ putStrLn . show $ resp+ return resp+++mpdResp :: [String] -> Handle -> IO Response+mpdResp buf h = do+ line <- hGetLine h+ if line `startsWith` "ACK" + then + return . ACK . drop 2 . dropWhile (\c -> c/='}') $ line+ else if line `startsWith` "OK" + then + return $ OK ( reverse buf )+ else + mpdResp (line:buf) h++data Response = + OK [String] | + ACK String+ deriving Show++property :: String -> (String,String)+property xs = + let key = takeWhile (\c -> c/=':') xs+ val = drop (length key + 2 ) xs+ in ( key , val )++pause conf = command conf "pause"+nextSong conf = command conf "next"+previousSong conf = command conf "previous"+play conf = command conf "play"+stop conf = command conf "stop"+fastforward conf = jog conf 2+rewind conf = jog conf (-2)+updatedb conf = command conf "update"++--Advance a song by 'n' seconds+jog conf n = do+ s <- status conf+ case (song s) of+ Nothing -> do return ()+ Just i -> do+ let position = ( +n ) . fromJust . elapsed $ s+ cmd = "seek " ++ (show i) ++ " " ++ (show position)+ command conf cmd+ return ()++quote :: String -> String +quote str = '"':str ++ "\""++addSongs :: (String,PortNumber) -> [Song] -> IO ()+addSongs conf xs = do+ commands conf lst + return ()+ where+ lst = map ( (\f -> "add \"" ++ f ++ "\"" ) . file) $ xs++
+ src/Hmpf/MPDSession.hs view
@@ -0,0 +1,115 @@+module Hmpf.MPDSession ( + albums + , artists + , status + , M.MPDStatus (..) + , currentsong + , M.Song (..) + , playAlbum+ , vol+ , pause+ , nextSong+ , previousSong+ , play+ , stop+ , fastforward+ , rewind+ , command+ , updatedb+ , tracksByArtist+ , tracks+ , albumByTrack+ , addSongs+ , playlistinfo+ , playlistinfoAt+ , clear+ , loadCache+ , albumByArtist ) where++import qualified Hmpf.MPD as M+import Hmpf.ApplicationTypes -- ( lift , get , Session (..) ) +import Control.Concurrent.MVar +import Hmpf.LCDProc (alert)+import Control.Concurrent (threadDelay, forkIO)++tracks = do+ st <- get+ (as,albs,trks) <- lift ( readMVar . cache $ st )+ return trks++albums = do+ st <- get+ (as,albs,trks) <- lift ( readMVar . cache $ st )+ return albs++artists = do+ st <- get+ (as,albs,trks) <- lift ( readMVar . cache $ st )+ return as++loadCache :: Session ()+loadCache = do+ st <- get+ (as',albs',trks') <- lift ( readMVar . cache $ st )+ let mc = mpdConf st+ conf <- lift ( readMVar mc )+ as <- lift . M.artists $ conf+ lift( swapMVar (cache st) ( as , albs' , trks' ) )+ albs <- lift . M.albums $ conf+ lift( swapMVar (cache st) ( as , albs , trks' ) )+ trks <- lift . M.tracks $ conf+ lift( swapMVar (cache st) ( as , albs , trks ) )+ return ()+++updatedb= do+ st <- get+ let mc = mpdConf st+ lift ( do+ conf <- readMVar mc+ M.updatedb conf + )+ cch <- lower (loadCache >> alert "Cache reloaded" "")+ let loadCache' = threadDelay 20000000 >> cch+ lift ( forkIO loadCache' )+++albumByTrack = passConfMore M.albumByTrack+playlistinfoAt = passConfMore M.playlistinfoAt+addSongs = passConfMore M.addSongs+clear = passConf M.clear+tracksByArtist = passConfMore M.tracksByArtist+albumByArtist = passConfMore M.albumByArtist +status = passConf M.status +playlistinfo = passConf M.playlistinfo+currentsong = passConf M.currentsong +playAlbum= passConfMore M.playAlbum+vol= passConfMore M.vol+pause= passConf M.pause+nextSong= passConf M.nextSong+previousSong= passConf M.previousSong+play= passConf M.play+stop= passConf M.stop+fastforward= passConf M.fastforward+rewind= passConf M.rewind+command= passConfMore M.command++passConfMore f x = do+ st <- get+ let mc = mpdConf st+ lift ( do+ conf <- takeMVar mc+ y <- f conf x+ putMVar mc conf + return y+ )++passConf f = do+ st <- get+ let mc = mpdConf st+ lift ( do+ conf <- takeMVar mc+ y <- f conf+ putMVar mc conf + return y+ )
+ src/Hmpf/Monitor.hs view
@@ -0,0 +1,70 @@+{- This module enables events to be scheduled for some time in the future.+ - 'initialize' starts the monitor thread.+ -}+module Hmpf.Monitor ( initialize+ , MonitorState+ , scheduleAction+ , scheduleActionAt + , unscheduleAction ) where ++import Control.Concurrent+import Control.Concurrent.MVar+import System.IO+import System.Time+import System.Posix.Time+import System.Posix.Types+import Data.Maybe+import Hmpf.ApplicationTypes+import qualified Control.Monad.State as S+++--Initialize the monitor+--We need to be careful not to create race conditions+initialize :: Session ()+initialize = do + mvar <- (S.get)+ st <- get+ v <- lift (takeMVar (scheduler st) )+ m <- lower monitor+ threadID <- lift . forkIO $ m+ lift (putMVar (scheduler st) (MonitorState [] threadID))+++monitor :: Session ()+monitor = do+ st <- get+ ms <- lift . takeMVar $ (scheduler st) -- monitorstate ( now empty )+ t <- lift epochTime+ let es = pending ms+ as = map ( snd . snd ) . filter ( (<t) . fst ) $ es+ rest = filter ( (>=t) . fst ) es+ --lift (putStrLn ( "Pending: " ++ (show . length $ es ) ))+ lift $ putMVar (scheduler st) ( ms {pending = rest} )+ (foldr (>>) (return ()) as)+ lift (threadDelay 100000) -- 1/10th of a second+ monitor ++--Schedule an action to occur in n seconds+scheduleAction :: String -> Int -> Session () -> Session ()+scheduleAction k i f = do+ t <- lift epochTime+ let tt = toEnum ( fromEnum t + i )+ scheduleActionAt k tt f++--Schedule an action to occur at a specified time+scheduleActionAt :: String -> EpochTime -> Session () -> Session ()+scheduleActionAt k time action = do+ mvar <- get >>= return . scheduler+ st <- lift (takeMVar mvar)+ let ps = ( time , ( k , action ) ) : ( pending st )+ lift $ putMVar mvar (st {pending=ps})+ return ()++unscheduleAction :: String -> Session (Maybe (Session ()))+unscheduleAction k = do+ mvar <- get >>= return . scheduler+ st <- lift $ takeMVar mvar+ let x = (lookup k) . map snd . pending $ st+ xs = filter ( (/= k) . fst . snd ) . pending $ st + lift $ putMVar mvar (st { pending = xs } )+ return x
+ src/Hmpf/RelatedArtist.hs view
@@ -0,0 +1,131 @@+{-+ - This module is used to collect a list of similar or + - related artists as defined by LastFM.+ - This list is then used to generate an intelligent playlist.+ -}+module Hmpf.RelatedArtist ( toggleAutogeneration + , generation+ ) where +import Data.List+import Network.HTTP+import Network.URI+import Data.Maybe+import Hmpf.Util+import Hmpf.MPDSession+import Hmpf.ApplicationTypes+import Control.Concurrent +import Control.Monad ( mzero, MonadPlus )+import Hmpf.LCDProc (alert)+++toggleAutogeneration :: Session Bool+toggleAutogeneration = do+ st <- get+ if ( generate st )+ then do+ put ( st { generate = False } )+ return False+ else do+ put ( st { generate = True } )+ return True+++-- Intelligent playlist generation+generation :: Session ()+generation = idle++active :: Session ()+active = do+ lift (threadDelay 1000000)+ st <- get+ if ( generate st )+ then do+ mpd <- status+ let add = do+ len <- playlistlength mpd+ s <- song mpd+ if( len - s - 2 < 1 )+ then return ( related 1 >>= (\i -> if ( (length i) > 0 ) + then do+ command "delete 0"+ alert ("Added: " ++ ( artist . head $ i ) ) ( title .head $ i )+ else return () ) )+ else fail "Not at the last track"+ case add of+ Nothing -> active+ Just x -> x >> active+ else idle+ ++idle :: Session ()+idle = do+ lift (threadDelay 1000000)+ st <- get+ if( generate st )+ then do+ --clear+ related 5+ active+ else idle++++url :: String -> String+url str = start ++ ( escapeURIString isUnescapedInURI str) ++ end+ where+ start = "http://ws.audioscrobbler.com/1.0/artist/"+ end = "/similar.txt"++similarArtists :: String -> Session [(Float,String)]+similarArtists a = do+ result <- lift (simpleHTTP req)+ case result of+ Left err -> do+ return []+ Right resp -> do+ let artists = lines (rspBody resp)+ f str = let v = takeWhile (/=',') str+ n = reverse . takeWhile (/=',') . reverse $ str+ in ( read v , n )+ if ( head artists `startsWith` "No artist exists" )+ then return []+ else return $ map f artists+ where+ uri = fromJust . parseURI . url $ a+ req = Request uri GET [] ""++--Add a number of related songs+related :: Int -> Session [Song]+related num = do+ st <- status+ case (playlistlength st ) of+ Nothing -> return []+ Just i -> do+ Just s <- playlistinfoAt (i-1) + sim <- similarArtists . artist $ s+ if ( null sim ) + then return []+ else do+ let as = map snd $ sim+ lift . putStrLn . show $ as + sngs <- takeM 5 (map tracksByArtist as)+ let snglst = concat . filter (not.null) $ sngs+ actions = take num . Data.List.repeat . lift $ (pick snglst)+ xs <- (sequence actions) + addSongs xs+ --return . length $ actions+ return xs++++--takeM :: (Monad m , Monad n ) => Int -> [ m (n a) ] -> m [ n a ]+takeM :: (Monad m ) => Int -> [ m [a] ] -> m [ [a] ]+takeM 0 _ = return []+takeM _ [] = return []+takeM i (x:xs) = do+ y <- x+ case y of+ [] -> takeM i xs+ _ -> do+ rest <- takeM (i-1) xs + return (y:rest)
+ src/Hmpf/Tree.hs view
@@ -0,0 +1,104 @@+{-+ - Tree data type. Every node is accessible from any other node.+ -}+module Hmpf.Tree + ( mkTree + , Tree + , up + , top + , branches + , build + , index + , isLeaf + , isRoot + , val + , path + , flatten ) where++import Data.List (elemIndex)+import Data.Maybe (fromJust)++data Tree a = Root (Branch a) |+ Node (Tree a) a (Branch a)++type Branch a = [Tree a]+++instance Eq a => Eq (Tree a) where+ t == t' = (flatten t) == (flatten t')++up :: Tree a -> Tree a +up (Node t _ _) = t+up x = x++top (Root b) = Root b+top (Node p _ _) = top p++branches :: Tree a -> [Tree a]+branches (Root b) = b+branches (Node _ _ b) = b++--True if it is the root node+isRoot (Root _) = True+isRoot _ = False++--True if the node has no children+isLeaf t = (length . branches $ t ) == 0++val :: Tree a -> Maybe a+val (Node r x b) = Just x+val _ = Nothing++mkTree :: ( a -> [(b, a)] ) -> a -> Tree b+mkTree f x = + let root = Root children+ children = map (mkBranches root f) (f x)+ in root++mkBranches :: Tree b -> ( a -> [(b,a)] ) -> (b, a) -> Tree b+mkBranches root f (n,x) = + let node = Node root n children+ children = map (mkBranches node f) (f x)+ in node+++build :: Eq a => [[a]] -> [(a,[[a]])]+build lst = + let lst' = filter (not.null) $ lst+ in case lst' of+ [] -> []+ (x:xs) -> let c = head x+ lst'' = map tail . filter (\i -> head i ==c) $ (x:xs)+ rest = filter (\i -> head i/=c) (x:xs)+ in (c,lst''):(build rest)+++path :: Tree a -> [a]+path t =+ case val t of+ Nothing -> []+ Just x -> x:(path . up $ t )++flatten :: Tree a -> [[a]]+flatten tree = + case val tree of+ Nothing -> rest+ Just x -> case (branches tree) of+ [] -> [[x]]+ _ -> map (x:) rest+ where+ rest = concat . map flatten . branches $ tree++index :: Eq a => Tree a -> Int+index (Root _) = 0+index tree = fromJust . elemIndex tree . branches . up $ tree+++++eol = '^'++t = mkTree build . map ( ++[eol] ) $ ["li","lic"]+++
+ src/Hmpf/UTF8Stream.hs view
@@ -0,0 +1,34 @@+{-+ - Module used to read a UTF-8 stream.+ - UTF-8 is used by the MPD daemon.+ -}+module Hmpf.UTF8Stream where++import qualified Data.ByteString.Lazy as L+import System.IO ( Handle , hFlush )+import Codec.Binary.UTF8.String +import Data.Word (Word8)++hGetLine :: Handle -> IO String+hGetLine h = do+ ln <- hGetLine' h+ return . decode $ ln+++hGetLine' :: Handle -> IO [Word8]+hGetLine' h = do+ c <- L.hGet h 1 + if ( ( fromEnum . head . L.unpack $ c ) == 10 )+ then return []+ else do+ rest <- hGetLine' h+ return ( ( head . L.unpack $ c ) : rest )++hPutStrLn :: Handle -> String -> IO ()+hPutStrLn h cmd = do+ L.hPut h bs+ L.hPut h eol+ hFlush h+ where+ bs = L.pack . encode $ cmd+ eol = L.pack . encode . (:[]) $ '\n'
+ src/Hmpf/Util.hs view
@@ -0,0 +1,63 @@+{-+ - A collection of utility functions.+ -}+module Hmpf.Util where++import System.Random+import System.Posix.Time+import System.Posix.Types+import System.Time+import Data.Char ( toLower )+++startsWith :: (Eq a) => [a] -> [a] -> Bool+_ `startsWith` [] = True+[] `startsWith` _ = False+(x:xs) `startsWith` (p:prefix) | x == p = xs `startsWith` prefix+ | otherwise = False+++time :: IO String+time = do + t <- (getClockTime >>= toCalendarTime)+ return . clock $ ( ctMin t + 60 * ctHour t )+{-+ putStrLn "1 abc 2 def 3 ghi"+ putStrLn "4 jkl 5 mno 6 pqr"+ putStrLn "7 stu 8 vwx 9 yz"+-}+++--Converts seconds to min:sec+clock :: Int -> String+clock secs = + min ++ ":" ++ ss + where+ min = show (secs `div` 60)+ sec = show (secs `mod` 60)+ zeros = repeat '0'+ ss = reverse . take 2 . ( ++ zeros ) . reverse $ sec++--+eqIgnoreCase :: String -> String -> Bool+eqIgnoreCase str1 str2 =+ let l1 = map toLower str1+ l2 = map toLower str2+ in l1 == l2+++pick :: [a] -> IO a+pick lst = do+ g <- newStdGen+ let binary = randoms g+ return . pick' binary $ lst + where+ pick' :: [Bool] -> [a] -> a+ pick' _ [x] = x+ pick' (b:bs) xs = case b of+ True -> pick' bs (left xs)+ False -> pick' bs (right xs)+ where+ n = (length xs) `div` 2+ left = take n+ right = drop n
+ src/Main.hs view
@@ -0,0 +1,208 @@+module Main where+++import qualified Hmpf.Monitor as M+import Hmpf.ApplicationTypes+import Hmpf.LCDProc+import Hmpf.Control+import Hmpf.Tree+import Hmpf.MPDSession+import Hmpf.LIRC +import Hmpf.Keys+import Hmpf.AudioScrobbler+import Hmpf.Util (pick)+import Hmpf.RelatedArtist+import Hmpf.Config+-----------------+import Control.Concurrent.MVar+import Control.Concurrent+import Data.List -- ( elemIndex )+import Data.Char ( toLower )+import Data.Time+import System.IO+import Control.Exception ( finally )+import qualified Control.Monad.State as S+++main :: IO ()+main = do+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ runSession programme++programme = do+ load ""+ Hmpf.LIRC.clear+ sm <- lower songMonitor+ scrm <- lower scrobblermonitor+ gen <- lower generation+ lc <- lower loadCache+ lift ( forkIO lc ) -- start thread to load cache+ lift ( forkIO (finally sm (putStrLn "Song monitor has failed"))) -- start thread to update play screen+ lift ( forkIO scrm ) -- start thread to send songs to Last.fm+ lift ( forkIO gen ) -- start thread to add auto-generated songs+ input+++input :: Session ()+input = do+ showMusic+ k <- lirc+ case k of + TaskSwitcher -> randomAlbum+ Eject -> do+ b <- toggleAutogeneration + let sw = ( toEnum . fromEnum $ b ) :: Switch+ alert "Auto-generated" ( "playlist :" ++ (show sw) )+ Play -> play>>return()+ Stop -> stop>>return()+ Pause -> pause>>return()+ Timer -> sleep+ NextChapter -> nextSong >> return()+ PrevChapter -> previousSong >> return()+ FastForward -> fastforward >> return()+ Rewind -> rewind >> return()+ VolUp -> vol 10 >>= percent "Vol" >> return()+ VolDown -> vol (-10) >>= percent "Vol" >> return()+ Purple -> updatedb >> alert "Updating the" "music database"+ Enter -> selectFromPlaylist >> return ()+ Red -> do + alb <- selectAlbumByTrack+ case alb of+ Nothing-> return ()+ Just alb' -> playAlbum alb'+ AppLauncher -> do+ alb <- selectAlbum+ case alb of+ Nothing -> return ()+ Just alb' -> playAlbum alb'+ MultiMon -> do+ a <- selectArtist -- choose the artist+ case a of + Nothing -> return ()+ Just a' -> do + alb <- selectAlbumByArtist a' -- choose the album+ maybe (return ()) playAlbum alb -- play the album+ _ -> return ()+ input++runSession :: Session a -> IO a+runSession fn = do+ mv <- empty+ S.runStateT ( initialize >> M.initialize >> fn >>= closeSession ) mv >>= ( return . fst )++--Select an artist+selectArtist :: Session (Maybe String)+selectArtist = do+ as <- artists+ let ls = map (map toLower) $ as+ l <- selector ls+ -- Use the Maybe monad here just to be funky+ return ( do+ x <- l+ i <- elemIndex x ls+ return ( as !! i )+ )++--Select an album+selectAlbum :: Session (Maybe String)+selectAlbum = do+ as <- albums+ let ls = map (map toLower) $ as+ l <- selector ls+ -- Use the Maybe monad here just to be funky+ return ( do+ x <- l+ i <- elemIndex x ls+ return ( as !! i )+ )++--Select an album by artist+selectAlbumByArtist :: String -> Session (Maybe String)+selectAlbumByArtist artist = do+ as <- albumByArtist artist+ let ls = map (map toLower) $ as+ l <- selector ls+ -- Use the Maybe monad here just to be funky+ return ( do+ x <- l+ i <- elemIndex x ls+ return ( as !! i )+ )+++--Select an album by track+selectAlbumByTrack:: Session (Maybe String)+selectAlbumByTrack = do+ ts <- getTracks+ let ls = map (map toLower) $ ts+ l <- selector ls+ let l' = ( do+ x <- l+ i <- elemIndex x ls+ return ( ts !! i )+ )+ case l' of + Nothing -> return Nothing+ Just l'' -> do+ albs <- ( Hmpf.MPDSession.albumByTrack l'')+ case albs of+ [] -> return Nothing+ (x:xs) -> return (Just x)+++randomAlbum :: Session ()+randomAlbum = do+ alb <- albums >>= (lift . pick)+ playAlbum alb+ Just sng <- currentsong+ alert alb (artist sng)+ lift (putStr $ (artist sng) ++ " -- ")+ lift (putStrLn alb)+ return ()+++selectFromPlaylist :: Session ()+selectFromPlaylist = do+ sngs <- playlistinfo+ st <- status+ let ns = map (\(i,t) -> (show i) ++ ". " ++ t ) . zip [1..] . map title $ sngs+ c = case ( song st ) of + Nothing -> 0+ Just i -> i+ xs = (drop c ns) ++ ( take c ns)+ r <- selectByList xs+ case r of + Nothing -> return ()+ Just i' -> (command ( "play " ++ (show $ i' + c ) ) >> return () )+++++getTracks :: Session [String] +getTracks = do+ ts <- tracks+ lift ( putStrLn . show . length $ ts)+ let ts' = filter badchars $ ts+ lift ( putStrLn . show . length $ ts')+ return ts'+ where+ badchars = foldr (\c -> \b -> (fromEnum c > 35) && b ) True+++sleep :: Session ()+sleep = do+ st <- get+ let t = (timer st + 10) `mod` 70+ put (st { timer = t })+ M.unscheduleAction "sleep"+ if t > 0 + then M.scheduleAction "sleep" + ( t * 60 ) + (do command "stop" + st' <- get+ put st' { timer = 0 } ) >> alert "Timer set" ( (show t) ++ " min" )+ else alert "Timer off" ""+++