libmpd 0.7.2 → 0.8.0

raw patch · 30 files changed

+1323/−1226 lines, 30 filesdep +HUnitdep +bytestringdep +data-defaultdep ~basedep ~filepathdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, bytestring, data-default, hspec, text, unix

Dependency ranges changed: base, filepath, mtl, old-locale, time

API changes (from Hackage documentation)

Files

• NEWS +14/−0
• Network/MPD.hs +52/−18
• Network/MPD/Commands.hs +66/−54
• Network/MPD/Commands/Arg.hs +15/−5
• Network/MPD/Commands/Extensions.hs +12/−9
• Network/MPD/Commands/Parse.hs +31/−23
• Network/MPD/Commands/Query.hs +6/−6
• Network/MPD/Commands/Types.hs +72/−14
• Network/MPD/Commands/Util.hs +27/−30
• Network/MPD/Core.hs +37/−30
• Network/MPD/Core/Class.hs +6/−5
• Network/MPD/Core/Error.hs +8/−2
• Network/MPD/Util.hs +48/−37
• README.md +6/−3
• libmpd.cabal +74/−54
• tests/Arbitrary.hs +38/−19
• tests/CommandSpec.hs +435/−0
• tests/Commands.hs +0/−613
• tests/Defaults.hs +21/−0
• tests/Displayable.hs +0/−80
• tests/EnvSpec.hs +80/−0
• tests/Main.hs +12/−10
• tests/ParserSpec.hs +67/−0
• tests/Properties.hs +0/−120
• tests/StringConn.hs +14/−7
• tests/TestUtil.hs +7/−0
• tests/Unparse.hs +75/−0
• tests/UtilSpec.hs +100/−0
• tests/coverage.lhs +0/−37
• tests/run-tests.lhs +0/−50

@@ -1,3 +1,17 @@+* v0.8.0, 2012-04-21+  - Use bytestring for wire communication (sol)+  - Increased type safety (sol)+  - Improved memory usage (sol)+  - `lsinfo` supports playlists (nandykins)+  - `idle` now takes a list of subsystems (sol)+  - `currentSong` works when playback is stopped (sol)+  - Fixes failure on songs without associated paths (sol)+  - `LsResult` replaces `EntryType` (nandykins)+  - hspec based testing added to the test-suite+  - More extensive parser testing+  - 'MPDError' now has an 'Exception' instance+  - Lower bound on Cabal bumped to 1.10+ * v0.7.2, 2012-02-13   - Release connections. Reported by Kanisterschleife on GitHub.   - Some minor internal changes (sol)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | Module    : Network.MPD -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)@@ -7,8 +8,9 @@ -- 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/>. ----- To avoid name clashes with the standard Prelude functions, do:---+-- To use the library, do:+-- +-- > {-# LANGUAGE OverloadedStrings #-} -- > import qualified Network.MPD as MPD  module Network.MPD (@@ -16,19 +18,21 @@     MonadMPD, MPD, MPDError(..), ACKType(..), Response,     Host, Port, Password,     -- * Connections-    withMPD, withMPDEx,+    withMPD, withMPD_, withMPDEx,     module Network.MPD.Commands,+#ifdef TEST+    getConnectionSettings, getEnvDefault+#endif     ) where -import Prelude hiding (catch)-import Control.Exception-import Network.MPD.Commands-import Network.MPD.Core-import Network.MPD.Util+import           Prelude hiding (catch)+import           Control.Exception+import           Network.MPD.Commands+import           Network.MPD.Core -import Control.Monad (liftM)-import System.Environment (getEnv)-import System.IO.Error (isDoesNotExistError)+import           System.Environment (getEnv)+import           System.IO.Error (isDoesNotExistError)+import           Data.Maybe (listToMaybe)  -- | A wrapper for 'withMPDEx' that uses localhost:6600 as the default -- host:port, or whatever is found in the environment variables MPD_HOST and@@ -40,14 +44,44 @@ -- > withMPD $ play Nothing -- > withMPD $ add_ "tool" >> play Nothing >> currentSong withMPD :: MPD a -> IO (Response a)-withMPD m = do-    port       <- read `liftM` getEnvDefault "MPD_PORT" "6600"-    (host, pw) <- parseHost `liftM` getEnvDefault "MPD_HOST" "localhost"-    withMPDEx host port pw m+withMPD = withMPD_ Nothing Nothing++-- | Same as `withMPD`, but takes optional arguments that override MPD_HOST and+-- MPD_PORT.+--+-- This is e.g. useful for clients that optionally take @--port@ and @--host@+-- as command line arguments, and fall back to `withMPD`'s defaults if those+-- arguments are not given.+withMPD_ :: Maybe String -- ^ optional override for MPD_HOST+         -> Maybe String -- ^ optional override for MPD_PORT+         -> MPD a -> IO (Response a)+withMPD_ mHost mPort action = do+    settings <- getConnectionSettings mHost mPort+    case settings of+      Right (host, port, pw) -> withMPDEx host port pw action+      Left err -> (return . Left . Custom) err++getConnectionSettings :: Maybe String -> Maybe String -> IO (Either String (Host, Port, Password))+getConnectionSettings mHost mPort = do+    (host, pw) <- parseHost `fmap`+        maybe (getEnvDefault "MPD_HOST" "localhost") return mHost+    port <- maybe (getEnvDefault "MPD_PORT" "6600") return mPort+    case maybeRead port of+      Just p  -> (return . Right) (host, p, pw)+      Nothing -> (return . Left) (show port ++ " is not a valid port!")     where-        getEnvDefault x dflt =-            catch (getEnv x) (\e -> if isDoesNotExistError e-                                    then return dflt else ioError e)         parseHost s = case breakChar '@' s of                           (host, "") -> (host, "")                           (pw, host) -> (host, pw)++getEnvDefault :: String -> String -> IO String+getEnvDefault x dflt =+    catch (getEnv x) (\e -> if isDoesNotExistError e+                            then return dflt else ioError e)++-- Break a string by character, removing the separator.+breakChar :: Char -> String -> (String, String)+breakChar c s = let (x, y) = break (== c) s in (x, drop 1 y)++maybeRead :: Read a => String -> Maybe a+maybeRead = fmap fst . listToMaybe . reads

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, OverloadedStrings #-}  -- | Module    : Network.MPD.Commands -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010@@ -52,18 +52,21 @@     commands, notCommands, tagTypes, urlHandlers, decoders,     ) 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.Util+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.Util -import Control.Monad (liftM)-import Control.Monad.Error (throwError)-import Prelude hiding (repeat)+import           Control.Monad (liftM)+import           Control.Monad.Error (throwError)+import           Prelude hiding (repeat) +import qualified Data.ByteString.UTF8 as UTF8+import           Data.ByteString (ByteString)+ -- -- Querying MPD's status --@@ -74,28 +77,34 @@  -- | 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+currentSong = getResponse "currentsong" >>= runParser parseMaybeSong . toAssocList  -- | 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 DatabaseS-                                                 "update"   -> return UpdateS-                                                 "stored_playlist" -> return StoredPlaylistS-                                                 "playlist" -> return PlaylistS-                                                 "player" -> return PlayerS-                                                 "mixer" -> return MixerS-                                                 "output" -> return OutputS-                                                 "options" -> return OptionsS-                                                 k -> fail ("Unknown subsystem: " ++ k))-         =<< toAssocList `liftM` getResponse "idle"+-- susbystems.+--+-- The first argument is a list of subsystems that should be considered.  An+-- empty list specifies that all subsystems should be considered.+--+-- A list of subsystems that have noteworthy changes is returned.+--+-- Note that running this command will block until either 'idle' returns or is+-- cancelled by 'noidle'.+idle :: MonadMPD m => [Subsystem] -> m [Subsystem]+idle subsystems =+    mapM f =<< toAssocList `liftM` getResponse ("idle" <$> foldr (<++>) (Args []) subsystems)+    where+        f ("changed", system) =+            case system of+                "database"        -> return DatabaseS+                "update"          -> return UpdateS+                "stored_playlist" -> return StoredPlaylistS+                "playlist"        -> return PlaylistS+                "player"          -> return PlayerS+                "mixer"           -> return MixerS+                "output"          -> return OutputS+                "options"         -> return OptionsS+                k                 -> fail ("Unknown subsystem: " ++ UTF8.toString k)+        f x                       =  fail ("idle: Unexpected " ++ show x)  -- | Cancel 'idle'. noidle :: MonadMPD m => m ()@@ -143,7 +152,7 @@  -- | Get the replay gain options. replayGainStatus :: MonadMPD m => m [String]-replayGainStatus = getResponse "replay_gain_status"+replayGainStatus = map UTF8.toString `liftM` getResponse "replay_gain_status"  -- -- Controlling playback@@ -230,7 +239,7 @@ playlist = mapM f =<< getResponse "playlist"     where f s | (pos, name) <- breakChar ':' s               , Just pos'   <- parseNum pos-              = return (pos', name)+              = return (pos', Path name)               | otherwise = throwError . Unexpected $ show s  -- | Search for songs in the current playlist with strict matching.@@ -260,7 +269,7 @@ plChangesPosId :: MonadMPD m => Integer -> m [(Int, Id)] plChangesPosId plver =     getResponse ("plchangesposid" <$> plver) >>=-    mapM f . splitGroups [("cpos",id)] . toAssocList+    mapM f . splitGroups ["cpos"] . toAssocList     where f xs | [("cpos", x), ("Id", y)] <- xs                , Just (x', y') <- pair parseNum (x, y)                = return (x', Id y')@@ -286,7 +295,7 @@ -- | Retrieve a list of files in a given playlist. listPlaylist :: MonadMPD m => PlaylistName -> m [Path] listPlaylist plname =-    liftM takeValues $ getResponse ("listplaylist" <$> plname)+    (map Path . takeValues) `liftM` getResponse ("listplaylist" <$> plname)  -- | Retrieve metadata for files in a given playlist. listPlaylistInfo :: MonadMPD m => PlaylistName -> m [Song]@@ -295,7 +304,7 @@  -- | Retreive a list of stored playlists. listPlaylists :: MonadMPD m => m [PlaylistName]-listPlaylists = (go [] . toAssocList) `liftM` getResponse "listplaylists"+listPlaylists = (map PlaylistName . go [] . toAssocList) `liftM` getResponse "listplaylists"     where         -- After each playlist name we get a timestamp         go acc [] = acc@@ -362,29 +371,28 @@ findAdd :: MonadMPD m => Query -> m () findAdd q = getResponse_ ("findadd" <$> q) --- | List all metadata of metadata (sic).+-- | List all tags of the specified type. list :: MonadMPD m      => Metadata -- ^ Metadata to list-     -> Query -> m [String]-list mtype query = liftM takeValues $ getResponse ("list" <$> mtype <++> query)+     -> Query -> m [Value]+list mtype query = (map Value . takeValues) `liftM` getResponse ("list" <$> mtype <++> query) + -- | 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)+listAll path = liftM (map (Path . 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)+lsInfo' :: MonadMPD m => Command -> Path -> m [LsResult]+lsInfo' cmd path = getResponse (cmd <$> path) >>= takeEntries  -- | Recursive 'lsInfo'.-listAllInfo :: MonadMPD m => Path -> m [Either Path Song]+listAllInfo :: MonadMPD m => Path -> m [LsResult] listAllInfo = lsInfo' "listallinfo"  -- | Non-recursively list the contents of a database directory.-lsInfo :: MonadMPD m => Path -> m [Either Path Song]+lsInfo :: MonadMPD m => Path -> m [LsResult] lsInfo = lsInfo' "lsinfo"  -- | Search the database using case insensitive matching.@@ -414,7 +422,7 @@            -> String -- ^ Object URI            -> String -- ^ Sticker name            -> m [String]-stickerGet typ uri name = takeValues `liftM` getResponse ("sticker get" <$> typ <++> uri <++> name)+stickerGet typ uri name = (map UTF8.toString . takeValues) `liftM` getResponse ("sticker get" <$> typ <++> uri <++> name)  -- | Adds a sticker value to the specified object. stickerSet :: MonadMPD m => ObjectType@@ -433,12 +441,16 @@ stickerDelete typ uri name =     getResponse_ ("sticker delete" <$> typ <++> uri <++> name) +-- an internal helper function+decodePair :: (ByteString, ByteString) -> (String, String)+decodePair (x, y) = (UTF8.toString x, UTF8.toString y)+ -- | 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)+    (map decodePair . toAssocList) `liftM` getResponse ("sticker list" <$> typ <++> uri)  -- | Searches the sticker database for stickers with the specified name, below -- the specified path.@@ -447,7 +459,7 @@             -> String -- ^ Sticker name             -> m [(String, String)] -- ^ URI\/sticker value stickerFind typ uri name =-    toAssocList `liftM`+    (map decodePair . toAssocList) `liftM`     getResponse ("sticker find" <$> typ <++> uri <++> name)  --@@ -487,19 +499,19 @@  -- | Retrieve a list of available commands. commands :: MonadMPD m => m [String]-commands = liftM takeValues (getResponse "commands")+commands = (map UTF8.toString . takeValues) `liftM` getResponse "commands"  -- | Retrieve a list of unavailable (due to access restrictions) commands. notCommands :: MonadMPD m => m [String]-notCommands = liftM takeValues (getResponse "notcommands")+notCommands = (map UTF8.toString . takeValues) `liftM` getResponse "notcommands"  -- | Retrieve a list of available song metadata. tagTypes :: MonadMPD m => m [String]-tagTypes = liftM takeValues (getResponse "tagtypes")+tagTypes = (map UTF8.toString . takeValues) `liftM` (getResponse "tagtypes")  -- | Retrieve a list of supported urlhandlers. urlHandlers :: MonadMPD m => m [String]-urlHandlers = liftM takeValues (getResponse "urlhandlers")+urlHandlers = (map UTF8.toString . takeValues) `liftM` (getResponse "urlhandlers")  -- | Retreive a list of decoder plugins with associated suffix and mime types. decoders :: MonadMPD m => m [(String, [(String, String)])]@@ -508,4 +520,4 @@         takeDecoders [] = []         takeDecoders ((_, p):xs) =             let (info, rest) = break ((==) "plugin" . fst) xs-            in (p, info) : takeDecoders rest+            in (UTF8.toString p, map decodePair info) : takeDecoders rest

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-}  -- | Module    : Network.MPD.Commands.Arg -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010@@ -8,10 +8,14 @@ -- -- Prepare command arguments. -module Network.MPD.Commands.Arg (Args(..), MPDArg(..), (<++>), (<$>)) where+module Network.MPD.Commands.Arg (Command, Args(..), MPDArg(..), (<++>), (<$>)) where -import Network.MPD.Util (showBool)+import           Network.MPD.Util (showBool) +import           Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as UTF8+import           Data.String+ -- | 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.@@ -37,11 +41,14 @@     where Args xs = prep x           Args ys = prep y +newtype Command = Command String+  deriving IsString+ -- | 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 = unwords $ x : filter (not . null) y'+(<$>) :: (MPDArg a) => Command -> a -> String+Command x <$> y = unwords $ x : filter (not . null) y'     where Args y' = prep y  instance MPDArg Args where prep = id@@ -50,6 +57,9 @@     -- We do this to avoid mangling     -- non-ascii characters with 'show'     prep x = Args ['"' : x ++ "\""]++instance MPDArg ByteString where+    prep = prep . UTF8.toString  instance (MPDArg a) => MPDArg (Maybe a) where     prep Nothing = Args []

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | Module    : Network.MPD.Commands.Extensions -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)@@ -8,12 +9,14 @@  module Network.MPD.Commands.Extensions where -import Network.MPD.Core-import Network.MPD.Commands-import Network.MPD.Commands.Arg-import Network.MPD.Commands.Util+import           Network.MPD.Core+import           Network.MPD.Commands+import           Network.MPD.Commands.Arg+import           Network.MPD.Commands.Util+import           Network.MPD.Util (read) -import Control.Monad (liftM)+import           Prelude hiding (read)+import           Control.Monad (liftM)  -- | Like 'update', but returns the update job id. updateId :: MonadMPD m => [Path] -> m Integer@@ -118,13 +121,13 @@  -- | List the artists in the database. listArtists :: MonadMPD m => m [Artist]-listArtists = liftM takeValues (getResponse "list artist")+listArtists = (map Value . takeValues) `liftM` (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)+listAlbums artist = (map Value . takeValues) `liftM`+                    getResponse ("list album" <$> fmap (("artist" :: String) <++>) artist)  -- | List the songs in an album of some artist. listAlbum :: MonadMPD m => Artist -> Album -> m [Song]@@ -141,4 +144,4 @@ volume :: MonadMPD m => Int -> m () volume n = do     current <- (fromIntegral . stVolume) `liftM` status-    setVolume . round $ (fromIntegral n / 100) * current + current+    setVolume . round $ (fromIntegral n / (100 :: Double)) * current + current

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}  -- | Module    : Network.MPD.Commands.Parse -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010@@ -10,19 +10,22 @@  module Network.MPD.Commands.Parse where -import Network.MPD.Commands.Types+import           Network.MPD.Commands.Types -import Control.Arrow ((***))-import Control.Monad.Error-import Data.Maybe (fromMaybe)+import           Control.Arrow ((***))+import           Control.Monad.Error+import           Data.Maybe (fromMaybe) -import Network.MPD.Util-import Network.MPD.Core (MonadMPD, MPDError(Unexpected))+import           Network.MPD.Util+import           Network.MPD.Core (MonadMPD, MPDError(Unexpected)) +import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.UTF8 as UTF8+ -- | Builds a 'Count' instance from an assoc. list.-parseCount :: [String] -> Either String Count+parseCount :: [ByteString] -> Either String Count parseCount = foldM f defaultCount . toAssocList-        where f :: Count -> (String, String) -> Either String Count+        where f :: Count -> (ByteString, ByteString) -> Either String Count               f a ("songs", x)    = return $ parse parseNum                                     (\x' -> a { cSongs = x'}) a x               f a ("playtime", x) = return $ parse parseNum@@ -30,19 +33,19 @@               f _ x               = Left $ show x  -- | Builds a list of 'Device' instances from an assoc. list-parseOutputs :: [String] -> Either String [Device]+parseOutputs :: [ByteString] -> Either String [Device] parseOutputs = mapM (foldM f defaultDevice)-             . splitGroups [("outputid",id)]+             . splitGroups ["outputid"]              . 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 ("outputname", x)    = return a { dOutputName = UTF8.toString 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 :: [ByteString] -> Either String Stats parseStats = foldM f defaultStats . toAssocList     where         f a ("artists", x)     = return $ parse parseNum@@ -61,11 +64,18 @@                                  (\x' -> a { stsDbUpdate = x' }) a x         f _ x = fail $ show x +parseMaybeSong :: [(ByteString, ByteString)] -> Either String (Maybe Song)+parseMaybeSong xs | null xs   = Right Nothing+                  | otherwise = Just `fmap` parseSong xs+ -- | Builds a 'Song' instance from an assoc. list.-parseSong :: [(String, String)] -> Either String Song-parseSong xs = foldM f defaultSong xs+parseSong :: [(ByteString, ByteString)] -> Either String Song+parseSong xs = case xs of+    ("file", path):ys -> foldM f (defaultSong $ Path path) ys+    _ -> Left "Got a song without a file path! This indicates a bug in either libmpd-haskell or MPD itself!"+     where-        f :: Song -> (String, String) -> Either String Song+        f :: Song -> (ByteString, ByteString) -> Either String Song         f s ("Last-Modified", v) =             return s { sgLastModified = parseIso8601 v }         f s ("Time", v) =@@ -77,9 +87,7 @@                                   (\v' -> s { sgIndex = Just v' }) s v)                   (const $ return s)                   (sgIndex s)-        f s ("file", v) =-            return s { sgFilePath = v }-        f s (k, v) = return . maybe s (\m -> sgAddTag m v s) $+        f s (k, v) = return . maybe s (\m -> sgAddTag m (Value v) s) $                      readMeta k          -- Custom-made Read instance@@ -98,7 +106,7 @@         readMeta _ = Nothing  -- | Builds a 'Status' instance from an assoc. list.-parseStatus :: [String] -> Either String Status+parseStatus :: [ByteString] -> Either String Status parseStatus = foldM f defaultStatus . toAssocList     where f a ("state", x)               = return $ parse state     (\x' -> a { stState = x' }) a x@@ -133,7 +141,7 @@           f a ("updating_db", x)               = return $ parse parseNum  (\x' -> a { stUpdatingDb = x' }) a x           f a ("error", x)-              = return a { stError = Just x }+              = return a { stError = Just (UTF8.toString x) }           f a ("single", x)               = return $ parse parseBool (\x' -> a { stSingle = x' }) a x           f a ("consume", x)@@ -164,12 +172,12 @@ -- | 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 :: (ByteString -> Maybe a) -> (a -> b) -> b -> ByteString -> 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 :: (ByteString -> Maybe a) -> (ByteString, ByteString) -> Maybe (a, a) pair p (x, y) = case (p x, p y) of                     (Just a, Just b) -> Just (a, b)                     _                -> Nothing

@@ -8,10 +8,10 @@  module Network.MPD.Commands.Query (Query, (=?), (<&>), anything) where -import Network.MPD.Commands.Arg-import Network.MPD.Commands.Types+import           Network.MPD.Commands.Arg+import           Network.MPD.Commands.Types -import Data.Monoid+import           Data.Monoid  -- | An interface for creating MPD queries. --@@ -28,10 +28,10 @@ newtype Query = Query [Match] deriving Show  -- A single query clause, comprising a metadata key and a desired value.-data Match = Match Metadata String+data Match = Match Metadata Value  instance Show Match where-    show (Match meta query) = show meta ++ " \"" ++ query ++ "\""+    show (Match meta query) = show meta ++ " \"" ++ toString query ++ "\""     showList xs _ = unwords $ map show xs  instance Monoid Query where@@ -47,7 +47,7 @@ anything = mempty  -- | Create a query.-(=?) :: Metadata -> String -> Query+(=?) :: Metadata -> Value -> Query m =? s = Query [Match m s]  -- | Combine queries.

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} -- | Module    : Network.MPD.Commands.Types -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)@@ -8,23 +9,61 @@  module Network.MPD.Commands.Types where -import Network.MPD.Commands.Arg (MPDArg(prep), Args(Args))+import           Network.MPD.Commands.Arg (MPDArg(prep), Args(Args))  import qualified Data.Map as M-import Data.Time.Clock (UTCTime)+import           Data.Time.Clock (UTCTime)+import           Data.String -type Artist       = String-type Album        = String-type Title        = String+import           Data.Text   (Text)+import qualified Data.Text.Encoding as Text+import           Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as UTF8 +-- The purpose of this class is to allow users to choose the optimal+-- representation of response values.+-- | A type class for values that can be converted to `String`s.+class ToString a where++  -- | Convert given value to `String`.+  toString :: a -> String++  -- | Convert given value to `Text`.+  toText   :: a -> Text++  -- | Convert given value an UTF-8 encoded `ByteString`.+  toUtf8   :: a -> ByteString++type Artist = Value+type Album  = Value+type Title  = Value+ -- | Used for commands which require a playlist name. -- If empty, the current playlist is used.-type PlaylistName = String+newtype PlaylistName = PlaylistName ByteString+  deriving (Eq, Show, MPDArg) +instance ToString PlaylistName where+  toString (PlaylistName x) = UTF8.toString x+  toText   (PlaylistName x) = Text.decodeUtf8 x+  toUtf8   (PlaylistName x) = x++instance IsString PlaylistName where+  fromString = PlaylistName . UTF8.fromString+ -- | Used for commands which require a path within the database. -- If empty, the root path is used.-type Path         = String+newtype Path = Path ByteString+  deriving (Eq, Show, MPDArg) +instance ToString Path where+  toString (Path x) = UTF8.toString x+  toText   (Path x) = Text.decodeUtf8 x+  toUtf8   (Path x) = x++instance IsString Path where+  fromString = Path . UTF8.fromString+ -- | Available metadata types\/scope modifiers, used for searching the -- database for entries with certain metadata values. data Metadata = Artist@@ -51,6 +90,18 @@  instance MPDArg Metadata +-- | A metadata value.+newtype Value = Value ByteString+  deriving (Eq, Show, MPDArg)++instance ToString Value where+  toString (Value x) = UTF8.toString x+  toText   (Value x) = Text.decodeUtf8 x+  toUtf8   (Value x) = x++instance IsString Value where+  fromString = Value . UTF8.fromString+ -- | Object types. data ObjectType = SongObj     deriving (Eq, Show)@@ -109,6 +160,13 @@ defaultCount :: Count defaultCount = Count { cSongs = 0, cPlaytime = 0 } +-- | Result of the lsInfo operation+data LsResult+    = LsDirectory Path        -- ^ Directory+    | LsSong Song             -- ^ Song+    | LsPlaylist PlaylistName -- ^ Playlist+      deriving (Eq, Show)+ -- | Represents an output device. data Device =     Device { dOutputID      :: Int    -- ^ Output's ID number@@ -123,9 +181,9 @@  -- | Represents a single song item. data Song = Song-         { sgFilePath     :: String+         { sgFilePath     :: Path          -- | Map of available tags (multiple occurences of one tag type allowed)-         , sgTags         :: M.Map Metadata [String]+         , sgTags         :: M.Map Metadata [Value]          -- | Last modification date          , sgLastModified :: Maybe UTCTime          -- | Length of the song in seconds@@ -143,16 +201,16 @@     prep (Id x) = prep x  -- | Get list of specific tag type-sgGetTag :: Metadata -> Song -> Maybe [String]+sgGetTag :: Metadata -> Song -> Maybe [Value] sgGetTag meta s = M.lookup meta $ sgTags s  -- | Add metadata tag value.-sgAddTag :: Metadata -> String -> Song -> Song+sgAddTag :: Metadata -> Value -> Song -> Song sgAddTag meta value s = s { sgTags = M.insertWith' (++) meta [value] (sgTags s) } -defaultSong :: Song-defaultSong =-    Song { sgFilePath = "", sgTags = M.empty, sgLastModified = Nothing+defaultSong :: Path -> Song+defaultSong path =+    Song { sgFilePath = path, sgTags = M.empty, sgLastModified = Nothing          , sgLength = 0, sgId = Nothing, sgIndex = Nothing }  -- | Container for database statistics.

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | Module    : Network.MPD.Commands.Util -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)@@ -8,65 +9,61 @@  module Network.MPD.Commands.Util where -import Network.MPD.Commands.Parse-import Network.MPD.Commands.Types-import Network.MPD.Core-import Network.MPD.Util+import           Network.MPD.Commands.Parse+import           Network.MPD.Commands.Types+import           Network.MPD.Core+import           Network.MPD.Util -import Control.Monad.Error-import Data.List (intersperse)-import Data.Maybe (mapMaybe)+import           Control.Monad.Error+import           Data.List (intersperse)+import           Data.Maybe (mapMaybe) +import           Data.ByteString.Char8 (ByteString)+ -- 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 :: MonadMPD m => [String] -> m [ByteString] 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 :: MonadMPD m => [ByteString] -> m [ByteString] 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 :: MonadMPD m => String -> m [ByteString] getResponse1 x = getResponse x >>= failOnEmpty  -- Run 'toAssocList' and return only the values.-takeValues :: [String] -> [String]+takeValues :: [ByteString] -> [ByteString] 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+takeEntries :: MonadMPD m => [ByteString] -> m [LsResult]+takeEntries = mapM toEntry . splitGroups groupHeads . toAssocList     where-        toEntry xs@(("file",_):_)   = liftM SongEntry $ runParser parseSong xs-        toEntry (("directory",d):_) = return $ DirEntry d-        toEntry (("playlist",pl):_) = return $ PLEntry  pl+        toEntry xs@(("file",_):_)   = LsSong `liftM` runParser parseSong xs+        toEntry (("directory",d):_) = (return . LsDirectory . Path) d+        toEntry (("playlist",pl):_) = (return . LsPlaylist . PlaylistName) pl         toEntry _ = error "takeEntries: splitGroups is broken"-        wrappers = [("file",id), ("directory",id), ("playlist",id)]+        groupHeads = ["file", "directory", "playlist"]  -- Extract a subset of songs, directories, and playlists.-extractEntries :: (Song -> Maybe a, String -> Maybe a, String -> Maybe a)-               -> [EntryType] -> [a]+extractEntries :: (Song -> Maybe a, PlaylistName -> Maybe a, Path -> Maybe a)+               -> [LsResult] -> [a] extractEntries (fSong,fPlayList,fDir) = mapMaybe f     where-        f (SongEntry s) = fSong s-        f (PLEntry pl)  = fPlayList pl-        f (DirEntry d)  = fDir d+        f (LsSong s) = fSong s+        f (LsPlaylist pl)  = fPlayList pl+        f (LsDirectory d)  = fDir d  -- Build a list of song instances from a response.-takeSongs :: MonadMPD m => [String] -> m [Song]+takeSongs :: MonadMPD m => [ByteString] -> m [Song] takeSongs = mapM (runParser parseSong)-          . splitGroups [("file",id)]+          . splitGroups ["file"]           . toAssocList

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Module    : Network.MPD.Core -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010@@ -20,24 +21,30 @@     getResponse, kill,     ) where -import Network.MPD.Util-import Network.MPD.Core.Class-import Network.MPD.Core.Error+import           Network.MPD.Util+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(..), modify, get, evalStateT)+import           Data.Char (isDigit)+import           Control.Applicative (Applicative(..), (<$>), (<*))+import           Control.Exception hiding (handle)+import           Control.Monad (ap, unless)+import           Control.Monad.Error (ErrorT(..), MonadError(..))+import           Control.Monad.Reader (ReaderT(..), ask)+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           Network (PortID(..), withSocketsDo, connectTo)+import           System.IO (Handle, hPutStrLn, hReady, hClose, hFlush)+import           System.IO.Error (isEOFError) import qualified System.IO.UTF8 as U-import Text.Printf (printf)+import           Text.Printf (printf) +import qualified Prelude+import           Prelude hiding (break, catch, drop, dropWhile, read)+import           Data.ByteString.Char8 (ByteString, isPrefixOf, break, drop, dropWhile)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.UTF8 as UTF8+ -- -- Data types. --@@ -106,13 +113,12 @@     where         safeConnectTo host@('/':_) _ =             (Just <$> connectTo "" (UnixSocket host))-            `catch` const (return Nothing)+            `catch` (\(_ :: SomeException) -> return Nothing)         safeConnectTo host port =             (Just <$> connectTo host (PortNumber $ fromInteger port))-            `catch` const (return Nothing)-+            `catch` (\(_ :: SomeException) -> return Nothing)         checkConn = do-            [msg] <- lines <$> send ""+            [msg] <- send ""             if "OK MPD" `isPrefixOf` msg                 then MPD $ checkVersion $ parseVersion msg                 else return False@@ -149,7 +155,7 @@             | isEOFError err = result             | otherwise      = ioError err -mpdSend :: String -> MPD String+mpdSend :: String -> MPD [ByteString] mpdSend str = send' `catchError` handler     where         handler TimedOut = mpdOpen >> send'@@ -167,10 +173,11 @@                                       else liftIO (ioError err))                            return +        getLines :: Handle -> [ByteString] -> IO [ByteString]         getLines handle acc = do-            l <- U.hGetLine handle+            l <- B.hGetLine handle             if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l-                then return . unlines $ reverse (l:acc)+                then (return . reverse) (l:acc)                 else getLines handle (l:acc)  @@ -188,7 +195,7 @@         cleanup e = if e == TimedOut then close else throwError e  -- | Send a command to the MPD server and return the result.-getResponse :: (MonadMPD m) => String -> m [String]+getResponse :: (MonadMPD m) => String -> m [ByteString] getResponse cmd = (send cmd >>= parseResponse) `catchError` sendpw     where         sendpw e@(ACK Auth _) = do@@ -200,17 +207,17 @@             throwError e  -- Consume response and return a Response.-parseResponse :: (MonadError MPDError m) => String -> m [String]-parseResponse s+parseResponse :: (MonadError MPDError m) => [ByteString] -> m [ByteString]+parseResponse xs     | null xs                    = throwError $ NoMPD-    | "ACK" `isPrefixOf` head xs = throwError $ parseAck s+    | "ACK" `isPrefixOf` x       = throwError $ parseAck x     | otherwise                  = return $ Prelude.takeWhile ("OK" /=) xs     where-        xs = lines s+        x = head xs  -- Turn MPD ACK into the corresponding 'MPDError'-parseAck :: String -> MPDError-parseAck s = ACK ack msg+parseAck :: ByteString -> MPDError+parseAck s = ACK ack (UTF8.toString msg)     where         ack = case code of                 2  -> InvalidArgument@@ -230,7 +237,7 @@ -- 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 -> (Int, String, String)+splitAck :: ByteString -> (Int, ByteString, ByteString) splitAck s = (read code, cmd, msg)     where         (code, notCode) = between '[' '@' s

@@ -10,11 +10,12 @@  module Network.MPD.Core.Class where -import System.IO (Handle)+import           System.IO (Handle)+import           Data.ByteString (ByteString) -import Network.MPD.Core.Error (MPDError)+import           Network.MPD.Core.Error (MPDError) -import Control.Monad.Error (MonadError)+import           Control.Monad.Error (MonadError)  type Password = String @@ -26,13 +27,13 @@     -- | Close the connection.     close :: m ()     -- | Send a string to the server and return its response.-    send  :: String -> m String+    send  :: String -> m [ByteString]     -- | 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 ()+    setPassword :: Password -> m ()     -- | Get MPD protocol version     getVersion :: m (Int, Int, Int)

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveDataTypeable #-}+ -- | Module    : Network.MPD.Core.Error -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)@@ -8,7 +10,9 @@  module Network.MPD.Core.Error where -import Control.Monad.Error (Error(..))+import           Control.Exception+import           Control.Monad.Error (Error(..))+import           Data.Typeable  -- | The MPDError type is used to signal errors, both from the MPD and -- otherwise.@@ -20,7 +24,9 @@               | Custom String      -- ^ Used for misc. errors               | ACK ACKType String -- ^ ACK type and a message from the                                    --   server-                deriving Eq+                deriving (Eq, Typeable)++instance Exception MPDError  instance Show MPDError where     show NoMPD          = "Could not connect to MPD"

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | Module    : Network.MPD.Util -- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 -- License     : LGPL (see LICENSE)@@ -9,28 +10,41 @@ module Network.MPD.Util (     parseDate, parseIso8601, formatIso8601, parseNum, parseFrac,     parseBool, showBool, breakChar, parseTriple,-    toAssoc, toAssocList, splitGroups+    toAssoc, toAssocList, splitGroups, read     ) where -import Data.Char (isDigit)-import Data.Maybe (fromMaybe)-import Data.Time.Format (ParseTime, parseTime, FormatTime, formatTime)-import System.Locale (defaultTimeLocale)+import           Data.Char (isDigit)+import           Data.Time.Format (ParseTime, parseTime, FormatTime, formatTime)+import           System.Locale (defaultTimeLocale) +import qualified Prelude+import           Prelude hiding        (break, take, drop, takeWhile, dropWhile, read, reads)+import           Data.ByteString.Char8 (break, take, drop, takeWhile, dropWhile, ByteString)+import qualified Data.ByteString.UTF8 as UTF8+import           Data.String++-- | Like Prelude.read, but works with ByteString.+read :: Read a => ByteString -> a+read = Prelude.read . UTF8.toString++-- | Like Prelude.reads, but works with ByteString.+reads :: Read a => ByteString -> [(a, String)]+reads = Prelude.reads . UTF8.toString+ -- Break a string by character, removing the separator.-breakChar :: Char -> String -> (String, String)+breakChar :: Char -> ByteString -> (ByteString, ByteString) breakChar c s = let (x, y) = break (== c) s in (x, drop 1 y)  -- XXX: need a more robust date parser. -- Parse a date value. -- > parseDate "2008" = Just 2008 -- > parseDate "2008-03-01" = Just 2008-parseDate :: String -> Maybe Int+parseDate :: ByteString -> Maybe Int parseDate = parseNum . takeWhile isDigit  -- Parse date in iso 8601 format-parseIso8601 :: (ParseTime t) => String -> Maybe t-parseIso8601 = parseTime defaultTimeLocale iso8601Format+parseIso8601 :: (ParseTime t) => ByteString -> Maybe t+parseIso8601 = parseTime defaultTimeLocale iso8601Format . UTF8.toString  formatIso8601 :: FormatTime t => t -> String formatIso8601 = formatTime defaultTimeLocale iso8601Format@@ -39,34 +53,35 @@ iso8601Format = "%FT%TZ"  -- Parse a positive or negative integer value, returning 'Nothing' on failure.-parseNum :: (Read a, Integral a) => String -> Maybe a+parseNum :: (Read a, Integral a) => ByteString -> 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 :: (Fractional a, Read a) => ByteString -> Maybe a parseFrac s =     case s of-        "nan"  -> return $ read "NaN"-        "inf"  -> return $ read "Infinity"-        "-inf" -> return $ read "-Infinity"+        "nan"  -> return $ Prelude.read "NaN"+        "inf"  -> return $ Prelude.read "Infinity"+        "-inf" -> return $ Prelude.read "-Infinity"         _      -> do [(x, "")] <- return $ reads s                      return x  -- Inverts 'parseBool'.-showBool :: Bool -> String+showBool :: IsString a => Bool -> a+-- FIXME: can we change the type to (Bool -> ByteString)? showBool x = if x then "1" else "0"  -- Parse a boolean response value.-parseBool :: String -> Maybe Bool+parseBool :: ByteString -> Maybe Bool parseBool s = case take 1 s of                   "1" -> Just True                   "0" -> Just False                   _   -> Nothing  -- Break a string into triple.-parseTriple :: Char -> (String -> Maybe a) -> String -> Maybe (a, a, a)+parseTriple :: Char -> (ByteString -> Maybe a) -> ByteString -> 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@@ -74,29 +89,25 @@         _                        -> Nothing  -- Break a string into an key-value pair, separating at the first ':'.-toAssoc :: String -> (String, String)+toAssoc :: ByteString -> (ByteString, ByteString) toAssoc x = (k, dropWhile (== ' ') $ drop 1 v)     where         (k,v) = break (== ':') x -toAssocList :: [String] -> [(String, String)]+toAssocList :: [ByteString] -> [(ByteString, ByteString)] 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--- first parameter. When a cycle finishes all of its pairs are passed--- to the key's associated function (the second tuple component) and--- the result appended to the resulting list.------ > splitGroups [(1,id),(5,id)]--- >             [(1,'a'),(2,'b'),(5,'c'),(6,'d'),(1,'z'),(2,'y'),(3,'x')] ==--- >     [[(1,'a'),(2,'b')],[(5,'c'),(6,'d')],[(1,'z'),(2,'y'),(3,'x')]]-splitGroups :: Eq a => [(a,[(a,b)] -> c)] -> [(a, b)] -> [c]-splitGroups [] _ = []-splitGroups _ [] = []-splitGroups wrappers (x@(k,_):xs) =-    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+-- Takes an association list with recurring keys and groups each cycle of keys+-- with their values together.  There can be several keys that begin cycles,+-- (the elements of the first parameter).+splitGroups :: [ByteString] -> [(ByteString, ByteString)] -> [[(ByteString, ByteString)]]+splitGroups groupHeads = go+  where+    go []     = []+    go (x:xs) =+      let+        (ys, zs) = Prelude.break isGroupHead xs+      in+        (x:ys) : go zs++    isGroupHead = (`elem` groupHeads) . fst

@@ -27,7 +27,7 @@ ## Running tests To run the libmpd testsuite, do: -`./tests/run-tests.lhs`+`cabal configure --enable-tests && cabal build && cabal test`  ## Compiler support We try to support the two last major versions of GHC, but only the latest@@ -42,9 +42,10 @@ ## Usage With GHCi: +    > :set -XOverloadedStrings     > import Network.MPD     > withMPD $ lsInfo ""-    Right [Left "Tool", Left "Tom Waits",...]+    Right [LsDirectory "Tool", LsDirectory "Tom Waits",...]     > withMPD $ add "Tom Waits/Big Time"     Right ["Tom Waits/Big Time/01 - 16 Shells from a Thirty-Ought-Six.mp3",...] @@ -84,7 +85,7 @@ [bug tracker]: http://github.com/joachifm/libmpd-haskell/issues [GitHub]: http://www.github.com [repository]: http://www.github.com/joachifm/libmpd-haskell-[API documentation]: http://hackage.haskell.org/packages/archive/libmpd/0.7.0/doc/html/Network-MPD.html+[API documentation]: http://hackage.haskell.org/packages/archive/libmpd/0.7.2/doc/html/Network-MPD.html [Protocol reference]: http://www.musicpd.org/doc/protocol/ [Using GitHub]: http://help.github.com @@ -105,3 +106,5 @@ Simon Hengel \<sol@typeful.net\>  Daniel Wagner \<daniel@wagner-home.com\>++nandykins

@@ -1,76 +1,96 @@ Name:               libmpd-Version:            0.7.2+Version:            0.8.0+Synopsis:           An MPD client library.+Description:        A client library for MPD, the Music Player Daemon+                    (<http://www.musicpd.org/>).+Category:           Network, Sound+ License:            LGPL License-file:       LICENSE Copyright:          Ben Sinclair 2005-2009, Joachim Fasting 2012 Author:             Ben Sinclair+ Maintainer:         Joachim Fasting <joachim.fasting@gmail.com> Stability:          beta Homepage:           http://github.com/joachifm/libmpd-haskell Bug-reports:        http://github.com/joachifm/libmpd-haskell/issues-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 == 7.0.2 Build-Type:         Simple-Cabal-Version:      >= 1.6-Extra-Source-Files: README.md NEWS-                    tests/Arbitrary.hs tests/Commands.hs-                    tests/Displayable.hs tests/Properties.hs-                    tests/StringConn.hs tests/Main.hs-                    tests/coverage.lhs tests/run-tests.lhs--flag test-    Description: Build test driver-    Default: False+Cabal-Version:      >= 1.10 -flag coverage-    Description: Build driver with hpc instrumentation-    Default: False+Extra-Source-Files:+    README.md+    NEWS+    tests/Arbitrary.hs+    tests/CommandSpec.hs+    tests/Defaults.hs+    tests/EnvSpec.hs+    tests/ParserSpec.hs+    tests/StringConn.hs+    tests/TestUtil.hs+    tests/Unparse.hs+    tests/UtilSpec.hs+    tests/Main.hs  Source-Repository head     type:       git-    location:   git://github.com/joachifm/libmpd-haskell.git+    location:   https://github.com/joachifm/libmpd-haskell  Library-    Build-Depends:      base >= 4 && < 5,-                        mtl >= 2.0 && < 2.1,-                        network >= 2.1 && < 2.4,-                        filepath >= 1.0 && < 1.4,-                        utf8-string >= 0.3.1 && < 0.4,-                        old-locale >= 1.0 && < 2.0,-                        time >= 1.1 && < 2.0,-                        containers >= 0.3 && < 0.5-    Exposed-Modules:    Network.MPD, Network.MPD.Commands.Extensions,-                        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.Commands.Util,-                        Network.MPD.Util+    Default-Language:   Haskell2010 -    ghc-prof-options:   -auto-all -prof+    Build-Depends:+        base >= 4 && < 5+      , mtl >= 2.0 && < 2.2+      , network >= 2.1 && < 2.4+      , filepath >= 1.0 && < 1.4+      , utf8-string >= 0.3.1 && < 0.4+      , old-locale >= 1.0 && < 2.0+      , time >= 1.1 && < 2.0+      , containers >= 0.3 && < 0.5+      , bytestring == 0.9.*+      , text == 0.11.* -    if flag(test)-        Buildable: False+    Exposed-Modules:+        Network.MPD+      , Network.MPD.Commands.Extensions+      , Network.MPD.Core -Executable test-    Hs-Source-Dirs:     . tests-    Main-Is:            tests/Main.hs-    Build-Depends:      base ==4.*, network, mtl, filepath, utf8-string-    -- Dependencies that are only required by the test-suite:-    if flag(test)-        Build-Depends: QuickCheck >= 2.1, time, containers-    ghc-options:        -Wall -fno-warn-warnings-deprecations-                        -fno-warn-type-defaults+    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.Commands.Util+      , Network.MPD.Util -    if flag(coverage)-        ghc-options:    -fhpc+    ghc-prof-options:   -auto-all -prof+    ghc-options:        -Wall -    if !flag(test)-        Buildable: False+Test-Suite specs+    type:               exitcode-stdio-1.0+    Default-Language:   Haskell2010+    Main-Is:            tests/Main.hs+    Hs-Source-Dirs:     . tests+    cpp-options:        -DTEST+    ghc-options:        -fno-warn-missing-signatures++    Build-Depends:+        base+      , utf8-string+      , bytestring+      , old-locale+      , network+      , mtl+      , text+      , containers+      , data-default+      , unix+      , time+      , QuickCheck >= 2.1+      , hspec+      , HUnit

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ {-# OPTIONS_GHC -Wwarn -fno-warn-orphans -fno-warn-missing-methods -XFlexibleInstances #-}  -- | This module contains Arbitrary instances for various types.@@ -10,16 +12,22 @@     , positive, field     ) where -import Control.Applicative ((<$>), (<*>))-import Control.Monad (liftM2, liftM3, replicateM)-import Data.Char (isSpace)-import Data.List (intersperse)+import           Control.Applicative ((<$>), (<*>))+import           Control.Monad (liftM2, liftM3, replicateM)+import           Data.Char (isSpace)+import           Data.List (intersperse) import qualified Data.Map as M-import Data.Time-import Test.QuickCheck+import           Data.Time+import           Test.QuickCheck -import Network.MPD.Commands.Types+import           Network.MPD.Commands.Types +import           Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as UTF8++instance Arbitrary ByteString where+  arbitrary = UTF8.fromString <$> arbitrary+ -- No longer provided by QuickCheck 2 two :: Monad m => m a -> m (a, a) two m = liftM2 (,) m m@@ -39,14 +47,20 @@ field :: Gen String field = (filter (/= '\n') . dropWhile isSpace) <$> arbitrary +fieldBS :: Gen ByteString+fieldBS = UTF8.fromString <$> field+ -- Orphan instances for built-in types-instance Arbitrary (M.Map Metadata [String]) where+instance Arbitrary (M.Map Metadata [Value]) where     arbitrary = do         size <- choose (1, 1000)-        vals <- replicateM size (listOf1 field)+        vals <- replicateM size (listOf1 arbitrary)         keys <- replicateM size arbitrary         return $ M.fromList (zip keys vals) +instance Arbitrary Value where+    arbitrary = Value <$> fieldBS+ instance Arbitrary Day where     arbitrary = ModifiedJulianDay <$> arbitrary @@ -58,38 +72,40 @@  -- an assoc. string is a string of the form "key: value", followed by -- the key and value separately.-data AssocString = AS String String String+data AssocString = AS ByteString ByteString ByteString  instance Show AssocString where-    show (AS str _ _) = str+    show (AS str _ _) = UTF8.toString str  instance Arbitrary AssocString where     arbitrary = do         key <- filter    (/= ':') <$> arbitrary         val <- dropWhile (== ' ') <$> arbitrary-        return $ AS (key ++ ": " ++ val) key val+        return $ AS (UTF8.fromString (key ++ ": " ++ val))+                    (UTF8.fromString key)+                    (UTF8.fromString val) -newtype BoolString = BS String+newtype BoolString = BS ByteString     deriving Show  instance Arbitrary BoolString where-    arbitrary = BS `fmap` elements ["1", "0"]+    arbitrary = BS <$> elements ["1", "0"]  -- Simple date representation, like "2004" and "1998".-newtype YearString = YS String+newtype YearString = YS ByteString     deriving Show  instance Arbitrary YearString where-    arbitrary = YS . show <$> (positive :: Gen Integer)+    arbitrary = YS . UTF8.fromString . show <$> (positive :: Gen Integer)  -- Complex date representations, like "2004-20-30".-newtype DateString = DS String+newtype DateString = DS ByteString     deriving Show  instance Arbitrary DateString where     arbitrary = do         (y,m,d) <- three (positive :: Gen Integer)-        return . DS . concat . intersperse "-" $ map show [y,m,d]+        return . DS . UTF8.fromString . concat . intersperse "-" $ map show [y,m,d]  instance Arbitrary Count where     arbitrary = liftM2 Count arbitrary arbitrary@@ -101,12 +117,15 @@     arbitrary = Id <$> arbitrary  instance Arbitrary Song where-    arbitrary = Song <$> field+    arbitrary = Song <$> arbitrary                      <*> arbitrary                      <*> possibly arbitrary                      <*> positive                      <*> possibly arbitrary                      <*> possibly positive++instance Arbitrary Path where+    arbitrary = Path <$> fieldBS  instance Arbitrary Stats where     arbitrary = Stats <$> positive <*> positive <*> positive <*> positive

@@ -0,0 +1,435 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- This module provides a way of verifying that the interface to the MPD+-- commands is correct. It does so by capturing the data flow between the+-- command and a dummy socket, checking the captured data against a set of+-- predefined values that are known to be correct. Of course, this does not+-- verify that the external behaviour is correct, it's simply a way of+-- catching silly mistakes and subtle bugs in the interface itself, without+-- having to actually send any requests to a real server.++module CommandSpec (main, spec) where++import           Arbitrary ()+import           Defaults ()+import           StringConn+import           TestUtil+import           Unparse++import           Test.Hspec.Monadic+import           Test.Hspec.HUnit ()++import           Network.MPD.Commands+import           Network.MPD.Commands.Extensions+import           Network.MPD.Core (MPDError(..), ACKType(..))++import           Prelude hiding (repeat)+import           Data.Default (Default(def))++main :: IO ()+main = hspecX spec++spec :: Specs+spec = do+    -- * Admin commands+    describe "enableOutput" $ do+        it "sends an enableoutput command" $ testEnableOutput+    +    describe "disableOutput" $ do+        it "sends an disableoutput command" $ testDisableOutput++    describe "outputs" $ do+        it "lists available outputs" $ testOutputs++    describe "update" $ do+        it "updates entire collection by default" $ testUpdate0+        it "can update single paths" $ testUpdate1+        it "can update multiple paths" $ testUpdateMany++    -- * Database commands++    describe "list" $ do+        it "returns a list of values for a given metadata type" $ testListAny+        it "can constrain listing to entries matching a query" $ testListQuery++    describe "listAll" $ do+        it "lists everything" $ testListAll++    describe "lsInfo" $ do+       it "lists information" $ testLsInfo++    describe "listAllInfo" $ do+        it "lists information" $ testListAllInfo++    describe "count" $ do+        it "returns a count of items matching a query" $ testCount++    -- * Playlist commands++    describe "add" $ do+        it "adds a url to the current playlist" $ testAdd++    describe "add_" $ do+        it "adds a url to current playlist, returning nothing" $ testAdd_++    describe "playlistAdd" $ do+        it "adds a url to a stored playlist" $ testPlaylistAdd++    describe "addId" $ do+        it "adds a url to a stored playlist, returning the pl index" $ testAddId++    describe "playlistClear" $ do+        it "clears a stored playlist" $ testPlaylistClear++    describe "clear" $ do+        it "clears current play list" $ testClear++    describe "plChangesPosid" $ do+        it "does something ..." $ testPlChangesPosId+        it "fails on weird input" $ testPlChangesPosIdWeird++    -- XXX: this is ill-defined+    {-+    describe "currentSong" $ do+        it "can handle cases where playback is stopped" $ testCurrentSong+     -}++    describe "playlistDelete" $ do+        it "deletes an item from a stored playlist" $ testPlaylistDelete++    describe "load" $ do+        it "loads a stored playlist" $ testLoad++    describe "playlistMove" $ do+        it "moves an item within a stored playlist" $ testMove2+    describe "rm" $ do+        it "deletes a stored playlist" $ testRm+    describe "rename" $ do+        it "renames a stored playlist" $ testRename+    describe "save" $ do+        it "creates a stored playlist" $ testSave+    describe "shuffle" $ do+        it "enables shuffle mode" $ testShuffle+    describe "listPlaylist" $ do+        it "returns a listing of paths in a stored playlist" $ testListPlaylist++    -- * Playback commands++    describe "crossfade" $ do+        it "sets crossfade between songs" $ testCrossfade+    describe "play" $ do+        it "toggles playback" $ testPlay+    describe "pause" $ do+        it "pauses playback" $ testPause+    describe "stop" $ do+        it "stops playback" $ testStop+    describe "next" $ do+        it "starts playback of next song" $ testNext+    describe "previous" $ do+        it "play previous song" $ testPrevious+    describe "random" $ do+        it "toggles random playback" $ testRandom+    describe "repeat" $ do+        it "toggles repeating playback" $ testRepeat+    describe "setVolume" $ do+        it "sets playback volume" $ testSetVolume+    describe "consume" $ do+        it "toggles consume mode" $ testConsume+    describe "single" $ do+        it "toggles single mode" $ testSingle++    -- * Misc+    describe "clearError" $ do+        it "removes errors" $ testClearError+    describe "commands" $ do+        it "lists available commands" $ testCommands+    describe "notCommands" $ do+        it "lists unavailable commands" $ testNotCommands+    describe "tagTypes" $ do+        it "lists available tag types" $ testTagTypes+    describe "urlHandlers" $ do+        it "lists available url handlers" $ testUrlHandlers+    describe "password" $ do+        it "sends a password to the server" $ testPassword+        it "gives access to restricted commmands" $ testPasswordSucceeds+        it "returns failure on incorrect password" $ testPasswordFails+    describe "ping" $ do+        it "sends a ping command" $ testPing+    describe "stats" $ do+        it "gets database stats" $ testStats++    -- * Extensions+    +    describe "updateId" $ do+        it "returns the job id" $ do+            testUpdateId0+            testUpdateId1+    describe "toggle" $ do+        it "starts playback if paused" $ testTogglePlay+        it "stops playback if playing" $ testToggleStop+    describe "addMany" $ do+        it "adds multiple paths in one go" $ testAddMany0+        it "can also add to stored playlists" $ testAddMany1+    describe "volume" $ do+        it "adjusts volume relative to current volume" $ testVolume+    +cmd_ expect f     = cmd expect (Right ()) f +cmd expect resp f = testMPD expect resp "" f `shouldBe` Ok++--+-- Admin commands+--++testEnableOutput  = cmd_ [("enableoutput 1", Right "OK")] (enableOutput 1)+testDisableOutput = cmd_ [("disableoutput 1", Right "OK")] (disableOutput 1)++-- XXX: this should be generalized to arbitrary inputs+testOutputs = do+    let obj1 = def { dOutputName = "SoundCard0", dOutputEnabled = True }+        obj2 = def { dOutputName = "SoundCard1", dOutputID = 1 }+        resp = concatMap unparse [obj1, obj2] ++ "OK"+    cmd [("outputs", Right resp)] (Right [obj1, obj2]) outputs++testUpdate0 = cmd_ [("update", Right "updating_db: 1\nOK")] (update [])+testUpdate1 =+    cmd_ [("update \"foo\"", Right "updating_db: 1\nOK")] (update ["foo"])++testUpdateMany =+    cmd_ [("command_list_begin\nupdate \"foo\"\nupdate \"bar\"\ncommand_list_end", Right "updating_db: 1\nOK")]+         (update ["foo","bar"])++--+-- Database commands+--++-- XXX: generalize to arbitrary Metadata values+testListAny = cmd [("list Title", Right "Title: Foo\nTitle: Bar\nOK")]+                  (Right ["Foo", "Bar"])+                  (list Title anything)++testListQuery = cmd [("list Title Artist \"Muzz\"", Right "Title: Foo\nOK")]+                    (Right ["Foo"])+                    (list Title (Artist =? "Muzz"))++testListAll =+    cmd [("listall \"\"", Right "directory: FooBand\n\+                                \directory: FooBand/album1\n\+                                \file: FooBand/album1/01 - songA.ogg\n\+                                \file: FooBand/album1/02 - songB.ogg\nOK")]+        (Right ["FooBand/album1/01 - songA.ogg"+               ,"FooBand/album1/02 - songB.ogg"])+        (listAll "")++-- XXX: generalize to arbitrary input+testLsInfo = do+    let song = defaultSong "Bar.ogg"+    cmd [("lsinfo \"\"", Right $ "directory: Foo\n" ++ unparse song ++ "playlist: Quux\nOK")]+        (Right [LsDirectory "Foo", LsSong song, LsPlaylist "Quux"])+        (lsInfo "")++testListAllInfo =+    cmd [("listallinfo \"\"", Right "directory: Foo\ndirectory: Bar\nOK")]+        (Right [LsDirectory "Foo", LsDirectory "Bar"])+        (listAllInfo "")++-- XXX: generalize to arbitrary input+testCount = do+    let obj  = Count 1 60+        resp = unparse obj ++ "OK"+    cmd [("count Title \"Foo\"", Right resp)] (Right obj)+        (count (Title =? "Foo"))++--+-- Playlist commands+--++testAdd =+    cmd [("add \"foo\"", Right "OK"),+         ("listall \"foo\"", Right "file: Foo\nfile: Bar\nOK")]+        (Right ["Foo", "Bar"])+        (add "foo")++testAdd_ =+    cmd_ [("add \"foo\"", Right "OK")] (add_ "foo")++testPlaylistAdd =+    cmd_ [("playlistadd \"foo\" \"bar\"", Right "OK")]+         (playlistAdd_ "foo" "bar")++testAddId =+    cmd [("addid \"dir/Foo-Bar.ogg\"", Right "Id: 20\nOK")]+        (Right $ Id 20)+        (addId "dir/Foo-Bar.ogg" Nothing)++testPlaylistClear =+    cmd_ [("playlistclear \"foo\"", Right "OK")]+         (playlistClear "foo")++testClear =+    cmd_ [("clear", Right "OK")] clear++testPlChangesPosId =+    cmd [("plchangesposid 10", Right "OK")]+        (Right [])+        (plChangesPosId 10)++testPlChangesPosIdWeird =+    cmd [("plchangesposid 10", Right "cpos: foo\nId: bar\nOK")]+        (Left $ Unexpected "[(\"cpos\",\"foo\"),(\"Id\",\"bar\")]")+        (plChangesPosId 10)++-- XXX: this is ill-defined+{-+testCurrentSong = do+    let obj  = def { stState = Stopped, stPlaylistVersion = 253 }+        resp = unparse obj ++ "OK"+    cmd [("status", Right resp)] (Right Nothing) currentSong+-}++testPlaylistDelete =+    cmd_ [("playlistdelete \"foo\" 1", Right "OK")] (playlistDelete "foo" 1)++testLoad =+    cmd_ [("load \"foo\"", Right "OK")] (load "foo")++testMove2 = cmd_ [("playlistmove \"foo\" 1 2", Right "OK")] (playlistMove "foo" 1 2)++testRm = cmd_ [("rm \"foo\"", Right "OK")] (rm "foo")++testRename = cmd_ [("rename \"foo\" \"bar\"", Right "OK")] (rename "foo" "bar")++testSave = cmd_ [("save \"foo\"", Right "OK")] (save "foo")++testShuffle = cmd_ [("shuffle", Right "OK")] (shuffle Nothing)++testListPlaylist = cmd [("listplaylist \"foo\""+                         ,Right "file: dir/Foo-bar.ogg\n\+                                \file: dir/Quux-quuz.ogg\n\+                                \OK")]+                   (Right ["dir/Foo-bar.ogg", "dir/Quux-quuz.ogg"])+                   (listPlaylist "foo")++--+-- Playback commands+--++testCrossfade = cmd_ [("crossfade 0", Right "OK")] (crossfade 0)++testPlay = cmd_ [("play", Right "OK")] (play Nothing)++testPause = cmd_ [("pause 0", Right "OK")] (pause False)++testStop = cmd_ [("stop", Right "OK")] stop++testNext = cmd_ [("next", Right "OK")] next++testPrevious = cmd_ [("previous", Right "OK")] previous++testRandom = cmd_ [("random 0", Right "OK")] (random False)++testRepeat = cmd_ [("repeat 0", Right "OK")] (repeat False)++testSetVolume = cmd_ [("setvol 10", Right "OK")] (setVolume 10)++testConsume = cmd_ [("consume 1", Right "OK")] (consume True)++testSingle = cmd_ [("single 1", Right "OK")] (single True)++--+-- Miscellaneous commands+--++testClearError = cmd_ [("clearerror", Right "OK")] clearError++testCommands =+    cmd [("commands", Right "command: foo\ncommand: bar")]+        (Right ["foo", "bar"])+        commands++testNotCommands =+    cmd [("notcommands", Right "command: foo\ncommand: bar")]+         (Right ["foo", "bar"])+         notCommands++testTagTypes =+    cmd [("tagtypes", Right "tagtype: foo\ntagtype: bar")]+         (Right ["foo", "bar"])+         tagTypes++testUrlHandlers =+    cmd [("urlhandlers", Right "urlhandler: foo\nurlhandler: bar")]+         (Right ["foo", "bar"])+         urlHandlers++testPassword = cmd_ [("password foo", Right "OK")] (password "foo")++testPasswordSucceeds =+    testMPD convo expected_resp "foo" cmd_in `shouldBe` Ok+    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 [LsDirectory "/bar"]+        cmd_in = lsInfo "/"++testPasswordFails =+    testMPD convo expected_resp "foo" cmd_in `shouldBe` Ok+    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_in = play Nothing++testPing = cmd_ [("ping", Right "OK")] ping++testStats = cmd [("stats", Right resp)] (Right obj) stats+    where obj = def { stsArtists = 1, stsAlbums = 1, stsSongs =  1+                    , stsUptime = 100, stsPlaytime = 100, stsDbUpdate = 10+                    , stsDbPlaytime = 100 }+          resp = unparse obj ++ "OK"++--+-- Extensions\/shortcuts+--++testUpdateId0 = cmd [("update", Right "updating_db: 1")]+                (Right 1)+                (updateId [])++testUpdateId1 = cmd [("update \"foo\"", Right "updating_db: 1")]+                (Right 1)+                (updateId ["foo"])++testTogglePlay = cmd_+               [("status", Right resp)+               ,("pause 1", Right "OK")]+               toggle+    where resp = unparse def { stState = Playing }++testToggleStop = cmd_+                [("status", Right resp)+                ,("play", Right "OK")]+                toggle+    where resp = unparse def { stState = Stopped }++{- this overlaps with testToggleStop, no?+testTogglePause = cmd_+                [("status", Right resp)+                ,("play", Right "OK")]+                toggle+    where resp = unparse def { stState = Paused }+-}++testAddMany0 = cmd_ [("add \"bar\"", Right "OK")]+               (addMany "" ["bar"])++testAddMany1 = cmd_ [("playlistadd \"foo\" \"bar\"", Right "OK")]+               (addMany "foo" ["bar"])++testVolume = cmd_ [("status", Right st), ("setvol 90", Right "OK")] (volume (-10))+    where st = unparse def { stVolume = 100 }

@@ -1,613 +0,0 @@-{-# OPTIONS_GHC -Wwarn -fno-warn-missing-signatures #-}---- |--- This module provides a way of verifying that the interface to the MPD--- commands is correct. It does so by capturing the data flow between the--- command and a dummy socket, checking the captured data against a set of--- predefined values that are known to be correct. Of course, this does not--- verify that the external behaviour is correct, it's simply a way of--- catching silly mistakes and subtle bugs in the interface itself, without--- having to actually send any requests to a real server.--module Commands (main) where--import Arbitrary ()-import Displayable-import Network.MPD.Commands-import Network.MPD.Commands.Extensions-import Network.MPD.Core (MPDError(..), Response, ACKType(..))-import StringConn--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) -> printf "%-25s : " n >> f) tests-    where tests = [("enableOutput", testEnableOutput)-                  ,("disableOutput", testDisableOutput)-                  ,("outputs", testOutputs)-                  ,("update0", testUpdate0)-                  ,("update1", testUpdate1)-                  ,("updateMany", testUpdateMany)-{--                  ,("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)-                  ,("lsInfo", testLsInfo)-                  ,("listAllInfo", testListAllInfo)-{--                  ,("search", testSearch)--}-                  ,("count", testCount)-                  ,("add", testAdd)-                  ,("add_", testAdd_)-                  ,("add_ / playlist", testAdd_pl)-                  ,("addId", testAddId)-                  ,("clear / playlist", testClearPlaylist)-                  ,("clear / current", testClearCurrent)-                  ,("plChangesPosId 0", testPlChangesPosId_0)-                  {--                  ,("plChangesPosId 1", testPlChangesPosId_1)-                  -}-                  ,("plChangesPosId weird", testPlChangesPosId_Weird)-                  ,("currentSong(_)", testCurrentSongStopped)-                  {--                  ,("currentSong(>)", testCurrentSongPlaying)-                  -}-                  {--                  ,("delete0", testDelete0)-                  ,("delete1", testDelete1)-                  -}-                  ,("delete2", testDelete2)-                  ,("load", testLoad)-                  {--                  ,("move0", testMove0)-                  ,("move1", testMove1)-                  ,("move2", testMove2)-                  -}-                  ,("rm", testRm)-                  ,("rename", testRename)-                  ,("save", testSave)-                  {--                  ,("swap0", testSwap0)-                  ,("swap1", testSwap1)-                  -}-                  ,("shuffle", testShuffle)-{--                  ,("playlistInfo0", testPlaylistInfo0)--}-                  {--                  ,("playlistInfo / pos", testPlaylistInfoPos)-                  ,("playlistInfo / id", testPlaylistInfoId)-                  -}-{--                  ,("listPlaylistInfo", testListPlaylistInfo)--}-                  ,("listPlaylist", testListPlaylist)-                  {--                  ,("playlist", testPlaylist)-                  -}-{--                  ,("plchanges", testPlChanges)-                  ,("playlistFind", testPlaylistFind)-                  ,("playlistSearch", testPlaylistSearch)--}-                  ,("crossfade", testCrossfade)-                  ,("play", testPlay)-                  {--                  ,("play / pos", testPlayPos)-                  ,("play / id", testPlayId)-                  -}-                  ,("pause", testPause)-                  ,("stop", testStop)-                  ,("next", testNext)-                  ,("previous", testPrevious)-                  {--                  ,("seek / pos", testSeekPos)-                  ,("seek / id", testSeekId)-                  ,("seek / current", testSeekCur)-                  -}-                  ,("random", testRandom)-                  ,("repeat", testRepeat)-                  ,("setVolume", testSetVolume)-                  ,("volume", testVolume)-                  ,("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)-                  ,("updateId1", testUpdateId1)-                  ,("toggle / stop", testToggleStop)-                  ,("toggle / play", testTogglePlay)-                  ,("toggle / pause", testTogglePause)-                  ,("addMany0", testAddMany0)-                  ,("addMany1", testAddMany1)-                  {--                  ,("deleteMany1", testDeleteMany1)-                  -}-                  ]--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--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-----testEnableOutput = test_ [("enableoutput 1", Right "OK")] (enableOutput 1)--testDisableOutput = test_ [("disableoutput 1", Right "OK")] (disableOutput 1)--testOutputs =-    test [("outputs", Right resp)] (Right [obj1, obj2]) outputs-    where obj1 = empty { dOutputName = "SoundCard0", dOutputEnabled = True }-          obj2 = empty { dOutputName = "SoundCard1", dOutputID = 1 }-          resp = concatMap display [obj1, obj2] ++ "OK"--testUpdate0 = test_ [("update", Right "updating_db: 1\nOK")] (update [])--testUpdate1 =-    test_ [("update \"foo\"", Right "updating_db: 1\nOK")]-          (update ["foo"])--testUpdateMany =-    test_ [("command_list_begin\nupdate \"foo\"\nupdate \"bar\"\n\-            \command_list_end", Right "updating_db: 1\nOK")]-          (update ["foo","bar"])------- Database commands-----{--prop_find :: Song -> Metadata -> 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"-            -}--}--{- XXX: where did these go?-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 anything)--testListJust =-    test [("list Title Artist \"Muzz\"", Right "Title: Foo\nOK")]-         (Right ["Foo"])-         (list Title (Artist =? "Muzz"))--testListAll =-    test [("listall \"\"", Right "directory: FooBand\n\-                                 \directory: FooBand/album1\n\-                                 \file: FooBand/album1/01 - songA.ogg\n\-                                 \file: FooBand/album1/02 - songB.ogg\nOK")]-         (Right ["FooBand/album1/01 - songA.ogg"-                ,"FooBand/album1/02 - songB.ogg"])-         (listAll "")--testLsInfo =-    test [("lsinfo \"\"",-           Right $ "directory: Foo\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 "Foo", Left "Bar"])-         (listAllInfo "")--{--testSearch =-    test [("search Artist \"oo\"", Right resp)] (Right [obj])-         (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 (Title =? "Foo"))-    where obj = Count 1 60-          resp = display obj ++ "OK"------- Playlist commands-----testAdd =-    test [("add \"foo\"", Right "OK"),-          ("listall \"foo\"", Right "file: Foo\nfile: Bar\nOK")]-         (Right ["Foo", "Bar"])-         (add "foo")--testAdd_ = test_ [("add \"foo\"", Right "OK")] (add_ "foo")--testAdd_pl = test_ [("playlistadd \"foo\" \"bar\"", Right "OK")]-             (playlistAdd_ "foo" "bar")--testAddId =-    test [("addid \"dir/Foo-Bar.ogg\"", Right "Id: 20\nOK")]-         (Right $ Id 20)-         (addId "dir/Foo-Bar.ogg" Nothing)--testClearPlaylist = test_ [("playlistclear \"foo\"", Right "OK")]-                    (playlistClear "foo")--testClearCurrent = test_ [("clear", Right "OK")] clear--testPlChangesPosId_0 =-    test [("plchangesposid 10", Right "OK")]-         (Right [])-         (plChangesPosId 10)--{- XXX: port this?-testPlChangesPosId_1 =-    test [("plchangesposid 10", Right "cpos: 0\nId: 20\nOK")]-         (Right [(Pos 0, ID 20)])-         (plChangesPosId 10)--}--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 }-          resp = display obj ++ "OK"--{- XXX: port this-testCurrentSongPlaying =-    test [("status", Right resp2)-         ,("currentsong", Right resp1)]-         (Right $ Just song)-         (currentSong)-    where song = empty { sgArtist = "Foo", sgTitle = "Bar"-                       , sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60 }-          resp1 = display song--          estatus = empty { stVolume = 80, stPlaylistVersion = 252-                          , stPlaylistLength = 21, stSongPos = Just (Pos 20)-                          , stSongID = Just (ID 238), stTime = (158, 376)-                          , stBitrate = 192, stAudio = (44100, 16, 2)-                          , stState = Playing }-          resp2 = display estatus ++ "OK"--testDelete0 = test_ [("delete 1", Right "OK")] (delete (Pos 1))--testDelete1 = test_ [("deleteid 1", Right "OK")] (delete (ID 1))--}--testDelete2 = test_ [("playlistdelete \"foo\" 1", Right "OK")] (playlistDelete "foo" 1)--testLoad = test_ [("load \"foo\"", Right "OK")] (load "foo")--{- XXX: port this-testMove0 = test_ [("move 1 2", Right "OK")] (move (Pos 1) 2)--testMove1 = test_ [("moveid 1 2", Right "OK")] (move (ID 1) 2)--}--testMove2 = test_ [("playlistmove \"foo\" 1 2", Right "OK")] (playlistMove "foo" 1 2)--testRm = test_ [("rm \"foo\"", Right "OK")] (rm "foo")--testRename = test_ [("rename \"foo\" \"bar\"", Right "OK")] (rename "foo" "bar")--testSave = test_ [("save \"foo\"", Right "OK")] (save "foo")--{--testSwap0 = test_ [("swap 1 2", Right "OK")] (swap (Pos 1) (Pos 2))--testSwap1 = test_ [("swapid 1 2", Right "OK")] (swap (ID 1) (ID 2))--}--testShuffle = test_ [("shuffle", Right "OK")] (shuffle Nothing)--{--testPlaylistInfo0 = test [("playlistinfo", Right resp)] (Right [obj])-                    (playlistInfo Nothing)-    where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60-                      , sgArtist = "Foo", sgTitle = "Bar" }-          resp = display obj ++ "OK"--}--{- XXX: port this-testPlaylistInfoPos = test [("playlistinfo 1", Right resp)] (Right [obj])-                      (playlistInfo (Just (Left (Pos 1))))-    where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60-                      , sgArtist = "Foo", sgTitle = "Bar" }-          resp = display obj ++ "OK"--}--{- XXX: port this-testPlaylistInfoId = test [("playlistid 1", Right resp)] (Right [obj])-                     (playlistInfo (Just (Left (ID 1))))-    where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60-                      , sgArtist = "Foo", sgTitle = "Bar" }-          resp = display obj ++ "OK"--}--{--testListPlaylistInfo = test [("listplaylistinfo \"foo\"", Right resp)]-                       (Right [obj])-                       (listPlaylistInfo "foo")-    where obj = empty { sgFilePath = "dir/Foo-Bar.ogg", sgLength = 60-                      , sgArtist = "Foo", sgTitle = "Bar" }-          resp = display obj ++ "OK"--}--testListPlaylist = test [("listplaylist \"foo\""-                         ,Right "file: dir/Foo-bar.ogg\n\-                                \file: dir/Quux-quuz.ogg\n\-                                \OK")]-                   (Right ["dir/Foo-bar.ogg", "dir/Quux-quuz.ogg"])-                   (listPlaylist "foo")--{--testPlaylist = test [("playlist"-                     ,Right "1:Foo.ogg\n\-                            \2:Bar.ogg\n\-                            \OK")]-               (Right [(Pos 1, "Foo.ogg")-                      ,(Pos 2, "Bar.ogg")])-               playlist--}--{--testPlChanges = test [("plchanges 0", Right resp)] (Right [obj]) (plChanges 0)-    where obj = empty { sgArtist = "Foo", sgTitle = "Bar"-                      , sgFilePath = "foo/bar.ogg" }-          resp = display obj ++ "OK"--}--{--testPlaylistFind = test [("playlistfind Artist \"Foo\"", Right resp)]-                   (Right [obj])-                   (playlistFind (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 (Artist =? "Foo"))-    where obj = empty { sgFilePath = "dir/Foo/Bar.ogg", sgArtist = "Foo" }-          resp = display obj ++ "OK"--}------- Playback commands-----testCrossfade = test_ [("crossfade 0", Right "OK")] (crossfade 0)--testPlay = test_ [("play", Right "OK")] (play Nothing)--{- XXX: port this-testPlayPos = test_ [("play 1", Right "OK")] (play . Just $ Pos 1)--}--{- XXX: port this-testPlayId = test_ [("playid 1", Right "OK")] (play . Just $ ID 1)--}--testPause = test_ [("pause 0", Right "OK")] (pause False)--testStop = test_ [("stop", Right "OK")] stop--testNext = test_ [("next", Right "OK")] next--testPrevious = test_ [("previous", Right "OK")] previous--{- XXX: port this-testSeekPos = test_ [("seek 1 10", Right "OK")] (seek (Just $ Pos 1) 10)--testSeekId = test_ [("seekid 1 10", Right "OK")] (seek (Just $ ID 1) 10)--}--{- XXX: port this-testSeekCur = test_ [("status", Right resp)-                    ,("seekid 1 10", Right "OK")]-              (seek Nothing 10)-    where obj = empty { stState = Playing, stSongID = Just (ID 1) }-          resp = display obj ++ "OK"--}--testRandom = test_ [("random 0", Right "OK")] (random False)--testRepeat = test_ [("repeat 0", Right "OK")] (repeat False)--testSetVolume = test_ [("setvol 10", Right "OK")] (setVolume 10)--testConsume = test_ [("consume 1", Right "OK")] (consume True)--testSingle = test_ [("single 1", Right "OK")] (single True)------- Miscellaneous commands-----testClearError = test_ [("clearerror", Right "OK")] clearError--testCommands =-    test [("commands", Right "command: foo\ncommand: bar")]-         (Right ["foo", "bar"])-         commands--testNotCommands =-    test [("notcommands", Right "command: foo\ncommand: bar")]-         (Right ["foo", "bar"])-         notCommands--testTagTypes =-    test [("tagtypes", Right "tagtype: foo\ntagtype: bar")]-         (Right ["foo", "bar"])-         tagTypes--testUrlHandlers =-    test [("urlhandlers", Right "urlhandler: foo\nurlhandler: bar")]-         (Right ["foo", "bar"])-         urlHandlers--testPassword = test_ [("password foo", Right "OK")] (password "foo")--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-    where obj = empty { stsArtists = 1, stsAlbums = 1, stsSongs =  1-                      , stsUptime = 100, stsPlaytime = 100, stsDbUpdate = 10-                      , stsDbPlaytime = 100 }-          resp = display obj ++ "OK"------- Extensions\/shortcuts-----testUpdateId0 = test [("update", Right "updating_db: 1")]-                (Right 1)-                (updateId [])--testUpdateId1 = test [("update \"foo\"", Right "updating_db: 1")]-                (Right 1)-                (updateId ["foo"])--testTogglePlay = test_-               [("status", Right resp)-               ,("pause 1", Right "OK")]-               toggle-    where resp = display empty { stState = Playing }--testToggleStop = test_-                [("status", Right resp)-                ,("play", Right "OK")]-                toggle-    where resp = display empty { stState = Stopped }--testTogglePause = test_-                [("status", Right resp)-                ,("play", Right "OK")]-                toggle-    where resp = display empty { stState = Paused }--testAddMany0 = test_ [("add \"bar\"", Right "OK")]-               (addMany "" ["bar"])--testAddMany1 = test_ [("playlistadd \"foo\" \"bar\"", Right "OK")]-               (addMany "foo" ["bar"])--{- XXX: where did this go?-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 }--

@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Defaults where++import           Data.Default+import           Network.MPD.Commands.Types++instance Default Count where+    def = defaultCount++instance Default Device where+    def = defaultDevice++-- XXX: note Song has no sensible default value+-- XXX: or does it?++instance Default Stats where+    def = defaultStats++instance Default Status where+    def = defaultStatus

@@ -1,80 +0,0 @@-{-# OPTIONS_GHC -Wwarn #-}--module Displayable (Displayable(..)) where--import qualified Data.Map as M-import Network.MPD.Commands.Types-import Network.MPD.Util---- | A uniform interface for types that--- can be turned into raw responses-class Displayable a where-    empty   :: a             -- ^ An empty instance-    display :: a -> String   -- ^ Transform instantiated object to a-                             --   string--instance Displayable Count where-    empty = defaultCount-    display s = unlines-        ["songs: "    ++ show (cSongs s)-        ,"playtime: " ++ show (cPlaytime s)]--instance Displayable Device where-    empty = defaultDevice-    display d = unlines-        ["outputid: "      ++ show (dOutputID d)-        ,"outputname: "    ++ dOutputName d-        ,"outputenabled: " ++ showBool (dOutputEnabled d)]--instance Displayable Song where-    empty = defaultSong-    display s =-        let fs  = concatMap toF . M.toList $ sgTags s-            id_ = maybe [] (\(Id n) -> ["Id: " ++ show n]) (sgId s)-            idx = maybe [] (\n -> ["Pos: " ++ show n]) (sgIndex s)-            lastModified = maybe [] (return . ("Last-Modified: " ++) . formatIso8601) (sgLastModified s)-        in unlines $ ["file: " ++ sgFilePath s]-                  ++ ["Time: " ++ (show . sgLength) s]-                  ++ fs-                  ++ lastModified-                  ++ id_-                  ++ idx-        where-            toF (k, vs) = map (toF' k) vs-            toF' k v    = show k ++ ": " ++ v--instance Displayable Stats where-    empty = defaultStats-    display s = unlines-        ["artists: " ++ show (stsArtists s)-        ,"albums: " ++ show (stsAlbums s)-        ,"songs: " ++ show (stsSongs s)-        ,"uptime: " ++ show (stsUptime s)-        ,"playtime: " ++ show (stsPlaytime s)-        ,"db_playtime: " ++ show (stsDbPlaytime s)-        ,"db_update: " ++ show (stsDbUpdate s)]--instance Displayable Status where-    empty = defaultStatus-    display s = unlines $-        ["state: " ++ (case stState s of Playing -> "play"-                                         Paused  -> "pause"-                                         _       -> "stop")-        ,"volume: " ++ show (stVolume s)-        ,"repeat: " ++ showBool (stRepeat s)-        ,"random: " ++ showBool (stRandom s)-        ,"playlist: " ++ show (stPlaylistVersion s)-        ,"playlistlength: " ++ show (stPlaylistLength s)-        ,"xfade: " ++ show (stXFadeWidth s)-        ,"time: " ++ (let (x, y) = stTime s in show x ++ ":" ++ show y)-        ,"bitrate: " ++ show (stBitrate s)-        ,"xfade: " ++ show (stXFadeWidth s)--        ,"audio: " ++ (let (x, y, z) = stAudio s in show x ++ ":" ++ show y ++-                                       ":" ++ show z)-        ,"updating_db: " ++ show (stUpdatingDb s)-        ,"error: " ++ show (stError s)-        ,"single: " ++ showBool (stSingle s)-        ,"consume: " ++ showBool (stConsume s)]-        ++ maybe [] (\n -> ["song: " ++ show n]) (stSongPos s)-        ++ maybe [] (\n -> ["songid: " ++ show n]) (stSongID s)

@@ -0,0 +1,80 @@+module EnvSpec (main, spec) where++import           TestUtil+import           Test.Hspec.Monadic++import           Network.MPD+import           System.Posix.Env hiding (getEnvDefault)++main :: IO ()+main = hspecX spec++spec :: Specs+spec = do+  describe "getEnvDefault" $ do+    it "returns the value of an environment variable" $ do+      setEnv "FOO" "foo" True+      r <- getEnvDefault "FOO" "bar"+      r `shouldBe` "foo"++    it "returns a given default value if that environment variable is not set" $ do+      unsetEnv "FOO"+      r <- getEnvDefault "FOO" "bar"+      r `shouldBe` "bar"++  describe "getConnectionSettings" $ do+    it "takes an optional argument, that overrides MPD_HOST" $ do+      setEnv "MPD_HOST" "user@example.com" True+      Right (host, _, pw) <- getConnectionSettings (Just "foo@bar") Nothing+      pw `shouldBe` "foo"+      host `shouldBe` "bar"++    it "takes an optional argument, that overrides MPD_PORT" $ do+      setEnv "MPD_PORT" "8080" True+      Right (_, port, _) <- getConnectionSettings Nothing (Just "23")+      port `shouldBe` 23++    it "returns an error message, if MPD_PORT is not an int" $ do+      setEnv "MPD_PORT" "foo" True+      r <- getConnectionSettings Nothing Nothing+      r `shouldBe` Left "\"foo\" is not a valid port!"+      unsetEnv "MPD_PORT"++    describe "host" $ do+      it "is taken from MPD_HOST" $ do+        setEnv "MPD_HOST" "example.com" True+        Right (host, _, _) <- getConnectionSettings Nothing Nothing+        host `shouldBe` "example.com"++      it "is 'localhost' if MPD_HOST is not set" $ do+        unsetEnv "MPD_HOST"+        Right (host, _, _) <- getConnectionSettings Nothing Nothing+        host `shouldBe` "localhost"++    describe "port" $ do+      it "is taken from MPD_PORT" $ do+        setEnv "MPD_PORT" "8080" True+        Right (_, port, _) <- getConnectionSettings Nothing Nothing+        port `shouldBe` 8080++      it "is 6600 if MPD_PORT is not set" $ do+        unsetEnv "MPD_PORT"+        Right (_, port, _) <- getConnectionSettings Nothing Nothing+        port `shouldBe` 6600++    describe "password" $ do+      it "is taken from MPD_HOST if MPD_HOST is of the form password@host" $ do+        setEnv "MPD_HOST" "password@host" True+        Right (host, _, pw) <- getConnectionSettings Nothing Nothing+        host `shouldBe` "host"+        pw `shouldBe` "password"++      it "is '' if MPD_HOST is not of the form password@host" $ do+        setEnv "MPD_HOST" "example.com" True+        Right (_, _, pw) <- getConnectionSettings Nothing Nothing+        pw `shouldBe` ""++      it "is '' if MPD_HOST is not set" $ do+        unsetEnv "MPD_HOST"+        Right (_, _, pw) <- getConnectionSettings Nothing Nothing+        pw `shouldBe` ""

@@ -1,12 +1,14 @@-{-# OPTIONS_GHC -Wwarn -fno-warn-missing-signatures #-}--- |--- GUTD: The Grand Unified Test Driver.-import qualified Commands-import qualified Properties+module Main (main) where -main = do-    putStrLn "*** Properties ***"-    Properties.main+import qualified CommandSpec+import qualified EnvSpec+import qualified ParserSpec+import qualified UtilSpec+import           Test.Hspec.Monadic (describe, hspecX) -    putStrLn "\n*** Unit Tests ***"-    Commands.main+main :: IO ()+main = hspecX $ do+    describe "CommandSpec" CommandSpec.spec+    describe "EnvSpec" EnvSpec.spec+    describe "ParserSpec" ParserSpec.spec+    describe "UtilSpec" UtilSpec.spec

@@ -0,0 +1,67 @@+{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ParserSpec (main, spec) where++import           Arbitrary ()+import           Defaults ()+import           Unparse++import           Test.Hspec.Monadic+import           Test.Hspec.HUnit ()+import           Test.Hspec.QuickCheck (prop)++import           Network.MPD.Commands.Parse+import           Network.MPD.Commands.Types+import           Network.MPD.Util hiding (read)++import qualified Data.ByteString.UTF8 as UTF8+import           Data.List+import qualified Data.Map as M+import           Data.Time++main :: IO ()+main = hspecX spec++spec :: Specs+spec = do+    describe "parseIso8601" $ do+        prop "parses dates in ISO8601 format" prop_parseIso8601++    describe "parseCount" $ do+        prop "parses counts" prop_parseCount++    describe "parseOutputs" $ do+        prop "parses outputs" prop_parseOutputs++    describe "parseSong" $ do+        prop "parses songs" prop_parseSong++    describe "parseStats" $ do+        prop "parses stats" prop_parseStats++-- This property also ensures, that (instance Arbitrary UTCTime) is sound.+-- Indeed, a bug in the instance declaration was the primary motivation to add+-- this property.+prop_parseIso8601 :: UTCTime -> Bool+prop_parseIso8601 t = Just t == (parseIso8601 . UTF8.fromString . formatIso8601) t++prop_parseCount :: Count -> Bool+prop_parseCount c = Right c == (parseCount . map UTF8.fromString . lines . unparse) c++prop_parseOutputs :: [Device] -> Bool+prop_parseOutputs ds =+    Right ds == (parseOutputs . map UTF8.fromString . lines . concatMap unparse) ds++deriving instance Ord Value++prop_parseSong :: Song -> Bool+prop_parseSong s = Right (sortTags s) == sortTags `fmap` (parseSong . toAssocList . map UTF8.fromString . lines . unparse) s+  where+    -- We consider lists of tag values equal if they contain the same elements.+    -- To ensure that two lists with the same elements are equal, we bring the+    -- elements in a deterministic order.+    sortTags song = song { sgTags = M.map sort $ sgTags song }++prop_parseStats :: Stats -> Bool+prop_parseStats s = Right s == (parseStats . map UTF8.fromString . lines . unparse) s

@@ -1,120 +0,0 @@-{-# OPTIONS_GHC -Wwarn -fno-warn-orphans -fno-warn-missing-methods #-}-module Properties (main) where--import Arbitrary-import Displayable--import Network.MPD.Commands.Parse-import Network.MPD.Commands.Types-import Network.MPD.Util--import Control.Monad-import Data.List-import Data.Maybe-import qualified Data.Map as M-import Data.Time-import System.Environment-import Text.Printf-import Test.QuickCheck---main :: IO ()-main = do-    n <- (maybe 100 read . listToMaybe) `liftM` getArgs-    mapM_ (\(s, f) -> printf "%-25s : " s >> f n) tests-    where tests = [("splitGroups / reversible",-                        mytest prop_splitGroups_rev)-                  ,("splitGroups / integrity",-                        mytest prop_splitGroups_integrity)-                  ,("parseBool", mytest prop_parseBool)-                  ,("parseBool / reversible",-                        mytest prop_parseBool_rev)-                  ,("showBool", mytest prop_showBool)-                  ,("toAssoc / reversible",-                        mytest prop_toAssoc_rev)-                  ,("parseNum", mytest prop_parseNum)-                  ,("parseDate / simple",-                        mytest prop_parseDate_simple)-                  ,("parseDate / complex",-                        mytest prop_parseDate_complex)-                  ,("parseIso8601", mytest prop_parseIso8601)-                  ,("parseCount", mytest prop_parseCount)-                  ,("parseOutputs", mytest prop_parseOutputs)-                  ,("parseSong", mytest prop_parseSong)-                  ,("parseStats", mytest prop_parseStats)]--mytest :: Testable a => a -> Int -> IO ()-mytest a n = quickCheckWith stdArgs { maxSize = n } a--prop_parseDate_simple :: YearString -> Bool-prop_parseDate_simple (YS x) = isJust $ parseDate x--prop_parseDate_complex :: DateString -> Bool-prop_parseDate_complex (DS x) = isJust $ parseDate x---- 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 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"-prop_showBool x    = showBool x == "0"--prop_splitGroups_rev :: [(String, String)] -> Property-prop_splitGroups_rev xs = not (null xs) ==>-    let wrappers = [(fst $ head xs, id)]-        r = splitGroups wrappers xs-    in r == splitGroups wrappers (concat r)--prop_splitGroups_integrity :: [(String, String)] -> Property-prop_splitGroups_integrity xs = not (null xs) ==>-    sort (concat $ splitGroups [(fst $ head xs, id)] xs) == sort xs--prop_parseNum :: 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------------------------------------------------------------------------------- This property also ensures, that (instance Arbitrary UTCTime) is sound.--- Indeed, a bug in the instance declaration was the primary motivation to add--- this property.-prop_parseIso8601 :: UTCTime -> Bool-prop_parseIso8601 t = Just t == (parseIso8601 . formatIso8601) t--prop_parseCount :: Count -> Bool-prop_parseCount c = Right c == (parseCount . lines $ display c)--prop_parseOutputs :: [Device] -> Bool-prop_parseOutputs ds =-    Right ds == (parseOutputs . lines $ concatMap display ds)--prop_parseSong :: Song -> Bool-prop_parseSong s = Right (sortTags s) == sortTags `fmap` (parseSong . toAssocList . lines $ display s)-  where-    -- We consider lists of tag values equal if they contain the same elements.-    -- To ensure that two lists with the same elements are equal, we bring the-    -- elements in a deterministic order.-    sortTags song = song {sgTags = M.map sort $ sgTags song}--prop_parseStats :: Stats -> Bool-prop_parseStats s = Right s == (parseStats . lines $ display s)

@@ -11,13 +11,16 @@  module StringConn where -import Prelude hiding (exp)-import Control.Monad.Error-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State-import Network.MPD.Core+import           Prelude hiding (exp)+import           Control.Monad.Error+import           Control.Monad.Identity+import           Control.Monad.Reader+import           Control.Monad.State+import           Network.MPD.Core +import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.UTF8 as UTF8+ -- | An expected request. type Expect = String @@ -50,6 +53,10 @@             handler (MErr (Right err))  = runSMPD (f err)  instance MonadMPD StringMPD where+    getVersion  = error "StringConn.getVersion: undefined"+    getHandle   = error "StringConn.getHandle: undefined"+    setPassword = error "StringConn.setPassword: undefined"+     open  = return ()     close = return ()     getPassword = SMPD ask@@ -62,7 +69,7 @@                  (throwError . MErr . Left                              $ UnexpectedRequest expected_request request)             put rest-            either (throwError . MErr . Right) return response+            either (throwError . MErr . Right) (return . B.lines . UTF8.fromString) response  -- | Run an action against a set of expected requests and responses, -- and an expected result. The result is Nothing if everything matched

@@ -0,0 +1,7 @@+module TestUtil (shouldBe) where++import           Test.Hspec.HUnit ()+import           Test.HUnit++shouldBe :: (Eq a, Show a) => a -> a -> Assertion+shouldBe = (@?=)

@@ -0,0 +1,75 @@+-- | Unparsing for MPD objects++module Unparse (Unparse(..)) where++import qualified Data.Map as M+import           Network.MPD.Commands.Types+import           Network.MPD.Util++class Unparse parsed where+    unparse :: parsed -> String++instance Unparse Count where+    unparse x = unlines+                [ "songs: "    ++ show (cSongs x)+                , "playtime: " ++ show (cPlaytime x) +                ]++instance Unparse Device where+    unparse x = unlines+        [ "outputid: "      ++ show (dOutputID x)+        , "outputname: "    ++ dOutputName x+        , "outputenabled: " ++ showBool (dOutputEnabled x)+        ]++instance Unparse Song where+    unparse s =+        let fs  = concatMap toF . M.toList $ sgTags s+            id_ = maybe [] (\(Id n) -> ["Id: " ++ show n]) (sgId s)+            idx = maybe [] (\n -> ["Pos: " ++ show n]) (sgIndex s)+            lastModified = maybe [] (return . ("Last-Modified: " ++) . formatIso8601) (sgLastModified s)+        in unlines $ ["file: " ++ (toString . sgFilePath) s]+                  ++ ["Time: " ++ (show . sgLength) s]+                  ++ fs+                  ++ lastModified+                  ++ id_+                  ++ idx+        where+            toF (k, vs) = map (toF' k) vs+            toF' k v    = show k ++ ": " ++ toString v++instance Unparse Stats where+    unparse s = unlines+        [ "artists: " ++ show (stsArtists s)+        , "albums: " ++ show (stsAlbums s)+        , "songs: " ++ show (stsSongs s)+        , "uptime: " ++ show (stsUptime s)+        , "playtime: " ++ show (stsPlaytime s)+        , "db_playtime: " ++ show (stsDbPlaytime s)+        , "db_update: " ++ show (stsDbUpdate s)+        ]++instance Unparse Status where+    unparse s = unlines $+        [ "state: " ++ (case stState s of Playing -> "play"+                                          Paused  -> "pause"+                                          _       -> "stop")+        , "volume: " ++ show (stVolume s)+        , "repeat: " ++ showBool (stRepeat s)+        , "random: " ++ showBool (stRandom s)+        , "playlist: " ++ show (stPlaylistVersion s)+        , "playlistlength: " ++ show (stPlaylistLength s)+        , "xfade: " ++ show (stXFadeWidth s)+        , "time: " ++ (let (x, y) = stTime s in show x ++ ":" ++ show y)+        , "bitrate: " ++ show (stBitrate s)+        , "xfade: " ++ show (stXFadeWidth s)++        , "audio: " ++ (let (x, y, z) = stAudio s in show x ++ ":" ++ show y +++                                       ":" ++ show z)+        , "updating_db: " ++ show (stUpdatingDb s)+        , "error: " ++ show (stError s)+        , "single: " ++ showBool (stSingle s)+        , "consume: " ++ showBool (stConsume s) +        ]+        ++ maybe [] (\n -> ["song: " ++ show n]) (stSongPos s)+        ++ maybe [] (\n -> ["songid: " ++ show n]) (stSongID s)

@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module UtilSpec (main, spec) where++import           Arbitrary+import           TestUtil++import           Test.Hspec.Monadic+import           Test.Hspec.HUnit ()+import           Test.Hspec.QuickCheck (prop)+import           Test.QuickCheck++import           Data.List (sort)+import           Data.Maybe (fromJust, isJust)+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.UTF8 as UTF8++import           Network.MPD.Util++main :: IO ()+main = hspecX spec++spec :: Specs+spec = do+    describe "splitGroups" $ do+        it "breaks an association list into sublists" $ do+            splitGroups ["1", "5"]+                        [("1","a"),("2","b"),+                         ("5","c"),("6","d"),+                         ("1","z"),("2","y"),("3","x")]+            `shouldBe`+            [[("1","a"),("2","b")],+             [("5","c"),("6","d")],+             [("1","z"),("2","y"),("3","x")]]+        prop "is reversible" prop_splitGroups_rev+        prop "preserves input" prop_splitGroups_integrity++    describe "parseDate" $ do+        prop "simple year strings" prop_parseDate_simple+        prop "complex year strings" prop_parseDate_complex++    describe "toAssoc" $ do+        prop "is reversible" prop_toAssoc_rev++    describe "parseBool" $ do+        prop "parses boolean values" prop_parseBool+        prop "is reversible" prop_parseBool_rev++    describe "showBool" $ do+        prop "unparses boolean values" prop_showBool++    describe "parseNum" $ do+        prop "parses positive and negative integers" prop_parseNum+++prop_parseDate_simple :: YearString -> Bool+prop_parseDate_simple (YS x) = isJust $ parseDate x++prop_parseDate_complex :: DateString -> Bool+prop_parseDate_complex (DS x) = isJust $ parseDate x++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 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"+prop_showBool x    = showBool x == "0"++prop_splitGroups_rev :: [(ByteString, ByteString)] -> Property+prop_splitGroups_rev xs = not (null xs) ==>+    let wrappers = [fst $ head xs]+        r = splitGroups wrappers xs+    in r == splitGroups wrappers (concat r)++prop_splitGroups_integrity :: [(ByteString, ByteString)] -> Property+prop_splitGroups_integrity xs = not (null xs) ==>+    sort (concat $ splitGroups [fst $ head xs] xs) == sort xs++prop_parseNum :: Integer -> Bool+prop_parseNum x =+    case xs of+        '-':_ -> ((<= 0) `fmap` parseNum bs) == Just True+        _     -> ((>= 0) `fmap` parseNum bs) == Just True+    where+      xs = show x+      bs = UTF8.fromString xs

@@ -1,37 +0,0 @@-#!/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.Directory (doesDirectoryExist, removeDirectoryRecursive,-                         removeFile)--excludeModules =-    ["Main", "Arbitrary", "Properties", "Displayable", "Commands", "StringConn"]--main = do-    -- Cleanup from previous runs-    hpcExists <- doesDirectoryExist ".hpc"-    when hpcExists $ do-        removeDirectoryRecursive ".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,50 +0,0 @@-#!/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}