diff --git a/libmpd.cabal b/libmpd.cabal
--- a/libmpd.cabal
+++ b/libmpd.cabal
@@ -1,5 +1,5 @@
Name: libmpd
-Version: 0.8.0.1
+Version: 0.8.0.2
Synopsis: An MPD client library.
Description: A client library for MPD, the Music Player Daemon
().
@@ -7,7 +7,7 @@
License: LGPL
License-file: LICENSE
-Copyright: Ben Sinclair 2005-2009, Joachim Fasting 2012
+Copyright: Ben Sinclair 2005-2009, Joachim Fasting 2013
Author: Ben Sinclair
Maintainer: Joachim Fasting
@@ -22,6 +22,16 @@
Extra-Source-Files:
README.md
NEWS
+ tests/Arbitrary.hs
+ tests/CommandSpec.hs
+ tests/EnvSpec.hs
+ tests/Defaults.hs
+ tests/ParserSpec.hs
+ tests/StringConn.hs
+ tests/TestUtil.hs
+ tests/Unparse.hs
+ tests/UtilSpec.hs
+ tests/Main.hs
Source-Repository head
type: git
@@ -33,7 +43,7 @@
Build-Depends:
base >= 4 && < 5
, mtl >= 2.0 && < 2.2
- , network >= 2.1 && < 2.4
+ , network >= 2.1 && < 2.5
, filepath >= 1.0 && < 1.4
, utf8-string >= 0.3.1 && < 0.4
, old-locale >= 1.0 && < 2.0
diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/tests/Arbitrary.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{-# OPTIONS_GHC -Wwarn -fno-warn-orphans -fno-warn-missing-methods -XFlexibleInstances #-}
+
+-- | This module contains Arbitrary instances for various types.
+
+module Arbitrary
+ ( AssocString(..)
+ , BoolString(..)
+ , YearString(..)
+ , DateString(..)
+ , positive, field
+ ) where
+
+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 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
+
+three :: Monad m => m a -> m (a, a, a)
+three m = liftM3 (,,) m m m
+
+-- Generate a positive number.
+positive :: (Arbitrary a, Num a) => Gen a
+positive = abs <$> arbitrary
+
+possibly :: Gen a -> Gen (Maybe a)
+possibly m = arbitrary >>= bool (Just <$> m) (return Nothing)
+ where bool thenE elseE b = if b then thenE else elseE
+
+-- MPD fields can't contain newlines and the parser skips initial spaces.
+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 [Value]) where
+ arbitrary = do
+ size <- choose (1, 1000)
+ 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
+
+instance Arbitrary DiffTime where
+ arbitrary = secondsToDiffTime <$> positive
+
+instance Arbitrary UTCTime where
+ arbitrary = UTCTime <$> arbitrary <*> arbitrary
+
+-- an assoc. string is a string of the form "key: value", followed by
+-- the key and value separately.
+data AssocString = AS ByteString ByteString ByteString
+
+instance Show AssocString where
+ show (AS str _ _) = UTF8.toString str
+
+instance Arbitrary AssocString where
+ arbitrary = do
+ key <- filter (/= ':') <$> arbitrary
+ val <- dropWhile (== ' ') <$> arbitrary
+ return $ AS (UTF8.fromString (key ++ ": " ++ val))
+ (UTF8.fromString key)
+ (UTF8.fromString val)
+
+newtype BoolString = BS ByteString
+ deriving Show
+
+instance Arbitrary BoolString where
+ arbitrary = BS <$> elements ["1", "0"]
+
+-- Simple date representation, like "2004" and "1998".
+newtype YearString = YS ByteString
+ deriving Show
+
+instance Arbitrary YearString where
+ arbitrary = YS . UTF8.fromString . show <$> (positive :: Gen Integer)
+
+-- Complex date representations, like "2004-20-30".
+newtype DateString = DS ByteString
+ deriving Show
+
+instance Arbitrary DateString where
+ arbitrary = do
+ (y,m,d) <- three (positive :: Gen Integer)
+ return . DS . UTF8.fromString . concat . intersperse "-" $ map show [y,m,d]
+
+instance Arbitrary Count where
+ arbitrary = liftM2 Count arbitrary arbitrary
+
+instance Arbitrary Device where
+ arbitrary = liftM3 Device arbitrary field arbitrary
+
+instance Arbitrary Id where
+ arbitrary = Id <$> arbitrary
+
+instance Arbitrary Song where
+ 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
+ <*> positive <*> positive <*> positive
+
+instance Arbitrary Metadata where
+ arbitrary = elements [minBound .. maxBound]
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/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/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/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/StringConn.hs b/tests/StringConn.hs
new file mode 100644
--- /dev/null
+++ b/tests/StringConn.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -Wwarn #-}
+
+-- | Module : StringConn
+-- Copyright : (c) Ben Sinclair 2005-2009
+-- License : LGPL (see LICENSE)
+-- Maintainer : bsinclai@turing.une.edu.au
+-- Stability : alpha
+--
+-- A testing scaffold for MPD commands
+
+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 qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.UTF8 as UTF8
+
+-- | An expected request.
+type Expect = String
+
+data StringMPDError
+ = TooManyRequests
+ | UnexpectedRequest Expect String
+ deriving (Show, Eq)
+
+data Result a
+ = Ok
+ | BadResult (Response a) (Response a) -- expected, then actual
+ | BadRequest StringMPDError
+ deriving (Show, Eq)
+
+newtype MatchError = MErr (Either StringMPDError MPDError)
+instance Error MatchError where
+ strMsg = MErr . Right . strMsg
+
+newtype StringMPD a =
+ SMPD { runSMPD :: ErrorT MatchError
+ (StateT [(Expect, Response String)]
+ (ReaderT Password Identity)) a
+ } deriving (Functor, Monad)
+
+instance MonadError MPDError StringMPD where
+ throwError = SMPD . throwError . MErr . Right
+ catchError m f = SMPD $ catchError (runSMPD m) handler
+ where
+ handler err@(MErr (Left _)) = throwError err
+ 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
+ send request =
+ SMPD $ do
+ ~pairs@((expected_request,response):rest) <- get
+ when (null pairs)
+ (throwError . MErr $ Left TooManyRequests)
+ when (expected_request /= request)
+ (throwError . MErr . Left
+ $ UnexpectedRequest expected_request request)
+ put rest
+ 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
+-- what was expected. If anything differed the result of the
+-- computation is returned along with pairs of expected and received
+-- requests.
+testMPD :: (Eq a)
+ => [(Expect, Response String)] -- ^ The expected requests and their
+ -- ^ corresponding responses.
+ -> Response a -- ^ The expected final result.
+ -> Password -- ^ A password to be supplied.
+ -> StringMPD a -- ^ The MPD action to run.
+ -> Result a
+testMPD pairs expected passwd m =
+ let result = runIdentity
+ $ runReaderT (evalStateT (runErrorT $ runSMPD m) pairs) passwd
+ in case result of
+ Right r
+ | Right r == expected -> Ok
+ | otherwise -> BadResult expected (Right r)
+ Left (MErr (Right r))
+ | Left r == expected -> Ok
+ | otherwise -> BadResult expected (Left r)
+ Left (MErr (Left e)) -> BadRequest e
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