diff --git a/Network/MPD.hs b/Network/MPD.hs --- a/Network/MPD.hs +++ b/Network/MPD.hs @@ -25,8 +25,8 @@ #endif ) where -import Prelude hiding (catch) -import Control.Exception +import Prelude +import qualified Control.Exception as E import Network.MPD.Commands import Network.MPD.Core @@ -76,7 +76,7 @@ getEnvDefault :: String -> String -> IO String getEnvDefault x dflt = - catch (getEnv x) (\e -> if isDoesNotExistError e + E.catch (getEnv x) (\e -> if isDoesNotExistError e then return dflt else ioError e) -- Break a string by character, removing the separator. diff --git a/Network/MPD/Core.hs b/Network/MPD/Core.hs --- a/Network/MPD/Core.hs +++ b/Network/MPD/Core.hs @@ -27,7 +27,7 @@ import Data.Char (isDigit) import Control.Applicative (Applicative(..), (<$>), (<*)) -import Control.Exception hiding (handle) +import qualified Control.Exception as E import Control.Monad (ap, unless) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.Reader (ReaderT(..), ask) @@ -40,7 +40,7 @@ import Text.Printf (printf) import qualified Prelude -import Prelude hiding (break, catch, drop, dropWhile, read) +import Prelude hiding (break, 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 @@ -113,10 +113,10 @@ where safeConnectTo host@('/':_) _ = (Just <$> connectTo "" (UnixSocket host)) - `catch` (\(_ :: SomeException) -> return Nothing) + `E.catch` (\(_ :: E.SomeException) -> return Nothing) safeConnectTo host port = (Just <$> connectTo host (PortNumber $ fromInteger port)) - `catch` (\(_ :: SomeException) -> return Nothing) + `E.catch` (\(_ :: E.SomeException) -> return Nothing) checkConn = do [msg] <- send "" if "OK MPD" `isPrefixOf` msg @@ -149,7 +149,7 @@ where sendClose handle = (hPutStrLn handle "close" >> hReady handle >> hClose handle) - `catch` whenEOF (return ()) + `E.catch` whenEOF (return ()) whenEOF result err | isEOFError err = result @@ -166,7 +166,7 @@ go handle = do unless (null str) $ liftIO $ U.hPutStrLn handle str >> hFlush handle - liftIO ((Right <$> getLines handle []) `catch` (return . Left)) + liftIO ((Right <$> getLines handle []) `E.catch` (return . Left)) >>= either (\err -> if isEOFError err then modify (\st -> st { stHandle = Nothing }) >> throwError TimedOut 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 @@ -10,7 +10,7 @@ module Network.MPD.Core.Error where -import Control.Exception +import qualified Control.Exception as E import Control.Monad.Error (Error(..)) import Data.Typeable @@ -26,7 +26,7 @@ -- server deriving (Eq, Typeable) -instance Exception MPDError +instance E.Exception MPDError instance Show MPDError where show NoMPD = "Could not connect to MPD" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ > :set -XOverloadedStrings > import Network.MPD > withMPD $ lsInfo "" - Right [LsDirectory "Tool", LsDirectory "Tom Waits",...] + Right [Left "Tool", Left "Tom Waits",...] > withMPD $ add "Tom Waits/Big Time" Right ["Tom Waits/Big Time/01 - 16 Shells from a Thirty-Ought-Six.mp3",...] diff --git a/libmpd.cabal b/libmpd.cabal --- a/libmpd.cabal +++ b/libmpd.cabal @@ -1,5 +1,5 @@ Name: libmpd -Version: 0.8.0 +Version: 0.8.0.1 Synopsis: An MPD client library. Description: A client library for MPD, the Music Player Daemon (). @@ -22,16 +22,6 @@ 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 @@ -48,8 +38,8 @@ , 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.* + , containers >= 0.3 && < 0.6 + , bytestring >= 0.9 && < 0.11 , text == 0.11.* Exposed-Modules: diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs deleted file mode 100644 --- a/tests/Arbitrary.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/CommandSpec.hs +++ /dev/null @@ -1,435 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/Defaults.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/EnvSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ -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 deleted file mode 100644 --- a/tests/ParserSpec.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/StringConn.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/TestUtil.hs +++ /dev/null @@ -1,7 +0,0 @@ -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 deleted file mode 100644 --- a/tests/Unparse.hs +++ /dev/null @@ -1,75 +0,0 @@ --- | 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 deleted file mode 100644 --- a/tests/UtilSpec.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# 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