libmpd 0.3.1 → 0.4.0

raw patch · 26 files changed

+1599/−1183 lines, 26 filesdep +QuickCheckdep ~basedep ~filepathdep ~mtlnew-component:exe:testnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

Dependency ranges changed: base, filepath, mtl, network, utf8-string

API changes (from Hackage documentation)

Files

• ChangeLog +10/−0
• Network/MPD.hs +12/−24
• Network/MPD/Commands.hs +426/−395
• Network/MPD/Commands/Arg.hs +63/−0
• Network/MPD/Commands/Parse.hs +171/−0
• Network/MPD/Commands/Query.hs +56/−0
• Network/MPD/Commands/Types.hs +194/−0
• Network/MPD/Core.hs +145/−132
• Network/MPD/Core/Class.hs +30/−0
• Network/MPD/Core/Error.hs +50/−0
• Network/MPD/Parse.hs +0/−156
• Network/MPD/SocketConn.hs +0/−83
• Network/MPD/Types.hs +0/−94
• Network/MPD/Utils.hs +16/−14
• README +0/−50
• README.md +99/−0
• TODO +0/−2
• libmpd.cabal +57/−16
• tests/Commands.hs +135/−56
• tests/Displayable.hs +13/−20
• tests/Main.hs +6/−1
• tests/Properties.hs +26/−109
• tests/coverage +0/−16
• tests/coverage.lhs +40/−0
• tests/run-tests +0/−15
• tests/run-tests.lhs +50/−0

@@ -1,3 +1,13 @@+* v0.4.0, 2010-03-26+	- New maintainer: Joachim Fasting <joachim.fasting@gmail.com>+	- Support QuickCheck 2+	- Better MPD api support+	Should be mostly compatible with mpd 0.16+	- Separated operations on current playlist from those on specific+	playlists+	- Fixed password sending+	- Several minor fixes and cleanups+ * v0.3.1, 2008-09-14 	- Now reconnects if MPD closes the connection. 

@@ -1,9 +1,8 @@ -- | Module    : Network.MPD--- Copyright   : (c) Ben Sinclair 2005-2008+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)--- Maintainer  : bsinclai@turing.une.edu.au+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com> -- Stability   : alpha--- Portability : Haskell 98 -- -- 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/>.@@ -14,7 +13,8 @@  module Network.MPD (     -- * Basic data types-    MPD, MPDError(..), ACKType(..), Response,+    MonadMPD, MPD, MPDError(..), ACKType(..), Response,+    Host, Port, Password,     -- * Connections     withMPD, withMPDEx,     module Network.MPD.Commands,@@ -22,13 +22,10 @@  import Network.MPD.Commands import Network.MPD.Core-import Network.MPD.SocketConn+import Network.MPD.Utils  import Control.Monad (liftM)-import Data.Maybe (listToMaybe)-import Data.IORef (newIORef, atomicModifyIORef) import System.Environment (getEnv)-import System.IO import System.IO.Error (isDoesNotExistError, ioError)  -- | A wrapper for 'withMPDEx' that uses localhost:6600 as the default@@ -39,25 +36,16 @@ -- Examples: -- -- > withMPD $ play Nothing--- > withMPD $ add_ "" "tool" >> play Nothing >> currentSong+-- > withMPD $ add_ "tool" >> play Nothing >> currentSong withMPD :: MPD a -> IO (Response a) withMPD m = do-    port <- liftM read (getEnvDefault "MPD_PORT" "6600")-    (pw,host) <- liftM (break (== '@')) (getEnvDefault "MPD_HOST" "localhost")-    let (host',pw') = if null host then (pw,host) else (drop 1 host,pw)-    pwGen <- mkPasswordGen [pw']-    withMPDEx host' port pwGen m+    port       <- read `liftM` getEnvDefault "MPD_PORT" "6600"+    (host, pw) <- parseHost `liftM` getEnvDefault "MPD_HOST" "localhost"+    withMPDEx host port pw m     where         getEnvDefault x dflt =             catch (getEnv x) (\e -> if isDoesNotExistError e                                     then return dflt else ioError e)---- | Create an action that produces passwords for a connection. You--- can pass these to 'withMPDEx' and it will use them to get passwords--- to send to the server until one works or it runs out of them.------ > do gen <- mkPasswordGen ["password1", "password2"]--- >    withMPDEx "localhost" 6600 gen (update [])-mkPasswordGen :: [String] -> IO (IO (Maybe String))-mkPasswordGen = liftM f . newIORef-    where f = flip atomicModifyIORef $ \xs -> (drop 1 xs, listToMaybe xs)+        parseHost s = case breakChar '@' s of+                          (host, "") -> (host, "")+                          (pw, host) -> (host, pw)

@@ -1,51 +1,66 @@-{-# LANGUAGE PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE PatternGuards #-}  -- | Module    : Network.MPD.Commands--- Copyright   : (c) Ben Sinclair 2005-2008+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)--- Maintainer  : bsinclai@turing.une.edu.au+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com> -- Stability   : alpha--- Portability : unportable (uses PatternGuards and TypeSynonymInstances) -- -- Interface to the user commands supported by MPD.  module Network.MPD.Commands (     -- * Command related data types-    Artist, Album, Title, PlaylistName, Path,-    Meta(..), Match(..), Query,-    module Network.MPD.Types,+    module Network.MPD.Commands.Types, -    -- * Admin commands-    disableOutput, enableOutput, kill, outputs, update,+    -- * Query interface+    module Network.MPD.Commands.Query, -    -- * Database commands-    find, list, listAll, listAllInfo, lsInfo, search, count,+    -- * Querying MPD's status+    clearError, currentSong, idle, noidle, status, stats, -    -- * Playlist commands-    -- $playlist-    add, add_, addId, clear, currentSong, delete, load, move,-    playlistInfo, listPlaylist, listPlaylistInfo, playlist, plChanges,-    plChangesPosId, playlistFind, playlistSearch, rm, rename, save, shuffle,-    swap,+    -- * Playback options+    consume, crossfade, random, repeat, setVolume, single, replayGainMode,+    replayGainStatus, -    -- * Playback commands-    crossfade, next, pause, play, previous, random, repeat, seek, setVolume,-    volume, stop,+    -- * Controlling playback+    next, pause, play, previous, seek, stop, -    -- * Miscellaneous commands-    clearError, close, commands, notCommands, password, ping, reconnect, stats,-    status, tagTypes, urlHandlers,+    -- * The current playlist+    add, add_, addId, clear, delete, move, playlist, playlistFind,+    playlistInfo, playlistSearch, plChanges, plChangesPosId, shuffle, swap, +    -- * Stored playlist+    listPlaylist, listPlaylistInfo, listPlaylists, load, playlistAdd,+    playlistAdd_, playlistClear, playlistDelete, playlistMove, rename, rm,+    save,++    -- * The music database+    count, find, findAdd, list, listAll, listAllInfo, lsInfo, search, update,+    rescan,++    -- * Stickers+    stickerGet, stickerSet, stickerDelete, stickerList, stickerFind,++    -- * Connection+    close, kill, password, ping,++    -- * Audio output devices+    disableOutput, enableOutput, outputs,++    -- * Reflection+    commands, notCommands, tagTypes, urlHandlers, decoders,+     -- * Extensions\/shortcuts     addMany, deleteMany, complete, crop, prune, lsDirs, lsFiles, lsPlaylists,-    findArtist, findAlbum, findTitle, listArtists, listAlbums, listAlbum,-    searchArtist, searchAlbum, searchTitle, getPlaylist, toggle, updateId+    listArtists, listAlbums, listAlbum, getPlaylist, toggle, updateId, volume     ) where +import Network.MPD.Commands.Arg+import Network.MPD.Commands.Parse+import Network.MPD.Commands.Query+import Network.MPD.Commands.Types import Network.MPD.Core import Network.MPD.Utils-import Network.MPD.Parse-import Network.MPD.Types  import Control.Monad (liftM, unless) import Control.Monad.Error (throwError)@@ -55,421 +70,448 @@ import System.FilePath (dropFileName)  ----- Data types+-- Querying MPD's status -- --- Arguments for getResponse are accumulated as strings in values of--- this type after being converted from whatever type (an instance of--- MPDArg) they were to begin with.-newtype Args = Args [String]-    deriving Show---- A uniform interface for argument preparation--- The basic idea is that one should be able--- to magically prepare an argument for use with--- an MPD command, without necessarily knowing/\caring--- how it needs to be represented internally.-class Show a => MPDArg a where-    prep :: a -> Args-    -- Note that because of this, we almost-    -- never have to actually provide-    -- an implementation of 'prep'-    prep = Args . return . show---- | Groups together arguments to getResponse.-infixl 3 <++>-(<++>) :: (MPDArg a, MPDArg b) => a -> b -> Args-x <++> y = Args $ xs ++ ys-    where Args xs = prep x-          Args ys = prep y---- | Converts a command name and a string of arguments into the string--- to hand to getResponse.-infix 2 <$>-(<$>) :: (MPDArg a) => String -> a -> String-x <$> y = x ++ " " ++ unwords (filter (not . null) y')-    where Args y' = prep y--instance MPDArg Args where prep = id--instance MPDArg String where-    -- We do this to avoid mangling-    -- non-ascii characters with 'show'-    prep x = Args ['"' : x ++ "\""]--instance (MPDArg a) => MPDArg (Maybe a) where-    prep Nothing = Args []-    prep (Just x) = prep x--instance MPDArg Int-instance MPDArg Integer-instance MPDArg Bool where prep = Args . return . showBool+-- | Clear the current error message in status.+clearError :: MonadMPD m => m ()+clearError = getResponse_ "clearerror" -type Artist       = String-type Album        = String-type Title        = String+-- | Get the currently playing song.+currentSong :: (Functor m, MonadMPD m) => m (Maybe Song)+currentSong = do+    cs <- status+    if stState cs == Stopped+       then return Nothing+       else getResponse1 "currentsong" >>=+            fmap Just . runParser parseSong . toAssocList --- | Used for commands which require a playlist name.--- If empty, the current playlist is used.-type PlaylistName = String+-- | Wait until there is a noteworthy change in one or more of MPD's+-- susbystems. Note that running this command will block until either 'idle'+-- returns or is cancelled by 'noidle'.+idle :: MonadMPD m => m [Subsystem]+idle =+    mapM (\("changed", system) -> case system of "database" -> return Database+                                                 "update"   -> return Update+                                                 "stored_playlist" -> return StoredPlaylist+                                                 "playlist" -> return Playlist+                                                 "player" -> return Player+                                                 "mixer" -> return Mixer+                                                 "output" -> return Output+                                                 "options" -> return Options+                                                 k -> fail ("Unknown subsystem: " ++ k))+         =<< toAssocList `liftM` getResponse "idle" --- | Used for commands which require a path within the database.--- If empty, the root path is used.-type Path         = String+-- | Cancel 'idle'.+noidle :: MonadMPD m => m ()+noidle = getResponse_ "noidle" --- | 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-      deriving Show+-- | Get server statistics.+stats :: MonadMPD m => m Stats+stats = getResponse "stats" >>= runParser parseStats -instance MPDArg Meta+-- | Get the server's status.+status :: MonadMPD m => m Status+status = getResponse "status" >>= runParser parseStatus --- | When searching for specific items in a collection--- of songs, we need a reliable way to build predicates. Match is--- one way of achieving this.--- Each Match is a clause, and by putting matches together in lists, we can--- compose queries. ----- For example, to match any song where the value of artist is \"Foo\", we use:------ > Match Artist "Foo"------ In composite matches (queries), all clauses must be satisfied, which means--- that each additional clause narrows the search. For example, to match--- any song where the value of artist is \"Foo\" AND the value of album is--- \"Bar\", we use:------ > [Match Artist "Foo", Match Album "Bar"]+-- Playback options ----- By adding additional clauses we can narrow the search even more, but this--- is usually not necessary.-data Match = Match Meta String -instance Show Match where-    show (Match meta query) = show meta ++ " \"" ++ query ++ "\""-    showList xs _ = unwords $ map show xs+-- | Set consume mode+consume :: MonadMPD m => Bool -> m ()+consume = getResponse_ . ("consume" <$>) --- | A query comprises a list of Match predicates-type Query = [Match]+-- | Set crossfading between songs.+crossfade :: MonadMPD m => Seconds -> m ()+crossfade secs = getResponse_ ("crossfade" <$> secs) -instance MPDArg Query where-    prep = foldl (<++>) (Args []) . f-        where f = map (\(Match m q) -> Args [show m] <++> q)+-- | Set random playing.+random :: MonadMPD m => Bool -> m ()+random = getResponse_ . ("random" <$>) ------ Admin commands---+-- | Set repeating.+repeat :: MonadMPD m => Bool -> m ()+repeat = getResponse_ . ("repeat" <$>) --- | Turn off an output device.-disableOutput :: Int -> MPD ()-disableOutput = getResponse_ . ("disableoutput" <$>)+-- | Set the volume (0-100 percent).+setVolume :: MonadMPD m => Int -> m ()+setVolume = getResponse_ . ("setvol" <$>) --- | Turn on an output device.-enableOutput :: Int -> MPD ()-enableOutput = getResponse_ . ("enableoutput" <$>)+-- | Set single mode+single :: MonadMPD m => Bool -> m ()+single = getResponse_ . ("single" <$>) --- | Retrieve information for all output devices.-outputs :: MPD [Device]-outputs = getResponse "outputs" >>= runParser parseOutputs+-- | Set the replay gain mode.+replayGainMode :: MonadMPD m => ReplayGainMode -> m ()+replayGainMode = getResponse_ . ("replay_gain_mode" <$>) --- | Update the server's database.--- 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" <$> x)-update xs  = getResponses (map ("update" <$>) xs) >> return ()+-- | Get the replay gain options.+replayGainStatus :: MonadMPD m => m [String]+replayGainStatus = getResponse "replay_gain_status"  ----- Database commands+-- Controlling playback -- --- | List all metadata of metadata (sic).-list :: Meta -- ^ Metadata to list-     -> Query -> MPD [String]-list mtype query = liftM takeValues $ getResponse ("list" <$> mtype <++> query)---- | Non-recursively list the contents of a database directory.-lsInfo :: Path -> MPD [Either Path Song]-lsInfo = lsInfo' "lsinfo"---- | List the songs (without metadata) in a database directory recursively.-listAll :: Path -> MPD [Path]-listAll path = liftM (map snd . filter ((== "file") . fst) . toAssoc)-                     (getResponse $ "listall" <$> path)+-- | Play the next song.+next :: MonadMPD m => m ()+next = getResponse_ "next" --- | Recursive 'lsInfo'.-listAllInfo :: Path -> MPD [Either Path Song]-listAllInfo = lsInfo' "listallinfo"+-- | Pause playing.+pause :: MonadMPD m => Bool -> m ()+pause = getResponse_ . ("pause" <$>) --- 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 <$> path)+-- | Begin\/continue playing.+play :: MonadMPD m => Maybe PLIndex -> m ()+play Nothing        = getResponse_  "play"+play (Just (Pos x)) = getResponse_ ("play"   <$> x)+play (Just (ID x))  = getResponse_ ("playid" <$> x) --- | Search the database for entries exactly matching a query.-find :: Query -> MPD [Song]-find query = getResponse ("find" <$> query) >>= takeSongs+-- | Play the previous song.+previous :: MonadMPD m => m ()+previous = getResponse_ "previous" --- | Search the database using case insensitive matching.-search :: Query -> MPD [Song]-search query = getResponse ("search" <$> query) >>= takeSongs+-- | Seek to some point in a song.+-- Seeks in current song if no position is given.+seek :: MonadMPD m => Maybe PLIndex -> Seconds -> m ()+seek (Just (Pos x)) time = getResponse_ ("seek" <$> x <++> time)+seek (Just (ID x)) time = getResponse_ ("seekid" <$> x <++> time)+seek Nothing time = do+    st <- status+    unless (stState st == Stopped) (seek (stSongID st) time) --- | Count the number of entries matching a query.-count :: Query -> MPD Count-count query = getResponse ("count" <$>  query) >>= runParser parseCount+-- | Stop playing.+stop :: MonadMPD m => m ()+stop = getResponse_ "stop"  ----- Playlist commands+-- The current playlist ----- $playlist--- 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 :: Path -> MPD Integer-addId p = getResponse1 ("addid" <$> p) >>=-          parse parseNum id . snd . head . toAssoc+addId :: MonadMPD m => Path -> Maybe Integer -- ^ Optional playlist position+      -> m Integer+addId p pos = liftM (parse parseNum id 0 . snd . head . toAssocList)+              $ getResponse1 ("addid" <$> p <++> pos)  -- | Like 'add_' but returns a list of the files added.-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_ :: PlaylistName -> Path -> MPD ()-add_ "" path     = getResponse_ ("add" <$> path)-add_ plname path = getResponse_ ("playlistadd" <$> plname <++> path)---- | Clear a playlist. Clears current playlist if no playlist is specified.--- If the specified playlist does not exist, it will be created.-clear :: PlaylistName -> MPD ()-clear "" = getResponse_ "clear"-clear pl = getResponse_ ("playlistclear" <$> 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 :: PlaylistName -> PLIndex -> MPD ()-delete "" (Pos x) = getResponse_ ("delete" <$> x)-delete "" (ID x)  = getResponse_ ("deleteid" <$> x)-delete plname (Pos x) = getResponse_ ("playlistdelete" <$> plname <++> x)-delete _ _ = fail "'delete' within a playlist doesn't accept a playlist ID"---- | Load an existing playlist.-load :: PlaylistName -> MPD ()-load plname = getResponse_ ("load" <$> plname)---- | Move a song to a given position.--- Note that a playlist position ('Pos') is required when operating on--- playlists other than the current.-move :: PlaylistName -> PLIndex -> Integer -> MPD ()-move "" (Pos from) to = getResponse_ ("move" <$> from <++> to)-move "" (ID from) to = getResponse_ ("moveid" <$> from <++> to)-move plname (Pos from) to =-    getResponse_ ("playlistmove" <$> plname <++> from <++> to)-move _ _ _ = fail "'move' within a playlist doesn't accept a playlist ID"---- | Delete existing playlist.-rm :: PlaylistName -> MPD ()-rm plname = getResponse_ ("rm" <$> plname)---- | Rename an existing playlist.-rename :: PlaylistName -- ^ Original playlist-       -> PlaylistName -- ^ New playlist name-       -> MPD ()-rename plname new = getResponse_ ("rename" <$> plname <++> new)---- | Save the current playlist.-save :: PlaylistName -> MPD ()-save plname = getResponse_ ("save" <$> plname)---- | Swap the positions of two songs.--- Note that the positions must be of the same type, i.e. mixing 'Pos' and 'ID'--- will result in a no-op.-swap :: PLIndex -> PLIndex -> MPD ()-swap (Pos x) (Pos y) = getResponse_ ("swap" <$> x <++> y)-swap (ID x)  (ID y)  = getResponse_ ("swapid" <$> x <++> y)-swap _ _ = fail "'swap' cannot mix position and ID arguments"+add :: MonadMPD m => Path -> m [Path]+add x = add_ x >> listAll x --- | Shuffle the playlist.-shuffle :: MPD ()-shuffle = getResponse_ "shuffle"+-- | Add a song (or a whole directory) to the current playlist.+add_ :: MonadMPD m => Path -> m ()+add_ path = getResponse_ ("add" <$> path) --- | Retrieve metadata for songs in the current playlist.-playlistInfo :: Maybe PLIndex -> MPD [Song]-playlistInfo x = getResponse cmd >>= takeSongs-    where cmd = case x of-                    Just (Pos x') -> "playlistinfo" <$> x'-                    Just (ID x')  -> "playlistid"   <$> x'-                    Nothing       -> "playlistinfo"+-- | Clear the current playlist.+clear :: MonadMPD m => m ()+clear = getResponse_ "clear" --- | Retrieve metadata for files in a given playlist.-listPlaylistInfo :: PlaylistName -> MPD [Song]-listPlaylistInfo plname =-    takeSongs =<< getResponse ("listplaylistinfo" <$> plname)+-- | Remove a song from the current playlist.+delete :: MonadMPD m => PLIndex -> m ()+delete (Pos x) = getResponse_ ("delete" <$> x)+delete (ID x)  = getResponse_ ("deleteid" <$> x) --- | Retrieve a list of files in a given playlist.-listPlaylist :: PlaylistName -> MPD [Path]-listPlaylist plname =-    liftM takeValues $ getResponse ("listplaylist" <$> plname)+-- | Move a song to a given position in the current playlist.+move :: MonadMPD m => PLIndex -> Integer -> m ()+move (Pos from) to = getResponse_ ("move" <$> from <++> to)+move (ID from) to = getResponse_ ("moveid" <$> from <++> to)  -- | 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, please use 'playlistInfo' -- instead.-playlist :: MPD [(PLIndex, Path)]+playlist :: MonadMPD m => m [(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 +-- | Search for songs in the current playlist with strict matching.+playlistFind :: MonadMPD m => Query -> m [Song]+playlistFind q = takeSongs =<< getResponse ("playlistfind" <$> q)++-- | Retrieve metadata for songs in the current playlist.+playlistInfo :: MonadMPD m => Maybe (Either PLIndex (Int, Int)) -> m [Song]+playlistInfo x = getResponse cmd >>= takeSongs+    where cmd = case x of+                    Nothing -> "playlistinfo"+                    Just (Left (Pos x')) -> "playlistinfo" <$> x'+                    Just (Left (ID x'))  -> "playlistid" <$> x'+                    Just (Right range)   -> "playlistinfo" <$> range++-- | Search case-insensitively with partial matches for songs in the+-- current playlist.+playlistSearch :: MonadMPD m => Query -> m [Song]+playlistSearch q = takeSongs =<< getResponse ("playlistsearch" <$> q)+ -- | Retrieve a list of changed songs currently in the playlist since -- a given playlist version.-plChanges :: Integer -> MPD [Song]+plChanges :: MonadMPD m => Integer -> m [Song] plChanges version = takeSongs =<< getResponse ("plchanges" <$> version)  -- | Like 'plChanges' but only returns positions and ids.-plChangesPosId :: Integer -> MPD [(PLIndex, PLIndex)]+plChangesPosId :: MonadMPD m => Integer -> m [(PLIndex, PLIndex)] plChangesPosId plver =     getResponse ("plchangesposid" <$> plver) >>=-    mapM f . splitGroups [("cpos",id)] . toAssoc+    mapM f . splitGroups [("cpos",id)] . toAssocList     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 q = takeSongs =<< getResponse ("playlistfind" <$> q)+-- | Shuffle the playlist.+shuffle :: MonadMPD m => Maybe (Int, Int) -- ^ Optional range (start, end)+        -> m ()+shuffle range = getResponse_ ("shuffle" <$> range) --- | Search case-insensitively with partial matches for songs in the--- current playlist.-playlistSearch :: Query -> MPD [Song]-playlistSearch q = takeSongs =<< getResponse ("playlistsearch" <$> q)+-- | Swap the positions of two songs.+-- Note that the positions must be of the same type, i.e. mixing 'Pos' and 'ID'+-- will result in a no-op.+swap :: MonadMPD m => PLIndex -> PLIndex -> m ()+swap (Pos x) (Pos y) = getResponse_ ("swap" <$> x <++> y)+swap (ID x)  (ID y)  = getResponse_ ("swapid" <$> x <++> y)+swap _ _ = fail "'swap' cannot mix position and ID arguments" --- | Get the currently playing song.-currentSong :: MPD (Maybe Song)-currentSong = do-    cs <- status-    if stState cs == Stopped-       then return Nothing-       else getResponse1 "currentsong" >>=-            fmap Just . runParser parseSong . toAssoc+--+-- Stored playlists+-- +-- | Retrieve a list of files in a given playlist.+listPlaylist :: MonadMPD m => PlaylistName -> m [Path]+listPlaylist plname =+    liftM takeValues $ getResponse ("listplaylist" <$> plname)++-- | Retrieve metadata for files in a given playlist.+listPlaylistInfo :: MonadMPD m => PlaylistName -> m [Song]+listPlaylistInfo plname =+    takeSongs =<< getResponse ("listplaylistinfo" <$> plname)++-- | Retreive a list of stored playlists.+listPlaylists :: MonadMPD m => m [PlaylistName]+listPlaylists = (go [] . toAssocList) `liftM` getResponse "listplaylists"+    where+        -- After each playlist name we get a timestamp+        go acc [] = acc+        go acc ((_, b):_:xs) = go (b : acc) xs+        go _ _ = error "listPlaylists: bug"++-- | Load an existing playlist.+load :: MonadMPD m => PlaylistName -> m ()+load plname = getResponse_ ("load" <$> plname)++-- | Like 'playlistAdd' but returns a list of the files added.+playlistAdd :: MonadMPD m => PlaylistName -> Path -> m [Path]+playlistAdd plname path = playlistAdd_ plname path >> listAll path++-- | Add a song (or a whole directory) to a stored playlist.+-- Will create a new playlist if the one specified does not already exist.+playlistAdd_ :: MonadMPD m => PlaylistName -> Path -> m ()+playlistAdd_ plname path = getResponse_ ("playlistadd" <$> plname <++> path)++-- | Clear a playlist. If the specified playlist does not exist, it will be+-- created.+playlistClear :: MonadMPD m => PlaylistName -> m ()+playlistClear = getResponse_ . ("playlistclear" <$>)++-- | Remove a song from a playlist.+playlistDelete :: MonadMPD m => PlaylistName+               -> Integer -- ^ Playlist position+               -> m ()+playlistDelete name pos = getResponse_ ("playlistdelete" <$> name <++> pos)++-- | Move a song to a given position in the playlist specified.+playlistMove :: MonadMPD m => PlaylistName -> Integer -> Integer -> m ()+playlistMove name from to =+    getResponse_ ("playlistmove" <$> name <++> from <++> to)++-- | Rename an existing playlist.+rename :: MonadMPD m+       => PlaylistName -- ^ Original playlist+       -> PlaylistName -- ^ New playlist name+       -> m ()+rename plname new = getResponse_ ("rename" <$> plname <++> new)++-- | Delete existing playlist.+rm :: MonadMPD m => PlaylistName -> m ()+rm plname = getResponse_ ("rm" <$> plname)++-- | Save the current playlist.+save :: MonadMPD m => PlaylistName -> m ()+save plname = getResponse_ ("save" <$> plname)+ ----- Playback commands+-- The music database -- --- | Set crossfading between songs.-crossfade :: Seconds -> MPD ()-crossfade secs = getResponse_ ("crossfade" <$> secs)+-- | Count the number of entries matching a query.+count :: MonadMPD m => Query -> m Count+count query = getResponse ("count" <$>  query) >>= runParser parseCount --- | Begin\/continue playing.-play :: Maybe PLIndex -> MPD ()-play Nothing        = getResponse_  "play"-play (Just (Pos x)) = getResponse_ ("play"   <$> x)-play (Just (ID x))  = getResponse_ ("playid" <$> x)+-- | Search the database for entries exactly matching a query.+find :: MonadMPD m => Query -> m [Song]+find query = getResponse ("find" <$> query) >>= takeSongs --- | Pause playing.-pause :: Bool -> MPD ()-pause = getResponse_ . ("pause" <$>)+-- | Adds songs matching a query to the current playlist.+findAdd :: MonadMPD m => Query -> m ()+findAdd q = getResponse_ ("findadd" <$> q) --- | Stop playing.-stop :: MPD ()-stop = getResponse_ "stop"+-- | List all metadata of metadata (sic).+list :: MonadMPD m+     => Meta -- ^ Metadata to list+     -> Query -> m [String]+list mtype query = liftM takeValues $ getResponse ("list" <$> mtype <++> query) --- | Play the next song.-next :: MPD ()-next = getResponse_ "next"+-- | List the songs (without metadata) in a database directory recursively.+listAll :: MonadMPD m => Path -> m [Path]+listAll path = liftM (map snd . filter ((== "file") . fst) . toAssocList)+                     (getResponse $ "listall" <$> path) --- | Play the previous song.-previous :: MPD ()-previous = getResponse_ "previous"+-- Helper for lsInfo and listAllInfo.+lsInfo' :: MonadMPD m => String -> Path -> m [Either Path Song]+lsInfo' cmd path =+    liftM (extractEntries (Just . Right, const Nothing, Just . Left)) $+         takeEntries =<< getResponse (cmd <$> path) --- | Seek to some point in a song.--- Seeks in current song if no position is given.-seek :: Maybe PLIndex -> Seconds -> MPD ()-seek (Just (Pos x)) time = getResponse_ ("seek" <$> x <++> time)-seek (Just (ID x)) time = getResponse_ ("seekid" <$> x <++> time)-seek Nothing time = do-    st <- status-    unless (stState st == Stopped) (seek (stSongID st) time)+-- | Recursive 'lsInfo'.+listAllInfo :: MonadMPD m => Path -> m [Either Path Song]+listAllInfo = lsInfo' "listallinfo" --- | Set random playing.-random :: Bool -> MPD ()-random = getResponse_ . ("random" <$>)+-- | Non-recursively list the contents of a database directory.+lsInfo :: MonadMPD m => Path -> m [Either Path Song]+lsInfo = lsInfo' "lsinfo" --- | Set repeating.-repeat :: Bool -> MPD ()-repeat = getResponse_ . ("repeat" <$>)+-- | Search the database using case insensitive matching.+search :: MonadMPD m => Query -> m [Song]+search query = getResponse ("search" <$> query) >>= takeSongs --- | Set the volume (0-100 percent).-setVolume :: Int -> MPD ()-setVolume = getResponse_ . ("setvol" <$>)+-- | Update the server's database.+-- If no paths are given, all paths will be scanned.+-- Unreadable or non-existent paths are silently ignored.+update :: MonadMPD m => [Path] -> m ()+update  [] = getResponse_ "update"+update [x] = getResponse_ ("update" <$> x)+update xs  = getResponses (map ("update" <$>) xs) >> return () --- | Increase or decrease volume by a given percent, e.g.--- '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, please use 'setVolume' instead.-volume :: Int -> MPD ()-volume = getResponse_ . ("volume" <$>)+-- | Like 'update' but also rescans unmodified files.+rescan :: MonadMPD m => [Path] -> m ()+rescan []  = getResponse_ "rescan"+rescan [x] = getResponse_ ("rescan" <$> x)+rescan xs  = getResponses (map ("rescan" <$>) xs) >> return ()  ----- Miscellaneous commands+-- Stickers -- --- | Clear the current error message in status.-clearError :: MPD ()-clearError = getResponse_ "clearerror"+-- | Reads a sticker value for the specified object.+stickerGet :: MonadMPD m => ObjectType+           -> String -- ^ Object URI+           -> String -- ^ Sticker name+           -> m [String]+stickerGet typ uri name = takeValues `liftM` getResponse ("sticker get" <$> typ <++> uri <++> name) --- | Retrieve a list of available commands.-commands :: MPD [String]-commands = liftM takeValues (getResponse "commands")+-- | Adds a sticker value to the specified object.+stickerSet :: MonadMPD m => ObjectType+           -> String -- ^ Object URI+           -> String -- ^ Sticker name+           -> String -- ^ Sticker value+           -> m ()+stickerSet typ uri name value =+    getResponse_ ("sticker set" <$> typ <++> uri <++> name <++> value) --- | Retrieve a list of unavailable (due to access restrictions) commands.-notCommands :: MPD [String]-notCommands = liftM takeValues (getResponse "notcommands")+-- | Delete a sticker value from the specified object.+stickerDelete :: MonadMPD m => ObjectType+              -> String -- ^ Object URI+              -> String -- ^ Sticker name+              -> m ()+stickerDelete typ uri name =+    getResponse_ ("sticker delete" <$> typ <++> uri <++> name) --- | Retrieve a list of available song metadata.-tagTypes :: MPD [String]-tagTypes = liftM takeValues (getResponse "tagtypes")+-- | Lists the stickers for the specified object.+stickerList :: MonadMPD m => ObjectType+            -> String -- ^ Object URI+            -> m [(String, String)] -- ^ Sticker name\/sticker value+stickerList typ uri =+    toAssocList `liftM` getResponse ("sticker list" <$> typ <++> uri) --- | Retrieve a list of supported urlhandlers.-urlHandlers :: MPD [String]-urlHandlers = liftM takeValues (getResponse "urlhandlers")+-- | Searches the sticker database for stickers with the specified name, below+-- the specified path.+stickerFind :: MonadMPD m => ObjectType+            -> String -- ^ Path+            -> String -- ^ Sticker name+            -> m [(String, String)] -- ^ URI\/sticker value+stickerFind typ uri name =+    toAssocList `liftM`+    getResponse ("sticker find" <$> typ <++> uri <++> name) --- XXX should the password be quoted? Change "++" to "<$>" if so.+--+-- Connection+--++-- XXX should the password be quoted? Change "++" to "<$>" if so.  If+--     it should, it also needs to be fixed in N.M.Core. -- | Send password to server to authenticate session. -- Password is sent as plain text.-password :: String -> MPD ()+password :: MonadMPD m => String -> m () password = getResponse_ . ("password " ++)  -- | Check that the server is still responding.-ping :: MPD ()+ping :: MonadMPD m => m () ping = getResponse_ "ping" --- | Get server statistics.-stats :: MPD Stats-stats = getResponse "stats" >>= runParser parseStats+--+-- Audio output devices+-- --- | Get the server's status.-status :: MPD Status-status = getResponse "status" >>= runParser parseStatus+-- | Turn off an output device.+disableOutput :: MonadMPD m => Int -> m ()+disableOutput = getResponse_ . ("disableoutput" <$>) +-- | Turn on an output device.+enableOutput :: MonadMPD m => Int -> m ()+enableOutput = getResponse_ . ("enableoutput" <$>)++-- | Retrieve information for all output devices.+outputs :: MonadMPD m => m [Device]+outputs = getResponse "outputs" >>= runParser parseOutputs+ --+-- Reflection+--++-- | Retrieve a list of available commands.+commands :: MonadMPD m => m [String]+commands = liftM takeValues (getResponse "commands")++-- | Retrieve a list of unavailable (due to access restrictions) commands.+notCommands :: MonadMPD m => m [String]+notCommands = liftM takeValues (getResponse "notcommands")++-- | Retrieve a list of available song metadata.+tagTypes :: MonadMPD m => m [String]+tagTypes = liftM takeValues (getResponse "tagtypes")++-- | Retrieve a list of supported urlhandlers.+urlHandlers :: MonadMPD m => m [String]+urlHandlers = liftM takeValues (getResponse "urlhandlers")++-- | Retreive a list of decoder plugins with associated suffix and mime types.+decoders :: MonadMPD m => m [(String, [(String, String)])]+decoders = (takeDecoders . toAssocList) `liftM` getResponse "decoders"+    where+        takeDecoders [] = []+        takeDecoders ((_, p):xs) =+            let (info, rest) = break ((==) "plugin" . fst) xs+            in (p, info) : takeDecoders rest++-- -- Extensions\/shortcuts. --  -- | Like 'update', but returns the update job id.-updateId :: [Path] -> MPD Integer+updateId :: MonadMPD m => [Path] -> m Integer updateId paths = liftM (read . head . takeValues) cmd   where cmd = case paths of                 []  -> getResponse  "update"@@ -477,15 +519,16 @@                 xs  -> getResponses $ map ("update" <$>) xs  -- | Toggles play\/pause. Plays if stopped.-toggle :: MPD ()+toggle :: MonadMPD m => m () toggle = status >>= \st -> case stState st of Playing -> pause True                                               _       -> play Nothing  -- | Add a list of songs\/folders to a playlist. -- Should be more efficient than running 'add' many times.-addMany :: PlaylistName -> [Path] -> MPD ()+addMany :: MonadMPD m => PlaylistName -> [Path] -> m () addMany _ [] = return ()-addMany plname [x] = add_ plname x+addMany "" [x] = add_ x+addMany plname [x] = playlistAdd_ plname x addMany plname xs = getResponses (map cmd xs) >> return ()     where cmd x = case plname of                       "" -> "add" <$> x@@ -494,9 +537,9 @@ -- | 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 :: PlaylistName -> [PLIndex] -> MPD ()+deleteMany :: MonadMPD m => PlaylistName -> [PLIndex] -> m () deleteMany _ [] = return ()-deleteMany plname [x] = delete plname x+deleteMany plname [(Pos x)] = playlistDelete plname x deleteMany "" xs = getResponses (map cmd xs) >> return ()     where cmd (Pos x) = "delete"   <$> x           cmd (ID x)  = "deleteid" <$> x@@ -506,7 +549,7 @@  -- | Returns all songs and directories that match the given partial -- path name.-complete :: String -> MPD [Either Path Song]+complete :: MonadMPD m => String -> m [Either Path Song] complete path = do     xs <- liftM matches . lsInfo $ dropFileName path     case xs of@@ -518,9 +561,11 @@  -- | Crop playlist. -- The bounds are inclusive.--- If 'Nothing' or 'ID' is passed the cropping will leave your playlist alone+-- If 'Nothing' is passed the cropping will leave your playlist alone -- on that side.-crop :: Maybe PLIndex -> Maybe PLIndex -> MPD ()+-- Using 'ID' will automatically find the absolute playlist position and use+-- that as the cropping boundary.+crop :: MonadMPD m => Maybe PLIndex -> Maybe PLIndex -> m () crop x y = do     pl <- playlistInfo Nothing     let x' = case x of Just (Pos p) -> fromInteger p@@ -535,11 +580,11 @@     where findByID i = findIndex ((==) i . (\(ID j) -> j) . fromJust . sgIndex)  -- | Remove duplicate playlist entries.-prune :: MPD ()+prune :: MonadMPD m => m () prune = findDuplicates >>= deleteMany ""  -- Find duplicate playlist entries.-findDuplicates :: MPD [PLIndex]+findDuplicates :: MonadMPD m => m [PLIndex] findDuplicates =     liftM (map ((\(ID x) -> ID x) . fromJust . sgIndex) . flip dups ([],[])) $         playlistInfo Nothing@@ -550,105 +595,89 @@           mSong x = let m = sgFilePath x in any ((==) m . sgFilePath)  -- | List directories non-recursively.-lsDirs :: Path -> MPD [Path]+lsDirs :: MonadMPD m => Path -> m [Path] lsDirs path =     liftM (extractEntries (const Nothing,const Nothing, Just)) $         takeEntries =<< getResponse ("lsinfo" <$> path)  -- | List files non-recursively.-lsFiles :: Path -> MPD [Path]+lsFiles :: MonadMPD m => Path -> m [Path] lsFiles path =     liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $         takeEntries =<< getResponse ("lsinfo" <$> path)  -- | List all playlists.-lsPlaylists :: MPD [PlaylistName]+lsPlaylists :: MonadMPD m => m [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]-findArtist x = find [Match Artist x]---- | Search the database for songs relating to an album.-findAlbum :: Album -> MPD [Song]-findAlbum  x = find [Match Album x]---- | Search the database for songs relating to a song title.-findTitle :: Title -> MPD [Song]-findTitle x = find [Match Title x]- -- | List the artists in the database.-listArtists :: MPD [Artist]+listArtists :: MonadMPD m => m [Artist] listArtists = liftM takeValues (getResponse "list artist")  -- | List the albums in the database, optionally matching a given -- artist.-listAlbums :: Maybe Artist -> MPD [Album]+listAlbums :: MonadMPD m => Maybe Artist -> m [Album] listAlbums artist = liftM takeValues $                     getResponse ("list album" <$> fmap ("artist" <++>) artist)  -- | List the songs in an album of some artist.-listAlbum :: Artist -> Album -> MPD [Song]-listAlbum artist album = find [Match Artist artist, Match Album album]---- | Search the database for songs relating to an artist using 'search'.-searchArtist :: Artist -> MPD [Song]-searchArtist x = search [Match Artist x]---- | Search the database for songs relating to an album using 'search'.-searchAlbum :: Album -> MPD [Song]-searchAlbum x = search [Match Album x]---- | Search the database for songs relating to a song title.-searchTitle :: Title -> MPD [Song]-searchTitle x = search [Match Title x]+listAlbum :: MonadMPD m => Artist -> Album -> m [Song]+listAlbum artist album = find (Artist =? artist <&> Album =? album)  -- | Retrieve the current playlist. -- Equivalent to @playlistinfo Nothing@.-getPlaylist :: MPD [Song]+getPlaylist :: MonadMPD m => m [Song] getPlaylist = playlistInfo Nothing +-- | Increase or decrease volume by a given percent, e.g.+-- 'volume 10' will increase the volume by 10 percent, while+-- 'volume (-10)' will decrease it by the same amount.+volume :: MonadMPD m => Int -> m ()+volume n = do+    current <- (fromIntegral . stVolume) `liftM` status+    setVolume . round $ (fromIntegral n / 100) * current + current+ -- -- Miscellaneous functions. --  -- Run getResponse but discard the response.-getResponse_ :: String -> MPD ()+getResponse_ :: MonadMPD m => String -> m () getResponse_ x = getResponse x >> return ()  -- Get the lines of the daemon's response to a list of commands.-getResponses :: [String] -> MPD [String]+getResponses :: MonadMPD m => [String] -> m [String] getResponses cmds = getResponse . concat $ intersperse "\n" cmds'     where cmds' = "command_list_begin" : cmds ++ ["command_list_end"]  -- Helper that throws unexpected error if input is empty.-failOnEmpty :: [String] -> MPD [String]+failOnEmpty :: MonadMPD m => [String] -> m [String] failOnEmpty [] = throwError $ Unexpected "Non-empty response expected." failOnEmpty xs = return xs  -- A wrapper for getResponse that fails on non-empty responses.-getResponse1 :: String -> MPD [String]+getResponse1 :: MonadMPD m => String -> m [String] getResponse1 x = getResponse x >>= failOnEmpty  -- -- Parsing. -- --- Run 'toAssoc' and return only the values.+-- Run 'toAssocList' and return only the values. takeValues :: [String] -> [String]-takeValues = snd . unzip . toAssoc+takeValues = snd . unzip . toAssocList  data EntryType     = SongEntry Song     | PLEntry   String     | DirEntry  String-      deriving Show+      deriving (Eq, Show)  -- Separate the result of an lsinfo\/listallinfo call into directories, -- playlists, and songs.-takeEntries :: [String] -> MPD [EntryType]-takeEntries = mapM toEntry . splitGroups wrappers . toAssoc . reverse+takeEntries :: MonadMPD m => [String] -> m [EntryType]+takeEntries = mapM toEntry . splitGroups wrappers . toAssocList     where         toEntry xs@(("file",_):_)   = liftM SongEntry $ runParser parseSong xs         toEntry (("directory",d):_) = return $ DirEntry d@@ -659,12 +688,14 @@ -- 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+extractEntries (fSong,fPlayList,fDir) = mapMaybe f     where         f (SongEntry s) = fSong s         f (PLEntry pl)  = fPlayList pl         f (DirEntry d)  = fDir d  -- Build a list of song instances from a response.-takeSongs :: [String] -> MPD [Song]-takeSongs = mapM (runParser parseSong) . splitGroups [("file",id)] . toAssoc+takeSongs :: MonadMPD m => [String] -> m [Song]+takeSongs = mapM (runParser parseSong)+          . splitGroups [("file",id)]+          . toAssocList

@@ -0,0 +1,63 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- | Module    : Network.MPD.Commands.Arg+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- Prepare command arguments.++module Network.MPD.Commands.Arg (Args(..), MPDArg(..), (<++>), (<$>)) where++import Network.MPD.Utils (showBool)++-- | Arguments for getResponse are accumulated as strings in values of+-- this type after being converted from whatever type (an instance of+-- MPDArg) they were to begin with.+newtype Args = Args [String]+    deriving Show++-- | A uniform interface for argument preparation+-- The basic idea is that one should be able+-- to magically prepare an argument for use with+-- an MPD command, without necessarily knowing/\caring+-- how it needs to be represented internally.+class Show a => MPDArg a where+    prep :: a -> Args+    -- Note that because of this, we almost+    -- never have to actually provide+    -- an implementation of 'prep'+    prep = Args . return . show++-- | Groups together arguments to getResponse.+infixl 3 <++>+(<++>) :: (MPDArg a, MPDArg b) => a -> b -> Args+x <++> y = Args $ xs ++ ys+    where Args xs = prep x+          Args ys = prep y++-- | Converts a command name and a string of arguments into the string+-- to hand to getResponse.+infix 2 <$>+(<$>) :: (MPDArg a) => String -> a -> String+x <$> y = x ++ " " ++ unwords (filter (not . null) y')+    where Args y' = prep y++instance MPDArg Args where prep = id++instance MPDArg String where+    -- We do this to avoid mangling+    -- non-ascii characters with 'show'+    prep x = Args ['"' : x ++ "\""]++instance (MPDArg a) => MPDArg (Maybe a) where+    prep Nothing = Args []+    prep (Just x) = prep x++instance (MPDArg a, MPDArg b) => MPDArg (a, b) where+    prep (x, y) = Args [show x ++ ":" ++ show y]++instance MPDArg Int+instance MPDArg Integer+instance MPDArg Bool where prep = Args . return . showBool

@@ -0,0 +1,171 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Module    : Network.MPD.Commands.Parse+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- Parsers for MPD data types.++module Network.MPD.Commands.Parse where++import Network.MPD.Commands.Types++import Control.Monad.Error+import Network.MPD.Utils+import Network.MPD.Core (MonadMPD, MPDError(Unexpected))++-- | Builds a 'Count' instance from an assoc. list.+parseCount :: [String] -> Either String Count+parseCount = foldM f defaultCount . toAssocList+        where f :: Count -> (String, String) -> Either String Count+              f a ("songs", x)    = return $ parse parseNum+                                    (\x' -> a { cSongs = x'}) a x+              f a ("playtime", x) = return $ parse parseNum+                                    (\x' -> a { cPlaytime = x' }) a x+              f _ x               = Left $ show x++-- | Builds a list of 'Device' instances from an assoc. list+parseOutputs :: [String] -> Either String [Device]+parseOutputs = mapM (foldM f defaultDevice)+             . splitGroups [("outputid",id)]+             . toAssocList+    where f a ("outputid", x)      = return $ parse parseNum+                                     (\x' -> a { dOutputID = x' }) a x+          f a ("outputname", x)    = return a { dOutputName = x }+          f a ("outputenabled", x) = return $ parse parseBool+                                     (\x' -> a { dOutputEnabled = x'}) a x+          f _ x                    = fail $ show x++-- | Builds a 'Stats' instance from an assoc. list.+parseStats :: [String] -> Either String Stats+parseStats = foldM f defaultStats . toAssocList+    where+        f a ("artists", x)     = return $ parse parseNum+                                 (\x' -> a { stsArtists  = x' }) a x+        f a ("albums", x)      = return $ parse parseNum+                                 (\x' -> a { stsAlbums   = x' }) a x+        f a ("songs", x)       = return $ parse parseNum+                                 (\x' -> a { stsSongs    = x' }) a x+        f a ("uptime", x)      = return $ parse parseNum+                                 (\x' -> a { stsUptime   = x' }) a x+        f a ("playtime", x)    = return $ parse parseNum+                                 (\x' -> a { stsPlaytime = x' }) a x+        f a ("db_playtime", x) = return $ parse parseNum+                                 (\x' -> a { stsDbPlaytime = x' }) a x+        f a ("db_update", x)   = return $ parse parseNum+                                 (\x' -> a { stsDbUpdate = x' }) a x+        f _ x = fail $ show x++-- | Builds a 'Song' instance from an assoc. list.+parseSong :: [(String, String)] -> Either String Song+parseSong xs = foldM f defaultSong 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)      = return $ parse parseDate+                                 (\x' -> a { sgDate = x' }) a x+          f a ("Track", x)     = return $ parse parseTuple+                                 (\x' -> a { sgTrack = x'}) a x+          f a ("Disc", x)      = return a { sgDisc = parseTuple x }+          f a ("file", x)      = return a { sgFilePath = x }+          f a ("Time", x)      = return $ parse parseNum+                                 (\x' -> a { sgLength = x'}) a x+          f a ("Id", x)        = return $ parse parseNum+                                 (\x' -> a { sgIndex = Just (ID x') }) a x+          -- We prefer Id but take Pos if no Id has been found.+          f a ("Pos", x)       =+              maybe (return $ parse parseNum+                           (\x' -> a { sgIndex = Just (Pos x') }) a x)+                    (const $ return a)+                    (sgIndex a)+          -- Collect auxiliary keys+          f a (k, v)           = return a { sgAux = (k, v) : sgAux a }++          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++-- | Builds a 'Status' instance from an assoc. list.+parseStatus :: [String] -> Either String Status+parseStatus = foldM f defaultStatus . toAssocList+    where f a ("state", x)+              = return $ parse state     (\x' -> a { stState = x' }) a x+          f a ("volume", x)+              = return $ parse parseNum  (\x' -> a { stVolume = x' }) a x+          f a ("repeat", x)+              = return $ parse parseBool (\x' -> a { stRepeat = x' }) a x+          f a ("random", x)+              = return $ parse parseBool (\x' -> a { stRandom = x' }) a x+          f a ("playlist", x)+              = return $ parse parseNum  (\x' -> a { stPlaylistVersion = x' }) a x+          f a ("playlistlength", x)+              = return $ parse parseNum  (\x' -> a { stPlaylistLength = x' }) a x+          f a ("xfade", x)+              = return $ parse parseNum  (\x' -> a { stXFadeWidth = x' }) a x+          f a ("song", x)+              = return $ parse parseNum  (\x' -> a { stSongPos = Just (Pos x') }) a x+          f a ("songid", x)+              = return $ parse parseNum  (\x' -> a { stSongID = Just (ID x') }) a x+          f a ("time", x)+              = return $ parse time      (\x' -> a { stTime = x' }) a x+          f a ("bitrate", x)+              = return $ parse parseNum  (\x' -> a { stBitrate = x' }) a x+          f a ("audio", x)+              = return $ parse audio     (\x' -> a { stAudio = x' }) a x+          f a ("updating_db", x)+              = return $ parse parseNum  (\x' -> a { stUpdatingDb = x' }) a x+          f a ("error", x)+              = return a { stError = x }+          f a ("single", x)+              = return $ parse parseBool (\x' -> a { stSingle = x' }) a x+          f a ("consume", x)+              = return $ parse parseBool (\x' -> a { stConsume = x' }) a x+          f a ("nextsong", x)+              = return $ parse parseNum  (\x' -> a { stNextSongPos = Just (Pos x') }) a x+          f a ("nextsongid", x)+              = return $ parse parseNum  (\x' -> a { stNextSongID = Just (ID x') }) a x+          f _ x+              = fail $ show x++          state "play"  = Just Playing+          state "pause" = Just Paused+          state "stop"  = Just Stopped+          state _       = Nothing++          time = pair parseNum . breakChar ':'++          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++-- | Run a parser and lift the result into the 'MPD' monad+runParser :: (MonadMPD m, MonadError MPDError m)+          => (input -> Either String a) -> input -> m 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 a default value. Used when building structures.+parse :: (String -> Maybe a) -> (a -> b) -> b -> String -> b+parse parser f x = maybe x f . parser++-- | 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

@@ -0,0 +1,56 @@+-- | Module    : Network.MPD.Commands.Query+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- Query interface.++module Network.MPD.Commands.Query (Query, (=?), (<&>), anything) where++import Network.MPD.Commands.Arg+import Network.MPD.Commands.Types++import Data.Monoid++-- | An interface for creating MPD queries.+--+-- For example, to match any song where the value of artist is \"Foo\", we+-- use:+--+-- > Artist =? "Foo"+--+-- We can also compose queries, thus narrowing the search. For example, to+-- match any song where the value of artist is \"Foo\" and the value of album+-- is \"Bar\", we use:+--+-- > Artist =? "Foo" <&> Album =? "Bar"+newtype Query = Query [Match] deriving Show++-- A single query clause, comprising a metadata key and a desired value.+data Match = Match Meta String++instance Show Match where+    show (Match meta query) = show meta ++ " \"" ++ query ++ "\""+    showList xs _ = unwords $ map show xs++instance Monoid Query where+    mempty  = Query []+    Query a `mappend` Query b = Query (a ++ b)++instance MPDArg Query where+    prep = foldl (<++>) (Args []) . f+        where f (Query ms) = map (\(Match m q) -> Args [show m] <++> q) ms++-- | An empty query. Matches anything.+anything :: Query+anything = mempty++-- | Create a query.+(=?) :: Meta -> String -> Query+m =? s = Query [Match m s]++-- | Combine queries.+infixr 6 <&>+(<&>) :: Query -> Query -> Query+(<&>) = mappend

@@ -0,0 +1,194 @@+-- | Module    : Network.MPD.Commands.Types+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- Various MPD data structures and types++module Network.MPD.Commands.Types where++import Network.MPD.Commands.Arg (MPDArg(prep), Args(Args))++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+      deriving Show++instance MPDArg Meta++-- | Object types.+data ObjectType = SongObj+    deriving (Eq, Show)++instance MPDArg ObjectType where+    prep SongObj = Args ["song"]++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 various MPD subsystems.+data Subsystem+    = Database          -- ^ The song database+    | Update            -- ^ Database updates+    | StoredPlaylist    -- ^ Stored playlists+    | Playlist          -- ^ The current playlist+    | Player            -- ^ The player+    | Mixer             -- ^ The volume mixer+    | Output            -- ^ Audio outputs+    | Options           -- ^ Playback options+      deriving (Eq, Show)++instance MPDArg Subsystem where+    prep Database = Args ["database"]+    prep Update = Args ["update"]+    prep StoredPlaylist = Args ["stored_playlist"]+    prep Playlist = Args ["playlist"]+    prep Player = Args ["player"]+    prep Mixer = Args ["mixer"]+    prep Output = Args ["output"]+    prep Options = Args ["options"]++data ReplayGainMode+    = Off       -- ^ Disable replay gain+    | TrackMode -- ^ Per track mode+    | AlbumMode -- ^ Per album mode+      deriving (Eq, Show)++instance MPDArg ReplayGainMode where+    prep Off = Args ["off"]+    prep TrackMode = Args ["track"]+    prep AlbumMode = Args ["album"]++-- | 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)++defaultCount :: Count+defaultCount = 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)++defaultDevice :: Device+defaultDevice =+    Device { dOutputID = 0, dOutputName = "", dOutputEnabled = 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)++defaultStats :: Stats+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      :: Maybe (Int, Int) -- ^ Position in set\/total in set+         , sgIndex     :: Maybe PLIndex+         , sgAux       :: [(String, String)] } -- ^ Auxiliary song fields+    deriving (Eq, Show)++defaultSong :: Song+defaultSong =+    Song { sgArtist = "", sgAlbum = "", sgTitle = ""+         , sgGenre = "", sgName = "", sgComposer = ""+         , sgPerformer = "", sgDate = 0, sgTrack = (0,0)+         , sgDisc = Nothing, sgFilePath = "", sgLength = 0+         , sgIndex = Nothing, sgAux = [] }++-- | 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+             -- | Next song's position in the playlist.+           , stNextSongPos     :: Maybe PLIndex+             -- | Next song's playlist ID.+           , stNextSongID      :: 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+             -- | If True, MPD will play only one song and stop after finishing it.+           , stSingle          :: Bool+             -- | If True, a song will be removed after it has been played.+           , stConsume         :: Bool+             -- | Last error message (if any).+           , stError           :: String }+    deriving (Eq, Show)++defaultStatus :: Status+defaultStatus =+    Status { stState = Stopped, stVolume = 0, stRepeat = False+           , stRandom = False, stPlaylistVersion = 0, stPlaylistLength = 0+           , stSongPos = Nothing, stSongID = Nothing, stTime = (0,0)+           , stNextSongPos = Nothing, stNextSongID = Nothing+           , stBitrate = 0, stXFadeWidth = 0, stAudio = (0,0,0)+           , stUpdatingDb = 0, stSingle = False, stConsume = False+           , stError = "" }

@@ -1,187 +1,200 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-}  -- | Module    : Network.MPD.Core--- Copyright   : (c) Ben Sinclair 2005-2008+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)--- Maintainer  : bsinclai@turing.une.edu.au+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com> -- Stability   : alpha--- Portability : not Haskell 98 (uses MultiParamTypeClasses) ----- Core functionality.+-- The core datatypes and operations are defined here, including the+-- primary instance of the 'MonadMPD' class, 'MPD'.  module Network.MPD.Core (+    -- * Classes+    MonadMPD(..),     -- * Data types-    MPD(..), Conn(..), MPDError(..), ACKType(..), Response,+    MPD, MPDError(..), ACKType(..), Response, Host, Port, Password,+    -- * Running+    withMPDEx,     -- * Interacting-    getResponse, close, reconnect, kill,+    getResponse, kill,     ) where -import Control.Monad (liftM)-import Control.Monad.Error (Error(..), MonadError(..))-import Control.Monad.Trans-import Prelude hiding (repeat)+import Network.MPD.Core.Class+import Network.MPD.Core.Error++import Control.Applicative (Applicative(..), (<$>))+import Control.Monad (ap, unless)+import Control.Monad.Error (ErrorT(..), MonadError(..))+import Control.Monad.Reader (ReaderT(..), ask)+import Control.Monad.State (StateT, MonadIO(..), put, get, evalStateT)+import qualified Data.Foldable as F import Data.List (isPrefixOf)-import Data.Maybe-import System.IO+import Network (PortID(..), withSocketsDo, connectTo)+import System.IO (Handle, hPutStrLn, hReady, hClose, hFlush)+import System.IO.Error (isEOFError)+import qualified System.IO.UTF8 as U  -- -- 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)+type Host = String+type Port = Integer --- | A response is either an 'MPDError' or some result.-type Response a = Either MPDError a+--+-- IO based MPD client implementation.+-- --- Export the type name but not the constructor or the field.--- | The MPD monad is basically a reader and error monad--- combined.+-- | The main implementation of an MPD client.  It actually connects+--   to a server and interacts with it. -- -- To use the error throwing\/catching capabilities: ----- > import Control.Monad.Error+-- > import Control.Monad.Error (throwError, catchError) -- -- To run IO actions within the MPD monad: ----- > import Control.Monad.Trans-data MPD a = MPD { runMPD :: Conn -> IO (Response a) }+-- > import Control.Monad.Trans (liftIO)+newtype MPD a =+    MPD { runMPD :: ErrorT MPDError+                    (StateT (Maybe Handle)+                     (ReaderT (Host, Port, Password) IO)) a+        } deriving (Functor, Monad, MonadIO, MonadError MPDError) -instance Functor MPD where-    fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn+instance Applicative MPD where+    (<*>) = ap+    pure  = return -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 MonadMPD MPD where+    open  = mpdOpen+    close = mpdClose+    send  = mpdSend+    getPassword = MPD $ ask >>= \(_,_,pw) -> return pw -instance MonadIO MPD where-    liftIO m = MPD $ \_ -> liftM Right m+-- | A response is either an 'MPDError' or some result.+type Response = Either MPDError -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)+-- | The most configurable API for running an MPD action.+withMPDEx :: Host -> Port -> Password -> MPD a -> IO (Response a)+withMPDEx host port pw x = withSocketsDo $+    runReaderT (evalStateT (runErrorT . runMPD $ open >> x) Nothing)+               (host, port, pw) -instance Error MPDError where-    noMsg  = Custom "An error occurred"-    strMsg = Custom+mpdOpen :: MPD ()+mpdOpen = MPD $ do+    (host, port, _) <- ask+    runMPD close+    handle <- liftIO (safeConnectTo host port)+    put handle+    F.forM_ handle (const $ runMPD checkConn >>= flip unless (runMPD close))+    where+        safeConnectTo host port =+            (Just <$> connectTo host (PortNumber $ fromInteger port))+            `catch` const (return Nothing) ------ Basic connection functions---+        checkConn =+            isPrefixOf "OK MPD" <$> send "" --- | Refresh a connection.-reconnect :: MPD ()-reconnect = MPD $ \conn -> Right `liftM` cOpen conn+mpdClose :: MPD ()+mpdClose =+    MPD $ get >>= F.mapM_ (liftIO . sendClose) >> put Nothing+    where+        sendClose handle =+            (hPutStrLn handle "close" >> hReady handle >> hClose handle)+            `catch` whenEOF (return ()) --- | Kill the server. Obviously, the connection is then invalid.-kill :: MPD ()-kill = getResponse "kill" `catchError` cleanup >> return ()+        whenEOF result err+            | isEOFError err = result+            | otherwise      = ioError err++mpdSend :: String -> MPD String+mpdSend str = send' `catchError` handler     where-      cleanup TimedOut = MPD $ \conn -> cClose conn >> return (Right [])-      cleanup x = throwError x >> return []+        handler TimedOut = mpdOpen >> send'+        handler err      = throwError err --- | Close an MPD connection.-close :: MPD ()-close = MPD $ \conn -> cClose conn >> return (Right ())+        send' = MPD $ get >>= maybe (throwError NoMPD) go +        go handle = do+            unless (null str) $+                liftIO $ U.hPutStrLn handle str >> hFlush handle+            liftIO ((Right <$> getLines handle []) `catch` (return . Left))+                >>= either (\err -> if isEOFError err then+                                        put Nothing >> throwError TimedOut+                                      else liftIO (ioError err))+                           return++        getLines handle acc = do+            l <- U.hGetLine handle+            if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l+                then return . unlines $ reverse (l:acc)+                else getLines handle (l:acc)++ ----- Sending messages and handling responses.+-- Other operations. -- --- | Send a command to the MPD and return the result.-getResponse :: String -> MPD [String]-getResponse cmd = MPD f+ignore :: (Monad m) => m a -> m ()+ignore x = x >> return ()++-- | Kill the server. Obviously, the connection is then invalid.+kill :: (MonadMPD m) => m ()+kill = ignore (send "kill") `catchError` cleanup     where-        f conn = catchAuth . either Left parseResponse =<< cSend conn cmd-            where-                catchAuth (Left (ACK Auth _)) = tryPassword conn (f conn)-                catchAuth x = return x+        cleanup e = if e == TimedOut then close else throwError e --- 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"+-- | Send a command to the MPD server and return the result.+getResponse :: (MonadMPD m) => String -> m [String]+getResponse cmd = (send cmd >>= parseResponse) `catchError` sendpw+    where+        sendpw e@(ACK Auth _) = do+            pw <- getPassword+            if null pw then throwError e+                else send ("password " ++ pw) >>= parseResponse+                  >> send cmd >>= parseResponse+        sendpw e =+            throwError e  -- 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+parseResponse :: (MonadError MPDError m) => String -> m [String]+parseResponse s+    | null xs                    = throwError $ NoMPD+    | isPrefixOf "ACK" (head xs) = throwError $ parseAck s+    | otherwise                  = return $ Prelude.takeWhile ("OK" /=) xs+    where+        xs = lines s  -- Turn MPD ACK into the corresponding 'MPDError' 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+                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+splitAck :: String -> (Int, String, String)+splitAck s = (read code, cmd, msg)+    where+        (code, notCode) = between '[' '@' s+        (cmd, notCmd)   = between '{' '}' notCode+        msg             = drop 1 $ dropWhile (' ' ==) notCmd -          -- take whatever is between 'f' and 'g'.-          between f g xs  = let (_, y) = break f xs-                            in break g (drop 1 y)+        -- take whatever is between 'f' and 'g'.+        between a b xs  = let (_, y) = break (== a) xs+                          in break (== b) (drop 1 y)

@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Module    : Network.MPD.Core.Class+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- The MPD typeclass.++module Network.MPD.Core.Class where++import Network.MPD.Core.Error (MPDError)++import Control.Monad.Error (MonadError)++type Password = String++-- | A typeclass to allow for multiple implementations of a connection+--   to an MPD server.+class (Monad m, MonadError MPDError m) => MonadMPD m where+    -- | Open (or re-open) a connection to the MPD server.+    open  :: m ()+    -- | Close the connection.+    close :: m ()+    -- | Send a string to the server and return its response.+    send  :: String -> m String+    -- | Produce a password to send to the server should it ask for+    --   one.+    getPassword :: m Password

@@ -0,0 +1,50 @@+-- | Module    : Network.MPD.Core.Error+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- MPD errors.++module Network.MPD.Core.Error where++import Control.Monad.Error (Error(..))++-- | 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++instance Error MPDError where+    noMsg  = Custom "An error occurred"+    strMsg = Custom++-- | 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

@@ -1,156 +0,0 @@--- | Module    : Network.MPD.Parse--- Copyright   : (c) Ben Sinclair 2005-2008--- License     : LGPL (see LICENSE)--- 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 Network.MPD.Types--import Control.Monad.Error-import Network.MPD.Utils-import Network.MPD.Core (MPD, MPDError(Unexpected))---- | 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 }---- | 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---- | 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 }----- | 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 }---- | 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,83 +0,0 @@--- | Module    : Network.MPD.SocketConn--- Copyright   : (c) Ben Sinclair 2005-2008--- License     : LGPL (see LICENSE)--- 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)-import qualified System.IO.UTF8 as U---- | 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-        cautiousSend' x =-            send' x >>= either (\e -> case e of TimedOut -> open' >> send' x-                                                _        -> return $ Left e)-                               (return . Right)-    open'-    runMPD m (Conn open' close' cautiousSend' 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 = catch (hPutStrLn h "close" >> hReady h >> hClose h)-                              (whenEOF $ writeIORef hR Nothing)--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) (U.hPutStrLn h str >> hFlush h)-                catch (getLines h [])-                      (whenEOF $ writeIORef hR Nothing >> return (Left TimedOut))-    where-        getLines handle acc = do-            l <- U.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 :: IO a -> IOError -> IO a-whenEOF result err = if isEOFError err then 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 ""

@@ -1,94 +0,0 @@--- | Module    : Network.MPD.Types--- Copyright   : (c) Ben Sinclair 2005-2008--- License     : LGPL (see LICENSE)--- Maintainer  : bsinclai@turing.une.edu.au--- Stability   : alpha--- Portability : Haskell 98------ Various MPD data structures and types--module Network.MPD.Types where--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)---- | 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)---- | 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)---- | 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 (Eq, Show)---- | 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)

@@ -1,18 +1,18 @@ -- | Module    : Network.MPD.Utils--- Copyright   : (c) Ben Sinclair 2005-2008+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)--- Maintainer  : bsinclai@turing.une.edu.au+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com> -- Stability   : alpha--- Portability : Haskell 98 -- -- Utilities.  module Network.MPD.Utils (     parseDate, parseNum, parseBool, showBool,-    breakChar, toAssoc, splitGroups+    breakChar, toAssoc, toAssocList, splitGroups     ) where  import Data.Char (isDigit)+import Data.Maybe (fromMaybe)  -- Break a string by character, removing the separator. breakChar :: Char -> String -> (String, String)@@ -42,13 +42,15 @@                   "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)+-- Break a string into an key-value pair, separating at the first ':'.+toAssoc :: String -> (String, String)+toAssoc x = (k, dropWhile (== ' ') $ drop 1 v)+    where+        (k,v) = break (== ':') x +toAssocList :: [String] -> [(String, String)]+toAssocList = map toAssoc+ -- 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@@ -63,7 +65,7 @@ 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+    fromMaybe (splitGroups wrappers xs) $ do+        f <- k `lookup` wrappers+        let (us,vs) = break (\(k',_) -> k' `elem` map fst wrappers) xs+        return $ f (x:us) : splitGroups wrappers vs

@@ -1,50 +0,0 @@--              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.6       http://haskell.org/ghc-    Cabal >= 1.2                              http://haskell.org/cabal-    network                                   http://hackage.haskell.org/cgi-bin/hackage-scripts/package/network-    mtl                                       http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-    filepath                                  http://hackage.haskell.org/cgi-bin/hackage-scripts/package/filepath--Building:-    $ 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:-    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 (as in compile) on Windows XP as well.--Latest Sources:-    darcs get http://turing.une.edu.au/~bsinclai/code/libmpd-haskell--License:-    LGPL--Authors:-    Ben Sinclair <bsinclai@turing.une.edu.au>-    Joachim Fasting <joachim.fasting@gmail.com>

@@ -0,0 +1,99 @@+# libmpd-haskell: a client library for MPD++## About++libmpd-haskell is a client library for [MPD] written in [Haskell] that <br />+aims to provide a safe and flexible yet consistent and intuitive <br />+interface to MPD's external API.++[MPD]: http://www.musicpd.org+[Haskell]: http://www.haskell.org++## Getting+* [Latest release]+* `git clone git://github.com/bens/libmpd-haskell.git`++[Latest release]: http://hackage.haskell.org/package/libmpd+[GIT repository]: git://github.com/bens/libmpd-haskell.git++## Building+The preferred method of building libmpd-haskell is using [cabal-install], which+takes care of dependency resolution and other minutiae.++To install libmpd-haskell, simply run:++`cd libmpd-haskell && cabal install`++To use the deprecated base 3, run:++`cabal install -f old_base`++[cabal-install]: http://hackage.haskell.org/package/cabal-install++## Compiler support+We try to support the two last major versions of GHC, but only the latest+version is actually tested for.++## MPD API compliance+We try to comply with the latest version of the MPD protocol specification;+any deviation from this is a bug.++## Usage++With GHCi:++    > import Network.MPD+    > withMPD $ lsInfo ""+    Right [Left "Tool", Left "Tom Waits",...]+    > withMPD $ add "Tom Waits/Big Time"+    Right ["Tom Waits/Big Time/01 - 16 Shells from a Thirty-Ough-Six.mp3",...]++## Development++To start developing libmpd-haskell you'll first need a clone of the+source code repository:++`git clone git://github.com/joachifm/libmpd-haskell`++To pull in new changes from upstream, use:++`git pull origin master`++When writing or modifying code, please try to conform to the+surrounding style. If you introduce new functionality, please include+a test case or at least document the expected behavior.++### Submitting patches+To submit a patch, use `git format-patch` and email the resulting+file to one of the developers or upload it to the [bug tracker].++Alternatively you can create your own fork of the [repository]+and send a pull request.++### Submitting bug reports+See our [bug tracker].++### Resources+* [API documentation]+* [Code coverage]+* [Protocol reference]+* [Using GitHub]+* \#libmpd-haskell @ irc.freenode.net++[bug tracker]: http://trac.haskell.org/libmpd/+[GitHub]: http://www.github.com+[repository]: http://www.github.com/bens/libmpd-haskell+[API documentation]: http://projects.haskell.org/libmpd/doc/+[Code coverage]: http://projects.haskell.org/libmpd/coverage/hpc_index.html+[Protocol reference]: http://www.musicpd.org/doc/protocol/+[Using GitHub]: http://help.github.com++## License+LGPL version 2.1++## Authors+Ben Sinclair \<ben.d.sinclair@gmail.com\>++Joachim Fasting \<joachim.fasting@gmail.com\>++Daniel Schoepe \<daniel.schoepe@googlemail.com\>

@@ -1,2 +0,0 @@-TODO:-    - improve parsing performance

@@ -1,30 +1,71 @@ Name:               libmpd-Version:            0.3.1+Version:            0.4.0 License:            LGPL License-file:       LICENSE-Copyright:          Ben Sinclair 2005-2008+Copyright:          Ben Sinclair 2005-2009, Joachim Fasting 2010 Author:             Ben Sinclair-Maintainer:         bsinclai@turing.une.edu.au+Maintainer:         Joachim Fasting <joachim.fasting@gmail.com> Stability:          beta-Homepage:           http://turing.une.edu.au/~bsinclai/code/libmpd-haskell.html+Homepage:           http://projects.haskell.org/libmpd/+Bug-reports:        http://trac.haskell.org/libmpd/newticket Synopsis:           An MPD client library. Description:        A client library for MPD, the Music Player Daemon                     (<http://www.musicpd.org/>). Category:           Network, Sound-Tested-With:        GHC == 6.6.1, GHC == 6.8.2+Tested-With:        GHC == 6.10.1, GHC == 6.12.1 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+Cabal-Version:      >= 1.6 && < 1.9+Extra-Source-Files: README.md ChangeLog tests/Properties.hs tests/Commands.hs+                    tests/Main.hs tests/Displayable.hs tests/run-tests.lhs+                    tests/coverage.lhs +flag test+    Description: Build test driver+    Default: False++flag coverage+    Description: Build driver with hpc instrumentation+    Default: False++flag old_base+    Description: Use base version 3+    Default: False++Source-Repository head+    type:       git+    location:   git://github.com/joachifm/libmpd-haskell.git+ Library-    Build-Depends:      base >= 2.1.1, network >= 2.0.1, mtl >= 1.0.1,-                        filepath >= 1.0, utf8-string >= 0.3.1-    Exposed-Modules:    Network.MPD-    Other-Modules:      Network.MPD.Core, Network.MPD.Commands,-                        Network.MPD.Parse, Network.MPD.SocketConn,-                        Network.MPD.Types, Network.MPD.Utils+    if flag(old_base)+        Build-Depends: base >= 3 && < 4+    else+        Build-Depends: base >= 4 && < 5 -    ghc-options:        -Wall+    Build-Depends:      network >= 2.1 && < 2.3,+                        mtl >= 1.1 && < 1.2, filepath >= 1.0 && < 1.2,+                        utf8-string >= 0.3.1 && < 0.4+    Exposed-Modules:    Network.MPD, Network.MPD.Core+    Other-Modules:      Network.MPD.Core.Class,+                        Network.MPD.Core.Error,+                        Network.MPD.Commands,+                        Network.MPD.Commands.Arg,+                        Network.MPD.Commands.Parse,+                        Network.MPD.Commands.Query,+                        Network.MPD.Commands.Types,+                        Network.MPD.Utils     ghc-prof-options:   -auto-all -prof++    if flag(test)+        Buildable: False++Executable test+    Hs-Source-Dirs:     . tests+    Main-Is:            tests/Main.hs+    Build-Depends:      base, network, mtl, filepath, utf8-string, QuickCheck ==2.1.*+    ghc-options:        -Wall -Werror -fno-warn-warnings-deprecations++    if flag(coverage)+        ghc-options:    -fhpc++    if !flag(test)+        Buildable: False

@@ -11,24 +11,29 @@  module Commands (main) where +import Arbitrary () import Displayable import Network.MPD.Commands-import Network.MPD.Core (Response, MPDError(..))+import Network.MPD.Core (MPDError(..), Response, ACKType(..)) import StringConn -import Control.Monad import Prelude hiding (repeat)+import Data.Char (isPrint, isSpace)+import Data.Maybe (fromJust, isJust) import Text.Printf+import qualified Test.QuickCheck as QC+import Test.QuickCheck ((==>)) -main = mapM_ (\(n, f) -> f >>= \x -> printf "%-14s: %s\n" n x) tests+main = mapM_ (\(n, f) -> printf "%-25s : " n >> f) tests     where tests = [("enableOutput", testEnableOutput)                   ,("disableOutput", testDisableOutput)                   ,("outputs", testOutputs)                   ,("update0", testUpdate0)                   ,("update1", testUpdate1)                   ,("updateMany", testUpdateMany)-                  ,("find", testFind)-                  ,("find / complex query", testFindComplex)+                  ,("prop_find", mycheck prop_find 100)+                  ,("prop_lsFiles", mycheck prop_lsFiles 100)+                  ,("prop_lsDirs", mycheck prop_lsDirs 100)                   ,("list(Nothing)", testListNothing)                   ,("list(Just)", testListJust)                   ,("listAll", testListAll)@@ -44,7 +49,7 @@                   ,("clear / current", testClearCurrent)                   ,("plChangesPosId 0", testPlChangesPosId_0)                   ,("plChangesPosId 1", testPlChangesPosId_1)-                  ,("plChangesPosId wierd", testPlChangesPosId_Wierd)+                  ,("plChangesPosId weird", testPlChangesPosId_Weird)                   ,("currentSong(_)", testCurrentSongStopped)                   ,("currentSong(>)", testCurrentSongPlaying)                   ,("delete0", testDelete0)@@ -84,12 +89,16 @@                   ,("repeat", testRepeat)                   ,("setVolume", testSetVolume)                   ,("volume", testVolume)+                  ,("consume", testConsume)+                  ,("single", testSingle)                   ,("clearError", testClearError)                   ,("commands", testCommands)                   ,("notCommands", testNotCommands)                   ,("tagTypes", testTagTypes)                   ,("urlHandlers", testUrlHandlers)                   ,("password", testPassword)+                  ,("passwordSucceeds", testPasswordSucceeds)+                  ,("passwordFails", testPasswordFails)                   ,("ping", testPing)                   ,("stats", testStats)                   ,("updateId0", testUpdateId0)@@ -102,19 +111,31 @@                   ,("deleteMany1", testDeleteMany1)                   ] -test a b c = liftM (showResult b) $ testMPD a b (return Nothing) c+test :: (Show a, Eq a)+     => [(Expect, Response String)] -> Response a -> StringMPD a -> IO ()+test a b c = putStrLn . showResult $ testMPD a b "" c +test_ :: [(Expect, Response String)] -> StringMPD () -> IO () 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+mycheck :: QC.Testable a => a -> Int -> IO ()+mycheck a n = QC.quickCheckWith QC.stdArgs { QC.maxSize = n } a +showResult :: Show a => Result a -> String+showResult Ok =+    "OK, passed."+showResult (BadRequest TooManyRequests) = unlines+    ["*** FAILURE ***"+    ,"    more requests were made than expected."]+showResult (BadRequest (UnexpectedRequest expected actual)) = unlines+    ["*** FAILURE ***"+    ,"    expected request: " ++ show expected+    ,"    actual request: "   ++ show actual]+showResult (BadResult expected actual) = unlines+    ["*** FAILURE ***"+    ,"    expected result: " ++ show expected+    ,"    actual result: "   ++ show actual]+ -- -- Admin commands --@@ -144,29 +165,57 @@ -- Database commands -- -testFind =-    test [("find Artist \"Foo\"", Right resp)] (Right [obj])-    (find [Match Artist "Foo"])-    where obj = empty { sgArtist = "Foo", sgTitle = "Bar"-                      , sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 }-          resp = display obj ++ "OK"+prop_find :: Song -> Meta -> QC.Property+prop_find song meta = isJust (sgDisc song) ==> result == Ok+    where+        result = testMPD [("find "++ show meta ++ " \"" ++ query ++ "\""+                          ,Right (display song ++ "OK"))]+                         (Right [song])+                         ""+                         (find (meta =? query))+        query = case meta of+            Artist    -> sgArtist    song+            Album     -> sgAlbum     song+            Title     -> sgTitle     song+            Track     -> show $ fst $ sgTrack song+            Name      -> sgName      song+            Genre     -> sgGenre     song+            Date      -> show $ sgDate song+            Composer  -> sgComposer  song+            Performer -> sgPerformer song+            Disc      -> show $ fromJust $ sgDisc song+            Filename  -> sgFilePath  song+            Any       -> "Foo" -testFindComplex =-    test [("find Artist \"Foo\" Album \"Bar\"", Right resp)] (Right [obj])-    (find [Match Artist "Foo", Match Album "Bar"])-    where obj = empty { sgFilePath = "dir/Foo/Bar/Baz.ogg", sgArtist = "Foo"-                      , sgAlbum = "Bar", sgTitle = "Baz" }-          resp = display obj ++ "OK"+prop_lsFiles :: [Song] -> Bool+prop_lsFiles ss = result == Ok+    where+        result =+            testMPD [("lsinfo \"\"", Right (concatMap display ss ++ "OK"))]+                    (Right (map sgFilePath ss))+                    ""+                    (lsFiles "") +prop_lsDirs :: [Path] -> QC.Property+prop_lsDirs ds = all (all goodChar) ds ==> result == Ok+    where+        goodChar c = ('\n' /= c) && (isPrint c)+        asDir d = "directory: " ++ d ++ "\n"+        result =+            testMPD [("lsinfo \"\"", Right (concatMap asDir ds ++ "OK"))]+                    (Right $ map (dropWhile isSpace) ds)+                    ""+                    (lsDirs "")+ testListNothing =     test [("list Title", Right "Title: Foo\nTitle: Bar\nOK")]          (Right ["Foo", "Bar"])-         (list Title [])+         (list Title anything)  testListJust =     test [("list Title Artist \"Muzz\"", Right "Title: Foo\nOK")]          (Right ["Foo"])-         (list Title [Match Artist "Muzz"])+         (list Title (Artist =? "Muzz"))  testListAll =     test [("listall \"\"", Right "directory: FooBand\n\@@ -178,25 +227,28 @@          (listAll "")  testLsInfo =-    test [("lsinfo \"\"", Right "directory: Foo\ndirectory: Bar\nOK")]-         (Right [Left "Bar", Left "Foo"])+    test [("lsinfo \"\"",+           Right $ "directory: Foo\n" ++ display song ++ "playlist: Quux\nOK")]+         (Right [Left "Foo", Right song])          (lsInfo "")+    where+        song = empty { sgFilePath = "Bar.ogg" }  testListAllInfo =     test [("listallinfo \"\"", Right "directory: Foo\ndirectory: Bar\nOK")]-         (Right [Left "Bar", Left "Foo"])+         (Right [Left "Foo", Left "Bar"])          (listAllInfo "")  testSearch =     test [("search Artist \"oo\"", Right resp)] (Right [obj])-         (search [Match Artist "oo"])+         (search (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 [Match Title "Foo"])+         (count (Title =? "Foo"))     where obj = Count 1 60           resp = display obj ++ "OK" @@ -208,22 +260,22 @@     test [("add \"foo\"", Right "OK"),           ("listall \"foo\"", Right "file: Foo\nfile: Bar\nOK")]          (Right ["Foo", "Bar"])-         (add "" "foo")+         (add "foo") -testAdd_ = test_ [("add \"foo\"", Right "OK")] (add_ "" "foo")+testAdd_ = test_ [("add \"foo\"", Right "OK")] (add_ "foo")  testAdd_pl = test_ [("playlistadd \"foo\" \"bar\"", Right "OK")]-             (add_ "foo" "bar")+             (playlistAdd_ "foo" "bar")  testAddId =     test [("addid \"dir/Foo-Bar.ogg\"", Right "Id: 20\nOK")]          (Right 20)-         (addId "dir/Foo-Bar.ogg")+         (addId "dir/Foo-Bar.ogg" Nothing)  testClearPlaylist = test_ [("playlistclear \"foo\"", Right "OK")]-                    (clear "foo")+                    (playlistClear "foo") -testClearCurrent = test_ [("clear", Right "OK")] (clear "")+testClearCurrent = test_ [("clear", Right "OK")] clear  testPlChangesPosId_0 =     test [("plchangesposid 10", Right "OK")]@@ -235,15 +287,14 @@          (Right [(Pos 0, ID 20)])          (plChangesPosId 10) -testPlChangesPosId_Wierd =+testPlChangesPosId_Weird =     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 }+    test [("status", Right resp)] (Right Nothing) currentSong+    where obj  = empty { stState = Stopped, stPlaylistVersion = 253 }           resp = display obj ++ "OK"  testCurrentSongPlaying =@@ -262,19 +313,19 @@                           , stState = Playing }           resp2 = display estatus ++ "OK" -testDelete0 = test_ [("delete 1", Right "OK")] (delete "" (Pos 1))+testDelete0 = test_ [("delete 1", Right "OK")] (delete (Pos 1)) -testDelete1 = test_ [("deleteid 1", Right "OK")] (delete "" (ID 1))+testDelete1 = test_ [("deleteid 1", Right "OK")] (delete (ID 1)) -testDelete2 = test_ [("playlistdelete \"foo\" 1", Right "OK")] (delete "foo" (Pos 1))+testDelete2 = test_ [("playlistdelete \"foo\" 1", Right "OK")] (playlistDelete "foo" 1)  testLoad = test_ [("load \"foo\"", Right "OK")] (load "foo") -testMove0 = test_ [("move 1 2", Right "OK")] (move "" (Pos 1) 2)+testMove0 = test_ [("move 1 2", Right "OK")] (move (Pos 1) 2) -testMove1 = test_ [("moveid 1 2", Right "OK")] (move "" (ID 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)+testMove2 = test_ [("playlistmove \"foo\" 1 2", Right "OK")] (playlistMove "foo" 1 2)  testRm = test_ [("rm \"foo\"", Right "OK")] (rm "foo") @@ -286,7 +337,7 @@  testSwap1 = test_ [("swapid 1 2", Right "OK")] (swap (ID 1) (ID 2)) -testShuffle = test_ [("shuffle", Right "OK")] shuffle+testShuffle = test_ [("shuffle", Right "OK")] (shuffle Nothing)  testPlaylistInfo0 = test [("playlistinfo", Right resp)] (Right [obj])                     (playlistInfo Nothing)@@ -295,13 +346,13 @@           resp = display obj ++ "OK"  testPlaylistInfoPos = test [("playlistinfo 1", Right resp)] (Right [obj])-                      (playlistInfo . Just $ Pos 1)+                      (playlistInfo (Just (Left (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)+                     (playlistInfo (Just (Left (ID 1))))     where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60                       , sgArtist = "Foo", sgTitle = "Bar" }           resp = display obj ++ "OK"@@ -335,13 +386,13 @@  testPlaylistFind = test [("playlistfind Artist \"Foo\"", Right resp)]                    (Right [obj])-                   (playlistFind [Match Artist "Foo"])+                   (playlistFind (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 [Match Artist "Foo"])+                     (playlistSearch (Artist =? "Foo"))     where obj = empty { sgFilePath = "dir/Foo/Bar.ogg", sgArtist = "Foo" }           resp = display obj ++ "OK" @@ -381,8 +432,10 @@  testSetVolume = test_ [("setvol 10", Right "OK")] (setVolume 10) -testVolume = test_ [("volume 10", Right "OK")] (volume 10)+testConsume = test_ [("consume 1", Right "OK")] (consume True) +testSingle = test_ [("single 1", Right "OK")] (single True)+ -- -- Miscellaneous commands --@@ -411,6 +464,27 @@  testPassword = test_ [("password foo", Right "OK")] (password "foo") +testPasswordSucceeds =+    putStrLn . showResult $ testMPD convo expected_resp "foo" cmd+    where+        convo = [("lsinfo \"/\"", Right "ACK [4@0] {play} you don't have \+                                        \permission for \"play\"")+                ,("password foo", Right "OK")+                ,("lsinfo \"/\"", Right "directory: /bar\nOK")]+        expected_resp = Right [Left "/bar"]+        cmd = lsInfo "/"++testPasswordFails =+    putStrLn . showResult $ testMPD convo expected_resp "foo" cmd+    where+        convo = [("play", Right "ACK [4@0] {play} you don't have \+                                \permission for \"play\"")+                ,("password foo",+                  Right "ACK [3@0] {password} incorrect password")]+        expected_resp =+            Left $ ACK InvalidPassword " incorrect password"+        cmd = play Nothing+ testPing = test_ [("ping", Right "OK")] ping  testStats = test [("stats", Right resp)] (Right obj) stats@@ -457,3 +531,8 @@  testDeleteMany1 = test_ [("playlistdelete \"foo\" 1", Right "OK")]                   (deleteMany "foo" [Pos 1])++testVolume = test_ [("status", Right st), ("setvol 90", Right "OK")] (volume (-10))+    where st = display empty { stVolume = 100 }++

@@ -1,7 +1,7 @@ module Displayable (Displayable(..)) where +import Network.MPD.Commands.Types import Network.MPD.Utils-import Network.MPD.Types  -- | A uniform interface for types that -- can be turned into raw responses@@ -11,23 +11,20 @@                              --   string  instance Displayable Count where-    empty = Count { cSongs = 0, cPlaytime = 0 }-    display s = unlines $+    empty = defaultCount+    display s = unlines         ["songs: "    ++ show (cSongs s)         ,"playtime: " ++ show (cPlaytime s)]  instance Displayable Device where-    empty = Device 0 "" False-    display d = unlines $+    empty = defaultDevice+    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 }+    empty = defaultSong     display s = unlines $         ["file: "      ++ sgFilePath s         ,"Artist: "    ++ sgArtist s@@ -39,15 +36,14 @@         ,"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)+        ,"Disc: "      ++ (case sgDisc s of Just (x,y) -> 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 $+    empty = defaultStats+    display s = unlines         ["artists: " ++ show (stsArtists s)         ,"albums: " ++ show (stsAlbums s)         ,"songs: " ++ show (stsSongs s)@@ -57,12 +53,7 @@         ,"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 = "" }+    empty = defaultStatus     display s = unlines $         ["state: " ++ (case stState s of Playing -> "play"                                          Paused  -> "pause"@@ -80,7 +71,9 @@         ,"audio: " ++ (let (x, y, z) = stAudio s in show x ++ ":" ++ show y ++                                        ":" ++ show z)         ,"updating_db: " ++ show (stUpdatingDb s)-        ,"error: " ++ show (stError s)]+        ,"error: " ++ show (stError s)+        ,"single: " ++ showBool (stSingle s)+        ,"consume: " ++ showBool (stConsume s)]         ++ maybe [] (\x -> [case x of Pos n -> "song: " ++ show n                                       _     -> undefined]) (stSongPos s)         ++ maybe [] (\x -> [case x of ID n  -> "songid: " ++ show n

@@ -4,4 +4,9 @@ import qualified Commands import qualified Properties -main = Properties.main >> Commands.main+main = do+    putStrLn "*** Properties ***"+    Properties.main++    putStrLn "\n*** Unit Tests ***"+    Commands.main

@@ -1,14 +1,14 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} module Properties (main) where +import Arbitrary import Displayable -import Network.MPD.Parse-import Network.MPD.Types+import Network.MPD.Commands.Parse+import Network.MPD.Commands.Types import Network.MPD.Utils  import Control.Monad-import Data.Char import Data.List import Data.Maybe import System.Environment@@ -29,8 +29,6 @@                   ,("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)@@ -42,82 +40,30 @@                   ,("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 $ elements ["1", "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+mytest a n = quickCheckWith stdArgs { maxSize = n } a -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_parseDate_simple :: YearString -> Bool+prop_parseDate_simple (YS x) = isJust $ parseDate x -prop_toAssoc_integrity :: [AssocString] -> Bool-prop_toAssoc_integrity x = length (toAssoc $ fromAS x) == length x+prop_parseDate_complex :: DateString -> Bool+prop_parseDate_complex (DS x) = isJust $ parseDate x -fromAS :: [AssocString] -> [String]-fromAS s = [x | AS x <- s]+-- Conversion to an association list.+prop_toAssoc_rev :: AssocString -> Bool+prop_toAssoc_rev x = k == k' && v == v'+    where+        AS str k v = x+        (k',v') = toAssoc str  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_parseBool (BS xs) =+    case parseBool xs of+        Nothing    -> False+        Just True  -> xs == "1"+        Just False -> xs == "0"  prop_showBool :: Bool -> Bool prop_showBool True = showBool True == "1"@@ -133,56 +79,27 @@ 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+prop_parseNum :: Integer -> Bool+prop_parseNum x =+    case show x of+        (xs@"")      -> parseNum xs == Nothing+        (xs@('-':_)) -> fromMaybe 0 (parseNum xs) <= 0+        (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 = liftM2 Count arbitrary arbitrary- prop_parseCount :: Count -> Bool prop_parseCount c = Right c == (parseCount . lines $ display c) -instance Arbitrary Device where-    arbitrary = liftM3 Device arbitrary field arbitrary- 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   <- abs `fmap` arbitrary-        track <- two $ abs `fmap` arbitrary-        disc  <- two $ abs `fmap` arbitrary-        idx   <- oneof [return Nothing-                       ,liftM (Just . Pos) $ abs `fmap` arbitrary-                       ,liftM (Just . ID)  $ abs `fmap` 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_parseSong s = Right s == (parseSong . toAssocList . lines $ display s)  prop_parseStats :: Stats -> Bool prop_parseStats s = Right s == (parseStats . lines $ display s)

@@ -1,16 +0,0 @@-#!/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=StringConn && \-    hpc report Main --exclude=Main --exclude=Properties --exclude=Commands \-    --exclude=Displayable --exclude=StringConn

@@ -0,0 +1,40 @@+#!/usr/bin/env runhaskell++Generate coverage reports with HPC.+Usage: runhaskell coverage.lhs++\begin{code}+import Control.Monad (when)+import System.Cmd (system)+import System.Exit (ExitCode(..), exitWith)+import System.FilePath ((</>))+import System.Directory (doesDirectoryExist, getDirectoryContents, removeDirectory, removeFile)++excludeModules =+    ["Main", "Arbitrary", "Properties", "Displayable", "Commands", "StringConn"]++main = do+    -- Cleanup from previous runs+    hpcExists <- doesDirectoryExist ".hpc"+    when hpcExists $ do+        cs <- getDirectoryContents ".hpc"+        let fs = map (".hpc" </>) (filter (`notElem` [".", ".."]) cs)+        mapM_ removeFile fs+        removeDirectory ".hpc"+        removeFile "test.tix"++    -- Build and generate coverage report+    run "runhaskell Setup clean"+    run "runhaskell Setup configure -f test -f coverage --disable-optimization --user"+    run "runhaskell Setup build"+    run "dist/build/test/test"+    run ("hpc markup test.tix --destdir=report " ++ exclude)+    run ("hpc report test.tix " ++ exclude)+    where+        exclude = unwords (map ("--exclude=" ++) excludeModules)++run x = system x >>= catchFailure+    where+        catchFailure (ExitFailure _) = exitWith (ExitFailure 1)+        catchFailure              _  = return ()+\end{code}

@@ -1,15 +0,0 @@-#!/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

@@ -0,0 +1,50 @@+#!/usr/bin/env runhaskell++Compile and run tests.+Usage: runhaskell run-tests.lhs [arguments]++\begin{code}+import Control.Monad (when)+import Data.Maybe (isJust)+import System.Directory (removeFile)+import System.Environment (getArgs)+import System.Exit (ExitCode(..), exitWith)+import System.IO (hGetContents)+import System.Process+import Text.Regex (matchRegex, mkRegex)+++main = do+    -- Build the test binary+    run "runhaskell Setup configure -f test --disable-optimization --user"+    run "runhaskell Setup build"++    -- Generate library haddocks+    run "runhaskell Setup configure --user"+    run "runhaskell Setup haddock --hyperlink"++    -- Run test suite and save output to test.log+    args <- getArgs+    (_, oh, _, ph) <- runInteractiveProcess "dist/build/test/test" args+                                            Nothing Nothing+    waitForProcess ph+    result <- hGetContents oh+    putStr result+    writeFile "test.log" result++    -- Detect failure+    let re = mkRegex "Falsifiable|\\*\\*\\* FAILURE \\*\\*\\*"+    when (isJust $ matchRegex re result) $ do+        putStrLn "Failure detected: see test.log"+        exitWith (ExitFailure 1)++    -- Cleanup+    removeFile "test.log"++-- A wrapper for 'system' that halts the program if the command fails.+run x = system x >>= catchFailure+    where+        catchFailure (ExitFailure _) = exitWith (ExitFailure 1)+        catchFailure              _  = return ()++\end{code}