libmpd-0.3.0: Network/MPD/Core.hs
{-# LANGUAGE MultiParamTypeClasses #-}
-- | Module : Network.MPD.Core
-- Copyright : (c) Ben Sinclair 2005-2008
-- License : LGPL (see LICENSE)
-- Maintainer : bsinclai@turing.une.edu.au
-- Stability : alpha
-- Portability : not Haskell 98 (uses MultiParamTypeClasses)
--
-- Core functionality.
module Network.MPD.Core (
-- * Data types
MPD(..), Conn(..), MPDError(..), ACKType(..), Response,
-- * Interacting
getResponse, close, reconnect, kill,
) where
import Control.Monad (liftM)
import Control.Monad.Error (Error(..), MonadError(..))
import Control.Monad.Trans
import Prelude hiding (repeat)
import Data.List (isPrefixOf)
import Data.Maybe
import System.IO
--
-- Data types.
--
-- A class of transports with which to connect to MPD servers.
data Conn = Conn { cOpen :: IO () -- Open connection
, cClose :: IO () -- Close connection
, cSend :: String -> IO (Response String) -- Write to connection
, cGetPW :: IO (Maybe String) } -- Password function
-- | The MPDError type is used to signal errors, both from the MPD and
-- otherwise.
data MPDError = NoMPD -- ^ MPD not responding
| TimedOut -- ^ The connection timed out
| Unexpected String -- ^ MPD returned an unexpected response.
-- This is a bug, either in the library or
-- in MPD itself.
| Custom String -- ^ Used for misc. errors
| ACK ACKType String -- ^ ACK type and a message from the
-- server
deriving Eq
instance Show MPDError where
show NoMPD = "Could not connect to MPD"
show TimedOut = "MPD connection timed out"
show (Unexpected s) = "MPD returned an unexpected response: " ++ s
show (Custom s) = s
show (ACK _ s) = s
-- | Represents various MPD errors (aka. ACKs).
data ACKType = InvalidArgument -- ^ Invalid argument passed (ACK 2)
| InvalidPassword -- ^ Invalid password supplied (ACK 3)
| Auth -- ^ Authentication required (ACK 4)
| UnknownCommand -- ^ Unknown command (ACK 5)
| FileNotFound -- ^ File or directory not found ACK 50)
| PlaylistMax -- ^ Playlist at maximum size (ACK 51)
| System -- ^ A system error (ACK 52)
| PlaylistLoad -- ^ Playlist loading failed (ACK 53)
| Busy -- ^ Update already running (ACK 54)
| NotPlaying -- ^ An operation requiring playback
-- got interrupted (ACK 55)
| FileExists -- ^ File already exists (ACK 56)
| UnknownACK -- ^ An unknown ACK (aka. bug)
deriving (Eq)
-- | A response is either an 'MPDError' or some result.
type Response a = Either MPDError a
-- Export the type name but not the constructor or the field.
-- | The MPD monad is basically a reader and error monad
-- combined.
--
-- To use the error throwing\/catching capabilities:
--
-- > import Control.Monad.Error
--
-- To run IO actions within the MPD monad:
--
-- > import Control.Monad.Trans
data MPD a = MPD { runMPD :: Conn -> IO (Response a) }
instance Functor MPD where
fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn
instance Monad MPD where
return a = MPD $ \_ -> return $ Right a
m >>= f = MPD $ \conn -> runMPD m conn >>=
either (return . Left) (flip runMPD conn . f)
fail err = MPD $ \_ -> return . Left $ Custom err
instance MonadIO MPD where
liftIO m = MPD $ \_ -> liftM Right m
instance MonadError MPDError MPD where
throwError e = MPD $ \_ -> return (Left e)
catchError m h = MPD $ \conn ->
runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
instance Error MPDError where
noMsg = Custom "An error occurred"
strMsg = Custom
--
-- Basic connection functions
--
-- | Refresh a connection.
reconnect :: MPD ()
reconnect = MPD $ \conn -> Right `liftM` cOpen conn
-- | Kill the server. Obviously, the connection is then invalid.
kill :: MPD ()
kill = getResponse "kill" `catchError` cleanup >> return ()
where
cleanup TimedOut = MPD $ \conn -> cClose conn >> return (Right [])
cleanup x = throwError x >> return []
-- | Close an MPD connection.
close :: MPD ()
close = MPD $ \conn -> cClose conn >> return (Right ())
--
-- Sending messages and handling responses.
--
-- | Send a command to the MPD and return the result.
getResponse :: String -> MPD [String]
getResponse cmd = MPD f
where
f conn = catchAuth . either Left parseResponse =<< cSend conn cmd
where
catchAuth (Left (ACK Auth _)) = tryPassword conn (f conn)
catchAuth x = return x
-- Send a password to MPD and run an action on success.
tryPassword :: Conn -> IO (Response a) -> IO (Response a)
tryPassword conn cont = do
resp <- cGetPW conn >>= maybe failAuth (cSend conn . ("password " ++))
case resp of
Left e -> return $ Left e
Right x -> either (return . Left) (const cont) $ parseResponse x
where failAuth = return . Left $ ACK Auth "Password required"
-- Consume response and return a Response.
parseResponse :: String -> Response [String]
parseResponse s | null xs = Left $ NoMPD
| isPrefixOf "ACK" (head xs) = Left $ parseAck s
| otherwise = Right $ takeWhile ("OK" /=) xs
where xs = lines s
-- Turn MPD ACK into the corresponding 'MPDError'
parseAck :: String -> MPDError
parseAck s = ACK ack msg
where
ack = case code of
"2" -> InvalidArgument
"3" -> InvalidPassword
"4" -> Auth
"5" -> UnknownCommand
"50" -> FileNotFound
"51" -> PlaylistMax
"52" -> System
"53" -> PlaylistLoad
"54" -> Busy
"55" -> NotPlaying
"56" -> FileExists
_ -> UnknownACK
(code, _, msg) = splitAck s
-- Break an ACK into (error code, current command, message).
-- ACKs are of the form:
-- ACK [error@command_listNum] {current_command} message_text\n
splitAck :: String -> (String, String, String)
splitAck s = (code, cmd, msg)
where (code, notCode) = between (== '[') (== '@') s
(cmd, notCmd) = between (== '{') (== '}') notCode
msg = drop 1 . snd $ break (== ' ') notCmd
-- take whatever is between 'f' and 'g'.
between f g xs = let (_, y) = break f xs
in break g (drop 1 y)