libmpd 0.4.2 → 0.5.0

raw patch · 12 files changed

+723/−536 lines, 12 filesdep +containersdep +old-localedep +timePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, old-locale, time

API changes (from Hackage documentation)

Files

• ChangeLog +13/−0
• Network/MPD/Commands.hs +77/−280
• Network/MPD/Commands/Extensions.hs +147/−0
• Network/MPD/Commands/Parse.hs +243/−131
• Network/MPD/Commands/Query.hs +2/−2
• Network/MPD/Commands/Types.hs +75/−79
• Network/MPD/Commands/Util.hs +47/−0
• Network/MPD/Core.hs +69/−34
• Network/MPD/Core/Class.hs +12/−2
• Network/MPD/Utils.hs +27/−2
• README.md +3/−3
• libmpd.cabal +8/−3

@@ -1,3 +1,16 @@+* v0.5.0, 2010-09-08+	- Moved extensions to Network.MPD.Commands.Extensions+	These might be removed in a later version+	- Non-blocking `idle'+	- The API is closer to the MPD spec, by untangling functionality+	- Better MPD API coverage+	- Improved parser implementation, now runs in constant space+	- Constructors of the `Subsystem' type have been renamed+	- Passwords can be changed using `setPassword'+	- The connection handle can be accessed via `getHandle'+	- The version of the MPD server is available via `getVersion'+	- Added support for connecting via unix sockets+ * v0.4.1, 2010-08-31 	- Only depend on QuickCheck when building the test target 

@@ -16,18 +16,19 @@     module Network.MPD.Commands.Query,      -- * Querying MPD's status-    clearError, currentSong, idle, noidle, status, stats,+    clearError, currentSong, idle, getIdle, noidle, status, stats,      -- * Playback options     consume, crossfade, random, repeat, setVolume, single, replayGainMode,     replayGainStatus,      -- * Controlling playback-    next, pause, play, previous, seek, stop,+    next, pause, play, playId, previous, seek, seekId, stop,      -- * The current playlist-    add, add_, addId, clear, delete, move, playlist, playlistFind,-    playlistInfo, playlistSearch, plChanges, plChangesPosId, shuffle, swap,+    add, add_, addId, clear, delete, deleteId, move, moveId, playlist,+    playlistId, playlistFind, playlistInfo, playlistSearch, plChanges,+    plChangesPosId, shuffle, swap, swapId,      -- * Stored playlist     listPlaylist, listPlaylistInfo, listPlaylists, load, playlistAdd,@@ -49,25 +50,20 @@      -- * Reflection     commands, notCommands, tagTypes, urlHandlers, decoders,--    -- * Extensions\/shortcuts-    addMany, deleteMany, complete, crop, prune, lsDirs, lsFiles, lsPlaylists,-    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.Commands.Util import Network.MPD.Core import Network.MPD.Utils -import Control.Monad (liftM, unless)+import Control.Monad (liftM) import Control.Monad.Error (throwError) import Prelude hiding (repeat)-import Data.List (findIndex, intersperse, isPrefixOf) import Data.Maybe-import System.FilePath (dropFileName)  -- -- Querying MPD's status@@ -77,42 +73,34 @@ clearError :: MonadMPD m => m () clearError = getResponse_ "clearerror" --- | 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+-- | Get the current song.+currentSong :: MonadMPD m => m (Maybe Song)+currentSong = getResponse "currentsong" >>= takeSongs >>= return . listToMaybe --- | 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"+-- | Make MPD server notify the client if there is a noteworthy change+--   in one or more of its subsystems. Note that after running this command+--   you can either monitor handle for incoming notifications or cancel this+--   by 'noidle'. Any command other than 'noidle' sent to MPD server while+--   idle is active will be ignored.+idle :: MonadMPD m => [Subsystem] -> m ()+idle ss = send ("idle" <$> foldr (<++>) (Args []) ss) +-- | Get idle notifications. If there is no notifications ready+--   at the moment, this function will block until they show up.+getIdle :: MonadMPD m => m [Subsystem]+getIdle = getResponse "" >>= return . parseIdle . toAssocList+ -- | Cancel 'idle'. noidle :: MonadMPD m => m () noidle = getResponse_ "noidle"  -- | Get server statistics. stats :: MonadMPD m => m Stats-stats = getResponse "stats" >>= runParser parseStats+stats = getResponse "stats" >>= return . parseStats . toAssocList  -- | Get the server's status. status :: MonadMPD m => m Status-status = getResponse "status" >>= runParser parseStatus+status = getResponse "status" >>= return . parseStatus . toAssocList  -- -- Playback options@@ -163,24 +151,26 @@ pause = getResponse_ . ("pause" <$>)  -- | 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)+play :: MonadMPD m => Maybe Int -> m ()+play (Just pos) = getResponse_ ("play" <$> pos)+play _          = getResponse_  "play" +-- | Play a file with given id.+playId :: MonadMPD m => Int -> m ()+playId id' = getResponse_ ("playid" <$> id')+ -- | Play the previous song. previous :: MonadMPD m => m () previous = getResponse_ "previous"  -- | 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)+seek :: MonadMPD m => Int -> Seconds -> m ()+seek pos time = getResponse_ ("seek" <$> pos <++> time) +-- | Seek to some point in a song (id version)+seekId :: MonadMPD m => Int -> Seconds -> m ()+seekId id' time = getResponse_ ("seekid" <$> id' <++> time)+ -- | Stop playing. stop :: MonadMPD m => m () stop = getResponse_ "stop"@@ -192,7 +182,7 @@ -- This might do better to throw an exception than silently return 0. -- | Like 'add', but returns a playlist id. addId :: MonadMPD m => Path -> Maybe Integer -- ^ Optional playlist position-      -> m Integer+      -> m Int addId p pos = liftM (parse parseNum id 0 . snd . head . toAssocList)               $ getResponse1 ("addid" <$> p <++> pos) @@ -209,24 +199,31 @@ clear = getResponse_ "clear"  -- | Remove a song from the current playlist.-delete :: MonadMPD m => PLIndex -> m ()-delete (Pos x) = getResponse_ ("delete" <$> x)-delete (ID x)  = getResponse_ ("deleteid" <$> x)+delete :: MonadMPD m => Int -> m ()+delete pos = getResponse_ ("delete" <$> pos) +-- | Remove a song from the current playlist.+deleteId :: MonadMPD m => Int -> m ()+deleteId id' = getResponse_ ("deleteid" <$> id')+ -- | 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)+move :: MonadMPD m => Int -> Int -> m ()+move pos to = getResponse_ ("move" <$> pos <++> to) +-- | Move a song from (songid) to (playlist index) in the playlist. If to is+-- negative, it is relative to the current song in the playlist (if there is one).+moveId :: MonadMPD m => Int -> Int -> m ()+moveId id' to = getResponse_ ("moveid" <$> id' <++> 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 :: MonadMPD m => m [(PLIndex, Path)]+playlist :: MonadMPD m => m [(Int, Path)] playlist = mapM f =<< getResponse "playlist"     where f s | (pos, name) <- breakChar ':' s               , Just pos'   <- parseNum pos-              = return (Pos pos', name)+              = return (pos', name)               | otherwise = throwError . Unexpected $ show s  -- | Search for songs in the current playlist with strict matching.@@ -234,14 +231,14 @@ 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+playlistInfo :: MonadMPD m => Maybe (Int, Int) -> m [Song]+playlistInfo range = takeSongs =<< getResponse ("playlistinfo" <$> range) +-- | Displays a list of songs in the playlist.+-- If id is specified, only its info is returned.+playlistId :: MonadMPD m => Maybe Int -> m [Song]+playlistId id' = takeSongs =<< getResponse ("playlistinfo" <$> id')+ -- | Search case-insensitively with partial matches for songs in the -- current playlist. playlistSearch :: MonadMPD m => Query -> m [Song]@@ -253,13 +250,13 @@ plChanges version = takeSongs =<< getResponse ("plchanges" <$> version)  -- | Like 'plChanges' but only returns positions and ids.-plChangesPosId :: MonadMPD m => Integer -> m [(PLIndex, PLIndex)]+plChangesPosId :: MonadMPD m => Integer -> m [(Int, Int)] plChangesPosId plver =     getResponse ("plchangesposid" <$> plver) >>=     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')+               = return (x', y')                | otherwise = throwError . Unexpected $ show xs  -- | Shuffle the playlist.@@ -268,13 +265,13 @@ shuffle range = getResponse_ ("shuffle" <$> range)  -- | 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"+swap :: MonadMPD m => Int -> Int -> m ()+swap pos1 pos2 = getResponse_ ("swap" <$> pos1 <++> pos2) +-- | Swap the positions of two songs (Id version+swapId :: MonadMPD m => Int -> Int -> m ()+swapId id1 id2 = getResponse_ ("swapid" <$> id1 <++> id2)+ -- -- Stored playlists --@@ -348,7 +345,7 @@  -- | Count the number of entries matching a query. count :: MonadMPD m => Query -> m Count-count query = getResponse ("count" <$>  query) >>= runParser parseCount+count query = getResponse ("count" <$>  query) >>= return . parseCount . toAssocList  -- | Search the database for entries exactly matching a query. find :: MonadMPD m => Query -> m [Song]@@ -360,7 +357,7 @@  -- | List all metadata of metadata (sic). list :: MonadMPD m-     => Meta -- ^ Metadata to list+     => Metadata -- ^ Metadata to list      -> Query -> m [String] list mtype query = liftM takeValues $ getResponse ("list" <$> mtype <++> query) @@ -369,23 +366,17 @@ listAll path = liftM (map snd . filter ((== "file") . fst) . toAssocList)                      (getResponse $ "listall" <$> path) --- 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)- -- | Recursive 'lsInfo'.-listAllInfo :: MonadMPD m => Path -> m [Either Path Song]-listAllInfo = lsInfo' "listallinfo"+listAllInfo :: MonadMPD m => Path -> m [Song]+listAllInfo path = takeSongs =<< getResponse ("listallinfo" <$> path)  -- | Non-recursively list the contents of a database directory.-lsInfo :: MonadMPD m => Path -> m [Either Path Song]-lsInfo = lsInfo' "lsinfo"+lsInfo :: MonadMPD m => Path -> m [Entry]+lsInfo path = takeEntries =<< getResponse ("lsinfo" <$> path)  -- | Search the database using case insensitive matching. search :: MonadMPD m => Query -> m [Song]-search query = getResponse ("search" <$> query) >>= takeSongs+search query = takeSongs =<< getResponse ("search" <$> query)  -- | Update the server's database. -- If no paths are given, all paths will be scanned.@@ -474,8 +465,8 @@ enableOutput = getResponse_ . ("enableoutput" <$>)  -- | Retrieve information for all output devices.-outputs :: MonadMPD m => m [Device]-outputs = getResponse "outputs" >>= runParser parseOutputs+outputs :: MonadMPD m => m [Output]+outputs = getResponse "outputs" >>= return . parseOutputs . toAssocList  -- -- Reflection@@ -505,197 +496,3 @@         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 :: MonadMPD m => [Path] -> m Integer-updateId paths = liftM (read . head . takeValues) cmd-  where cmd = case paths of-                []  -> getResponse  "update"-                [x] -> getResponse ("update" <$> x)-                xs  -> getResponses $ map ("update" <$>) xs---- | Toggles play\/pause. Plays if stopped.-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 :: MonadMPD m => PlaylistName -> [Path] -> m ()-addMany _ [] = return ()-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-                      pl -> "playlistadd" <$> pl <++> x---- | 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 :: MonadMPD m => PlaylistName -> [PLIndex] -> m ()-deleteMany _ [] = return ()-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-deleteMany plname xs = getResponses (map cmd xs) >> return ()-    where cmd (Pos x) = "playlistdelete" <$> plname <++> x-          cmd _       = ""---- | Returns all songs and directories that match the given partial--- path name.-complete :: MonadMPD m => String -> m [Either Path Song]-complete path = do-    xs <- liftM matches . lsInfo $ dropFileName path-    case xs of-        [Left dir] -> complete $ dir ++ "/"-        _          -> return xs-    where-        matches = filter (isPrefixOf path . takePath)-        takePath = either id sgFilePath---- | Crop playlist.--- The bounds are inclusive.--- If 'Nothing' is passed the cropping will leave your playlist alone--- on that side.--- 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-                       Just (ID i)  -> fromMaybe 0 (findByID i pl)-                       Nothing      -> 0-        -- ensure that no songs are deleted twice with 'max'.-        ys = case y of Just (Pos p) -> drop (max (fromInteger p) x') pl-                       Just (ID i)  -> maybe [] (flip drop pl . max x' . (+1))-                                      (findByID i pl)-                       Nothing      -> []-    deleteMany "" . mapMaybe sgIndex $ take x' pl ++ ys-    where findByID i = findIndex ((==) i . (\(ID j) -> j) . fromJust . sgIndex)---- | Remove duplicate playlist entries.-prune :: MonadMPD m => m ()-prune = findDuplicates >>= deleteMany ""---- Find duplicate playlist entries.-findDuplicates :: MonadMPD m => m [PLIndex]-findDuplicates =-    liftM (map ((\(ID x) -> ID x) . fromJust . sgIndex) . flip dups ([],[])) $-        playlistInfo Nothing-    where dups [] (_, dup) = dup-          dups (x:xs) (ys, dup)-              | x `mSong` xs && not (x `mSong` ys) = dups xs (ys, x:dup)-              | otherwise                          = dups xs (x:ys, dup)-          mSong x = let m = sgFilePath x in any ((==) m . sgFilePath)---- | List directories non-recursively.-lsDirs :: MonadMPD m => Path -> m [Path]-lsDirs path =-    liftM (extractEntries (const Nothing,const Nothing, Just)) $-        takeEntries =<< getResponse ("lsinfo" <$> path)---- | List files non-recursively.-lsFiles :: MonadMPD m => Path -> m [Path]-lsFiles path =-    liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $-        takeEntries =<< getResponse ("lsinfo" <$> path)---- | List all playlists.-lsPlaylists :: MonadMPD m => m [PlaylistName]-lsPlaylists = liftM (extractEntries (const Nothing, Just, const Nothing)) $-                    takeEntries =<< getResponse "lsinfo"---- | List the artists in the database.-listArtists :: MonadMPD m => m [Artist]-listArtists = liftM takeValues (getResponse "list artist")---- | List the albums in the database, optionally matching a given--- artist.-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 :: MonadMPD m => Artist -> Album -> m [Song]-listAlbum artist album = find (Artist =? artist <&> Album =? album)---- | Retrieve the current playlist.--- Equivalent to @playlistinfo Nothing@.-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_ :: MonadMPD m => String -> m ()-getResponse_ x = getResponse x >> return ()---- Get the lines of the daemon's response to a list of commands.-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 :: 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 :: MonadMPD m => String -> m [String]-getResponse1 x = getResponse x >>= failOnEmpty------- Parsing.------- Run 'toAssocList' and return only the values.-takeValues :: [String] -> [String]-takeValues = snd . unzip . toAssocList--data EntryType-    = SongEntry Song-    | PLEntry   String-    | DirEntry  String-      deriving (Eq, Show)---- Separate the result of an lsinfo\/listallinfo call into directories,--- playlists, and songs.-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-        toEntry (("playlist",pl):_) = return $ PLEntry  pl-        toEntry _ = error "takeEntries: splitGroups is broken"-        wrappers = [("file",id), ("directory",id), ("playlist",id)]---- Extract a subset of songs, directories, and playlists.-extractEntries :: (Song -> Maybe a, String -> Maybe a, String -> Maybe a)-               -> [EntryType] -> [a]-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 :: MonadMPD m => [String] -> m [Song]-takeSongs = mapM (runParser parseSong)-          . splitGroups [("file",id)]-          . toAssocList

@@ -0,0 +1,147 @@+-- | Module    : Network.MPD.Commands.Extensions+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- Extensions and shortcuts to the standard MPD command set.++module Network.MPD.Commands.Extensions where++import Network.MPD.Commands.Arg+import Network.MPD.Commands.Query+import Network.MPD.Commands.Types+import Network.MPD.Commands.Util+import Network.MPD.Commands+import Network.MPD.Core++import Control.Monad (liftM)+import Prelude hiding (repeat)++-- | Like 'update', but returns the update job id.+updateId :: MonadMPD m => [Path] -> m Integer+updateId paths = liftM (read . head . takeValues) cmd+  where cmd = case paths of+                []  -> getResponse  "update"+                [x] -> getResponse ("update" <$> x)+                xs  -> getResponses $ map ("update" <$>) xs++-- | Toggles play\/pause. Plays if stopped.+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 :: MonadMPD m => PlaylistName -> [Path] -> m ()+addMany _ [] = return ()+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+                      pl -> "playlistadd" <$> pl <++> x++-- | 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 :: MonadMPD m => PlaylistName -> [PLIndex] -> m ()+deleteMany _ [] = return ()+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+deleteMany plname xs = getResponses (map cmd xs) >> return ()+    where cmd (Pos x) = "playlistdelete" <$> plname <++> x+          cmd _       = ""++-- | Returns all songs and directories that match the given partial+-- path name.+complete :: MonadMPD m => String -> m [Either Path Song]+complete path = do+    xs <- liftM matches . lsInfo $ dropFileName path+    case xs of+        [Left dir] -> complete $ dir ++ "/"+        _          -> return xs+    where+        matches = filter (isPrefixOf path . takePath)+        takePath = either id sgFilePath++-- | Crop playlist.+-- The bounds are inclusive.+-- If 'Nothing' is passed the cropping will leave your playlist alone+-- on that side.+-- 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+                       Just (ID i)  -> fromMaybe 0 (findByID i pl)+                       Nothing      -> 0+        -- ensure that no songs are deleted twice with 'max'.+        ys = case y of Just (Pos p) -> drop (max (fromInteger p) x') pl+                       Just (ID i)  -> maybe [] (flip drop pl . max x' . (+1))+                                      (findByID i pl)+                       Nothing      -> []+    deleteMany "" . mapMaybe sgIndex $ take x' pl ++ ys+    where findByID i = findIndex ((==) i . (\(ID j) -> j) . fromJust . sgIndex)++-- | Remove duplicate playlist entries.+prune :: MonadMPD m => m ()+prune = findDuplicates >>= deleteMany ""++-- Find duplicate playlist entries.+findDuplicates :: MonadMPD m => m [PLIndex]+findDuplicates =+    liftM (map ((\(ID x) -> ID x) . fromJust . sgIndex) . flip dups ([],[])) $+        playlistInfo Nothing+    where dups [] (_, dup) = dup+          dups (x:xs) (ys, dup)+              | x `mSong` xs && not (x `mSong` ys) = dups xs (ys, x:dup)+              | otherwise                          = dups xs (x:ys, dup)+          mSong x = let m = sgFilePath x in any ((==) m . sgFilePath)++-- | List directories non-recursively.+lsDirs :: MonadMPD m => Path -> m [Path]+lsDirs path =+    liftM (extractEntries (const Nothing,const Nothing, Just)) $+        takeEntries =<< getResponse ("lsinfo" <$> path)++-- | List files non-recursively.+lsFiles :: MonadMPD m => Path -> m [Path]+lsFiles path =+    liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $+        takeEntries =<< getResponse ("lsinfo" <$> path)++-- | List all playlists.+lsPlaylists :: MonadMPD m => m [PlaylistName]+lsPlaylists = liftM (extractEntries (const Nothing, Just, const Nothing)) $+                    takeEntries =<< getResponse "lsinfo" -}++-- | List the artists in the database.+listArtists :: MonadMPD m => m [Artist]+listArtists = liftM takeValues (getResponse "list artist")++-- | List the albums in the database, optionally matching a given+-- artist.+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 :: MonadMPD m => Artist -> Album -> m [Song]+listAlbum artist album = find (Artist =? artist <&> Album =? album)++-- | Retrieve the current playlist.+-- Equivalent to @playlistinfo Nothing@.+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

@@ -8,154 +8,266 @@ -- -- Parsers for MPD data types. -module Network.MPD.Commands.Parse where+module Network.MPD.Commands.Parse (+    -- * Parsers for many objects+    parseSongs, parseEntries, parseOutputs,+    -- * Parsers for one object+    parseCount, parseStats, parseStatus,+    -- * Other parsers+    parseIdle,+    -- * Misc utilities+    parse, pair+    ) where  import Network.MPD.Commands.Types -import Control.Monad.Error+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Control.Arrow (first, (***)) import Network.MPD.Utils-import Network.MPD.Core (MonadMPD, MPDError(Unexpected)) +type ItemGen a = [(String, String)] -- ^ list of (key,value) pairs+               -> a                 -- ^ intermediate object+               -> (a, Int)          -- ^ result object along with information+                                    --   about amount of lines it consumed++-- | Generate Output object.+parseOutput :: ItemGen Output+parseOutput ls d = f ls d 0+    where f []                d' n = (d', n)+          f ((key, value):ls') d' n =+              case key of+                   "outputname"    -> f ls' d' { outName = value }      (succ n)+                   "outputenabled" -> f ls' (up outenabled' parseBool) (succ n)+                   "outputid"      -> (d', n) -- new output, we're done here+                   _               -> f ls' d' (succ n) -- ignore unknown keys++              where up g parser = maybe d g $ parser value+                    outenabled' v = d' { outEnabled = v }++-- | Generate Entry object+parseEntry :: ItemGen Entry+parseEntry ls (SongE s) = first SongE $ parseSong ls s+parseEntry _  d@(DirectoryE _) = (d, 0)+parseEntry ls (PlaylistE p) = first PlaylistE $ parsePlaylist ls p 0+    where parsePlaylist [] s n = (s, n)+          parsePlaylist ((key, value):ls') p' n =+              case key of+                   "Last-Modified" -> parsePlaylist ls' p'+                                        { plLastModified = parseIso8601 value }+                                        (succ n)+                   "playlist"      -> (p', n) -- new playlist, we're done here+                   _               -> parsePlaylist ls' p' (succ n) -- ignore unknown keys++-- | Generate Song object+parseSong :: ItemGen Song+parseSong ls s = f ls s 0+    where f []                s' n = (s', n)+          f ((key, value):ls') s' n =+              case key of+                   "Last-Modified" -> f ls' s' { sgLastModified = lm   } (succ n)+                   "Time"          -> f ls' s' { sgLength       = time } (succ n)+                   "Id"            -> f ls' s' { sgIndex        = id'  } (succ n)+                   "Pos"           -> f ls' s' { sgIndex        = pos  } (succ n)+                   "file"          -> (s', n) -- new item, we're done here+                   "playlist"      -> (s', n) -- new item, we're done here+                   -- "directory" is not needed, files are always after dirs+                   _ -> case tagValue key of+                            Just meta -> f ls' s'+                                           { sgTags = M.insertWith' (++)+                                                 meta [value] (sgTags s')+                                           } (succ n)+                            Nothing   -> f ls' s' (succ n) -- ignore unknown keys++              where lm     = parseIso8601 value+                    time   = maybe 0 id $ parseNum value+                    id'    = Just (maybe 0 fst $ sgIndex s', maybe 0 id $ parseNum value)+                    pos    = Just (maybe 0 id $ parseNum value, maybe 0 snd $ sgIndex s')++                    -- Why not just derive instance of Read? Because+                    -- using read is a few times slower than this.+                    tagValue "Artist" = Just Artist+                    tagValue "ArtistSort" = Just ArtistSort+                    tagValue "Album" = Just Album+                    tagValue "AlbumArtist" = Just AlbumArtist+                    tagValue "AlbumArtistSort" = Just AlbumArtistSort+                    tagValue "Title" = Just Title+                    tagValue "Track" = Just Track+                    tagValue "Name" = Just Name+                    tagValue "Genre" = Just Genre+                    tagValue "Date" = Just Date+                    tagValue "Composer" = Just Composer+                    tagValue "Performer" = Just Performer+                    tagValue "Disc" = Just Disc+                    tagValue "MUSICBRAINZ_ARTISTID" = Just MUSICBRAINZ_ARTISTID+                    tagValue "MUSICBRAINZ_ALBUMID" = Just MUSICBRAINZ_ALBUMID+                    tagValue "MUSICBRAINZ_ALBUMARTISTID" = Just MUSICBRAINZ_ALBUMARTISTID+                    tagValue "MUSICBRAINZ_TRACKID" = Just MUSICBRAINZ_TRACKID+                    tagValue _ = Nothing++-------------------------------------------------------------------++-- | Parser generator.+genParser :: [(String, String -> a)] -> ItemGen a -> [(String, String)] -> [a]+genParser _    _      []                = []+genParser ptrs parser ((key, value):ls) =+    case key `lookup` ptrs of+        Just ctr -> let (item, n) = parser ls (ctr value) in+                        item : genParser ptrs parser (drop n ls)+        Nothing  ->            genParser ptrs parser ls++-- | Parser for songs.+parseSongs :: [(String, String)] -> [Song]+parseSongs = genParser [ ("file", initSong)+                       ] parseSong++initSong :: String -> Song+initSong filepath =+    Song { sgFilePath = filepath, sgTags = M.empty+         , sgLastModified = Nothing, sgLength = 0+         , sgIndex = Nothing }++-- | Parser for database entries.+parseEntries :: [(String, String)] -> [Entry]+parseEntries = genParser [ ("directory", DirectoryE)+                         , ("file", SongE . initSong)+                         , ("playlist", PlaylistE . initPlaylist)+                         ] parseEntry++initPlaylist :: String -> Playlist+initPlaylist name =+    Playlist { plName = name, plLastModified = Nothing }++-- | Parser for outputs.+parseOutputs :: [(String, String)] -> [Output]+parseOutputs = genParser [ ("outputid", initOutput . fromMaybe (-1) . parseNum )+                         ] parseOutput++initOutput :: Int -> Output+initOutput id' =+    Output { outID = id', outName = "", outEnabled = False }++------------------------------------------------------------------+ -- | 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+parseCount :: [(String, String)] -> Count+parseCount = flip parseCount' defaultCount --- | 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+-- | Helper function.+parseCount' :: [(String, String)] -> Count -> Count+parseCount' []                c = c+parseCount' ((key, value):ls) c =+    case key of+        "songs"    -> modify parseNum $ \v -> c { cSongs = v }+        "playtime" -> modify parseNum $ \v -> c { cPlaytime = v }+        _          -> parseCount' ls c +    where modify p f = parseCount' ls $ parse p f c value++defaultCount =+    Count { cSongs = 0, cPlaytime = 0 }++-------------------------------------------------------------------+ -- | 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+parseStats :: [(String, String)] -> Stats+parseStats = flip parseStats' defaultStats --- | 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 }+-- | Helper function.+parseStats' :: [(String, String)] -> Stats -> Stats+parseStats' []                s = s+parseStats' ((key, value):ls) s =+    case key of+        "artists"     -> modify parseNum $ \v -> s { stsArtists = v }+        "albums"      -> modify parseNum $ \v -> s { stsAlbums = v }+        "songs"       -> modify parseNum $ \v -> s { stsSongs = v }+        "uptime"      -> modify parseNum $ \v -> s { stsUptime = v }+        "playtime"    -> modify parseNum $ \v -> s { stsPlaytime = v }+        "db_playtime" -> modify parseNum $ \v -> s { stsDbPlaytime = v }+        "db_update"   -> modify parseNum $ \v -> s { stsDbUpdate = v }+        _             -> parseStats' ls s -          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+    where modify p f = parseStats' ls $ parse p f s value +defaultStats =+     Stats { stsArtists = 0, stsAlbums = 0, stsSongs = 0, stsUptime = 0+           , stsPlaytime = 0, stsDbPlaytime = 0, stsDbUpdate = 0 }++-------------------------------------------------------------------+ -- | 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+parseStatus :: [(String, String)] -> Status+parseStatus = flip parseStatus' defaultStatus -          state "play"  = Just Playing-          state "pause" = Just Paused-          state "stop"  = Just Stopped-          state _       = Nothing+-- | Helper function.+parseStatus' :: [(String, String)] -> Status -> Status+parseStatus' []                s = s+parseStatus' ((key, value):ls) s =+    case key of+       "volume"         -> modify parseNum   $ \v -> s { stVolume = v }+       "repeat"         -> modify parseBool  $ \v -> s { stRepeat = v }+       "random"         -> modify parseBool  $ \v -> s { stRandom = v }+       "single"         -> modify parseBool  $ \v -> s { stSingle = v }+       "consume"        -> modify parseBool  $ \v -> s { stConsume = v }+       "playlist"       -> modify parseNum   $ \v -> s { stPlaylistID = v }+       "playlistlength" -> modify parseNum   $ \v -> s { stPlaylistLength = v }+       "xfade"          -> modify parseNum   $ \v -> s { stXFadeWidth = v }+       "mixrampdb"      -> modify parseFrac  $ \v -> s { stMixRampdB = v }+       "mixrampdelay"   -> modify parseFrac  $ \v -> s { stMixRampDelay = v }+       "state"          -> modify parseState $ \v -> s { stState = v }+       "song"           -> parseStatus' ls s { stSongPos = parseNum value }+       "songid"         -> parseStatus' ls s { stSongID = parseNum value }+       "time"           -> modify parseTime  $ \v -> s { stTime = v }+       "elapsed"        -> modify parseFrac  $ \v -> s { stTime = (v, snd $ stTime s) }+       "bitrate"        -> modify parseNum   $ \v -> s { stBitrate = v }+       "audio"          -> modify parseAudio $ \v -> s { stAudio = v }+       "nextsong"       -> parseStatus' ls s { stNextSongPos = parseNum value }+       "nextsongid"     -> parseStatus' ls s { stNextSongID = parseNum value }+       "error"          -> parseStatus' ls s { stError = Just value }+       _                -> parseStatus' ls s -          time = pair parseNum . breakChar ':'+    where modify p f = parseStatus' ls $ parse p f s value -          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+          parseAudio = parseTriple ':' parseNum --- | 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+          parseState "play"  = Just Playing+          parseState "pause" = Just Paused+          parseState "stop"  = Just Stopped+          parseState _       = Nothing++          parseTime s' =+              case parseFrac *** parseNum $ breakChar ':' s' of+                 (Just a, Just b) -> Just (a, b)+                 _                -> Nothing++defaultStatus =+    Status { stState = Stopped, stVolume = 0, stRepeat = False+           , stRandom = False, stPlaylistID = 0, stPlaylistLength = 0+           , stSongPos = Nothing, stSongID = Nothing, stTime = (0, 0)+           , stNextSongPos = Nothing, stNextSongID = Nothing+           , stBitrate = 0, stXFadeWidth = 0, stMixRampdB = 0+           , stMixRampDelay = 0, stAudio = (0, 0, 0), stUpdatingDb = 0+           , stSingle = False, stConsume = False, stError = Nothing }++-------------------------------------------------------------------++-- | Builds list of idle subsystems.+parseIdle :: [(String, String)] -> [Subsystem]+parseIdle [] = []+parseIdle (("changed", value):ls) =+    case value of+        "database"        -> DatabaseS       : parseIdle ls+        "update"          -> UpdateS         : parseIdle ls+        "stored_playlist" -> StoredPlaylistS : parseIdle ls+        "playlist"        -> PlaylistS       : parseIdle ls+        "player"          -> PlayerS         : parseIdle ls+        "mixer"           -> MixerS          : parseIdle ls+        "output"          -> OutputS         : parseIdle ls+        "options"         -> OptionsS        : parseIdle ls+        _                 ->                   parseIdle ls+parseIdle (_:ls) = parseIdle ls++-------------------------------------------------------------------  -- | A helper that runs a parser on a string and, depending on the -- outcome, either returns the result of some command applied to the

@@ -28,7 +28,7 @@ newtype Query = Query [Match] deriving Show  -- A single query clause, comprising a metadata key and a desired value.-data Match = Match Meta String+data Match = Match Metadata String  instance Show Match where     show (Match meta query) = show meta ++ " \"" ++ query ++ "\""@@ -47,7 +47,7 @@ anything = mempty  -- | Create a query.-(=?) :: Meta -> String -> Query+(=?) :: Metadata -> String -> Query m =? s = Query [Match m s]  -- | Combine queries.

@@ -10,6 +10,9 @@  import Network.MPD.Commands.Arg (MPDArg(prep), Args(Args)) +import qualified Data.Map as M+import Data.Time.Clock (UTCTime)+ type Artist       = String type Album        = String type Title        = String@@ -24,11 +27,14 @@  -- | 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+data Metadata = Artist | ArtistSort | Album | AlbumArtist+              | AlbumArtistSort | Title | Track | Name | Genre+              | Date | Composer | Performer | Comment | Disc+              | MUSICBRAINZ_ARTISTID | MUSICBRAINZ_ALBUMID+              | MUSICBRAINZ_ALBUMARTISTID | MUSICBRAINZ_TRACKID+              deriving (Eq, Ord, Show) -instance MPDArg Meta+instance MPDArg Metadata  -- | Object types. data ObjectType = SongObj@@ -39,12 +45,6 @@  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@@ -53,25 +53,25 @@  -- | 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+    = DatabaseS          -- ^ The song database+    | UpdateS            -- ^ Database updates+    | StoredPlaylistS    -- ^ Stored playlists+    | PlaylistS          -- ^ The current playlist+    | PlayerS            -- ^ The player+    | MixerS             -- ^ The volume mixer+    | OutputS            -- ^ Audio outputs+    | OptionsS           -- ^ 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"]+    prep DatabaseS = Args ["database"]+    prep UpdateS = Args ["update"]+    prep StoredPlaylistS = Args ["stored_playlist"]+    prep PlaylistS = Args ["playlist"]+    prep PlayerS = Args ["player"]+    prep MixerS = Args ["mixer"]+    prep OutputS = Args ["output"]+    prep OptionsS = Args ["options"]  data ReplayGainMode     = Off       -- ^ Disable replay gain@@ -84,6 +84,8 @@     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@@ -91,21 +93,45 @@           }     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)+data Output =+    Output { outID      :: Int    -- ^ Output's ID number+           , outName    :: String -- ^ Output's name as defined in+                                  --   the MPD configuration file+           , outEnabled :: Bool+           } deriving (Eq, Show) -defaultDevice :: Device-defaultDevice =-    Device { dOutputID = 0, dOutputName = "", dOutputEnabled = False }+-- | Represents a single song item.+data Song = Song+         { sgFilePath     :: String+         -- | Map of available tags (multiple occurences of one tag type allowed)+         , sgTags         :: M.Map Metadata [String]+         -- | Last modification date+         , sgLastModified :: Maybe UTCTime+         -- | Length of the song in seconds+         , sgLength       :: Seconds+         -- | Position/ID in playlist+         , sgIndex        :: Maybe (Int, Int)+         } deriving (Eq, Show) +-- | Get list of specific tag type+sgGet :: Metadata -> Song -> Maybe [String]+sgGet meta s = M.lookup meta $ sgTags s++-- | Represents a single playlist item.+data Playlist = Playlist {+               plName         :: String+             , plLastModified :: Maybe UTCTime+             } deriving (Eq, Show)++-- | Represents a single item in database.+data Entry = SongE Song+           | PlaylistE Playlist+           | DirectoryE String+           deriving (Eq, Show)++------------------------------------------------------------------+ -- | Container for database statistics. data Stats =     Stats { stsArtists    :: Integer -- ^ Number of artists.@@ -119,31 +145,6 @@           }     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@@ -153,23 +154,27 @@            , stRandom          :: Bool              -- | A value that is incremented by the server every time the              --   playlist changes.-           , stPlaylistVersion :: Integer+           , stPlaylistID      :: Integer              -- | The number of items in the current playlist.            , stPlaylistLength  :: Integer              -- | Current song's position in the playlist.-           , stSongPos         :: Maybe PLIndex+           , stSongPos         :: Maybe Int              -- | Current song's playlist ID.-           , stSongID          :: Maybe PLIndex+           , stSongID          :: Maybe Int              -- | Next song's position in the playlist.-           , stNextSongPos     :: Maybe PLIndex+           , stNextSongPos     :: Maybe Int              -- | Next song's playlist ID.-           , stNextSongID      :: Maybe PLIndex+           , stNextSongID      :: Maybe Int              -- | Time elapsed\/total time.-           , stTime            :: (Seconds, Seconds)+           , stTime            :: (Double, Seconds)              -- | Bitrate (in kilobytes per second) of playing song (if any).            , stBitrate         :: Int              -- | Crossfade time.            , stXFadeWidth      :: Seconds+             -- | MixRamp threshold in dB+           , stMixRampdB       :: Double+             -- | MixRamp extra delay in seconds+           , stMixRampDelay    :: Double              -- | Samplerate\/bits\/channels for the chosen output device              --   (see mpd.conf).            , stAudio           :: (Int, Int, Int)@@ -180,15 +185,6 @@              -- | If True, a song will be removed after it has been played.            , stConsume         :: Bool              -- | Last error message (if any).-           , stError           :: String }+           , stError           :: Maybe 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 = "" }

@@ -0,0 +1,47 @@+-- | Module    : Network.MPD.Commands.Util+-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010+-- License     : LGPL (see LICENSE)+-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>+-- Stability   : alpha+--+-- Internal utilities for implementing MPD commands.++module Network.MPD.Commands.Util where++import Network.MPD.Commands.Parse+import Network.MPD.Commands.Types+import Network.MPD.Core+import Network.MPD.Utils++import Control.Monad.Error (throwError)+import Data.List (intersperse)++-- Run getResponse but discard the response.+getResponse_ :: MonadMPD m => String -> m ()+getResponse_ x = getResponse x >> return ()++-- Get the lines of the daemon's response to a list of commands.+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 :: 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 :: MonadMPD m => String -> m [String]+getResponse1 x = getResponse x >>= failOnEmpty++-- Run 'toAssocList' and return only the values.+takeValues :: [String] -> [String]+takeValues = map snd . toAssocList++-- Build a list of Song instances from a response.+takeSongs :: MonadMPD m => [String] -> m [Song]+takeSongs = return . parseSongs . toAssocList++-- Build a list of Entry instances from a response.+takeEntries :: MonadMPD m => [String] -> m [Entry]+takeEntries = return . parseEntries . toAssocList

@@ -20,19 +20,22 @@     getResponse, kill,     ) where +import Network.MPD.Utils import Network.MPD.Core.Class import Network.MPD.Core.Error +import Data.Char (isDigit) 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 Control.Monad.State (StateT, MonadIO(..), modify, get, evalStateT) import qualified Data.Foldable as F import Data.List (isPrefixOf) import Network (PortID(..), withSocketsDo, connectTo) import System.IO (Handle, hPutStrLn, hReady, hClose, hFlush) import System.IO.Error (isEOFError)+import System.IO.Unsafe (unsafeInterleaveIO) import qualified System.IO.UTF8 as U  --@@ -56,10 +59,11 @@ -- To run IO actions within the MPD monad: -- -- > import Control.Monad.Trans (liftIO)+ newtype MPD a =     MPD { runMPD :: ErrorT MPDError-                    (StateT (Maybe Handle)-                     (ReaderT (Host, Port, Password) IO)) a+                    (StateT MPDState+                     (ReaderT (Host, Port) IO)) a         } deriving (Functor, Monad, MonadIO, MonadError MPDError)  instance Applicative MPD where@@ -70,35 +74,66 @@     open  = mpdOpen     close = mpdClose     send  = mpdSend-    getPassword = MPD $ ask >>= \(_,_,pw) -> return pw+    receive = mpdReceive+    getHandle = MPD $ get >>= return . stHandle+    getPassword = MPD $ get >>= return . stPassword+    setPassword pw = MPD $ modify (\st -> st { stPassword = pw })+    getVersion = MPD $ get >>= return . stVersion +-- | Inner state for MPD+data MPDState =+    MPDState { stHandle   :: Maybe Handle+             , stPassword :: String+             , stVersion  :: (Int, Int, Int)+             }+ -- | A response is either an 'MPDError' or some result. type Response = Either MPDError  -- | 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)+    runReaderT (evalStateT (runErrorT . runMPD $ open >> x) initState)+               (host, port)+                   where initState = MPDState Nothing pw (0, 0, 0)  mpdOpen :: MPD () mpdOpen = MPD $ do-    (host, port, _) <- ask+    (host, port) <- ask     runMPD close     handle <- liftIO (safeConnectTo host port)-    put handle+    modify (\st -> st { stHandle = handle })     F.forM_ handle (const $ runMPD checkConn >>= flip unless (runMPD close))     where+        safeConnectTo host@('/':_) _ =+            (Just <$> connectTo "" (UnixSocket host))+            `catch` const (return Nothing)         safeConnectTo host port =             (Just <$> connectTo host (PortNumber $ fromInteger port))             `catch` const (return Nothing) -        checkConn =-            isPrefixOf "OK MPD" <$> send ""+        checkConn = do+            msg <- mpdReceive >>= checkMsg+            if isPrefixOf "OK MPD" msg+               then do+                   MPD $ maybe (throwError $ Custom "Couldn't determine MPD version")+                               (\v -> modify (\st -> st { stVersion = v }))+                               (parseVersion msg)+                   return True+               else return False +        checkMsg ls =+            if null ls+               then throwError $ Custom "No welcome message"+               else return $ head ls++        parseVersion = parseTriple '.' parseNum . dropWhile (not . isDigit)+ mpdClose :: MPD () mpdClose =-    MPD $ get >>= F.mapM_ (liftIO . sendClose) >> put Nothing+    MPD $ do+        get >>= F.mapM_ (liftIO . sendClose) . stHandle+        modify (\st -> st { stHandle = Nothing })     where         sendClose handle =             (hPutStrLn handle "close" >> hReady handle >> hClose handle)@@ -108,29 +143,30 @@             | isEOFError err = result             | otherwise      = ioError err -mpdSend :: String -> MPD String-mpdSend str = send' `catchError` handler+mpdSend :: String -> MPD ()+mpdSend str = MPD $ get >>= maybe (throwError NoMPD) go . stHandle     where-        handler TimedOut = mpdOpen >> send'-        handler err      = throwError err--        send' = MPD $ get >>= maybe (throwError NoMPD) go--        go handle = do+        go handle =             unless (null str) $                 liftIO $ U.hPutStrLn handle str >> hFlush handle-            liftIO ((Right <$> getLines handle []) `catch` (return . Left))++mpdReceive :: MPD [String]+mpdReceive = getHandle >>= maybe (throwError NoMPD) recv+    where+        recv handle = MPD $+            liftIO ((Right <$> getLines handle) `catch` (return . Left))                 >>= either (\err -> if isEOFError err then-                                        put Nothing >> throwError TimedOut+                                        modify (\st -> st { stHandle = Nothing })+                                        >> throwError TimedOut                                       else liftIO (ioError err))                            return -        getLines handle acc = do+        getLines handle = do             l <- U.hGetLine handle             if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l-                then return . unlines $ reverse (l:acc)-                else getLines handle (l:acc)-+                then return [l]+                else do ls <- unsafeInterleaveIO $ getLines handle+                        return (l:ls)  -- -- Other operations.@@ -147,24 +183,23 @@  -- | Send a command to the MPD server and return the result. getResponse :: (MonadMPD m) => String -> m [String]-getResponse cmd = (send cmd >>= parseResponse) `catchError` sendpw+getResponse cmd = (send cmd >> receive >>= 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+            if null pw+                then throwError e+                else do send ("password " ++ pw) >> receive >>= parseResponse+                        send cmd                 >> receive >>= parseResponse         sendpw e =             throwError e  -- Consume response and return a Response.-parseResponse :: (MonadError MPDError m) => String -> m [String]-parseResponse s+parseResponse :: (MonadError MPDError m) => [String] -> m [String]+parseResponse xs     | null xs                    = throwError $ NoMPD-    | isPrefixOf "ACK" (head xs) = throwError $ parseAck s+    | isPrefixOf "ACK" (head xs) = throwError $ parseAck (head xs)     | otherwise                  = return $ Prelude.takeWhile ("OK" /=) xs-    where-        xs = lines s  -- Turn MPD ACK into the corresponding 'MPDError' parseAck :: String -> MPDError

@@ -10,6 +10,8 @@  module Network.MPD.Core.Class where +import System.IO (Handle)+ import Network.MPD.Core.Error (MPDError)  import Control.Monad.Error (MonadError)@@ -23,8 +25,16 @@     open  :: m ()     -- | Close the connection.     close :: m ()-    -- | Send a string to the server and return its response.-    send  :: String -> m String+    -- | Send a string to the server.+    send  :: String -> m ()+    -- | Get response from the server.+    receive :: m [String]+    -- | Get underlying Handle (or Nothing, if no connection is estabilished)+    getHandle :: m (Maybe Handle)     -- | Produce a password to send to the server should it ask for     --   one.     getPassword :: m Password+    -- | Alters password to be sent to the server.+    setPassword :: String -> m ()+    -- | Get MPD protocol version+    getVersion :: m (Int, Int, Int)

@@ -7,12 +7,15 @@ -- Utilities.  module Network.MPD.Utils (-    parseDate, parseNum, parseBool, showBool,-    breakChar, toAssoc, toAssocList, splitGroups+    parseDate, parseIso8601, parseNum, parseFrac,+    parseBool, showBool, breakChar, parseTriple,+    toAssoc, toAssocList, splitGroups     ) where  import Data.Char (isDigit) import Data.Maybe (fromMaybe)+import Data.Time.Format (ParseTime, parseTime)+import System.Locale (defaultTimeLocale)  -- Break a string by character, removing the separator. breakChar :: Char -> String -> (String, String)@@ -25,12 +28,26 @@ parseDate :: String -> Maybe Int parseDate = parseNum . takeWhile isDigit +-- Parse date in iso 8601 format+parseIso8601 :: (ParseTime t) => String -> Maybe t+parseIso8601 = parseTime defaultTimeLocale "%FT%TZ"+ -- Parse a positive or negative integer value, returning 'Nothing' on failure. parseNum :: (Read a, Integral a) => String -> Maybe a parseNum s = do     [(x, "")] <- return (reads s)     return x +-- Parse C style floating point value, returning 'Nothing' on failure.+parseFrac :: (Fractional a, Read a) => String -> Maybe a+parseFrac s =+    case s of+        "nan"  -> return $ read "NaN"+        "inf"  -> return $ read "Infinity"+        "-inf" -> return $ read "-Infinity"+        _      -> do [(x, "")] <- return $ reads s+                     return x+ -- Inverts 'parseBool'. showBool :: Bool -> String showBool x = if x then "1" else "0"@@ -41,6 +58,14 @@                   "1" -> Just True                   "0" -> Just False                   _   -> Nothing++-- Break a string into triple.+parseTriple :: Char -> (String -> Maybe a) -> String -> Maybe (a, a, a)+parseTriple c f s = let (u, u') = breakChar c s+                        (v, w)  = breakChar c u' in+    case (f u, f v, f w) of+        (Just x, Just y, Just z) -> Just (x, y, z)+        _                        -> Nothing  -- Break a string into an key-value pair, separating at the first ':'. toAssoc :: String -> (String, String)

@@ -81,7 +81,6 @@  ### Resources * [API documentation]-* [Code coverage] * [Protocol reference] * [Using GitHub] * \#libmpd-haskell @ irc.freenode.net@@ -89,8 +88,7 @@ [bug tracker]: http://trac.haskell.org/libmpd/ [GitHub]: http://www.github.com [repository]: http://www.github.com/joachifm/libmpd-haskell-[API documentation]: http://projects.haskell.org/libmpd/doc/-[Code coverage]: http://projects.haskell.org/libmpd/coverage/hpc_index.html+[API documentation]: http://hackage.haskell.org/packages/archive/libmpd/0.4.2/doc/html/Network-MPD.html [Protocol reference]: http://www.musicpd.org/doc/protocol/ [Using GitHub]: http://help.github.com @@ -103,3 +101,5 @@ Joachim Fasting \<joachim.fasting@gmail.com\>  Daniel Schoepe \<daniel.schoepe@googlemail.com\>++Andrzej Rybczak \<electricityispower@gmail.com\>

@@ -1,5 +1,5 @@ Name:               libmpd-Version:            0.4.2+Version:            0.5.0 License:            LGPL License-file:       LICENSE Copyright:          Ben Sinclair 2005-2009, Joachim Fasting 2010@@ -43,8 +43,12 @@      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+                        utf8-string >= 0.3.1 && < 0.4,+                        containers >= 0.3 && < 0.4,+                        time >= 1.1 && < 1.2,+                        old-locale >= 1.0 && < 1.1+    Exposed-Modules:    Network.MPD, Network.MPD.Commands.Extensions,+                        Network.MPD.Core     Other-Modules:      Network.MPD.Core.Class,                         Network.MPD.Core.Error,                         Network.MPD.Commands,@@ -52,6 +56,7 @@                         Network.MPD.Commands.Parse,                         Network.MPD.Commands.Query,                         Network.MPD.Commands.Types,+                        Network.MPD.Commands.Util,                         Network.MPD.Utils     ghc-prof-options:   -auto-all -prof