diff --git a/Hmpf.cabal b/Hmpf.cabal new file mode 100644 --- /dev/null +++ b/Hmpf.cabal @@ -0,0 +1,25 @@ +Name: Hmpf +Version: 0.1 +License: GPL +Maintainer: Thomas L. Bevan +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 diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,25 @@ +Hmpf +Copyright (C) 2007 Thomas L. Bevan + +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. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/hmpf.conf.sample b/hmpf.conf.sample new file mode 100644 --- /dev/null +++ b/hmpf.conf.sample @@ -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 diff --git a/src/Hmpf/ApplicationTypes.hs b/src/Hmpf/ApplicationTypes.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/ApplicationTypes.hs @@ -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 ) diff --git a/src/Hmpf/AudioScrobbler.hs b/src/Hmpf/AudioScrobbler.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/AudioScrobbler.hs @@ -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 ) diff --git a/src/Hmpf/Config.hs b/src/Hmpf/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/Config.hs @@ -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 ) diff --git a/src/Hmpf/Control.hs b/src/Hmpf/Control.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/Control.hs @@ -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 + + + diff --git a/src/Hmpf/Keys.hs b/src/Hmpf/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/Keys.hs @@ -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 ) diff --git a/src/Hmpf/LCDProc.hs b/src/Hmpf/LCDProc.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/LCDProc.hs @@ -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 diff --git a/src/Hmpf/LIRC.hs b/src/Hmpf/LIRC.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/LIRC.hs @@ -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 diff --git a/src/Hmpf/MPD.hs b/src/Hmpf/MPD.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/MPD.hs @@ -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 + + diff --git a/src/Hmpf/MPDSession.hs b/src/Hmpf/MPDSession.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/MPDSession.hs @@ -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 + ) diff --git a/src/Hmpf/Monitor.hs b/src/Hmpf/Monitor.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/Monitor.hs @@ -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 + --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 diff --git a/src/Hmpf/RelatedArtist.hs b/src/Hmpf/RelatedArtist.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/RelatedArtist.hs @@ -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) diff --git a/src/Hmpf/Tree.hs b/src/Hmpf/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/Tree.hs @@ -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"] + + + diff --git a/src/Hmpf/UTF8Stream.hs b/src/Hmpf/UTF8Stream.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/UTF8Stream.hs @@ -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' diff --git a/src/Hmpf/Util.hs b/src/Hmpf/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hmpf/Util.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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" "" + + +