diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +* v0.2.0, 2008-04-14 + - A connection stub for testing purposes. + - QuickCheck tests for parsing. + - Partial unit test coverage. + - Many bug fixes. + - Precise error handling. + - Parsing improvements. + - Code coverage generation. + - Cabal 1.2 support. + - Uniform command names. + * v0.1.3, 2007-10-02 - Bugfixes. diff --git a/Network/MPD.hs b/Network/MPD.hs --- a/Network/MPD.hs +++ b/Network/MPD.hs @@ -1,6 +1,6 @@ {- libmpd for Haskell, an MPD client library. - Copyright (C) 2005-2007 Ben Sinclair + Copyright (C) 2005-2008 Ben Sinclair This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,26 +18,26 @@ -} -- | Module : Network.MPD --- Copyright : (c) Ben Sinclair 2005-2007 +-- Copyright : (c) Ben Sinclair 2005-2008 -- License : LGPL -- Maintainer : bsinclai@turing.une.edu.au -- Stability : alpha -- Portability : Haskell 98 -- --- MPD client library. +-- An MPD client library. MPD is a daemon for playing music that is +-- controlled over a network socket. Its site is at . module Network.MPD ( -- * Basic data types MPD, MPDError(..), ACKType(..), Response, - module Network.MPD.Commands, -- * Connections withMPD, withMPDEx, - -- * Misc. - kill, throwMPD, catchMPD + module Network.MPD.Commands, ) where import Network.MPD.Commands -import Network.MPD.Prim +import Network.MPD.Core +import Network.MPD.SocketConn import Control.Monad (liftM) import Data.Maybe (listToMaybe) @@ -46,10 +46,15 @@ import System.IO import System.IO.Error (isDoesNotExistError, ioError) --- | Run an MPD action using localhost:6600 as the default host:port, --- or whatever is found in the environment variables MPD_HOST and --- MPD_PORT. If MPD_HOST is of the form \"password\@host\" then the --- password will be supplied as well. +-- | A wrapper for 'withMPDEx' that uses localhost:6600 as the default +-- host:port, or whatever is found in the environment variables MPD_HOST and +-- MPD_PORT. If MPD_HOST is of the form \"password\@host\" the password +-- will be supplied as well. +-- +-- Examples: +-- +-- > withMPD $ play Nothing +-- > withMPD $ add_ "" "tool" >> play Nothing >> currentSong withMPD :: MPD a -> IO (Response a) withMPD m = do port <- liftM read (getEnvDefault "MPD_PORT" "6600") diff --git a/Network/MPD/Commands.hs b/Network/MPD/Commands.hs --- a/Network/MPD/Commands.hs +++ b/Network/MPD/Commands.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE PatternGuards #-} {- libmpd for Haskell, an MPD client library. - Copyright (C) 2005-2007 Ben Sinclair + Copyright (C) 2005-2008 Ben Sinclair This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -18,11 +19,11 @@ -} -- | Module : Network.MPD.Commands --- Copyright : (c) Ben Sinclair 2005-2007 +-- Copyright : (c) Ben Sinclair 2005-2008 -- License : LGPL -- Maintainer : bsinclai@turing.une.edu.au -- Stability : alpha --- Portability : Haskell 98 +-- Portability : unportable (uses PatternGuards) -- -- Interface to the user commands supported by MPD. @@ -31,20 +32,20 @@ State(..), Status(..), Stats(..), Device(..), Query(..), Meta(..), - Artist, Album, Title, Seconds, PLIndex(..), - Song(..), Count(..), + Artist, Album, Title, Seconds, PlaylistName, Path, + PLIndex(..), Song(..), Count(..), -- * Admin commands - disableoutput, enableoutput, outputs, update, + disableOutput, enableOutput, kill, outputs, update, -- * Database commands - find, list, listAll, listAllinfo, lsinfo, search, count, + find, list, listAll, listAllInfo, lsInfo, search, count, -- * Playlist commands -- $playlist - add, add_, addid, clear, currentSong, delete, load, move, - playlistinfo, listplaylist, listplaylistinfo, playlist, plchanges, - plchangesposid, playlistfind, playlistsearch, rm, rename, save, shuffle, + add, add_, addId, clear, currentSong, delete, load, move, + playlistInfo, listPlaylist, listPlaylistInfo, playlist, plChanges, + plChangesPosId, playlistFind, playlistSearch, rm, rename, save, shuffle, swap, -- * Playback commands @@ -52,51 +53,57 @@ volume, stop, -- * Miscellaneous commands - clearerror, close, commands, notcommands, tagtypes, urlhandlers, password, - ping, reconnect, stats, status, + clearError, close, commands, notCommands, password, ping, reconnect, stats, + status, tagTypes, urlHandlers, -- * Extensions\/shortcuts - addMany, deleteMany, crop, prune, lsdirs, lsfiles, lsplaylists, findArtist, - findAlbum, findTitle, listArtists, listAlbums, listAlbum, searchArtist, - searchAlbum, searchTitle, getPlaylist, toggle, updateid + addMany, deleteMany, complete, crop, prune, lsDirs, lsFiles, lsPlaylists, + findArtist, findAlbum, findTitle, listArtists, listAlbums, listAlbum, + searchArtist, searchAlbum, searchTitle, getPlaylist, toggle, updateId ) where -import Network.MPD.Prim +import Network.MPD.Core +import Network.MPD.Utils +import Network.MPD.Parse import Control.Monad (liftM, unless) +import Control.Monad.Error (throwError) import Prelude hiding (repeat) -import Data.List (findIndex, intersperse) +import Data.List (findIndex, intersperse, isPrefixOf) import Data.Maybe +import System.FilePath (dropFileName) -- -- Data types -- -type Artist = String -type Album = String -type Title = String -type Seconds = Integer +type Artist = String +type Album = String +type Title = String +-- | Used for commands which require a playlist name. +-- If empty, the current playlist is used. +type PlaylistName = String + +-- | Used for commands which require a path within the database. +-- If empty, the root path is used. +type Path = String + -- | Available metadata types\/scope modifiers, used for searching the -- database for entries with certain metadata values. data Meta = Artist | Album | Title | Track | Name | Genre | Date | Composer | Performer | Disc | Any | Filename - -instance Show Meta where - show Artist = "Artist" - show Album = "Album" - show Title = "Title" - show Track = "Track" - show Name = "Name" - show Genre = "Genre" - show Date = "Date" - show Composer = "Composer" - show Performer = "Performer" - show Disc = "Disc" - show Any = "Any" - show Filename = "Filename" + deriving Show -- | A query is composed of a scope modifier and a query string. +-- +-- To match entries where album equals \"Foo\", use: +-- +-- > Query Album "Foo" +-- +-- To match entries where album equals \"Foo\" and artist equals \"Bar\", use: +-- +-- > MultiQuery [Query Album "Foo", Query Artist "Bar"] data Query = Query Meta String -- ^ Simple query. | MultiQuery [Query] -- ^ Query with multiple conditions. @@ -105,117 +112,26 @@ show (MultiQuery xs) = show xs showList xs _ = unwords $ map show xs --- | Represents a song's playlist index. -data PLIndex = Pos Integer -- ^ A playlist position index (starting from 0) - | ID Integer -- ^ A playlist ID number that more robustly - -- identifies a song. - deriving Show - --- | Represents the different playback states. -data State = Playing - | Stopped - | Paused - deriving (Show, Eq) - --- | Container for MPD status. -data Status = - Status { stState :: State - -- | A percentage (0-100) - , stVolume :: Int - , stRepeat :: Bool - , stRandom :: Bool - -- | A value that is incremented by the server every time the - -- playlist changes. - , stPlaylistVersion :: Integer - , stPlaylistLength :: Integer - -- | Current song's position in the playlist. - , stSongPos :: Maybe PLIndex - -- | Current song's playlist ID. - , stSongID :: Maybe PLIndex - -- | Time elapsed\/total time. - , stTime :: (Seconds, Seconds) - -- | Bitrate (in kilobytes per second) of playing song (if any). - , stBitrate :: Int - -- | Crossfade time. - , stXFadeWidth :: Seconds - -- | Samplerate\/bits\/channels for the chosen output device - -- (see mpd.conf). - , stAudio :: (Int, Int, Int) - -- | Job ID of currently running update (if any). - , stUpdatingDb :: Integer - -- | Last error message (if any). - , stError :: String } - deriving Show - --- | Container for database statistics. -data Stats = - Stats { stsArtists :: Integer -- ^ Number of artists. - , stsAlbums :: Integer -- ^ Number of albums. - , stsSongs :: Integer -- ^ Number of songs. - , stsUptime :: Seconds -- ^ Daemon uptime in seconds. - , stsPlaytime :: Seconds -- ^ Total playing time. - , stsDbPlaytime :: Seconds -- ^ Total play time of all the songs in - -- the database. - , stsDbUpdate :: Integer -- ^ Last database update in UNIX time. - } - deriving Show - --- | Represents a single song item. -data Song = - Song { sgArtist, sgAlbum, sgTitle, sgFilePath, sgGenre, sgName, sgComposer - , sgPerformer :: String - , sgLength :: Seconds -- ^ Length in seconds - , sgDate :: Int -- ^ Year - , sgTrack :: (Int, Int) -- ^ Track number\/total tracks - , sgDisc :: (Int, Int) -- ^ Position in set\/total in set - , sgIndex :: Maybe PLIndex } - deriving Show - --- Avoid the need for writing a proper 'elem' for use in 'prune'. -instance Eq Song where - (==) x y = sgFilePath x == sgFilePath y - --- | Represents the result of running 'count'. -data Count = - Count { cSongs :: Integer -- ^ Number of songs matching the query - , cPlaytime :: Seconds -- ^ Total play time of matching songs - } - deriving Show - --- | Represents an output device. -data Device = - Device { dOutputID :: Int -- ^ Output's ID number - , dOutputName :: String -- ^ Output's name as defined in the MPD - -- configuration file - , dOutputEnabled :: Bool } - deriving Show - -- -- Admin commands -- -- | Turn off an output device. -disableoutput :: Int -> MPD () -disableoutput = getResponse_ . ("disableoutput " ++) . show +disableOutput :: Int -> MPD () +disableOutput = getResponse_ . ("disableoutput " ++) . show -- | Turn on an output device. -enableoutput :: Int -> MPD () -enableoutput = getResponse_ . ("enableoutput " ++) . show +enableOutput :: Int -> MPD () +enableOutput = getResponse_ . ("enableoutput " ++) . show -- | Retrieve information for all output devices. outputs :: MPD [Device] -outputs = liftM (map takeDevInfo . splitGroups . toAssoc) - (getResponse "outputs") - where - takeDevInfo xs = Device { - dOutputID = takeNum "outputid" xs, - dOutputName = takeString "outputname" xs, - dOutputEnabled = takeBool "outputenabled" xs - } +outputs = getResponse "outputs" >>= runParser parseOutputs -- | Update the server's database. -update :: [String] -- ^ Optionally specify a list of paths - -> MPD () +-- If no paths are given, all paths will be scanned. +-- Unreadable or non-existent paths are silently ignored. +update :: [Path] -> MPD () update [] = getResponse_ "update" update [x] = getResponse_ ("update " ++ show x) update xs = getResponses (map (("update " ++) . show) xs) >> return () @@ -231,40 +147,35 @@ where cmd = "list " ++ show mtype ++ maybe "" ((" "++) . show) query -- | Non-recursively list the contents of a database directory. -lsinfo :: Maybe String -- ^ Optionally specify a path. - -> MPD [Either String Song] -lsinfo path = do - (dirs,_,songs) <- liftM takeEntries - (getResponse ("lsinfo " ++ maybe "" show path)) - return (map Left dirs ++ map Right songs) +lsInfo :: Path -> MPD [Either Path Song] +lsInfo = lsInfo' "lsinfo" -- | List the songs (without metadata) in a database directory recursively. -listAll :: Maybe String -> MPD [String] +listAll :: Path -> MPD [Path] listAll path = liftM (map snd . filter ((== "file") . fst) . toAssoc) - (getResponse ("listall " ++ maybe "" show path)) + (getResponse ("listall " ++ show path)) --- | Recursive 'lsinfo'. -listAllinfo :: Maybe String -- ^ Optionally specify a path - -> MPD [Either String Song] -listAllinfo path = do - (dirs,_,songs) <- liftM takeEntries - (getResponse ("listallinfo " ++ maybe "" show path)) - return (map Left dirs ++ map Right songs) +-- | Recursive 'lsInfo'. +listAllInfo :: Path -> MPD [Either Path Song] +listAllInfo = lsInfo' "listallinfo" +-- Helper for lsInfo and listAllInfo. +lsInfo' :: String -> Path -> MPD [Either Path Song] +lsInfo' cmd path = do + liftM (extractEntries (Just . Right, const Nothing, Just . Left)) $ + takeEntries =<< getResponse (cmd ++ " " ++ show path) + -- | Search the database for entries exactly matching a query. find :: Query -> MPD [Song] -find query = liftM takeSongs (getResponse ("find " ++ show query)) +find query = getResponse ("find " ++ show query) >>= takeSongs -- | Search the database using case insensitive matching. search :: Query -> MPD [Song] -search query = liftM takeSongs (getResponse ("search " ++ show query)) +search query = getResponse ("search " ++ show query) >>= takeSongs -- | Count the number of entries matching a query. count :: Query -> MPD Count -count query = liftM (takeCountInfo . toAssoc) - (getResponse ("count " ++ show query)) - where takeCountInfo xs = Count { cSongs = takeNum "songs" xs, - cPlaytime = takeNum "playtime" xs } +count query = getResponse ("count " ++ show query) >>= runParser parseCount -- -- Playlist commands @@ -273,73 +184,72 @@ -- Unless otherwise noted all playlist commands operate on the current -- playlist. +-- This might do better to throw an exception than silently return 0. -- | Like 'add', but returns a playlist id. -addid :: String -> MPD Integer -addid x = - liftM (read . snd . head . toAssoc) (getResponse ("addid " ++ show x)) +addId :: Path -> MPD Integer +addId p = getResponse1 ("addid " ++ show p) >>= + parse parseNum id . snd . head . toAssoc -- | Like 'add_' but returns a list of the files added. -add :: Maybe String -> String -> MPD [String] -add plname x = add_ plname x >> listAll (Just x) +add :: PlaylistName -> Path -> MPD [Path] +add plname x = add_ plname x >> listAll x -- | Add a song (or a whole directory) to a playlist. -- Adds to current if no playlist is specified. -- Will create a new playlist if the one specified does not already exist. -add_ :: Maybe String -- ^ Optionally specify a playlist to operate on - -> String -> MPD () -add_ Nothing = getResponse_ . ("add " ++) . show -add_ (Just plname) = getResponse_ . - (("playlistadd " ++ show plname ++ " ") ++) . show +add_ :: PlaylistName -> Path -> MPD () +add_ "" = getResponse_ . ("add " ++) . show +add_ plname = getResponse_ . + (("playlistadd " ++ show plname ++ " ") ++) . show -- | Clear a playlist. Clears current playlist if no playlist is specified. -- If the specified playlist does not exist, it will be created. -clear :: Maybe String -- ^ Optional name of a playlist to clear. - -> MPD () -clear = getResponse_ . maybe "clear" (("playlistclear " ++) . show) +clear :: PlaylistName -> MPD () +clear = getResponse_ . cmd + where cmd "" = "clear" + cmd pl = "playlistclear " ++ show pl -- | Remove a song from a playlist. -- If no playlist is specified, current playlist is used. -- Note that a playlist position ('Pos') is required when operating on -- playlists other than the current. -delete :: Maybe String -- ^ Optionally specify a playlist to operate on - -> PLIndex -> MPD () -delete Nothing (Pos x) = getResponse_ ("delete " ++ show x) -delete Nothing (ID x) = getResponse_ ("deleteid " ++ show x) -delete (Just plname) (Pos x) = +delete :: PlaylistName -> PLIndex -> MPD () +delete "" (Pos x) = getResponse_ ("delete " ++ show x) +delete "" (ID x) = getResponse_ ("deleteid " ++ show x) +delete plname (Pos x) = getResponse_ ("playlistdelete " ++ show plname ++ " " ++ show x) delete _ _ = fail "'delete' within a playlist doesn't accept a playlist ID" -- | Load an existing playlist. -load :: String -> MPD () +load :: PlaylistName -> MPD () load = getResponse_ . ("load " ++) . show -- | Move a song to a given position. -- Note that a playlist position ('Pos') is required when operating on -- playlists other than the current. -move :: Maybe String -- ^ Optionally specify a playlist to operate on - -> PLIndex -> Integer -> MPD () -move Nothing (Pos from) to = +move :: PlaylistName -> PLIndex -> Integer -> MPD () +move "" (Pos from) to = getResponse_ ("move " ++ show from ++ " " ++ show to) -move Nothing (ID from) to = +move "" (ID from) to = getResponse_ ("moveid " ++ show from ++ " " ++ show to) -move (Just plname) (Pos from) to = +move plname (Pos from) to = getResponse_ ("playlistmove " ++ show plname ++ " " ++ show from ++ " " ++ show to) move _ _ _ = fail "'move' within a playlist doesn't accept a playlist ID" -- | Delete existing playlist. -rm :: String -> MPD () +rm :: PlaylistName -> MPD () rm = getResponse_ . ("rm " ++) . show -- | Rename an existing playlist. -rename :: String -- ^ Name of playlist to be renamed - -> String -- ^ New playlist name +rename :: PlaylistName -- ^ Original playlist + -> PlaylistName -- ^ New playlist name -> MPD () rename plname new = getResponse_ ("rename " ++ show plname ++ " " ++ show new) -- | Save the current playlist. -save :: String -> MPD () +save :: PlaylistName -> MPD () save = getResponse_ . ("save " ++) . show -- | Swap the positions of two songs. @@ -355,61 +265,67 @@ shuffle = getResponse_ "shuffle" -- | Retrieve metadata for songs in the current playlist. -playlistinfo :: Maybe PLIndex -- ^ Optional playlist index. - -> MPD [Song] -playlistinfo x = liftM takeSongs (getResponse cmd) +playlistInfo :: Maybe PLIndex -> MPD [Song] +playlistInfo x = getResponse cmd >>= takeSongs where cmd = case x of Just (Pos x') -> "playlistinfo " ++ show x' Just (ID x') -> "playlistid " ++ show x' Nothing -> "playlistinfo" -- | Retrieve metadata for files in a given playlist. -listplaylistinfo :: String -> MPD [Song] -listplaylistinfo = liftM takeSongs . getResponse . - ("listplaylistinfo " ++) . show +listPlaylistInfo :: PlaylistName -> MPD [Song] +listPlaylistInfo plname = + takeSongs =<< (getResponse . ("listplaylistinfo " ++) $ show plname) -- | Retrieve a list of files in a given playlist. -listplaylist :: String -> MPD [String] -listplaylist = liftM takeValues . getResponse . ("listplaylist " ++) . show +listPlaylist :: PlaylistName -> MPD [Path] +listPlaylist = liftM takeValues . getResponse . ("listplaylist " ++) . show -- | Retrieve file paths and positions of songs in the current playlist. -- Note that this command is only included for completeness sake; it's --- deprecated and likely to disappear at any time. -playlist :: MPD [(PLIndex, String)] -playlist = liftM (map f) (getResponse "playlist") - where f s = let (pos, name) = break (== ':') s - in (Pos $ read pos, drop 1 name) +-- deprecated and likely to disappear at any time, please use 'playlistInfo' +-- instead. +playlist :: MPD [(PLIndex, Path)] +playlist = mapM f =<< getResponse "playlist" + where f s | (pos, name) <- breakChar ':' s + , Just pos' <- parseNum pos + = return (Pos pos', name) + | otherwise = throwError . Unexpected $ show s -- | Retrieve a list of changed songs currently in the playlist since -- a given playlist version. -plchanges :: Integer -> MPD [Song] -plchanges = liftM takeSongs . getResponse . ("plchanges " ++) . show +plChanges :: Integer -> MPD [Song] +plChanges version = + takeSongs =<< (getResponse . ("plchanges " ++) $ show version) --- | Like 'plchanges' but only returns positions and ids. -plchangesposid :: Integer -> MPD [(PLIndex, PLIndex)] -plchangesposid plver = - liftM (map takePosid . splitGroups . toAssoc) (getResponse cmd) - where cmd = "plchangesposid " ++ show plver - takePosid xs = (Pos $ takeNum "cpos" xs, ID $ takeNum "Id" xs) +-- | Like 'plChanges' but only returns positions and ids. +plChangesPosId :: Integer -> MPD [(PLIndex, PLIndex)] +plChangesPosId plver = + getResponse ("plchangesposid " ++ show plver) >>= + mapM f . splitGroups [("cpos",id)] . toAssoc + where f xs | [("cpos", x), ("Id", y)] <- xs + , Just (x', y') <- pair parseNum (x, y) + = return (Pos x', ID y') + | otherwise = throwError . Unexpected $ show xs -- | Search for songs in the current playlist with strict matching. -playlistfind :: Query -> MPD [Song] -playlistfind = liftM takeSongs . getResponse . ("playlistfind " ++) . show +playlistFind :: Query -> MPD [Song] +playlistFind q = takeSongs =<< (getResponse . ("playlistfind " ++) $ show q) -- | Search case-insensitively with partial matches for songs in the -- current playlist. -playlistsearch :: Query -> MPD [Song] -playlistsearch = liftM takeSongs . getResponse . ("playlistsearch " ++) . show +playlistSearch :: Query -> MPD [Song] +playlistSearch q = + takeSongs =<< (getResponse . ("playlistsearch " ++) $ show q) -- | Get the currently playing song. currentSong :: MPD (Maybe Song) currentSong = do - currStatus <- status - if stState currStatus == Stopped - then return Nothing - else do ls <- liftM toAssoc (getResponse "currentsong") - return $ if null ls then Nothing - else Just (takeSongInfo ls) + cs <- status + if stState cs == Stopped + then return Nothing + else getResponse1 "currentsong" >>= + fmap Just . runParser parseSong . toAssoc -- -- Playback commands @@ -460,7 +376,7 @@ repeat :: Bool -> MPD () repeat = getResponse_ . ("repeat " ++) . showBool --- | Set the volume. +-- | Set the volume (0-100 percent). setVolume :: Int -> MPD () setVolume = getResponse_ . ("setvol " ++) . show @@ -468,7 +384,7 @@ -- 'volume 10' will increase the volume by 10 percent, while -- 'volume (-10)' will decrease it by the same amount. -- Note that this command is only included for completeness sake ; it's --- deprecated and may disappear at any time. +-- deprecated and may disappear at any time, please use 'setVolume' instead. volume :: Int -> MPD () volume = getResponse_ . ("volume " ++) . show @@ -477,24 +393,24 @@ -- -- | Clear the current error message in status. -clearerror :: MPD () -clearerror = getResponse_ "clearerror" +clearError :: MPD () +clearError = getResponse_ "clearerror" -- | Retrieve a list of available commands. commands :: MPD [String] commands = liftM takeValues (getResponse "commands") --- | Retrieve a list of unavailable commands. -notcommands :: MPD [String] -notcommands = liftM takeValues (getResponse "notcommands") +-- | Retrieve a list of unavailable (due to access restrictions) commands. +notCommands :: MPD [String] +notCommands = liftM takeValues (getResponse "notcommands") -- | Retrieve a list of available song metadata. -tagtypes :: MPD [String] -tagtypes = liftM takeValues (getResponse "tagtypes") +tagTypes :: MPD [String] +tagTypes = liftM takeValues (getResponse "tagtypes") -- | Retrieve a list of supported urlhandlers. -urlhandlers :: MPD [String] -urlhandlers = liftM takeValues (getResponse "urlhandlers") +urlHandlers :: MPD [String] +urlHandlers = liftM takeValues (getResponse "urlhandlers") -- XXX should the password be quoted? -- | Send password to server to authenticate session. @@ -508,51 +424,20 @@ -- | Get server statistics. stats :: MPD Stats -stats = liftM (parseStats . toAssoc) (getResponse "stats") - where parseStats xs = - Stats { stsArtists = takeNum "artists" xs, - stsAlbums = takeNum "albums" xs, - stsSongs = takeNum "songs" xs, - stsUptime = takeNum "uptime" xs, - stsPlaytime = takeNum "playtime" xs, - stsDbPlaytime = takeNum "db_playtime" xs, - stsDbUpdate = takeNum "db_update" xs } +stats = getResponse "stats" >>= runParser parseStats -- | Get the server's status. status :: MPD Status -status = liftM (parseStatus . toAssoc) (getResponse "status") - where parseStatus xs = - Status { stState = maybe Stopped parseState $ lookup "state" xs, - stVolume = takeNum "volume" xs, - stRepeat = takeBool "repeat" xs, - stRandom = takeBool "random" xs, - stPlaylistVersion = takeNum "playlist" xs, - stPlaylistLength = takeNum "playlistlength" xs, - stXFadeWidth = takeNum "xfade" xs, - stSongPos = takeIndex Pos "song" xs, - stSongID = takeIndex ID "songid" xs, - stTime = maybe (0,0) parseTime $ lookup "time" xs, - stBitrate = takeNum "bitrate" xs, - stAudio = maybe (0,0,0) parseAudio $ lookup "audio" xs, - stUpdatingDb = takeNum "updating_db" xs, - stError = takeString "error" xs - } - parseState x = case x of "play" -> Playing - "pause" -> Paused - _ -> Stopped - parseTime x = let (y,_:z) = break (== ':') x in (read y, read z) - parseAudio x = - let (u,_:u') = break (== ':') x; (v,_:w) = break (== ':') u' in - (read u, read v, read w) +status = getResponse "status" >>= runParser parseStatus -- -- Extensions\/shortcuts. -- -- | Like 'update', but returns the update job id. -updateid :: [String] -> MPD Integer -updateid paths = liftM (read . head . takeValues) cmd - where cmd = case paths of +updateId :: [Path] -> MPD Integer +updateId paths = liftM (read . head . takeValues) cmd + where cmd = case map show paths of [] -> getResponse "update" [x] -> getResponse ("update " ++ x) xs -> getResponses (map ("update " ++) xs) @@ -564,72 +449,87 @@ -- | Add a list of songs\/folders to a playlist. -- Should be more efficient than running 'add' many times. -addMany :: Maybe String -> [String] -> MPD () +addMany :: PlaylistName -> [Path] -> MPD () addMany _ [] = return () addMany plname [x] = add_ plname x -addMany plname xs = getResponses (map (cmd ++) xs) >> return () - where cmd = maybe ("add ") (\pl -> "playlistadd " ++ show pl ++ " ") plname +addMany plname xs = getResponses (map ((cmd ++) . show) xs) >> return () + where cmd = case plname of "" -> "add " + pl -> "playlistadd " ++ show pl ++ " " -- | Delete a list of songs from a playlist. -- If there is a duplicate then no further songs will be deleted, so -- take care to avoid them (see 'prune' for this). -deleteMany :: Maybe String -> [PLIndex] -> MPD () +deleteMany :: PlaylistName -> [PLIndex] -> MPD () deleteMany _ [] = return () deleteMany plname [x] = delete plname x -deleteMany (Just plname) xs = getResponses (map cmd xs) >> return () - where cmd (Pos x) = "playlistdelete " ++ show plname ++ " " ++ show x - cmd _ = "" -deleteMany Nothing xs = getResponses (map cmd xs) >> return () +deleteMany "" xs = getResponses (map cmd xs) >> return () where cmd (Pos x) = "delete " ++ show x cmd (ID x) = "deleteid " ++ show x +deleteMany plname xs = getResponses (map cmd xs) >> return () + where cmd (Pos x) = "playlistdelete " ++ show plname ++ " " ++ show x + cmd _ = "" +-- | Returns all songs and directories that match the given partial +-- path name. +complete :: String -> MPD [Either Path Song] +complete path = do + xs <- liftM matches . lsInfo $ dropFileName path + case xs of + [Left dir] -> complete $ dir ++ "/" + _ -> return xs + where + matches = filter (isPrefixOf path . takePath) + takePath = either id sgFilePath + -- | Crop playlist. -- The bounds are inclusive. -- If 'Nothing' or 'ID' is passed the cropping will leave your playlist alone -- on that side. crop :: Maybe PLIndex -> Maybe PLIndex -> MPD () crop x y = do - pl <- playlistinfo Nothing + pl <- playlistInfo Nothing let x' = case x of Just (Pos p) -> fromInteger p - Just (ID i) -> maybe 0 id (findByID i pl) + Just (ID i) -> fromMaybe 0 (findByID i pl) Nothing -> 0 -- ensure that no songs are deleted twice with 'max'. ys = case y of Just (Pos p) -> drop (max (fromInteger p) x') pl Just (ID i) -> maybe [] (flip drop pl . max x' . (+1)) (findByID i pl) Nothing -> [] - deleteMany Nothing . mapMaybe sgIndex $ take x' pl ++ ys + deleteMany "" . mapMaybe sgIndex $ take x' pl ++ ys where findByID i = findIndex ((==) i . (\(ID j) -> j) . fromJust . sgIndex) -- | Remove duplicate playlist entries. prune :: MPD () -prune = findDuplicates >>= deleteMany Nothing +prune = findDuplicates >>= deleteMany "" -- Find duplicate playlist entries. findDuplicates :: MPD [PLIndex] findDuplicates = liftM (map ((\(ID x) -> ID x) . fromJust . sgIndex) . flip dups ([],[])) $ - playlistinfo Nothing + playlistInfo Nothing where dups [] (_, dup) = dup dups (x:xs) (ys, dup) - | x `elem` xs && x `notElem` ys = dups xs (ys, x:dup) - | otherwise = dups xs (x:ys, dup) + | x `elem` xs && x `notElem` ys = dups xs (ys, x:dup) + | otherwise = dups xs (x:ys, dup) -- | List directories non-recursively. -lsdirs :: Maybe String -- ^ optional path. - -> MPD [String] -lsdirs path = liftM ((\(x,_,_) -> x) . takeEntries) - (getResponse ("lsinfo " ++ maybe "" show path)) +lsDirs :: Path -> MPD [Path] +lsDirs path = + liftM (extractEntries (const Nothing,const Nothing, Just)) $ + takeEntries =<< getResponse ("lsinfo " ++ show path) -- | List files non-recursively. -lsfiles :: Maybe String -- ^ optional path. - -> MPD [String] -lsfiles path = liftM (map sgFilePath . (\(_,_,x) -> x) . takeEntries) - (getResponse ("lsinfo " ++ maybe "" show path)) +lsFiles :: Path -> MPD [Path] +lsFiles path = + liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $ + takeEntries =<< getResponse ("lsinfo " ++ show path) -- | List all playlists. -lsplaylists :: MPD [String] -lsplaylists = liftM ((\(_,x,_) -> x) . takeEntries) (getResponse "lsinfo") +lsPlaylists :: MPD [PlaylistName] +lsPlaylists = + liftM (extractEntries (const Nothing, Just, const Nothing)) $ + takeEntries =<< getResponse "lsinfo" -- | Search the database for songs relating to an artist. findArtist :: Artist -> MPD [Song] @@ -671,9 +571,9 @@ searchTitle = search . Query Title -- | Retrieve the current playlist. --- Equivalent to 'playlistinfo Nothing'. +-- Equivalent to @playlistinfo Nothing@. getPlaylist :: MPD [Song] -getPlaylist = playlistinfo Nothing +getPlaylist = playlistInfo Nothing -- -- Miscellaneous functions. @@ -685,90 +585,52 @@ -- Get the lines of the daemon's response to a list of commands. getResponses :: [String] -> MPD [String] -getResponses cmds = getResponse (concat . intersperse "\n" $ cmds') +getResponses cmds = getResponse . concat $ intersperse "\n" cmds' where cmds' = "command_list_begin" : cmds ++ ["command_list_end"] --- Break up a list of strings into an assoc. list, separating at --- the first ':'. -toAssoc :: [String] -> [(String, String)] -toAssoc = map f - where f x = let (k,v) = break (== ':') x in - (k,dropWhile (== ' ') $ drop 1 v) +-- Helper that throws unexpected error if input is empty. +failOnEmpty :: [String] -> MPD [String] +failOnEmpty [] = throwError $ Unexpected "Non-empty response expected." +failOnEmpty xs = return xs --- Takes an assoc. list with recurring keys, and groups each cycle of --- keys with their values together. The first key of each cycle needs --- to be present in every cycle for it to work, but the rest don't --- affect anything. +-- A wrapper for getResponse that fails on non-empty responses. +getResponse1 :: String -> MPD [String] +getResponse1 x = getResponse x >>= failOnEmpty + -- --- > splitGroups [(1,'a'),(2,'b'),(1,'c'),(2,'d')] == --- > [[(1,'a'),(2,'b')],[(1,'c'),(2,'d')]] -splitGroups :: Eq a => [(a, b)] -> [[(a, b)]] -splitGroups [] = [] -splitGroups (x:xs) = ((x:us):splitGroups vs) - where (us,vs) = break (\y -> fst x == fst y) xs +-- Parsing. +-- -- Run 'toAssoc' and return only the values. takeValues :: [String] -> [String] takeValues = snd . unzip . toAssoc +data EntryType + = SongEntry Song + | PLEntry String + | DirEntry String + deriving Show + -- Separate the result of an lsinfo\/listallinfo call into directories, -- playlists, and songs. -takeEntries :: [String] -> ([String], [String], [Song]) -takeEntries s = - (dirs, playlists, map takeSongInfo . splitGroups $ reverse filedata) - where (dirs, playlists, filedata) = foldl split ([], [], []) $ toAssoc s - split (ds, pls, ss) x@(k, v) | k == "directory" = (v:ds, pls, ss) - | k == "playlist" = (ds, v:pls, ss) - | otherwise = (ds, pls, x:ss) - --- Build a list of song instances from a response. -takeSongs :: [String] -> [Song] -takeSongs = map takeSongInfo . splitGroups . toAssoc - --- Builds a song instance from an assoc. list. -takeSongInfo :: [(String,String)] -> Song -takeSongInfo xs = - Song { - sgArtist = takeString "Artist" xs, - sgAlbum = takeString "Album" xs, - sgTitle = takeString "Title" xs, - sgGenre = takeString "Genre" xs, - sgName = takeString "Name" xs, - sgComposer = takeString "Composer" xs, - sgPerformer = takeString "Performer" xs, - sgDate = takeNum "Date" xs, - sgTrack = maybe (0, 0) parseTrack $ lookup "Track" xs, - sgDisc = maybe (0, 0) parseTrack $ lookup "Disc" xs, - sgFilePath = takeString "file" xs, - sgLength = takeNum "Time" xs, - sgIndex = takeIndex ID "Id" xs - } - where parseTrack x = let (trck, tot) = break (== '/') x - in (read trck, parseNum (drop 1 tot)) - --- Helpers for retrieving values from an assoc. list. -takeString :: String -> [(String, String)] -> String -takeString v = fromMaybe "" . lookup v - -takeIndex :: (Integer -> PLIndex) -> String -> [(String, String)] - -> Maybe PLIndex -takeIndex c v = maybe Nothing (Just . c . parseNum) . lookup v - -takeNum :: (Read a, Num a) => String -> [(String, String)] -> a -takeNum v = maybe 0 parseNum . lookup v - -takeBool :: String -> [(String, String)] -> Bool -takeBool v = maybe False parseBool . lookup v - --- Parse a numeric value, returning 0 on failure. -parseNum :: (Read a, Num a) => String -> a -parseNum = fromMaybe 0 . maybeReads - where maybeReads s = do ; [(x, "")] <- return (reads s) ; return x +takeEntries :: [String] -> MPD [EntryType] +takeEntries = mapM toEntry . splitGroups wrappers . toAssoc . reverse + where + toEntry xs@(("file",_):_) = liftM SongEntry $ runParser parseSong xs + toEntry (("directory",d):_) = return $ DirEntry d + toEntry (("playlist",pl):_) = return $ PLEntry pl + toEntry _ = error "takeEntries: splitGroups is broken" + wrappers = [("file",id), ("directory",id), ("playlist",id)] --- Inverts 'parseBool'. -showBool :: Bool -> String -showBool x = if x then "1" else "0" +-- Extract a subset of songs, directories, and playlists. +extractEntries :: (Song -> Maybe a, String -> Maybe a, String -> Maybe a) + -> [EntryType] -> [a] +extractEntries (fSong,fPlayList,fDir) = catMaybes . map f + where + f (SongEntry s) = fSong s + f (PLEntry pl) = fPlayList pl + f (DirEntry d) = fDir d --- Parse a boolean response value. -parseBool :: String -> Bool -parseBool = (== "1") . take 1 +-- Build a list of song instances from a response. +takeSongs :: [String] -> MPD [Song] +takeSongs = mapM (runParser parseSong) . splitGroups [("file",id)] . toAssoc diff --git a/Network/MPD/Core.hs b/Network/MPD/Core.hs new file mode 100644 --- /dev/null +++ b/Network/MPD/Core.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{- + libmpd for Haskell, an MPD client library. + Copyright (C) 2005-2008 Ben Sinclair + + This library 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 library 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 library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +-} + +-- | Module : Network.MPD.Core +-- Copyright : (c) Ben Sinclair 2005-2008 +-- License : LGPL +-- Maintainer : bsinclai@turing.une.edu.au +-- Stability : alpha +-- Portability : not Haskell 98 (uses MultiParamTypeClasses) +-- +-- Core functionality. + +module Network.MPD.Core ( + -- * Data types + MPD(..), Conn(..), MPDError(..), ACKType(..), Response, + -- * Interacting + getResponse, close, reconnect, kill, + ) where + +import Control.Monad (liftM) +import Control.Monad.Error (Error(..), MonadError(..)) +import Control.Monad.Trans +import Prelude hiding (repeat) +import Data.List (isPrefixOf) +import Data.Maybe +import System.IO + +-- +-- Data types. +-- + +-- A class of transports with which to connect to MPD servers. +data Conn = Conn { cOpen :: IO () -- Open connection + , cClose :: IO () -- Close connection + , cSend :: String -> IO (Response String) -- Write to connection + , cGetPW :: IO (Maybe String) } -- Password function + +-- | The MPDError type is used to signal errors, both from the MPD and +-- otherwise. +data MPDError = NoMPD -- ^ MPD not responding + | TimedOut -- ^ The connection timed out + | Unexpected String -- ^ MPD returned an unexpected response. + -- This is a bug, either in the library or + -- in MPD itself. + | Custom String -- ^ Used for misc. errors + | ACK ACKType String -- ^ ACK type and a message from the + -- server + deriving Eq + +instance Show MPDError where + show NoMPD = "Could not connect to MPD" + show TimedOut = "MPD connection timed out" + show (Unexpected s) = "MPD returned an unexpected response: " ++ s + show (Custom s) = s + show (ACK _ s) = s + +-- | Represents various MPD errors (aka. ACKs). +data ACKType = InvalidArgument -- ^ Invalid argument passed (ACK 2) + | InvalidPassword -- ^ Invalid password supplied (ACK 3) + | Auth -- ^ Authentication required (ACK 4) + | UnknownCommand -- ^ Unknown command (ACK 5) + | FileNotFound -- ^ File or directory not found ACK 50) + | PlaylistMax -- ^ Playlist at maximum size (ACK 51) + | System -- ^ A system error (ACK 52) + | PlaylistLoad -- ^ Playlist loading failed (ACK 53) + | Busy -- ^ Update already running (ACK 54) + | NotPlaying -- ^ An operation requiring playback + -- got interrupted (ACK 55) + | FileExists -- ^ File already exists (ACK 56) + | UnknownACK -- ^ An unknown ACK (aka. bug) + deriving (Eq) + +-- | A response is either an 'MPDError' or some result. +type Response a = Either MPDError a + +-- Export the type name but not the constructor or the field. +-- | The MPD monad is basically a reader and error monad +-- combined. +-- +-- To use the error throwing\/catching capabilities: +-- +-- > import Control.Monad.Error +-- +-- To run IO actions within the MPD monad: +-- +-- > import Control.Monad.Trans +data MPD a = MPD { runMPD :: Conn -> IO (Response a) } + +instance Functor MPD where + fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn + +instance Monad MPD where + return a = MPD $ \_ -> return $ Right a + m >>= f = MPD $ \conn -> runMPD m conn >>= + either (return . Left) (flip runMPD conn . f) + fail err = MPD $ \_ -> return . Left $ Custom err + +instance MonadIO MPD where + liftIO m = MPD $ \_ -> liftM Right m + +instance MonadError MPDError MPD where + throwError e = MPD $ \_ -> return (Left e) + catchError m h = MPD $ \conn -> + runMPD m conn >>= either (flip runMPD conn . h) (return . Right) + +instance Error MPDError where + noMsg = Custom "An error occurred" + strMsg = Custom + +-- +-- Basic connection functions +-- + +-- | Refresh a connection. +reconnect :: MPD () +reconnect = MPD $ \conn -> Right `liftM` cOpen conn + +-- | Kill the server. Obviously, the connection is then invalid. +kill :: MPD () +kill = getResponse "kill" `catchError` cleanup >> return () + where + cleanup TimedOut = MPD $ \conn -> cClose conn >> return (Right []) + cleanup x = throwError x >> return [] + +-- | Close an MPD connection. +close :: MPD () +close = MPD $ \conn -> cClose conn >> return (Right ()) + +-- +-- Sending messages and handling responses. +-- + +-- | Send a command to the MPD and return the result. +getResponse :: String -> MPD [String] +getResponse cmd = MPD f + where + f conn = catchAuth . either Left parseResponse =<< cSend conn cmd + where + catchAuth (Left (ACK Auth _)) = tryPassword conn (f conn) + catchAuth x = return x + +-- Send a password to MPD and run an action on success. +tryPassword :: Conn -> IO (Response a) -> IO (Response a) +tryPassword conn cont = do + resp <- cGetPW conn >>= maybe failAuth (cSend conn . ("password " ++)) + case resp of + Left e -> return $ Left e + Right x -> either (return . Left) (const cont) $ parseResponse x + where failAuth = return . Left $ ACK Auth "Password required" + +-- Consume response and return a Response. +parseResponse :: String -> Response [String] +parseResponse s | null xs = Left $ NoMPD + | isPrefixOf "ACK" (head xs) = Left $ parseAck s + | otherwise = Right $ takeWhile ("OK" /=) xs + where xs = lines s + +parseAck :: String -> MPDError +parseAck s = ACK ack msg + where + ack = case code of + "2" -> InvalidArgument + "3" -> InvalidPassword + "4" -> Auth + "5" -> UnknownCommand + "50" -> FileNotFound + "51" -> PlaylistMax + "52" -> System + "53" -> PlaylistLoad + "54" -> Busy + "55" -> NotPlaying + "56" -> FileExists + _ -> UnknownACK + (code, _, msg) = splitAck s + +-- Break an ACK into (error code, current command, message). +-- ACKs are of the form: +-- ACK [error@command_listNum] {current_command} message_text\n +splitAck :: String -> (String, String, String) +splitAck s = (code, cmd, msg) + where (code, notCode) = between (== '[') (== '@') s + (cmd, notCmd) = between (== '{') (== '}') notCode + msg = drop 1 . snd $ break (== ' ') notCmd + + -- take whatever is between 'f' and 'g'. + between f g xs = let (_, y) = break f xs + in break g (drop 1 y) diff --git a/Network/MPD/Parse.hs b/Network/MPD/Parse.hs new file mode 100644 --- /dev/null +++ b/Network/MPD/Parse.hs @@ -0,0 +1,260 @@ +{- + libmpd for Haskell, an MPD client library. + Copyright (C) 2005-2008 Ben Sinclair + + This library 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 library 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 library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +-} + +-- | Module : Network.MPD.Parse +-- Copyright : (c) Ben Sinclair 2005-2008 +-- License : LGPL +-- Maintainer : bsinclai@turing.une.edu.au +-- Stability : alpha +-- Portability : Haskell 98 +-- +-- Various data types and parsing functions for them. + +module Network.MPD.Parse where + +import Control.Monad.Error +import Network.MPD.Utils +import Network.MPD.Core (MPD, MPDError(Unexpected)) + +type Seconds = Integer + +-- | Represents a song's playlist index. +data PLIndex = Pos Integer -- ^ A playlist position index (starting from 0) + | ID Integer -- ^ A playlist ID number that more robustly + -- identifies a song. + deriving (Show, Eq) + +-- | Represents the different playback states. +data State = Playing + | Stopped + | Paused + deriving (Show, Eq) + +-- | Represents the result of running 'count'. +data Count = + Count { cSongs :: Integer -- ^ Number of songs matching the query + , cPlaytime :: Seconds -- ^ Total play time of matching songs + } + deriving (Eq, Show) + +-- | Builds a 'Count' instance from an assoc. list. +parseCount :: [String] -> Either String Count +parseCount = foldM f empty . toAssoc + where f a ("songs", x) = parse parseNum + (\x' -> a { cSongs = x'}) x + f a ("playtime", x) = parse parseNum + (\x' -> a { cPlaytime = x' }) x + f _ x = Left $ show x + empty = Count { cSongs = 0, cPlaytime = 0 } + +-- | Represents an output device. +data Device = + Device { dOutputID :: Int -- ^ Output's ID number + , dOutputName :: String -- ^ Output's name as defined in the MPD + -- configuration file + , dOutputEnabled :: Bool } + deriving (Eq, Show) + +-- | Builds a list of 'Device' instances from an assoc. list +parseOutputs :: [String] -> Either String [Device] +parseOutputs = mapM (foldM f empty) . splitGroups [("outputid",id)] . toAssoc + where f a ("outputid", x) = parse parseNum (\x' -> a { dOutputID = x' }) x + f a ("outputname", x) = return a { dOutputName = x } + f a ("outputenabled", x) = parse parseBool + (\x' -> a { dOutputEnabled = x'}) x + f _ x = fail $ show x + empty = Device 0 "" False + +-- | Container for database statistics. +data Stats = + Stats { stsArtists :: Integer -- ^ Number of artists. + , stsAlbums :: Integer -- ^ Number of albums. + , stsSongs :: Integer -- ^ Number of songs. + , stsUptime :: Seconds -- ^ Daemon uptime in seconds. + , stsPlaytime :: Seconds -- ^ Total playing time. + , stsDbPlaytime :: Seconds -- ^ Total play time of all the songs in + -- the database. + , stsDbUpdate :: Integer -- ^ Last database update in UNIX time. + } + deriving (Eq, Show) + +-- | Builds a 'Stats' instance from an assoc. list. +parseStats :: [String] -> Either String Stats +parseStats = foldM f defaultStats . toAssoc + where + f a ("artists", x) = parse parseNum (\x' -> a { stsArtists = x' }) x + f a ("albums", x) = parse parseNum (\x' -> a { stsAlbums = x' }) x + f a ("songs", x) = parse parseNum (\x' -> a { stsSongs = x' }) x + f a ("uptime", x) = parse parseNum (\x' -> a { stsUptime = x' }) x + f a ("playtime", x) = parse parseNum (\x' -> a { stsPlaytime = x' }) x + f a ("db_playtime", x) = parse parseNum + (\x' -> a { stsDbPlaytime = x' }) x + f a ("db_update", x) = parse parseNum (\x' -> a { stsDbUpdate = x' }) x + f _ x = fail $ show x + defaultStats = + Stats { stsArtists = 0, stsAlbums = 0, stsSongs = 0, stsUptime = 0 + , stsPlaytime = 0, stsDbPlaytime = 0, stsDbUpdate = 0 } + +-- | Represents a single song item. +data Song = + Song { sgArtist, sgAlbum, sgTitle, sgFilePath, sgGenre, sgName, sgComposer + , sgPerformer :: String + , sgLength :: Seconds -- ^ Length in seconds + , sgDate :: Int -- ^ Year + , sgTrack :: (Int, Int) -- ^ Track number\/total tracks + , sgDisc :: (Int, Int) -- ^ Position in set\/total in set + , sgIndex :: Maybe PLIndex } + deriving Show + +-- Avoid the need for writing a proper 'elem' for use in 'prune'. +instance Eq Song where + (==) x y = sgFilePath x == sgFilePath y + +-- | Builds a 'Song' instance from an assoc. list. +parseSong :: [(String, String)] -> Either String Song +parseSong xs = foldM f song xs + where f a ("Artist", x) = return a { sgArtist = x } + f a ("Album", x) = return a { sgAlbum = x } + f a ("Title", x) = return a { sgTitle = x } + f a ("Genre", x) = return a { sgGenre = x } + f a ("Name", x) = return a { sgName = x } + f a ("Composer", x) = return a { sgComposer = x } + f a ("Performer", x) = return a { sgPerformer = x } + f a ("Date", x) = parse parseDate (\x' -> a { sgDate = x' }) x + f a ("Track", x) = parse parseTuple (\x' -> a { sgTrack = x'}) x + f a ("Disc", x) = parse parseTuple (\x' -> a { sgDisc = x'}) x + f a ("file", x) = return a { sgFilePath = x } + f a ("Time", x) = parse parseNum (\x' -> a { sgLength = x'}) x + f a ("Id", x) = parse parseNum + (\x' -> a { sgIndex = Just (ID x') }) x + -- We prefer Id but take Pos if no Id has been found. + f a ("Pos", x) = + maybe (parse parseNum (\x' -> a { sgIndex = Just (Pos x') }) x) + (const $ return a) + (sgIndex a) + -- Catch unrecognised keys + f _ x = fail $ show x + + parseTuple s = let (x, y) = breakChar '/' s in + -- Handle incomplete values. For example, songs might + -- have a track number, without specifying the total + -- number of tracks, in which case the resulting + -- tuple will have two identical parts. + case (parseNum x, parseNum y) of + (Just x', Nothing) -> Just (x', x') + (Just x', Just y') -> Just (x', y') + _ -> Nothing + + song = Song { sgArtist = "", sgAlbum = "", sgTitle = "" + , sgGenre = "", sgName = "", sgComposer = "" + , sgPerformer = "", sgDate = 0, sgTrack = (0,0) + , sgDisc = (0,0), sgFilePath = "", sgLength = 0 + , sgIndex = Nothing } + +-- | Container for MPD status. +data Status = + Status { stState :: State + -- | A percentage (0-100) + , stVolume :: Int + , stRepeat :: Bool + , stRandom :: Bool + -- | A value that is incremented by the server every time the + -- playlist changes. + , stPlaylistVersion :: Integer + -- | The number of items in the current playlist. + , stPlaylistLength :: Integer + -- | Current song's position in the playlist. + , stSongPos :: Maybe PLIndex + -- | Current song's playlist ID. + , stSongID :: Maybe PLIndex + -- | Time elapsed\/total time. + , stTime :: (Seconds, Seconds) + -- | Bitrate (in kilobytes per second) of playing song (if any). + , stBitrate :: Int + -- | Crossfade time. + , stXFadeWidth :: Seconds + -- | Samplerate\/bits\/channels for the chosen output device + -- (see mpd.conf). + , stAudio :: (Int, Int, Int) + -- | Job ID of currently running update (if any). + , stUpdatingDb :: Integer + -- | Last error message (if any). + , stError :: String } + deriving (Eq, Show) + +-- | Builds a 'Status' instance from an assoc. list. +parseStatus :: [String] -> Either String Status +parseStatus = foldM f empty . toAssoc + where f a ("state", x) = parse state (\x' -> a { stState = x'}) x + f a ("volume", x) = parse parseNum (\x' -> a { stVolume = x'}) x + f a ("repeat", x) = parse parseBool + (\x' -> a { stRepeat = x' }) x + f a ("random", x) = parse parseBool + (\x' -> a { stRandom = x' }) x + f a ("playlist", x) = parse parseNum + (\x' -> a { stPlaylistVersion = x'}) x + f a ("playlistlength", x) = parse parseNum + (\x' -> a { stPlaylistLength = x'}) x + f a ("xfade", x) = parse parseNum + (\x' -> a { stXFadeWidth = x'}) x + f a ("song", x) = parse parseNum + (\x' -> a { stSongPos = Just (Pos x') }) x + f a ("songid", x) = parse parseNum + (\x' -> a { stSongID = Just (ID x') }) x + f a ("time", x) = parse time (\x' -> a { stTime = x' }) x + f a ("bitrate", x) = parse parseNum + (\x' -> a { stBitrate = x'}) x + f a ("audio", x) = parse audio (\x' -> a { stAudio = x' }) x + f a ("updating_db", x) = parse parseNum + (\x' -> a { stUpdatingDb = x' }) x + f a ("error", x) = return a { stError = x } + f _ x = fail $ show x + + state "play" = Just Playing + state "pause" = Just Paused + state "stop" = Just Stopped + state _ = Nothing + + time s = pair parseNum $ breakChar ':' s + + audio s = let (u, u') = breakChar ':' s + (v, w) = breakChar ':' u' in + case (parseNum u, parseNum v, parseNum w) of + (Just a, Just b, Just c) -> Just (a, b, c) + _ -> Nothing + + empty = Status Stopped 0 False False 0 0 Nothing Nothing (0,0) 0 0 + (0,0,0) 0 "" + +-- | Run a parser and lift the result into the 'MPD' monad +runParser :: (input -> Either String a) -> input -> MPD a +runParser f = either (throwError . Unexpected) return . f + +-- | A helper that runs a parser on a string and, depending, on the +-- outcome, either returns the result of some command applied to the +-- result, or fails. Used when building structures. +parse :: Monad m => (String -> Maybe a) -> (a -> b) -> String -> m b +parse p g x = maybe (fail x) (return . g) (p x) + +-- | A helper for running a parser returning Maybe on a pair of strings. +-- Returns Just if both strings where parsed successfully, Nothing otherwise. +pair :: (String -> Maybe a) -> (String, String) -> Maybe (a, a) +pair p (x, y) = case (p x, p y) of + (Just a, Just b) -> Just (a, b) + _ -> Nothing diff --git a/Network/MPD/Prim.hs b/Network/MPD/Prim.hs deleted file mode 100644 --- a/Network/MPD/Prim.hs +++ /dev/null @@ -1,271 +0,0 @@ -{- - libmpd for Haskell, an MPD client library. - Copyright (C) 2005-2007 Ben Sinclair - - This library 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 library 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 library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA --} - --- | Module : Network.MPD.Prim --- Copyright : (c) Ben Sinclair 2005-2007 --- License : LGPL --- Maintainer : bsinclai@turing.une.edu.au --- Stability : alpha --- Portability : Haskell 98 --- --- Core functionality. - -module Network.MPD.Prim ( - -- * Data types - MPD, MPDError(..), ACKType(..), Response, - - -- * Running an action - withMPDEx, - - -- * Errors - throwMPD, catchMPD, - - -- * Interacting - getResponse, close, reconnect, kill, - ) where - -import Control.Monad (liftM, unless) -import Control.Exception (finally) -import Control.Monad.Trans -import Prelude hiding (repeat) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (isPrefixOf) -import Data.Maybe -import Network -import System.IO -import System.IO.Error (isEOFError) - --- --- Data types. --- - --- The field names should not be exported. --- The accessors 'connPortNum' and 'connHandle' are not used, though --- the fields are used (see 'reconnect'). --- | A connection to an MPD server. -data Connection = Conn { connHostName :: String - , connPortNum :: Integer - , connHandle :: IORef (Maybe Handle) - , connGetPass :: IO (Maybe String) - } - --- | The MPDError type is used to signal errors, both from the MPD and --- otherwise. -data MPDError = NoMPD -- ^ MPD not responding - | TimedOut -- ^ The connection timed out - | Custom String -- ^ Used for misc. errors - | ACK ACKType String -- ^ ACK type and a message from the - -- server. - -instance Show MPDError where - show NoMPD = "Could not connect to MPD" - show TimedOut = "MPD connection timed out" - show (Custom s) = s - show (ACK _ s) = s - --- | Represents various MPD errors (aka. ACKs). -data ACKType = InvalidArgument -- ^ Invalid argument passed (ACK 2) - | InvalidPassword -- ^ Invalid password supplied (ACK 3) - | Auth -- ^ Authentication required (ACK 4) - | UnknownCommand -- ^ Unknown command (ACK 5) - | FileNotFound -- ^ File or directory not found ACK 50) - | PlaylistMax -- ^ Playlist at maximum size (ACK 51) - | System -- ^ A system error (ACK 52) - | PlaylistLoad -- ^ Playlist loading failed (ACK 53) - | Busy -- ^ Update already running (ACK 54) - | NotPlaying -- ^ An operation requiring playback - -- got interrupted (ACK 55) - | FileExists -- ^ File already exists (ACK 56) - | UnknownACK -- ^ An unknown ACK (aka. bug) - --- | A response is either an ACK or some result. -type Response a = Either MPDError a - --- Export the type name but not the constructor or the field. --- --- This is basically a state and an error monad combined. It's just --- nice if we can have a few custom functions that fiddle with the --- internals. -newtype MPD a = MPD { runMPD :: Connection -> IO (Response a) } - -instance Functor MPD where - fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn - -instance Monad MPD where - return a = MPD $ \_ -> return (Right a) - m >>= f = MPD $ \conn -> runMPD m conn >>= - either (return . Left) (flip runMPD conn . f) - fail err = MPD $ \_ -> return . Left $ Custom err - -instance MonadIO MPD where - liftIO m = MPD $ \_ -> liftM Right m - --- | Throw an exception. -throwMPD :: MPDError -> MPD () -throwMPD e = MPD $ \_ -> return (Left e) - --- | Catch an exception from an action. -catchMPD :: MPD a -> (MPDError -> MPD a) -> MPD a -catchMPD m h = MPD $ \conn -> - runMPD m conn >>= either (flip runMPD conn . h) (return . Right) - --- --- Basic connection functions --- - --- | Run an MPD action against a server. -withMPDEx :: String -- ^ Host name. - -> Integer -- ^ Port number. - -> IO (Maybe String) -- ^ An action that supplies passwords. - -> MPD a -- ^ The action to run. - -> IO (Response a) -withMPDEx host port getpw m = do - hRef <- newIORef Nothing - connect host port hRef - readIORef hRef >>= maybe (return $ Left NoMPD) - (\_ -> finally (runMPD m $ Conn host port hRef getpw) (closeIO hRef)) - --- Connect to an MPD server. -connect :: String -> Integer -- host and port - -> IORef (Maybe Handle) -> IO () -connect host port hRef = - withSocketsDo $ do - closeIO hRef - handle <- safeConnectTo host port - writeIORef hRef handle - maybe (return ()) (\h -> checkConn h >>= flip unless (closeIO hRef)) - handle - -safeConnectTo :: String -> Integer -> IO (Maybe Handle) -safeConnectTo host port = - catch (liftM Just $ connectTo host (PortNumber $ fromInteger port)) - (const $ return Nothing) - --- Check that an MPD daemon is at the other end of a connection. -checkConn :: Handle -> IO Bool -checkConn h = isPrefixOf "OK MPD" `liftM` hGetLine h - --- Close a connection. -closeIO :: IORef (Maybe Handle) -> IO () -closeIO hRef = do - readIORef hRef >>= maybe (return ()) - (\h -> hPutStrLn h "close" >> hClose h) - writeIORef hRef Nothing - --- | Refresh a connection. -reconnect :: MPD () -reconnect = MPD $ \(Conn host port hRef _) -> do - connect host port hRef - liftM (maybe (Left NoMPD) (const $ Right ())) (readIORef hRef) - --- | Kill the server. Obviously, the connection is then invalid. -kill :: MPD () -kill = getResponse "kill" `catchMPD` cleanup >> return () - where cleanup TimedOut = MPD $ \conn -> do - readIORef (connHandle conn) >>= maybe (return ()) hClose - writeIORef (connHandle conn) Nothing - return (Right []) - cleanup x = throwMPD x >> return [] - --- | Close an MPD connection. -close :: MPD () -close = MPD $ \conn -> closeIO (connHandle conn) >> return (Right ()) - --- | Send a command to the MPD and return the result. -getResponse :: String -> MPD [String] -getResponse cmd = MPD $ \conn -> respRead (sendCmd conn) reader (givePW conn) - where sendCmd conn = - readIORef (connHandle conn) >>= - maybe (return $ Left NoMPD) - (\h -> hPutStrLn h cmd >> hFlush h >> return (Right h)) - reader h = getLineTO h >>= return . (either Left parseResponse) - givePW conn cont (ACK Auth _) = tryPassword conn cont - givePW _ _ ack = return (Left ack) - --- Get a line of text, handling a timed-out connection. -getLineTO :: Handle -> IO (Response String) -getLineTO h = catch (liftM Right $ hGetLine h) - (\err -> if isEOFError err then return $ Left TimedOut - else ioError err) - --- Send a password to MPD and run an action on success. -tryPassword :: Connection -> IO (Response a) -> IO (Response a) -tryPassword conn cont = - readIORef (connHandle conn) >>= maybe (return $ Left NoMPD) get - where - get h = connGetPass conn >>= - maybe (return . Left $ ACK Auth "Password required") (send h) - send h pw = do hPutStrLn h ("password " ++ pw) >> hFlush h - result <- hGetLine h - case result of "OK" -> cont - _ -> tryPassword conn cont - --- XXX suggestions for names welcome. --- --- Run a setup action before a recurrent reader. If the reader returns --- Nothing it has finished reading. If an error is returned a handler --- is called with an action that, when invoked, will run the setup --- action again and continue. -respRead :: IO (Either e a) -- setup - -> (a -> IO (Either e (Maybe b))) -- reader - -> (IO (Either e [b]) -> e -> IO (Either e [b])) -- handler - -> IO (Either e [b]) -respRead sup rdr onErr = start [] - where start acc = sup >>= either (return . Left) (\x -> readAll x acc) - readAll x acc = - rdr x >>= either (onErr (start acc)) - (maybe result (\y -> readAll x (y:acc))) - where result = return $ Right (reverse acc) - --- Consume response and return a Response. -parseResponse :: String -> Response (Maybe String) -parseResponse s | isPrefixOf "ACK" s = Left $ parseAck s - | isPrefixOf "OK" s = Right Nothing - | otherwise = Right $ Just s - -parseAck :: String -> MPDError -parseAck s = ACK ack msg - where - ack = case code of - "2" -> InvalidArgument - "3" -> InvalidPassword - "4" -> Auth - "5" -> UnknownCommand - "50" -> FileNotFound - "51" -> PlaylistMax - "52" -> System - "53" -> PlaylistLoad - "54" -> Busy - "55" -> NotPlaying - "56" -> FileExists - _ -> UnknownACK - (code, _, msg) = splitAck s - --- Break an ACK into (error code, current command, message). --- ACKs are of the form: --- ACK [error@command_listNum] {current_command} message_text\n -splitAck :: String -> (String, String, String) -splitAck s = (code, cmd, msg) - where (code, notCode) = between (== '[') (== '@') s - (cmd, notCmd) = between (== '{') (== '}') notCode - msg = drop 1 . snd $ break (== ' ') notCmd - - -- take whatever is between 'f' and 'g'. - between f g xs = let (_, y) = break f xs - in break g (drop 1 y) diff --git a/Network/MPD/SocketConn.hs b/Network/MPD/SocketConn.hs new file mode 100644 --- /dev/null +++ b/Network/MPD/SocketConn.hs @@ -0,0 +1,95 @@ +{- + libmpd for Haskell, an MPD client library. + Copyright (C) 2005-2008 Ben Sinclair + + This library 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 library 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 library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +-} + +-- | Module : Network.MPD.SocketConn +-- Copyright : (c) Ben Sinclair 2005-2008 +-- License : LGPL +-- Maintainer : bsinclai@turing.une.edu.au +-- Stability : alpha +-- Portability : Haskell 98 +-- +-- Connection over a network socket. + +module Network.MPD.SocketConn (withMPDEx) where + +import Network.MPD.Core hiding (close) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Network +import System.IO +import Control.Monad (liftM, unless) +import Data.List (isPrefixOf) +import System.IO.Error (isEOFError) +import Control.Exception (finally) + +-- | Run an MPD action against a server. +withMPDEx :: String -- ^ Host name. + -> Integer -- ^ Port number. + -> IO (Maybe String) -- ^ An action that supplies passwords. + -> MPD a -- ^ The action to run. + -> IO (Response a) +withMPDEx host port getpw m = do + hR <- newIORef Nothing + let open' = open host port hR + close' = close hR + send' = send hR + open' + runMPD m (Conn open' close' send' getpw) `finally` close' + +open :: String -> Integer -> IORef (Maybe Handle) -> IO () +open host port hR = withSocketsDo $ do + close hR + h <- safeConnectTo host port + writeIORef hR h + maybe (return ()) (\_ -> checkConn hR >>= flip unless (close hR)) h + +close :: IORef (Maybe Handle) -> IO () +close hR = readIORef hR >>= maybe (return ()) sendClose >> writeIORef hR Nothing + where sendClose h = hPutStrLn h "close" >> hClose h `catch` whenEOF () + +send :: IORef (Maybe Handle) -> String -> IO (Response String) +send hR str = do + hM <- readIORef hR + case hM of + Nothing -> return $ Left NoMPD + Just h -> do + unless (null str) (hPutStrLn h str >> hFlush h) + getLines h [] `catch` whenEOF (Left TimedOut) + where + getLines handle acc = do + l <- hGetLine handle + if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l + then return . Right . unlines . reverse $ l:acc + else getLines handle (l:acc) + +-- +-- Helpers +-- + +-- Return a value if the error is an EOFError, otherwise throw the error again. +whenEOF :: a -> IOError -> IO a +whenEOF result err = if isEOFError err then return result else ioError err + +safeConnectTo :: String -> Integer -> IO (Maybe Handle) +safeConnectTo host port = + catch (liftM Just . connectTo host . PortNumber $ fromInteger port) + (const $ return Nothing) + +-- Check that an MPD daemon is at the other end of a connection. +checkConn :: IORef (Maybe Handle) -> IO Bool +checkConn c = liftM (either (const False) (isPrefixOf "OK MPD")) $ send c "" diff --git a/Network/MPD/StringConn.hs b/Network/MPD/StringConn.hs new file mode 100644 --- /dev/null +++ b/Network/MPD/StringConn.hs @@ -0,0 +1,80 @@ +{- + libmpd for Haskell, an MPD client library. + Copyright (C) 2005-2008 Ben Sinclair + + This library 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 library 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 library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +-} + +-- | Module : Network.MPD.StringConn +-- Copyright : (c) Ben Sinclair 2005-2008 +-- License : LGPL +-- Maintainer : bsinclai@turing.une.edu.au +-- Stability : alpha +-- Portability : Haskell 98 +-- +-- Connection over a network socket. + +module Network.MPD.StringConn (Expect, Result(..), testMPD) where + +import Control.Monad (liftM) +import Prelude hiding (exp) +import Network.MPD.Core +import Data.IORef + +-- | An expected request. +type Expect = String + +data Result a = Ok | Failure (Response a) [(Expect,String)] + deriving Show + +-- | Run an action against a set of expected requests and responses, +-- and an expected result. The result is Nothing if everything matched +-- what was expected. If anything differed the result of the +-- computation is returned along with pairs of expected and received +-- requests. +testMPD :: (Eq a) + => [(Expect, Response String)] -- ^ The expected requests and their + -- ^ corresponding responses. + -> Response a -- ^ The expected result. + -> IO (Maybe String) -- ^ An action that supplies passwords. + -> MPD a -- ^ The MPD action to run. + -> IO (Result a) +testMPD pairs expected getpw m = do + expectsRef <- newIORef pairs + mismatchesRef <- newIORef ([] :: [(Expect, String)]) + let open' = return () + close' = return () + send' = send expectsRef mismatchesRef + result <- runMPD m $ Conn open' close' send' getpw + mismatches <- liftM reverse $ readIORef mismatchesRef + return $ if null mismatches && result == expected + then Ok + else Failure result mismatches + +send :: IORef [(Expect, Response String)] -- Expected requests and their + -- responses. + -> IORef [(Expect, String)] -- An initially empty list of + -- mismatches between expected and + -- actual requests. + -> String + -> IO (Response String) +send expsR mmsR str = do + xs <- readIORef expsR + case xs of + ((exp,resp):_) | exp == str -> modifyIORef expsR (drop 1) >> return resp + | otherwise -> addMismatch exp + [] -> addMismatch "" + where + addMismatch exp = modifyIORef mmsR ((exp,str):) >> return (Left NoMPD) diff --git a/Network/MPD/Utils.hs b/Network/MPD/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/MPD/Utils.hs @@ -0,0 +1,88 @@ +{- + libmpd for Haskell, an MPD client library. + Copyright (C) 2005-2008 Ben Sinclair + + This library 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 library 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 library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +-} + +-- | Module : Network.MPD.Utils +-- Copyright : (c) Ben Sinclair 2005-2008 +-- License : LGPL +-- Maintainer : bsinclai@turing.une.edu.au +-- Stability : alpha +-- Portability : Haskell 98 +-- +-- Utilities. + +module Network.MPD.Utils ( + parseDate, parseNum, parseBool, showBool, + breakChar, toAssoc, splitGroups + ) where + +import Data.Char (isDigit) + +-- Break a string a character, removing the separator. +breakChar :: Char -> String -> (String, String) +breakChar c s = let (x, y) = break (== c) s in (x, drop 1 y) + +-- XXX: need a more robust date parser. +-- Parse a date value. +-- > parseDate "2008" = Just 2008 +-- > parseDate "2008-03-01" = Just 2008 +parseDate :: String -> Maybe Int +parseDate = parseNum . takeWhile isDigit + +-- Parse a positive or negative integer value, returning 'Nothing' on failure. +parseNum :: (Read a, Integral a) => String -> Maybe a +parseNum s = do + [(x, "")] <- return (reads s) + return x + +-- Inverts 'parseBool'. +showBool :: Bool -> String +showBool x = if x then "1" else "0" + +-- Parse a boolean response value. +parseBool :: String -> Maybe Bool +parseBool s = case take 1 s of + "1" -> Just True + "0" -> Just False + _ -> Nothing + +-- Break up a list of strings into an assoc. list, separating at +-- the first ':'. +toAssoc :: [String] -> [(String, String)] +toAssoc = map f + where f x = let (k,v) = break (== ':') x in + (k,dropWhile (== ' ') $ drop 1 v) + +-- Takes an assoc. list with recurring keys and groups each cycle of +-- keys with their values together. There can be several keys that +-- begin cycles, being listed as the first tuple component in the +-- first parameter. When a cycle finishes all of its pairs are passed +-- to the key's associated function (the second tuple component) and +-- the result appended to the resulting list. +-- +-- > splitGroups [(1,id),(5,id)] +-- > [(1,'a'),(2,'b'),(5,'c'),(6,'d'),(1,'z'),(2,'y'),(3,'x')] == +-- > [[(1,'a'),(2,'b')],[(5,'c'),(6,'d')],[(1,'z'),(2,'y'),(3,'x')]] +splitGroups :: Eq a => [(a,[(a,b)] -> c)] -> [(a, b)] -> [c] +splitGroups [] _ = [] +splitGroups _ [] = [] +splitGroups wrappers (x@(k,_):xs) = + maybe (splitGroups wrappers xs) id $ do + f <- k `lookup` wrappers + let (us,vs) = break (\(k',_) -> k' `elem` map fst wrappers) xs + return $ (f $ x:us) : splitGroups wrappers vs diff --git a/README b/README --- a/README +++ b/README @@ -2,6 +2,10 @@ libmpd : An MPD client library for Haskell -------------------------------------------- +About MPD: + MPD is a daemon for playing music that is controlled over network + sockets. Its website is at http://www.musicpd.org/. + Dependencies: The Glasgow Haskell Compiler >= 6.4 http://haskell.org/ghc Cabal > 1.0 http://haskell.org/cabal @@ -9,28 +13,30 @@ mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl Building: - $ chmod +x configure Setup.lhs - $ ./Setup.lhs configure --prefix=${HOME} - $ ./Setup.lhs build - $ ./Setup.lhs install --user + $ runhaskell Setup configure --prefix=$HOME + $ runhaskell Setup build + $ runhaskell Setup install --user This assumes you have Cabal installed. Cabal is installed by default with newer GHCs. +API compatibility: + This library covers all the functionality provided by MPD version 0.13.0. + Use: Import the Network.MPD module and specify the libmpd package (-package libmpd) when compiling, or add it to the `Build-Depends' list in your `_.cabal' file. Limitations: - Most of the API is complete, but some parts, most notably parsing, are - not yet as good as they could be. + Some parts, most notably parsing, are not yet as good as they could be. + The library is thus ill-suited for applications where speed is a major + concern. Platforms: libmpd has been confirmed to work on: Linux/x86 - Seems to work on Windows XP as well, but there is no MPD support for - that platform. + Seems to work (as in compile) on Windows XP as well. Latest Sources: darcs get http://turing.une.edu.au/~bsinclai/code/libmpd-haskell diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,4 +1,2 @@ TODO: - improve parsing performance - - find a way to retrieve the name of the currently loaded - playlist (if any). should return "current" by default. diff --git a/libmpd.cabal b/libmpd.cabal --- a/libmpd.cabal +++ b/libmpd.cabal @@ -1,19 +1,40 @@ Name: libmpd -Version: 0.1.3 +Version: 0.2.0 License: LGPL License-file: LICENSE -Copyright: Ben Sinclair 2005-2007 +Copyright: Ben Sinclair 2005-2008 Author: Ben Sinclair Maintainer: bsinclai@turing.une.edu.au -Stability: alpha +Stability: beta Homepage: http://turing.une.edu.au/~bsinclai/code/libmpd-haskell.html Synopsis: An MPD client library. -Description: A client library for MPD, the Music Player Daemon. +Description: A client library for MPD, the Music Player Daemon + (). Category: Network, Sound -Tested-With: GHC == 6.5, GHC == 6.6.1, Hugs == 2006.9 -Build-Depends: base, network, mtl -Extra-Source-Files: TODO README ChangeLog -Exposed-Modules: Network.MPD -Other-Modules: Network.MPD.Prim, Network.MPD.Commands -ghc-options: -Wall -O2 -ghc-prof-options: -auto-all -prof +Tested-With: GHC == 6.6.1, GHC == 6.8.2 +Build-Type: Simple +Cabal-Version: >= 1.2 +Extra-Source-Files: TODO README ChangeLog tests/Properties.hs tests/Commands.hs + tests/Main.hs tests/Displayable.hs tests/run-tests + tests/coverage + +flag test + Description: Test build + Default: False + +flag splitBase + Description: Choose the new smaller, split-up base package. + +Library + Build-Depends: base, network, mtl, filepath + Exposed-Modules: Network.MPD + Other-Modules: Network.MPD.Core, Network.MPD.Commands, + Network.MPD.Parse, Network.MPD.SocketConn, + Network.MPD.StringConn, Network.MPD.Utils + + if flag(test) + ghc-options: -Wall + else + ghc-options: -Wall + + ghc-prof-options: -auto-all -prof diff --git a/tests/Commands.hs b/tests/Commands.hs new file mode 100644 --- /dev/null +++ b/tests/Commands.hs @@ -0,0 +1,459 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +-- | +-- This module provides a way of verifying that the interface to the MPD +-- commands is correct. It does so by capturing the data flow between the +-- command and a dummy socket, checking the captured data against a set of +-- predefined values that are known to be correct. Of course, this does not +-- verify that the external behaviour is correct, it's simply a way of +-- catching silly mistakes and subtle bugs in the interface itself, without +-- having to actually send any requests to a real server. + +module Commands (main) where + +import Displayable +import Network.MPD.Commands +import Network.MPD.Core (Response, MPDError(..)) +import Network.MPD.StringConn + +import Control.Monad +import Prelude hiding (repeat) +import Text.Printf + +main = mapM_ (\(n, f) -> f >>= \x -> printf "%-14s: %s\n" n x) tests + where tests = [("enableOutput", testEnableOutput) + ,("disableOutput", testDisableOutput) + ,("outputs", testOutputs) + ,("update0", testUpdate0) + ,("update1", testUpdate1) + ,("updateMany", testUpdateMany) + ,("find", testFind) + ,("find / complex query", testFindComplex) + ,("list(Nothing)", testListNothing) + ,("list(Just)", testListJust) + ,("listAll", testListAll) + ,("lsInfo", testLsInfo) + ,("listAllInfo", testListAllInfo) + ,("search", testSearch) + ,("count", testCount) + ,("add", testAdd) + ,("add_", testAdd_) + ,("add_ / playlist", testAdd_pl) + ,("addId", testAddId) + ,("clear / playlist", testClearPlaylist) + ,("clear / current", testClearCurrent) + ,("plChangesPosId 0", testPlChangesPosId_0) + ,("plChangesPosId 1", testPlChangesPosId_1) + ,("plChangesPosId wierd", testPlChangesPosId_Wierd) + ,("currentSong(_)", testCurrentSongStopped) + ,("currentSong(>)", testCurrentSongPlaying) + ,("delete0", testDelete0) + ,("delete1", testDelete1) + ,("delete2", testDelete2) + ,("load", testLoad) + ,("move0", testMove0) + ,("move1", testMove1) + ,("move2", testMove2) + ,("rm", testRm) + ,("rename", testRename) + ,("save", testSave) + ,("swap0", testSwap0) + ,("swap1", testSwap1) + ,("shuffle", testShuffle) + ,("playlistInfo0", testPlaylistInfo0) + ,("playlistInfo / pos", testPlaylistInfoPos) + ,("playlistInfo / id", testPlaylistInfoId) + ,("listPlaylistInfo", testListPlaylistInfo) + ,("listPlaylist", testListPlaylist) + ,("playlist", testPlaylist) + ,("plchanges", testPlChanges) + ,("playlistFind", testPlaylistFind) + ,("playlistSearch", testPlaylistSearch) + ,("crossfade", testCrossfade) + ,("play", testPlay) + ,("play / pos", testPlayPos) + ,("play / id", testPlayId) + ,("pause", testPause) + ,("stop", testStop) + ,("next", testNext) + ,("previous", testPrevious) + ,("seek / pos", testSeekPos) + ,("seek / id", testSeekId) + ,("seek / current", testSeekCur) + ,("random", testRandom) + ,("repeat", testRepeat) + ,("setVolume", testSetVolume) + ,("volume", testVolume) + ,("clearError", testClearError) + ,("commands", testCommands) + ,("notCommands", testNotCommands) + ,("tagTypes", testTagTypes) + ,("urlHandlers", testUrlHandlers) + ,("password", testPassword) + ,("ping", testPing) + ,("stats", testStats) + ,("updateId0", testUpdateId0) + ,("updateId1", testUpdateId1) + ,("toggle / stop", testToggleStop) + ,("toggle / play", testTogglePlay) + ,("toggle / pause", testTogglePause) + ,("addMany0", testAddMany0) + ,("addMany1", testAddMany1) + ,("deleteMany1", testDeleteMany1) + ] + +test a b c = liftM (showResult b) $ testMPD a b (return Nothing) c + +test_ a b = test a (Right ()) b + +showResult :: (Show a) => Response a -> Result a -> String +showResult _ Ok = "passed" +showResult expectedResult (Failure result mms) = + "*** FAILURE ***" ++ + concatMap (\(x,y) -> "\n expected request: " ++ show x ++ + "\n actual request: " ++ show y) mms ++ + "\n expected result: " ++ show expectedResult ++ + "\n actual result: " ++ show result + +-- +-- Admin commands +-- + +testEnableOutput = test_ [("enableoutput 1", Right "OK")] (enableOutput 1) + +testDisableOutput = test_ [("disableoutput 1", Right "OK")] (disableOutput 1) + +testOutputs = + test [("outputs", Right resp)] (Right [obj1, obj2]) outputs + where obj1 = empty { dOutputName = "SoundCard0", dOutputEnabled = True } + obj2 = empty { dOutputName = "SoundCard1", dOutputID = 1 } + resp = concatMap display [obj1, obj2] ++ "OK" + +testUpdate0 = test_ [("update", Right "updating_db: 1\nOK")] (update []) + +testUpdate1 = + test_ [("update \"foo\"", Right "updating_db: 1\nOK")] + (update ["foo"]) + +testUpdateMany = + test_ [("command_list_begin\nupdate \"foo\"\nupdate \"bar\"\n\ + \command_list_end", Right "updating_db: 1\nOK")] + (update ["foo","bar"]) + +-- +-- Database commands +-- + +testFind = + test [("find Artist \"Foo\"", Right resp)] (Right [obj]) + (find (Query Artist "Foo")) + where obj = empty { sgArtist = "Foo", sgTitle = "Bar" + , sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 } + resp = display obj ++ "OK" + +testFindComplex = + test [("find Artist \"Foo\" Album \"Bar\"", Right resp)] (Right [obj]) + (find $ MultiQuery [Query Artist "Foo", Query Album "Bar"]) + where obj = empty { sgFilePath = "dir/Foo/Bar/Baz.ogg", sgArtist = "Foo" + , sgAlbum = "Bar", sgTitle = "Baz" } + resp = display obj ++ "OK" + +testListNothing = + test [("list Title", Right "Title: Foo\nTitle: Bar\nOK")] + (Right ["Foo", "Bar"]) + (list Title Nothing) + +testListJust = + test [("list Title Artist \"Muzz\"", Right "Title: Foo\nOK")] + (Right ["Foo"]) + (list Title (Just $ Query Artist "Muzz")) + +testListAll = + test [("listall \"\"", Right "directory: FooBand\n\ + \directory: FooBand/album1\n\ + \file: FooBand/album1/01 - songA.ogg\n\ + \file: FooBand/album1/02 - songB.ogg\nOK")] + (Right ["FooBand/album1/01 - songA.ogg" + ,"FooBand/album1/02 - songB.ogg"]) + (listAll "") + +testLsInfo = + test [("lsinfo \"\"", Right "directory: Foo\ndirectory: Bar\nOK")] + (Right [Left "Bar", Left "Foo"]) + (lsInfo "") + +testListAllInfo = + test [("listallinfo \"\"", Right "directory: Foo\ndirectory: Bar\nOK")] + (Right [Left "Bar", Left "Foo"]) + (listAllInfo "") + +testSearch = + test [("search Artist \"oo\"", Right resp)] (Right [obj]) + (search (Query Artist "oo")) + where obj = empty { sgArtist = "Foo", sgTitle = "Bar" + , sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 } + resp = display obj ++ "OK" + +testCount = + test [("count Title \"Foo\"", Right resp)] (Right obj) + (count (Query Title "Foo")) + where obj = Count 1 60 + resp = display obj ++ "OK" + +-- +-- Playlist commands +-- + +testAdd = + test [("add \"foo\"", Right "OK"), + ("listall \"foo\"", Right "file: Foo\nfile: Bar\nOK")] + (Right ["Foo", "Bar"]) + (add "" "foo") + +testAdd_ = test_ [("add \"foo\"", Right "OK")] (add_ "" "foo") + +testAdd_pl = test_ [("playlistadd \"foo\" \"bar\"", Right "OK")] + (add_ "foo" "bar") + +testAddId = + test [("addid \"dir/Foo-Bar.ogg\"", Right "Id: 20\nOK")] + (Right 20) + (addId "dir/Foo-Bar.ogg") + +testClearPlaylist = test_ [("playlistclear \"foo\"", Right "OK")] + (clear "foo") + +testClearCurrent = test_ [("clear", Right "OK")] (clear "") + +testPlChangesPosId_0 = + test [("plchangesposid 10", Right "OK")] + (Right []) + (plChangesPosId 10) + +testPlChangesPosId_1 = + test [("plchangesposid 10", Right "cpos: 0\nId: 20\nOK")] + (Right [(Pos 0, ID 20)]) + (plChangesPosId 10) + +testPlChangesPosId_Wierd = + test [("plchangesposid 10", Right "cpos: foo\nId: bar\nOK")] + (Left $ Unexpected "[(\"cpos\",\"foo\"),(\"Id\",\"bar\")]") + (plChangesPosId 10) + +testCurrentSongStopped = + test [("status", Right resp)] (Right Nothing) + (currentSong) + where obj = empty { stState = Stopped, stPlaylistVersion = 253 } + resp = display obj ++ "OK" + +testCurrentSongPlaying = + test [("status", Right resp2) + ,("currentsong", Right resp1)] + (Right $ Just song) + (currentSong) + where song = empty { sgArtist = "Foo", sgTitle = "Bar" + , sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 } + resp1 = display song + + estatus = empty { stVolume = 80, stPlaylistVersion = 252 + , stPlaylistLength = 21, stSongPos = Just (Pos 20) + , stSongID = Just (ID 238), stTime = (158, 376) + , stBitrate = 192, stAudio = (44100, 16, 2) + , stState = Playing } + resp2 = display estatus ++ "OK" + +testDelete0 = test_ [("delete 1", Right "OK")] (delete "" (Pos 1)) + +testDelete1 = test_ [("deleteid 1", Right "OK")] (delete "" (ID 1)) + +testDelete2 = test_ [("playlistdelete \"foo\" 1", Right "OK")] (delete "foo" (Pos 1)) + +testLoad = test_ [("load \"foo\"", Right "OK")] (load "foo") + +testMove0 = test_ [("move 1 2", Right "OK")] (move "" (Pos 1) 2) + +testMove1 = test_ [("moveid 1 2", Right "OK")] (move "" (ID 1) 2) + +testMove2 = test_ [("playlistmove \"foo\" 1 2", Right "OK")] (move "foo" (Pos 1) 2) + +testRm = test_ [("rm \"foo\"", Right "OK")] (rm "foo") + +testRename = test_ [("rename \"foo\" \"bar\"", Right "OK")] (rename "foo" "bar") + +testSave = test_ [("save \"foo\"", Right "OK")] (save "foo") + +testSwap0 = test_ [("swap 1 2", Right "OK")] (swap (Pos 1) (Pos 2)) + +testSwap1 = test_ [("swapid 1 2", Right "OK")] (swap (ID 1) (ID 2)) + +testShuffle = test_ [("shuffle", Right "OK")] shuffle + +testPlaylistInfo0 = test [("playlistinfo", Right resp)] (Right [obj]) + (playlistInfo Nothing) + where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 + , sgArtist = "Foo", sgTitle = "Bar" } + resp = display obj ++ "OK" + +testPlaylistInfoPos = test [("playlistinfo 1", Right resp)] (Right [obj]) + (playlistInfo . Just $ Pos 1) + where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 + , sgArtist = "Foo", sgTitle = "Bar" } + resp = display obj ++ "OK" + +testPlaylistInfoId = test [("playlistid 1", Right resp)] (Right [obj]) + (playlistInfo . Just $ ID 1) + where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 + , sgArtist = "Foo", sgTitle = "Bar" } + resp = display obj ++ "OK" + +testListPlaylistInfo = test [("listplaylistinfo \"foo\"", Right resp)] + (Right [obj]) + (listPlaylistInfo "foo") + where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 + , sgArtist = "Foo", sgTitle = "Bar" } + resp = display obj ++ "OK" + +testListPlaylist = test [("listplaylist \"foo\"" + ,Right "file: dir/Foo-bar.ogg\n\ + \file: dir/Quux-quuz.ogg\n\ + \OK")] + (Right ["dir/Foo-bar.ogg", "dir/Quux-quuz.ogg"]) + (listPlaylist "foo") + +testPlaylist = test [("playlist" + ,Right "1:Foo.ogg\n\ + \2:Bar.ogg\n\ + \OK")] + (Right [(Pos 1, "Foo.ogg") + ,(Pos 2, "Bar.ogg")]) + playlist + +testPlChanges = test [("plchanges 0", Right resp)] (Right [obj]) (plChanges 0) + where obj = empty { sgArtist = "Foo", sgTitle = "Bar" + , sgFilePath = "foo/bar.ogg" } + resp = display obj ++ "OK" + +testPlaylistFind = test [("playlistfind Artist \"Foo\"", Right resp)] + (Right [obj]) + (playlistFind $ Query Artist "Foo") + where obj = empty { sgFilePath = "dir/Foo/Bar.ogg", sgArtist = "Foo" } + resp = display obj ++ "OK" + +testPlaylistSearch = test [("playlistsearch Artist \"Foo\"", Right resp)] + (Right [obj]) + (playlistSearch $ Query Artist "Foo") + where obj = empty { sgFilePath = "dir/Foo/Bar.ogg", sgArtist = "Foo" } + resp = display obj ++ "OK" + +-- +-- Playback commands +-- + +testCrossfade = test_ [("crossfade 0", Right "OK")] (crossfade 0) + +testPlay = test_ [("play", Right "OK")] (play Nothing) + +testPlayPos = test_ [("play 1", Right "OK")] (play . Just $ Pos 1) + +testPlayId = test_ [("playid 1", Right "OK")] (play . Just $ ID 1) + +testPause = test_ [("pause 0", Right "OK")] (pause False) + +testStop = test_ [("stop", Right "OK")] stop + +testNext = test_ [("next", Right "OK")] next + +testPrevious = test_ [("previous", Right "OK")] previous + +testSeekPos = test_ [("seek 1 10", Right "OK")] (seek (Just $ Pos 1) 10) + +testSeekId = test_ [("seekid 1 10", Right "OK")] (seek (Just $ ID 1) 10) + +testSeekCur = test_ [("status", Right resp) + ,("seekid 1 10", Right "OK")] + (seek Nothing 10) + where obj = empty { stState = Playing, stSongID = Just (ID 1) } + resp = display obj ++ "OK" + +testRandom = test_ [("random 0", Right "OK")] (random False) + +testRepeat = test_ [("repeat 0", Right "OK")] (repeat False) + +testSetVolume = test_ [("setvol 10", Right "OK")] (setVolume 10) + +testVolume = test_ [("volume 10", Right "OK")] (volume 10) + +-- +-- Miscellaneous commands +-- + +testClearError = test_ [("clearerror", Right "OK")] clearError + +testCommands = + test [("commands", Right "command: foo\ncommand: bar")] + (Right ["foo", "bar"]) + commands + +testNotCommands = + test [("notcommands", Right "command: foo\ncommand: bar")] + (Right ["foo", "bar"]) + notCommands + +testTagTypes = + test [("tagtypes", Right "tagtype: foo\ntagtype: bar")] + (Right ["foo", "bar"]) + tagTypes + +testUrlHandlers = + test [("urlhandlers", Right "urlhandler: foo\nurlhandler: bar")] + (Right ["foo", "bar"]) + urlHandlers + +testPassword = test_ [("password foo", Right "OK")] (password "foo") + +testPing = test_ [("ping", Right "OK")] ping + +testStats = test [("stats", Right resp)] (Right obj) stats + where obj = empty { stsArtists = 1, stsAlbums = 1, stsSongs = 1 + , stsUptime = 100, stsPlaytime = 100, stsDbUpdate = 10 + , stsDbPlaytime = 100 } + resp = display obj ++ "OK" + +-- +-- Extensions\/shortcuts +-- + +testUpdateId0 = test [("update", Right "updating_db: 1")] + (Right 1) + (updateId []) + +testUpdateId1 = test [("update \"foo\"", Right "updating_db: 1")] + (Right 1) + (updateId ["foo"]) + +testTogglePlay = test_ + [("status", Right resp) + ,("pause 1", Right "OK")] + toggle + where resp = display empty { stState = Playing } + +testToggleStop = test_ + [("status", Right resp) + ,("play", Right "OK")] + toggle + where resp = display empty { stState = Stopped } + +testTogglePause = test_ + [("status", Right resp) + ,("play", Right "OK")] + toggle + where resp = display empty { stState = Paused } + +testAddMany0 = test_ [("add \"bar\"", Right "OK")] + (addMany "" ["bar"]) + +testAddMany1 = test_ [("playlistadd \"foo\" \"bar\"", Right "OK")] + (addMany "foo" ["bar"]) + +testDeleteMany1 = test_ [("playlistdelete \"foo\" 1", Right "OK")] + (deleteMany "foo" [Pos 1]) diff --git a/tests/Displayable.hs b/tests/Displayable.hs new file mode 100644 --- /dev/null +++ b/tests/Displayable.hs @@ -0,0 +1,87 @@ +module Displayable (Displayable(..)) where + +import Network.MPD.Utils +import Network.MPD.Parse + +-- | A uniform interface for types that +-- can be turned into raw responses +class Displayable a where + empty :: a -- ^ An empty instance + display :: a -> String -- ^ Transform instantiated object to a + -- string + +instance Displayable Count where + empty = Count { cSongs = 0, cPlaytime = 0 } + display s = unlines $ + ["songs: " ++ show (cSongs s) + ,"playtime: " ++ show (cPlaytime s)] + +instance Displayable Device where + empty = Device 0 "" False + display d = unlines $ + ["outputid: " ++ show (dOutputID d) + ,"outputname: " ++ dOutputName d + ,"outputenabled: " ++ showBool (dOutputEnabled d)] + +instance Displayable Song where + empty = Song { sgArtist = "", sgAlbum = "", sgTitle = "", sgFilePath = "" + , sgGenre = "", sgName = "", sgComposer = "" + , sgPerformer = "", sgLength = 0, sgDate = 0 + , sgTrack = (0,0), sgDisc = (0,0), sgIndex = Nothing } + display s = unlines $ + ["file: " ++ sgFilePath s + ,"Artist: " ++ sgArtist s + ,"Album: " ++ sgAlbum s + ,"Title: " ++ sgTitle s + ,"Genre: " ++ sgGenre s + ,"Name: " ++ sgName s + ,"Composer: " ++ sgComposer s + ,"Performer: " ++ sgPerformer s + ,"Date: " ++ show (sgDate s) + ,"Track: " ++ (let (x,y) = sgTrack s in show x++"/"++show y) + ,"Disc: " ++ (let (x,y) = sgDisc s in show x++"/"++show y) + ,"Time: " ++ show (sgLength s)] + ++ maybe [] (\x -> [case x of Pos n -> "Pos: " ++ show n + ID n -> "Id: " ++ show n]) (sgIndex s) + +instance Displayable Stats where + empty = Stats { stsArtists = 0, stsAlbums = 0, stsSongs = 0, stsUptime = 0 + , stsPlaytime = 0, stsDbPlaytime = 0, stsDbUpdate = 0 } + display s = unlines $ + ["artists: " ++ show (stsArtists s) + ,"albums: " ++ show (stsAlbums s) + ,"songs: " ++ show (stsSongs s) + ,"uptime: " ++ show (stsUptime s) + ,"playtime: " ++ show (stsPlaytime s) + ,"db_playtime: " ++ show (stsDbPlaytime s) + ,"db_update: " ++ show (stsDbUpdate s)] + +instance Displayable Status where + empty = Status { stState = Stopped, stVolume = 0, stRepeat = False + , stRandom = False, stPlaylistVersion = 0 + , stPlaylistLength = 0, stSongPos = Nothing + , stSongID = Nothing, stTime = (0, 0), stBitrate = 0 + , stXFadeWidth = 0, stAudio = (0, 0, 0) + , stUpdatingDb = 0, stError = "" } + display s = unlines $ + ["state: " ++ (case stState s of Playing -> "play" + Paused -> "pause" + _ -> "stop") + ,"volume: " ++ show (stVolume s) + ,"repeat: " ++ showBool (stRepeat s) + ,"random: " ++ showBool (stRandom s) + ,"playlist: " ++ show (stPlaylistVersion s) + ,"playlistlength: " ++ show (stPlaylistLength s) + ,"xfade: " ++ show (stXFadeWidth s) + ,"time: " ++ (let (x, y) = stTime s in show x ++ ":" ++ show y) + ,"bitrate: " ++ show (stBitrate s) + ,"xfade: " ++ show (stXFadeWidth s) + + ,"audio: " ++ (let (x, y, z) = stAudio s in show x ++ ":" ++ show y ++ + ":" ++ show z) + ,"updating_db: " ++ show (stUpdatingDb s) + ,"error: " ++ show (stError s)] + ++ maybe [] (\x -> [case x of Pos n -> "song: " ++ show n + _ -> undefined]) (stSongPos s) + ++ maybe [] (\x -> [case x of ID n -> "songid: " ++ show n + _ -> undefined]) (stSongID s) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- | +-- GUTD: The Grand Unified Test Driver. +import qualified Commands +import qualified Properties + +main = Properties.main >> Commands.main diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,191 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} +module Properties (main) where +import Displayable +import Network.MPD.Utils +import Network.MPD.Parse + +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import System.Environment +import Text.Printf +import Test.QuickCheck + +main :: IO () +main = do + n <- (maybe 100 read . listToMaybe) `liftM` getArgs + mapM_ (\(s, f) -> printf "%-25s : " s >> f n) tests + where tests = [("splitGroups / reversible", + mytest prop_splitGroups_rev) + ,("splitGroups / integrity", + mytest prop_splitGroups_integrity) + ,("parseBool", mytest prop_parseBool) + ,("parseBool / reversible", + mytest prop_parseBool_rev) + ,("showBool", mytest prop_showBool) + ,("toAssoc / reversible", + mytest prop_toAssoc_rev) + ,("toAssoc / integrity", + mytest prop_toAssoc_integrity) + ,("parseNum", mytest prop_parseNum) + ,("parseDate / simple", + mytest prop_parseDate_simple) + ,("parseDate / complex", + mytest prop_parseDate_complex) + ,("parseCount", mytest prop_parseCount) + ,("parseOutputs", mytest prop_parseOutputs) + ,("parseSong", mytest prop_parseSong) + ,("parseStats", mytest prop_parseStats)] + +mytest :: Testable a => a -> Int -> IO () +mytest a n = check defaultConfig { configMaxTest = n } a + +instance Arbitrary Char where + arbitrary = choose ('\0', '\128') + +-- an assoc. string is a string of the form "key: value". +newtype AssocString = AS String + deriving Show + +instance Arbitrary AssocString where + arbitrary = do + key <- arbitrary + val <- arbitrary + return . AS $ key ++ ": " ++ val + +newtype IntegralString = IS String + deriving Show + +instance Arbitrary IntegralString where + arbitrary = fmap (IS . show) (arbitrary :: Gen Integer) + +newtype BoolString = BS String + deriving Show + +instance Arbitrary BoolString where + arbitrary = fmap BS $ oneof [return "1", return "0"] + +-- Positive integers. +newtype PosInt = PI Integer + +instance Show PosInt where + show (PI x) = show x + +instance Arbitrary PosInt where + arbitrary = (PI . abs) `fmap` arbitrary + +-- Simple date representation, like "2004" and "1998". +newtype SimpleDateString = SDS String + deriving Show + +instance Arbitrary SimpleDateString where + arbitrary = (SDS . show) `fmap` (arbitrary :: Gen PosInt) + +-- Complex date representations, like "2004-20-30". +newtype ComplexDateString = CDS String + deriving Show + +instance Arbitrary ComplexDateString where + arbitrary = do + -- eww... + [y,m,d] <- replicateM 3 (arbitrary :: Gen PosInt) + return . CDS . concat . intersperse "-" $ map show [y,m,d] + +prop_parseDate_simple :: SimpleDateString -> Bool +prop_parseDate_simple (SDS x) = isJust $ parseDate x + +prop_parseDate_complex :: ComplexDateString -> Bool +prop_parseDate_complex (CDS x) = isJust $ parseDate x + +prop_toAssoc_rev :: [AssocString] -> Bool +prop_toAssoc_rev x = toAssoc (fromAssoc r) == r + where r = toAssoc (fromAS x) + fromAssoc = map (\(a, b) -> a ++ ": " ++ b) + +prop_toAssoc_integrity :: [AssocString] -> Bool +prop_toAssoc_integrity x = length (toAssoc $ fromAS x) == length x + +fromAS :: [AssocString] -> [String] +fromAS s = [x | AS x <- s] + +prop_parseBool_rev :: BoolString -> Bool +prop_parseBool_rev (BS x) = showBool (fromJust $ parseBool x) == x + +prop_parseBool :: BoolString -> Bool +prop_parseBool (BS "1") = fromJust $ parseBool "1" +prop_parseBool (BS x) = not (fromJust $ parseBool x) + +prop_showBool :: Bool -> Bool +prop_showBool True = showBool True == "1" +prop_showBool x = showBool x == "0" + +prop_splitGroups_rev :: [(String, String)] -> Property +prop_splitGroups_rev xs = not (null xs) ==> + let wrappers = [(fst $ head xs, id)] + r = splitGroups wrappers xs + in r == splitGroups wrappers (concat r) + +prop_splitGroups_integrity :: [(String, String)] -> Property +prop_splitGroups_integrity xs = not (null xs) ==> + sort (concat $ splitGroups [(fst $ head xs, id)] xs) == sort xs + +prop_parseNum :: IntegralString -> Bool +prop_parseNum (IS xs@"") = parseNum xs == Nothing +prop_parseNum (IS xs@('-':_)) = fromMaybe 0 (parseNum xs) <= 0 +prop_parseNum (IS xs) = fromMaybe 0 (parseNum xs) >= 0 + + +-------------------------------------------------------------------------- +-- Parsers +-------------------------------------------------------------------------- + +-- MPD fields can't contain newlines and the parser skips initial spaces. +field :: Gen String +field = (filter (/= '\n') . dropWhile isSpace) `fmap` arbitrary + +instance Arbitrary Count where + arbitrary = do + songs <- arbitrary + time <- arbitrary + return $ Count { cSongs = songs, cPlaytime = time } + +prop_parseCount :: Count -> Bool +prop_parseCount c = Right c == (parseCount . lines $ display c) + +instance Arbitrary Device where + arbitrary = do + did <- arbitrary + name <- field + enabled <- arbitrary + return $ Device did name enabled + +prop_parseOutputs :: [Device] -> Bool +prop_parseOutputs ds = + Right ds == (parseOutputs . lines $ concatMap display ds) + +instance Arbitrary Song where + arbitrary = do + [file,artist,album,title,genre,name,cmpsr,prfmr] <- replicateM 8 field + date <- abs `fmap` arbitrary + len <- arbitrary + (track,disc) <- arbitrary + idx <- oneof [return Nothing + ,liftM (Just . Pos) arbitrary + ,liftM (Just . ID) arbitrary] + return $ Song { sgArtist = artist, sgAlbum = album, sgTitle = title + , sgFilePath = file, sgGenre = genre, sgName = name + , sgComposer = cmpsr, sgPerformer = prfmr, sgLength = len + , sgDate = date, sgTrack = track, sgDisc = disc + , sgIndex = idx } + +prop_parseSong :: Song -> Bool +prop_parseSong s = Right s == (parseSong . toAssoc . lines $ display s) + +instance Arbitrary Stats where + arbitrary = do + [arts,albs,sngs,upt,plt,dbplt,dbupd] <- replicateM 7 (fmap abs $ arbitrary) + return $ Stats arts albs sngs upt plt dbplt dbupd + +prop_parseStats :: Stats -> Bool +prop_parseStats s = Right s == (parseStats . lines $ display s) diff --git a/tests/coverage b/tests/coverage new file mode 100644 --- /dev/null +++ b/tests/coverage @@ -0,0 +1,16 @@ +#!/bin/sh + +# Generate code coverage reports with hpc. +# Needs to be run from within './tests'. +# Non-relevant modules are excluded from the final +# reports. + +rm -f *.tix +mkdir -p build report +ghc -i.. -fhpc --make Main.hs -odir=build -hidir=build && \ + ./Main && \ + hpc markup Main --destdir=report --exclude=Main --exclude=Properties \ + --exclude=Displayable --exclude=Commands \ + --exclude=Network.MPD.StringConn && \ + hpc report Main --exclude=Main --exclude=Properties --exclude=Commands \ + --exclude=Displayable --exclude=Network.MPD.StringConn diff --git a/tests/run-tests b/tests/run-tests new file mode 100644 --- /dev/null +++ b/tests/run-tests @@ -0,0 +1,15 @@ +#!/bin/sh + +# Run tests and signal error on failure. +# Saves output in 'test.log', unless no failures are detected. + +runhaskell -itests tests/Main.hs | tee test.log +if $(grep Falsifiable test.log >/dev/null) \ + || $(grep "\*\*\* FAILURE \*\*\*" test.log >/dev/null) ; then + #echo "Failure detected!" + exit 1 +else + rm test.log +fi +runhaskell Setup configure --disable-optimization -f test && \ +runhaskell Setup build && runhaskell Setup haddock