module Network.MPD.Prim (
MPD, MPDError(..), ACKType(..), Response,
withMPDEx,
throwMPD, catchMPD,
getResponse, close, reconnect, kill,
) where
import Control.Monad (liftM, unless)
import Control.Exception (finally)
import Control.Monad.Trans
import Prelude hiding (repeat)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (isPrefixOf)
import Data.Maybe
import Network
import System.IO
import System.IO.Error (isEOFError)
data Connection = Conn { connHostName :: String
, connPortNum :: Integer
, connHandle :: IORef (Maybe Handle)
, connGetPass :: IO (Maybe String)
}
data MPDError = NoMPD
| TimedOut
| Custom String
| ACK ACKType String
instance Show MPDError where
show NoMPD = "Could not connect to MPD"
show TimedOut = "MPD connection timed out"
show (Custom s) = s
show (ACK _ s) = s
data ACKType = InvalidArgument
| InvalidPassword
| Auth
| UnknownCommand
| FileNotFound
| PlaylistMax
| System
| PlaylistLoad
| Busy
| NotPlaying
| FileExists
| UnknownACK
type Response a = Either MPDError a
newtype MPD a = MPD { runMPD :: Connection -> 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
throwMPD :: MPDError -> MPD ()
throwMPD e = MPD $ \_ -> return (Left e)
catchMPD :: MPD a -> (MPDError -> MPD a) -> MPD a
catchMPD m h = MPD $ \conn ->
runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
withMPDEx :: String
-> Integer
-> IO (Maybe String)
-> MPD a
-> IO (Response a)
withMPDEx host port getpw m = do
hRef <- newIORef Nothing
connect host port hRef
readIORef hRef >>= maybe (return $ Left NoMPD)
(\_ -> finally (runMPD m $ Conn host port hRef getpw) (closeIO hRef))
connect :: String -> Integer
-> IORef (Maybe Handle) -> IO ()
connect host port hRef =
withSocketsDo $ do
closeIO hRef
handle <- safeConnectTo host port
writeIORef hRef handle
maybe (return ()) (\h -> checkConn h >>= flip unless (closeIO hRef))
handle
safeConnectTo :: String -> Integer -> IO (Maybe Handle)
safeConnectTo host port =
catch (liftM Just $ connectTo host (PortNumber $ fromInteger port))
(const $ return Nothing)
checkConn :: Handle -> IO Bool
checkConn h = isPrefixOf "OK MPD" `liftM` hGetLine h
closeIO :: IORef (Maybe Handle) -> IO ()
closeIO hRef = do
readIORef hRef >>= maybe (return ())
(\h -> hPutStrLn h "close" >> hClose h)
writeIORef hRef Nothing
reconnect :: MPD ()
reconnect = MPD $ \(Conn host port hRef _) -> do
connect host port hRef
liftM (maybe (Left NoMPD) (const $ Right ())) (readIORef hRef)
kill :: MPD ()
kill = getResponse "kill" `catchMPD` cleanup >> return ()
where cleanup TimedOut = MPD $ \conn -> do
readIORef (connHandle conn) >>= maybe (return ()) hClose
writeIORef (connHandle conn) Nothing
return (Right [])
cleanup x = throwMPD x >> return []
close :: MPD ()
close = MPD $ \conn -> closeIO (connHandle conn) >> return (Right ())
getResponse :: String -> MPD [String]
getResponse cmd = MPD $ \conn -> respRead (sendCmd conn) reader (givePW conn)
where sendCmd conn =
readIORef (connHandle conn) >>=
maybe (return $ Left NoMPD)
(\h -> hPutStrLn h cmd >> hFlush h >> return (Right h))
reader h = getLineTO h >>= return . (either Left parseResponse)
givePW conn cont (ACK Auth _) = tryPassword conn cont
givePW _ _ ack = return (Left ack)
getLineTO :: Handle -> IO (Response String)
getLineTO h = catch (liftM Right $ hGetLine h)
(\err -> if isEOFError err then return $ Left TimedOut
else ioError err)
tryPassword :: Connection -> IO (Response a) -> IO (Response a)
tryPassword conn cont =
readIORef (connHandle conn) >>= maybe (return $ Left NoMPD) get
where
get h = connGetPass conn >>=
maybe (return . Left $ ACK Auth "Password required") (send h)
send h pw = do hPutStrLn h ("password " ++ pw) >> hFlush h
result <- hGetLine h
case result of "OK" -> cont
_ -> tryPassword conn cont
respRead :: IO (Either e a)
-> (a -> IO (Either e (Maybe b)))
-> (IO (Either e [b]) -> e -> IO (Either e [b]))
-> IO (Either e [b])
respRead sup rdr onErr = start []
where start acc = sup >>= either (return . Left) (\x -> readAll x acc)
readAll x acc =
rdr x >>= either (onErr (start acc))
(maybe result (\y -> readAll x (y:acc)))
where result = return $ Right (reverse acc)
parseResponse :: String -> Response (Maybe String)
parseResponse s | isPrefixOf "ACK" s = Left $ parseAck s
| isPrefixOf "OK" s = Right Nothing
| otherwise = Right $ Just 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)