diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ # libmpd-haskell: a client library for MPD +[![Hackage](https://budueba.com/hackage/libmpd)](http://hackage.haskell.org/package/libmpd) +[![Build Status](https://secure.travis-ci.org/vimus/libmpd-haskell.png?branch=master)](http://travis-ci.org/vimus/libmpd-haskell) + ## About libmpd-haskell is a pure [Haskell] client library for [MPD], the music playing daemon. @@ -11,14 +14,14 @@ * [Latest release on Hackage] * `git clone git://github.com/vimus/libmpd-haskell.git` -[Latest release on Hackage]: http://hackage.haskell.org/package/libmpd "libmpd-haskell on Hackage" +[Latest release on Hackage]: https://hackage.haskell.org/package/libmpd "libmpd-haskell on Hackage" ## Installation With [cabal-install], do `cd libmpd-haskell && cabal install` -[cabal-install]: http://hackage.haskell.org/package/cabal-install +[cabal-install]: https://hackage.haskell.org/package/cabal-install ## Usage With GHCi: @@ -46,25 +49,31 @@ Well-formatted patches are appreciated. New features should have a test case. +## See also +* [vimus], an MPD client with vim-like keybindings + +[vimus]: https://github.com/vimus/vimus + ## Resources * [API documentation] * [MPD protocol reference] * [Using GitHub] * \#vimus @ irc.freenode.net -[bug tracker]: http://github.com/vimus/libmpd-haskell/issues -[GitHub]: http://www.github.com -[GitHub repository]: http://www.github.com/vimus/libmpd-haskell -[API documentation]: http://hackage.haskell.org/packages/archive/libmpd/latest/doc/html/Network-MPD.html +[bug tracker]: https://github.com/vimus/libmpd-haskell/issues +[GitHub]: https://github.com +[GitHub repository]: https://github.com/vimus/libmpd-haskell +[API documentation]: https://hackage.haskell.org/packages/archive/libmpd/latest/doc/html/Network-MPD.html [MPD protocol reference]: http://www.musicpd.org/doc/protocol/ -[Using GitHub]: http://help.github.com +[Using GitHub]: https://help.github.com ## License libmpd-haskell is distributed under the [MIT license]. -[MIT license]: http://www.opensource.org/licenses/MIT +[MIT license]: http://opensource.org/licenses/MIT ## Contributors -See `CONTRIBUTORS` in the source distribution. -Feel free to add yourself to this list if you deem it appropriate -to do so. +See [CONTRIBUTORS](https://github.com/vimus/libmpd-haskell/blob/master/CONTRIBUTORS) in the +source distribution. +Feel free to add yourself to this list if you deem it appropriate to do +so. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +* v0.9.10 + - Port it for newer network library + * v0.9.0, 2014-09-21 - New commands: `deleteRange`, `moveRange`, `playlistInfoRange`, `searchAdd`, `searchAddpl`. diff --git a/libmpd.cabal b/libmpd.cabal --- a/libmpd.cabal +++ b/libmpd.cabal @@ -1,5 +1,5 @@ Name: libmpd -Version: 0.9.0.9 +Version: 0.9.0.10 Synopsis: An MPD client library. Description: A client library for MPD, the Music Player Daemon. Category: Network, Sound @@ -19,7 +19,7 @@ Homepage: http://github.com/vimus/libmpd-haskell#readme Bug-reports: http://github.com/vimus/libmpd-haskell/issues -Tested-With: GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.1, GHC ==8.0.1 +Tested-With: GHC ==8.0.1, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1 Build-Type: Simple Cabal-Version: >= 1.10 @@ -39,7 +39,7 @@ Build-Depends: -- Platform dependencies - base >= 4 && < 5 + base >= 4.9 && < 5 , attoparsec >= 0.10.1 && < 1 , bytestring >= 0.9 && < 1 , containers >= 0.3 && < 1 @@ -50,12 +50,13 @@ -- Additional dependencies , data-default-class >= 0.0.1 && < 1 - , network >= 2.1 && < 3 + , network >= 2.6.3.5 + , safe-exceptions >= 0.1 && < 0.2 , utf8-string >= 0.3.1 && < 1.1 if impl(ghc >= 7.10.0) Build-Depends: - time >= 1.5 && <1.9 + time >= 1.5 else Build-Depends: time >= 1.1 && <1.5 @@ -67,6 +68,7 @@ , Network.MPD.Applicative.Connection , Network.MPD.Applicative.CurrentPlaylist , Network.MPD.Applicative.Database + , Network.MPD.Applicative.Mount , Network.MPD.Applicative.Output , Network.MPD.Applicative.PlaybackControl , Network.MPD.Applicative.PlaybackOptions @@ -96,6 +98,7 @@ , Network.MPD.Commands.Connection , Network.MPD.Commands.Output , Network.MPD.Commands.Reflection + , Network.MPD.Commands.Mount , Network.MPD.Applicative.Util , Network.MPD.Applicative.Internal , Network.MPD.Util @@ -125,9 +128,10 @@ -- Additional dependencies , data-default-class , network + , safe-exceptions , utf8-string -- Test dependencies , unix - , QuickCheck >= 2.1 + , QuickCheck >= 2.10 , hspec >= 1.3 diff --git a/src/Network/MPD/Applicative.hs b/src/Network/MPD/Applicative.hs --- a/src/Network/MPD/Applicative.hs +++ b/src/Network/MPD/Applicative.hs @@ -31,13 +31,21 @@ -- * Reflection , module Network.MPD.Applicative.Reflection + +-- * Mounting +, module Network.MPD.Applicative.Mount + +-- * Client-to-client +, module Network.MPD.Applicative.ClientToClient ) where import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.ClientToClient import Network.MPD.Applicative.Connection import Network.MPD.Applicative.CurrentPlaylist import Network.MPD.Applicative.Database +import Network.MPD.Applicative.Mount import Network.MPD.Applicative.Output import Network.MPD.Applicative.PlaybackControl import Network.MPD.Applicative.PlaybackOptions diff --git a/src/Network/MPD/Applicative/CurrentPlaylist.hs b/src/Network/MPD/Applicative/CurrentPlaylist.hs --- a/src/Network/MPD/Applicative/CurrentPlaylist.hs +++ b/src/Network/MPD/Applicative/CurrentPlaylist.hs @@ -29,9 +29,14 @@ , playlistSearch , plChanges , plChangesPosId + , prio + , prioId , shuffle , swap , swapId + , addTagId + , clearTagId + , rangeId ) where import Network.MPD.Commands.Arg hiding (Command) @@ -135,6 +140,14 @@ = Right (x', Id y') | otherwise = Left "" +-- | Set the priority of the specified songs. +prio :: Priority -> (Position, Position) -> Command () +prio p range = Command emptyResponse ["prio" <@> p <++> range] + +-- | Set priority by song id. +prioId :: Priority -> Id -> Command () +prioId p ids = Command emptyResponse ["prioid" <@> p <++> ids] + -- | Shuffle the current playlist. -- Optionally restrict to a range of songs. shuffle :: Maybe (Position, Position) -> Command () @@ -147,3 +160,17 @@ -- | Swap songs by id. swapId :: Id -> Id -> Command () swapId id1 id2 = Command emptyResponse ["swapid" <@> id1 <++> id2] + +-- | Add tag to specified (remote) song. +addTagId :: Id -> Metadata -> Value -> Command () +addTagId id' tag val = Command emptyResponse ["addtagid" <@> id' <++> tag <++> val] + +-- | Remove tag from specified (remote) song. +clearTagId :: Id -> Metadata -> Command () +clearTagId id' tags = Command emptyResponse ["cleartagid" <@> id' <++> tags] + +-- | Specify portion of song that shall be played. +-- Both ends of the range are optional; omitting both plays everything. +rangeId :: Id -> (Maybe Double, Maybe Double) -> Command () +rangeId id' (mbStart, mbEnd) = Command emptyResponse ["rangeid " ++ show id' ++ " " ++ arg ] + where arg = maybe "" show mbStart ++ ":" ++ maybe "" show mbEnd diff --git a/src/Network/MPD/Applicative/Database.hs b/src/Network/MPD/Applicative/Database.hs --- a/src/Network/MPD/Applicative/Database.hs +++ b/src/Network/MPD/Applicative/Database.hs @@ -77,6 +77,11 @@ lsInfo :: Path -> Command [LsResult] lsInfo = lsInfo' "lsinfo" +-- | Read comments from the file at the specified path. +readComments :: Path -> Command [(String, String)] +readComments uri = Command p ["readcomments" <@> uri] + where p = map decodePair . toAssocList <$> getResponse + -- | Like 'find' but with inexact matching. search :: Query -> Command [Song] search q = Command p ["search" <@> q] diff --git a/src/Network/MPD/Applicative/Internal.hs b/src/Network/MPD/Applicative/Internal.hs --- a/src/Network/MPD/Applicative/Internal.hs +++ b/src/Network/MPD/Applicative/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} {- | Module : Network.MPD.Applicative.Internal @@ -38,6 +39,7 @@ import Network.MPD.Core hiding (getResponse) import qualified Network.MPD.Core as Core import Control.Monad.Error +import qualified Control.Monad.Fail as Fail -- | A line-oriented parser that returns a value along with any remaining input. newtype Parser a @@ -45,9 +47,11 @@ deriving Functor instance Monad Parser where - fail = Parser . const . Left return a = Parser $ \input -> Right (a, input) p1 >>= p2 = Parser $ \input -> runParser p1 input >>= uncurry (runParser . p2) + +instance Fail.MonadFail Parser where + fail = Prelude.fail instance Applicative Parser where pure = return diff --git a/src/Network/MPD/Applicative/Mount.hs b/src/Network/MPD/Applicative/Mount.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Mount.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Mount +Copyright : (c) Joachim Fasting 2014 +License : MIT + +Maintainer : joachifm@fastmail.fm +Stability : stable +Portability : unportable + +Mounting remote storage. +-} + +module Network.MPD.Applicative.Mount + ( mount + , unmount + , listMounts + , listNeighbors + ) where + +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Applicative.Internal +import Network.MPD.Util + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +mount :: String -- Path + -> String -- Uri + -> Command () +mount p u = Command emptyResponse ["mount" <@> p <++> u] + +unmount :: String -- Path + -> Command () +unmount p = Command emptyResponse ["unmount" <@> p] + +listMounts :: Command [(String, String)] -- (Path, Uri) +listMounts = Command (liftParser p) ["listmounts"] + where + p = mapM parseMount . splitGroups ["mount"] . toAssocList + parseMount :: [(ByteString, ByteString)] -> Either String (String, String) + parseMount [("mount", mo), ("storage", st)] = Right (UTF8.toString mo, UTF8.toString st) + parseMount _ = Left "Unexpected result from listMounts" + +listNeighbors :: Command [(String, String)] -- (Uri, Name) +listNeighbors = Command (liftParser p) ["listneighbors"] + where + p = mapM parseNeighbor . splitGroups ["neighbor"] . toAssocList + parseNeighbor :: [(ByteString, ByteString)] -> Either String (String, String) + parseNeighbor [("neighbor", ne), ("name", na)] = Right (UTF8.toString ne, UTF8.toString na) + parseNeighbor _ = Left "Unexpected result from listNeighbors" diff --git a/src/Network/MPD/Applicative/Output.hs b/src/Network/MPD/Applicative/Output.hs --- a/src/Network/MPD/Applicative/Output.hs +++ b/src/Network/MPD/Applicative/Output.hs @@ -15,6 +15,7 @@ module Network.MPD.Applicative.Output ( disableOutput , enableOutput + , toggleOutput , outputs ) where @@ -30,6 +31,10 @@ -- | Turn on output. enableOutput :: Int -> Command () enableOutput n = Command emptyResponse ["enableoutput" <@> n] + +-- | Toggle output. +toggleOutput :: Int -> Command () +toggleOutput n = Command emptyResponse ["toggleoutput" <@> n] -- | Get information about all available output devices. outputs :: Command [Device] diff --git a/src/Network/MPD/Applicative/PlaybackControl.hs b/src/Network/MPD/Applicative/PlaybackControl.hs --- a/src/Network/MPD/Applicative/PlaybackControl.hs +++ b/src/Network/MPD/Applicative/PlaybackControl.hs @@ -50,11 +50,11 @@ previous = Command emptyResponse ["previous"] -- | Seek to time in the song at the given position. -seek :: Position -> Seconds -> Command () +seek :: Position -> FractionalSeconds -> Command () seek pos time = Command emptyResponse ["seek" <@> pos <++> time] -- | Seek to time in the song with the given id. -seekId :: Id -> Seconds -> Command () +seekId :: Id -> FractionalSeconds -> Command () seekId id' time = Command emptyResponse ["seekid" <@> id' <++> time] -- | Stop playback. diff --git a/src/Network/MPD/Applicative/PlaybackOptions.hs b/src/Network/MPD/Applicative/PlaybackOptions.hs --- a/src/Network/MPD/Applicative/PlaybackOptions.hs +++ b/src/Network/MPD/Applicative/PlaybackOptions.hs @@ -50,8 +50,8 @@ repeat :: Bool -> Command () repeat f = Command emptyResponse ["repeat" <@> f] --- | Set volume in percent. -setVolume :: Int -> Command () +-- | Set volume. +setVolume :: Volume -> Command () setVolume vol = Command emptyResponse ["setvol" <@> vol] -- | Toggle single mode. diff --git a/src/Network/MPD/Applicative/Status.hs b/src/Network/MPD/Applicative/Status.hs --- a/src/Network/MPD/Applicative/Status.hs +++ b/src/Network/MPD/Applicative/Status.hs @@ -96,7 +96,7 @@ "nextsongid" -> int $ \x -> a { stNextSongID = Just $ Id x } "time" -> time $ \x -> a { stTime = Just x } "elapsed" -> frac $ \x -> a { stTime = fmap ((x,) . snd) (stTime a) } - "duration" -> frac $ \x -> a { stTime = fmap ((, round x) . fst) (stTime a) } + "duration" -> frac $ \x -> a { stTime = fmap ((,x) . fst) (stTime a) } "bitrate" -> int $ \x -> a { stBitrate = Just x } "xfade" -> num $ \x -> a { stXFadeWidth = x } "mixrampdb" -> frac $ \x -> a { stMixRampdB = x } @@ -116,7 +116,7 @@ -- errors. audio f = Right $ maybe a f (parseTriple ':' parseNum v) - time f = case parseFrac *** parseNum $ breakChar ':' v of + time f = case parseFrac *** parseFrac $ breakChar ':' v of (Just a_, Just b) -> (Right . f) (a_, b) _ -> unexpectedPair @@ -127,8 +127,8 @@ _ -> unexpectedPair -- A volume of -1 indicates an audio backend w/o a mixer - vol f = case parseNum v of + vol f = case (parseNum v :: Maybe Int) of Nothing -> unexpectedPair -- does it really make sense to fail here? when does this occur? Just v' -> (Right . f) (g v') where g n | n < 0 = Nothing - | otherwise = Just (n::Int) + | otherwise = Just $ fromIntegral n diff --git a/src/Network/MPD/Commands.hs b/src/Network/MPD/Commands.hs --- a/src/Network/MPD/Commands.hs +++ b/src/Network/MPD/Commands.hs @@ -23,15 +23,18 @@ , Value , ObjectType(..) , Seconds + , FractionalSeconds , Decibels - , State(..) + , PlaybackState(..) , Subsystem(..) , ReplayGainMode(..) , Count(..) , LsResult(..) , Device(..) , Song(..) + , Priority(..) , Position + , Volume , Id(..) , sgGetTag , sgAddTag @@ -50,6 +53,7 @@ , module Network.MPD.Commands.Output , module Network.MPD.Commands.Reflection , module Network.MPD.Commands.ClientToClient + , module Network.MPD.Commands.Mount ) where import Network.MPD.Commands.Query @@ -66,3 +70,4 @@ import Network.MPD.Commands.Output import Network.MPD.Commands.Reflection import Network.MPD.Commands.ClientToClient +import Network.MPD.Commands.Mount diff --git a/src/Network/MPD/Commands/CurrentPlaylist.hs b/src/Network/MPD/Commands/CurrentPlaylist.hs --- a/src/Network/MPD/Commands/CurrentPlaylist.hs +++ b/src/Network/MPD/Commands/CurrentPlaylist.hs @@ -28,9 +28,14 @@ , playlistSearch , plChanges , plChangesPosId + , prio + , prioId , shuffle , swap , swapId + , addTagId + , clearTagId + , rangeId ) where import qualified Network.MPD.Applicative.Internal as A @@ -114,6 +119,14 @@ plChangesPosId :: MonadMPD m => Integer -> m [(Position, Id)] plChangesPosId = A.runCommand . A.plChangesPosId +-- | Set the priority of the specified songs. +prio :: MonadMPD m => Priority -> (Position, Position) -> m () +prio p = A.runCommand . A.prio p + +-- | Set priority by song id. +prioId :: MonadMPD m => Priority -> Id -> m () +prioId p = A.runCommand . A.prioId p + -- | Shuffle the playlist. shuffle :: MonadMPD m => Maybe (Position, Position) -- ^ Optional range (start, end) -> m () @@ -126,3 +139,16 @@ -- | Swap the positions of two songs (Id version) swapId :: MonadMPD m => Id -> Id -> m () swapId id1 = A.runCommand . A.swapId id1 + +-- | Add tag to (remote) song. +addTagId :: (MonadMPD m) => Id -> Metadata -> Value -> m () +addTagId id' tag = A.runCommand . A.addTagId id' tag + +-- | Remove tag from (remote) song. +clearTagId :: (MonadMPD m) => Id -> Metadata -> m () +clearTagId id' = A.runCommand . A.clearTagId id' + +-- | Specify portion of song that shall be played. +-- Both ends of the range are optional; omitting both plays everything. +rangeId :: (MonadMPD m) => Id -> (Maybe Double, Maybe Double) -> m () +rangeId id' = A.runCommand . A.rangeId id' diff --git a/src/Network/MPD/Commands/Database.hs b/src/Network/MPD/Commands/Database.hs --- a/src/Network/MPD/Commands/Database.hs +++ b/src/Network/MPD/Commands/Database.hs @@ -20,6 +20,7 @@ , listAll , listAllInfo , lsInfo + , readComments , search , update , rescan @@ -60,6 +61,10 @@ -- | Non-recursively list the contents of a database directory. lsInfo :: MonadMPD m => Path -> m [LsResult] lsInfo = A.runCommand . A.lsInfo + +-- | Read comments from file at path. +readComments :: MonadMPD m => Path -> m [(String, String)] +readComments = A.runCommand . A.readComments -- | Search the database using case insensitive matching. search :: MonadMPD m => Query -> m [Song] diff --git a/src/Network/MPD/Commands/Mount.hs b/src/Network/MPD/Commands/Mount.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Mount.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Mount +Copyright : (c) Joachim Fasting 2014 +License : MIT + +Maintainer : joachifm@fastmail.fm +Stability : stable +Portability : unportable + +Mounting remote storage. +-} + +module Network.MPD.Commands.Mount + ( mount + , unmount + , listMounts + , listNeighbors + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Mount as A +import Network.MPD.Core + +mount :: (MonadMPD m) => String -> String -> m () +mount p = A.runCommand . A.mount p + +unmount :: (MonadMPD m) => String -> m () +unmount = A.runCommand . A.unmount + +listMounts :: (MonadMPD m) => m [(String, String)] +listMounts = A.runCommand A.listMounts + +listNeighbors :: (MonadMPD m) => m [(String, String)] +listNeighbors = A.runCommand A.listNeighbors diff --git a/src/Network/MPD/Commands/Output.hs b/src/Network/MPD/Commands/Output.hs --- a/src/Network/MPD/Commands/Output.hs +++ b/src/Network/MPD/Commands/Output.hs @@ -15,6 +15,7 @@ module Network.MPD.Commands.Output ( disableOutput , enableOutput + , toggleOutput , outputs ) where @@ -30,6 +31,10 @@ -- | Turn on an output device. enableOutput :: MonadMPD m => Int -> m () enableOutput = A.runCommand . A.enableOutput + +-- | Toggle output device. +toggleOutput :: MonadMPD m => Int -> m () +toggleOutput = A.runCommand . A.toggleOutput -- | Retrieve information for all output devices. outputs :: MonadMPD m => m [Device] diff --git a/src/Network/MPD/Commands/PlaybackControl.hs b/src/Network/MPD/Commands/PlaybackControl.hs --- a/src/Network/MPD/Commands/PlaybackControl.hs +++ b/src/Network/MPD/Commands/PlaybackControl.hs @@ -49,11 +49,11 @@ previous = A.runCommand A.previous -- | Seek to some point in a song. -seek :: MonadMPD m => Position -> Seconds -> m () +seek :: MonadMPD m => Position -> FractionalSeconds -> m () seek pos = A.runCommand . A.seek pos -- | Seek to some point in a song (id version) -seekId :: MonadMPD m => Id -> Seconds -> m () +seekId :: MonadMPD m => Id -> FractionalSeconds -> m () seekId id' = A.runCommand . A.seekId id' -- | Stop playing. diff --git a/src/Network/MPD/Commands/PlaybackOptions.hs b/src/Network/MPD/Commands/PlaybackOptions.hs --- a/src/Network/MPD/Commands/PlaybackOptions.hs +++ b/src/Network/MPD/Commands/PlaybackOptions.hs @@ -46,8 +46,8 @@ repeat :: MonadMPD m => Bool -> m () repeat = A.runCommand . A.repeat --- | Set the volume (0-100 percent). -setVolume :: MonadMPD m => Int -> m () +-- | Set the volume. +setVolume :: MonadMPD m => Volume -> m () setVolume = A.runCommand . A.setVolume -- | Set single mode diff --git a/src/Network/MPD/Commands/Types.hs b/src/Network/MPD/Commands/Types.hs --- a/src/Network/MPD/Commands/Types.hs +++ b/src/Network/MPD/Commands/Types.hs @@ -18,8 +18,9 @@ , Value(..) , ObjectType(..) , Seconds + , FractionalSeconds , Decibels - , State(..) + , PlaybackState(..) , Subsystem(..) , ReplayGainMode(..) , Count(..) @@ -28,8 +29,10 @@ , Song(..) , Position , Id(..) + , Priority(..) , sgGetTag , sgAddTag + , Volume(..) , Stats(..) , Status(..) , def @@ -138,15 +141,18 @@ instance MPDArg ObjectType where prep SongObj = Args ["song"] +type FractionalSeconds = Double + type Seconds = Integer type Decibels = Integer -- | Represents the different playback states. -data State = Playing - | Stopped - | Paused - deriving (Show, Eq) +data PlaybackState + = Playing + | Stopped + | Paused + deriving (Eq, Enum, Ord, Bounded, Show) -- | Represents the various MPD subsystems. data Subsystem @@ -161,7 +167,7 @@ | StickerS -- ^ Sticker database | SubscriptionS -- ^ Subscription | MessageS -- ^ Message on subscribed channel - deriving (Eq, Show) + deriving (Eq, Enum, Ord, Bounded, Show) instance MPDArg Subsystem where prep DatabaseS = Args ["database"] @@ -180,7 +186,7 @@ = Off -- ^ Disable replay gain | TrackMode -- ^ Per track mode | AlbumMode -- ^ Per album mode - deriving (Eq, Show) + deriving (Eq, Enum, Ord, Bounded, Show) instance MPDArg ReplayGainMode where prep Off = Args ["off"] @@ -246,6 +252,12 @@ instance (MPDArg Id) where prep (Id x) = prep x +newtype Priority = Priority Int + deriving (Eq, Show) + +instance (MPDArg Priority) where + prep (Priority x) = prep x + -- | Get list of specific tag type sgGetTag :: Metadata -> Song -> Maybe [Value] sgGetTag meta s = M.lookup meta $ sgTags s @@ -280,13 +292,56 @@ instance Default Stats where def = defaultStats +-- | Volume values. +-- +-- Values of this type are always in the range 0-100. +-- +-- Arithmetic on volumes has the property that: +-- +-- @current + new = 100 if current + new > 100@ +-- +-- @current - new = 0 if current - new < 0@ +-- +-- but @current / 0@ still yields a division by zero exception. +newtype Volume = Volume Int deriving (Eq, Ord, Show) + +instance Enum Volume where + toEnum = Volume . min 100 . max 0 + fromEnum (Volume x) = x + +instance Bounded Volume where + minBound = 0 + maxBound = 100 + +instance Num Volume where + Volume x + Volume y = toEnum (x + y) + Volume x - Volume y = toEnum (x - y) + Volume x * Volume y = toEnum (x * y) + + negate = id + abs = id + signum = const 0 + + fromInteger = toEnum . fromIntegral + +instance Integral Volume where + quotRem (Volume x) (Volume y) = + let (x', y') = x `quotRem` y in (Volume x', Volume y') + toInteger (Volume x) = fromIntegral x + +instance Real Volume where + toRational (Volume x) = toRational x + +instance MPDArg Volume where + prep (Volume x) = prep x + -- | Container for MPD status. data Status = - Status { stState :: State + Status { stState :: PlaybackState -- | A percentage (0-100). -- -- 'Nothing' indicates that the output lacks mixer support. - , stVolume :: Maybe Int + , stVolume :: Maybe Volume , stRepeat :: Bool , stRandom :: Bool -- | A value that is incremented by the server every time the @@ -303,7 +358,7 @@ -- | Next song's playlist ID. , stNextSongID :: Maybe Id -- | Time elapsed\/total time of playing song (if any). - , stTime :: Maybe (Double, Seconds) + , stTime :: Maybe (FractionalSeconds, FractionalSeconds) -- | Bitrate (in kilobytes per second) of playing song (if any). , stBitrate :: Maybe Int -- | Crossfade time. diff --git a/src/Network/MPD/Core.hs b/src/Network/MPD/Core.hs --- a/src/Network/MPD/Core.hs +++ b/src/Network/MPD/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings, CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Module : Network.MPD.Core @@ -28,12 +28,26 @@ import Data.Char (isDigit) import Control.Applicative (Applicative(..), (<$>), (<*)) import qualified Control.Exception as E +import Control.Exception.Safe (catch, catchAny) import Control.Monad (ap, unless) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.Reader (ReaderT(..), ask) import Control.Monad.State (StateT, MonadIO(..), modify, gets, evalStateT) import qualified Data.Foldable as F -import Network (PortID(..), withSocketsDo, connectTo) +import System.IO (IOMode(..)) +import Network.Socket + ( SockAddr(..) + , addrAddress + , addrFamily + , addrProtocol + , addrSocketType + , connect + , defaultHints + , getAddrInfo + , socket + , socketToHandle + , withSocketsDo + ) import System.IO (Handle, hPutStrLn, hReady, hClose, hFlush) import System.IO.Error (isEOFError, tryIOError, ioeGetErrorType) import Text.Printf (printf) @@ -105,16 +119,15 @@ mpdOpen = MPD $ do (host, port) <- ask runMPD close - mHandle <- liftIO (safeConnectTo host port) + addr:_ <- liftIO $ getAddrInfo (Just defaultHints) (Just host) (Just $ show port) + sock <- liftIO $ socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + mHandle <- liftIO (safeConnectTo (sock,(addrAddress addr))) modify (\st -> st { stHandle = mHandle }) F.forM_ mHandle $ \_ -> runMPD checkConn >>= (`unless` runMPD close) where - safeConnectTo host@('/':_) _ = - (Just <$> connectTo "" (UnixSocket host)) - `E.catch` (\(_ :: E.SomeException) -> return Nothing) - safeConnectTo host port = - (Just <$> connectTo host (PortNumber $ fromInteger port)) - `E.catch` (\(_ :: E.SomeException) -> return Nothing) + safeConnectTo (sock,addr) = + (connect sock addr) >> (Just <$> socketToHandle sock ReadWriteMode) + `catchAny` const (return Nothing) checkConn = do singleMsg <- send "" let [msg] = singleMsg @@ -151,7 +164,7 @@ where sendClose handle = (hPutStrLn handle "close" >> hReady handle >> hClose handle >> return Nothing) - `E.catch` handler + `catch` handler handler err | isEOFError err = return Nothing diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -20,14 +20,17 @@ import qualified Data.Map as M import Data.Time import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen import Network.MPD.Commands.Types import Data.ByteString (ByteString) import qualified Data.ByteString.UTF8 as UTF8 + instance Arbitrary ByteString where - arbitrary = UTF8.fromString <$> arbitrary + arbitrary = UTF8.fromString <$> listOf1 arbitraryPrintableChar -- No longer provided by QuickCheck 2 -- two :: Monad m => m a -> m (a, a) @@ -46,7 +49,7 @@ -- MPD fields can't contain newlines and the parser skips initial spaces. field :: Gen String -field = (filter (/= '\n') . dropWhile isSpace) <$> arbitrary +field = (filter (/= '\n') . dropWhile isSpace) <$> listOf1 arbitraryPrintableChar fieldBS :: Gen ByteString fieldBS = UTF8.fromString <$> field diff --git a/tests/ParserSpec.hs b/tests/ParserSpec.hs --- a/tests/ParserSpec.hs +++ b/tests/ParserSpec.hs @@ -41,25 +41,25 @@ -- 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_parseIso8601 :: UTCTime -> Expectation +prop_parseIso8601 t = Just t `shouldBe` (parseIso8601 . UTF8.fromString . formatIso8601) t -prop_parseCount :: Count -> Bool -prop_parseCount c = Right c == (parseCount . map UTF8.fromString . lines . unparse) c +prop_parseCount :: Count -> Expectation +prop_parseCount c = Right c `shouldBe` (parseCount . map UTF8.fromString . lines . unparse) c -prop_parseOutputs :: [Device] -> Bool +prop_parseOutputs :: [Device] -> Expectation prop_parseOutputs ds = - Right ds == (parseOutputs . map UTF8.fromString . lines . concatMap unparse) ds + Right ds `shouldBe` (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 +prop_parseSong :: Song -> Expectation +prop_parseSong s = Right (sortTags s) `shouldBe` 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 +prop_parseStats :: Stats -> Expectation +prop_parseStats s = Right s `shouldBe` (parseStats . map UTF8.fromString . lines . unparse) s diff --git a/tests/StringConn.hs b/tests/StringConn.hs --- a/tests/StringConn.hs +++ b/tests/StringConn.hs @@ -1,10 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wwarn #-} --- | Module : StringConn +-- | +-- Module : StringConn -- Copyright : (c) Ben Sinclair 2005-2009 -- License : MIT (see LICENSE) --- Maintainer : bsinclai@turing.une.edu.au -- Stability : alpha -- -- A testing scaffold for MPD commands diff --git a/tests/TypeSpec.hs b/tests/TypeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/TypeSpec.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module TypeSpec (main, spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import qualified Test.QuickCheck as QC + +import Network.MPD.Commands.Types (Volume) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Volume arithmetic is closed over 0-100" $ do + prop "for addition" prop_volume_add + prop "for subtraction" prop_volume_sub + prop "for multiplication" prop_volume_mul + prop "for division" prop_volume_div + +instance QC.Arbitrary Volume where + arbitrary = QC.elements [0..100] + +inRange :: Ord a => a -> a -> a -> Bool +inRange l h x = l <= x && x <= h + +prop_volume_arith op cur new = inRange 0 100 ((cur :: Volume) `op` new) + +prop_volume_add = prop_volume_arith (+) +prop_volume_sub = prop_volume_arith (-) +prop_volume_mul = prop_volume_arith (*) +prop_volume_div cur new = new /= 0 QC.==> prop_volume_arith div cur new diff --git a/tests/Unparse.hs b/tests/Unparse.hs --- a/tests/Unparse.hs +++ b/tests/Unparse.hs @@ -53,12 +53,16 @@ , "db_update: " ++ show (stsDbUpdate s) ] +instance Unparse Volume where + unparse (Volume x) = show x + instance Unparse Status where unparse s = unlines $ [ "state: " ++ (case stState s of Playing -> "play" Paused -> "pause" _ -> "stop") - , "volume: " ++ maybe "-1" show (stVolume s) + , "volume: " ++ maybe "-1" unparse (stVolume s) + , "volume: " ++ unparse (stVolume s) , "repeat: " ++ showBool (stRepeat s) , "random: " ++ showBool (stRandom s) , "playlist: " ++ show (stPlaylistVersion s)