module Network.MPD.Core (
MPD(..), Conn(..), MPDError(..), ACKType(..), Response,
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 Conn = Conn { cOpen :: IO ()
, cClose :: IO ()
, cSend :: String -> IO (Response String)
, cGetPW :: IO (Maybe String) }
data MPDError = NoMPD
| TimedOut
| Unexpected String
| Custom String
| ACK ACKType String
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
data ACKType = InvalidArgument
| InvalidPassword
| Auth
| UnknownCommand
| FileNotFound
| PlaylistMax
| System
| PlaylistLoad
| Busy
| NotPlaying
| FileExists
| UnknownACK
deriving (Eq)
type Response a = Either MPDError a
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
reconnect :: MPD ()
reconnect = MPD $ \conn -> Right `liftM` cOpen conn
kill :: MPD ()
kill = getResponse "kill" `catchError` cleanup >> return ()
where
cleanup TimedOut = MPD $ \conn -> cClose conn >> return (Right [])
cleanup x = throwError x >> return []
close :: MPD ()
close = MPD $ \conn -> cClose conn >> return (Right ())
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
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"
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
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
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
between f g xs = let (_, y) = break f xs
in break g (drop 1 y)