diff --git a/NEWS b/NEWS
--- a/NEWS
+++ b/NEWS
@@ -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)
diff --git a/Network/MPD.hs b/Network/MPD.hs
--- a/Network/MPD.hs
+++ b/Network/MPD.hs
@@ -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 .
--
--- 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
diff --git a/Network/MPD/Commands.hs b/Network/MPD/Commands.hs
--- a/Network/MPD/Commands.hs
+++ b/Network/MPD/Commands.hs
@@ -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
diff --git a/Network/MPD/Commands/Arg.hs b/Network/MPD/Commands/Arg.hs
--- a/Network/MPD/Commands/Arg.hs
+++ b/Network/MPD/Commands/Arg.hs
@@ -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 []
diff --git a/Network/MPD/Commands/Extensions.hs b/Network/MPD/Commands/Extensions.hs
--- a/Network/MPD/Commands/Extensions.hs
+++ b/Network/MPD/Commands/Extensions.hs
@@ -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
diff --git a/Network/MPD/Commands/Parse.hs b/Network/MPD/Commands/Parse.hs
--- a/Network/MPD/Commands/Parse.hs
+++ b/Network/MPD/Commands/Parse.hs
@@ -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
diff --git a/Network/MPD/Commands/Query.hs b/Network/MPD/Commands/Query.hs
--- a/Network/MPD/Commands/Query.hs
+++ b/Network/MPD/Commands/Query.hs
@@ -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.
diff --git a/Network/MPD/Commands/Types.hs b/Network/MPD/Commands/Types.hs
--- a/Network/MPD/Commands/Types.hs
+++ b/Network/MPD/Commands/Types.hs
@@ -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.
diff --git a/Network/MPD/Commands/Util.hs b/Network/MPD/Commands/Util.hs
--- a/Network/MPD/Commands/Util.hs
+++ b/Network/MPD/Commands/Util.hs
@@ -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
diff --git a/Network/MPD/Core.hs b/Network/MPD/Core.hs
--- a/Network/MPD/Core.hs
+++ b/Network/MPD/Core.hs
@@ -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
diff --git a/Network/MPD/Core/Class.hs b/Network/MPD/Core/Class.hs
--- a/Network/MPD/Core/Class.hs
+++ b/Network/MPD/Core/Class.hs
@@ -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)
diff --git a/Network/MPD/Core/Error.hs b/Network/MPD/Core/Error.hs
--- a/Network/MPD/Core/Error.hs
+++ b/Network/MPD/Core/Error.hs
@@ -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"
diff --git a/Network/MPD/Util.hs b/Network/MPD/Util.hs
--- a/Network/MPD/Util.hs
+++ b/Network/MPD/Util.hs
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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 \
Daniel Wagner \
+
+nandykins
diff --git a/libmpd.cabal b/libmpd.cabal
--- a/libmpd.cabal
+++ b/libmpd.cabal
@@ -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
+ ().
+Category: Network, Sound
+
License: LGPL
License-file: LICENSE
Copyright: Ben Sinclair 2005-2009, Joachim Fasting 2012
Author: Ben Sinclair
+
Maintainer: Joachim Fasting
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
- ().
-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
diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs
--- a/tests/Arbitrary.hs
+++ b/tests/Arbitrary.hs
@@ -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
diff --git a/tests/CommandSpec.hs b/tests/CommandSpec.hs
new file mode 100644
--- /dev/null
+++ b/tests/CommandSpec.hs
@@ -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 }
diff --git a/tests/Commands.hs b/tests/Commands.hs
deleted file mode 100644
--- a/tests/Commands.hs
+++ /dev/null
@@ -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 }
-
-
diff --git a/tests/Defaults.hs b/tests/Defaults.hs
new file mode 100644
--- /dev/null
+++ b/tests/Defaults.hs
@@ -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
diff --git a/tests/Displayable.hs b/tests/Displayable.hs
deleted file mode 100644
--- a/tests/Displayable.hs
+++ /dev/null
@@ -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)
diff --git a/tests/EnvSpec.hs b/tests/EnvSpec.hs
new file mode 100644
--- /dev/null
+++ b/tests/EnvSpec.hs
@@ -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` ""
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -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
diff --git a/tests/ParserSpec.hs b/tests/ParserSpec.hs
new file mode 100644
--- /dev/null
+++ b/tests/ParserSpec.hs
@@ -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
diff --git a/tests/Properties.hs b/tests/Properties.hs
deleted file mode 100644
--- a/tests/Properties.hs
+++ /dev/null
@@ -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)
diff --git a/tests/StringConn.hs b/tests/StringConn.hs
--- a/tests/StringConn.hs
+++ b/tests/StringConn.hs
@@ -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
diff --git a/tests/TestUtil.hs b/tests/TestUtil.hs
new file mode 100644
--- /dev/null
+++ b/tests/TestUtil.hs
@@ -0,0 +1,7 @@
+module TestUtil (shouldBe) where
+
+import Test.Hspec.HUnit ()
+import Test.HUnit
+
+shouldBe :: (Eq a, Show a) => a -> a -> Assertion
+shouldBe = (@?=)
diff --git a/tests/Unparse.hs b/tests/Unparse.hs
new file mode 100644
--- /dev/null
+++ b/tests/Unparse.hs
@@ -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)
diff --git a/tests/UtilSpec.hs b/tests/UtilSpec.hs
new file mode 100644
--- /dev/null
+++ b/tests/UtilSpec.hs
@@ -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
diff --git a/tests/coverage.lhs b/tests/coverage.lhs
deleted file mode 100644
--- a/tests/coverage.lhs
+++ /dev/null
@@ -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}
diff --git a/tests/run-tests.lhs b/tests/run-tests.lhs
deleted file mode 100644
--- a/tests/run-tests.lhs
+++ /dev/null
@@ -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}