libmpd 0.8.0.1 → 0.8.0.2
raw patch · 10 files changed
+1029/−3 lines, 10 filesdep ~networkPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: network
API changes (from Hackage documentation)
Files
- libmpd.cabal +13/−3
- tests/Arbitrary.hs +135/−0
- tests/CommandSpec.hs +435/−0
- tests/Defaults.hs +21/−0
- tests/EnvSpec.hs +80/−0
- tests/ParserSpec.hs +67/−0
- tests/StringConn.hs +96/−0
- tests/TestUtil.hs +7/−0
- tests/Unparse.hs +75/−0
- tests/UtilSpec.hs +100/−0
libmpd.cabal view
@@ -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 (<http://www.musicpd.org/>).@@ -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 <joachim.fasting@gmail.com>@@ -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
+ tests/Arbitrary.hs view
@@ -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]
+ tests/CommandSpec.hs view
@@ -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 }
+ tests/Defaults.hs view
@@ -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
+ tests/EnvSpec.hs view
@@ -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` ""
+ tests/ParserSpec.hs view
@@ -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
+ tests/StringConn.hs view
@@ -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
+ tests/TestUtil.hs view
@@ -0,0 +1,7 @@+module TestUtil (shouldBe) where++import Test.Hspec.HUnit ()+import Test.HUnit++shouldBe :: (Eq a, Show a) => a -> a -> Assertion+shouldBe = (@?=)
+ tests/Unparse.hs view
@@ -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)
+ tests/UtilSpec.hs view
@@ -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