libmpd 0.1.3 → 0.2.0

raw patch · 18 files changed

+1799/−665 lines, 18 filesdep +filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath

API changes (from Hackage documentation)

Files

• ChangeLog +11/−0
• Network/MPD.hs +16/−11
• Network/MPD/Commands.hs +224/−362
• Network/MPD/Core.hs +204/−0
• Network/MPD/Parse.hs +260/−0
• Network/MPD/Prim.hs +0/−271
• Network/MPD/SocketConn.hs +95/−0
• Network/MPD/StringConn.hs +80/−0
• Network/MPD/Utils.hs +88/−0
• README +14/−8
• TODO +0/−2
• libmpd.cabal +32/−11
• tests/Commands.hs +459/−0
• tests/Displayable.hs +87/−0
• tests/Main.hs +7/−0
• tests/Properties.hs +191/−0
• tests/coverage +16/−0
• tests/run-tests +15/−0

@@ -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. 

@@ -1,6 +1,6 @@ {-     libmpd for Haskell, an MPD client library.-    Copyright (C) 2005-2007  Ben Sinclair <bsinclai@turing.une.edu.au>+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>      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 <http://www.musicpd.org/>.  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")

@@ -1,6 +1,7 @@+{-# LANGUAGE PatternGuards #-} {-     libmpd for Haskell, an MPD client library.-    Copyright (C) 2005-2007  Ben Sinclair <bsinclai@turing.une.edu.au>+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>      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

@@ -0,0 +1,204 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-+    libmpd for Haskell, an MPD client library.+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>++    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)

@@ -0,0 +1,260 @@+{-+    libmpd for Haskell, an MPD client library.+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>++    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

@@ -1,271 +0,0 @@-{--    libmpd for Haskell, an MPD client library.-    Copyright (C) 2005-2007  Ben Sinclair <bsinclai@turing.une.edu.au>--    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)

@@ -0,0 +1,95 @@+{-+    libmpd for Haskell, an MPD client library.+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>++    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 ""

@@ -0,0 +1,80 @@+{-+    libmpd for Haskell, an MPD client library.+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>++    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)

@@ -0,0 +1,88 @@+{-+    libmpd for Haskell, an MPD client library.+    Copyright (C) 2005-2008  Ben Sinclair <bsinclai@turing.une.edu.au>++    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

@@ -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

@@ -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.

@@ -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+                    (<http://www.musicpd.org/>). 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

@@ -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])

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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