Prim.hs

   1 {-
   2     libmpd for Haskell, an MPD client library.
   3     Copyright (C) 2005  Ben Sinclair <bsinclai@turing.une.edu.au>
   4
   5     This library is free software; you can redistribute it and/or
   6     modify it under the terms of the GNU Lesser General Public
   7     License as published by the Free Software Foundation; either
   8     version 2.1 of the License, or (at your option) any later version.
   9
  10     This library is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13     Lesser General Public License for more details.
  14
  15     You should have received a copy of the GNU Lesser General Public
  16     License along with this library; if not, write to the Free Software
  17     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  18 -}
  19
  20 -- | Module    : Prim
  21 -- Copyright   : (c) Ben Sinclair 2005
  22 -- License     : LGPL
  23 -- Maintainer  : bsinclai@turing.une.edu.au
  24 -- Stability   : alpha
  25 -- Portability : Haskell 98
  26 --
  27 -- MPD client library.
  28
  29 module Prim (
  30
  31              -- * Data types
  32              MPD, ACK(..),
  33
  34              -- * Running an action
  35              withMPDEx,
  36
  37              -- * Errors
  38              throwMPD, catchMPD,
  39
  40              -- * Interacting
  41              getResponse, clearerror, close, reconnect, kill,
  42
  43              module Control.Monad.Trans
  44             ) where
  45
  46 import Control.Monad (liftM, unless)
  47 import Control.Exception (finally)
  48 import Control.Monad.Trans
  49 import Prelude hiding (repeat)
  50 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  51 import Data.List (isPrefixOf)
  52 import Data.Maybe
  53 import Network
  54 import System.IO
  55 import System.IO.Error (isEOFError)
  56
  57 --
  58 -- Data types.
  59 --
  60
  61 -- | A connection to an MPD server.
  62 -- don't export the field names.
  63 data Connection = Conn { connHostName :: String
  64                        , connPortNum  :: Integer
  65                        , connHandle   :: IORef (Maybe Handle)
  66                        , connGetPass  :: IO (Maybe String)
  67                        }
  68
  69 -- | Represents various MPD errors (aka. ACKs).
  70 data ACK = NoMPD                  -- ^ MPD not responding
  71          | TimedOut               -- ^ The connection timed out.
  72          | Auth                   -- ^ ACK [4\@0]
  73          | Busy                   -- ^ ACK [54\@0]
  74          | UnknownCommand String  -- ^ ACK [5\@0]
  75          | FileNotFound           -- ^ ACK [50\@0]
  76          | FileExists String      -- ^ ACK [56\@0]
  77          | System String          -- ^ ACK [52\@0]
  78          | PlaylistLoad           -- ^ ACK [53\@0]
  79          | NotPlaying             -- ^ ACK [55\@0]
  80          | PlaylistMax            -- ^ ACK [51\@0]
  81          | InvalidArgument String -- ^ ACK [2\@0]
  82          | InvalidPassword        -- ^ ACK [3\@0]
  83          | Custom String
  84
  85 instance Show ACK where
  86     show NoMPD               = "Could not connect to MPD"
  87     show TimedOut            = "MPD connection timed out"
  88     show Auth                = "Password needed"
  89     show Busy                = "Already updating"
  90     show (UnknownCommand s)  = s
  91     show FileNotFound        = "File or directory does not exist"
  92     show (FileExists s)      = s
  93     show (System s)          = "System error: " ++ s
  94     show PlaylistLoad        = "Failed to load playlist"
  95     show PlaylistMax         = "Playlist full"
  96     show (InvalidArgument s) = "Invalid argument: " ++ s
  97     show InvalidPassword     = "Invalid password"
  98     show NotPlaying          = "Playback stopped"
  99     show (Custom s)          = s
 100
 101 -- Export the type name but not the constructor or the field.
 102 --
 103 -- This is basically a state and an error monad combined. It's just
 104 -- nice if we can have a few custom functions that fiddle with the
 105 -- internals.
 106 newtype MPD a = MPD { runMPD :: Connection -> IO (Either ACK a) }
 107
 108 instance Functor MPD where
 109     fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn
 110
 111 instance Monad MPD where
 112     return a = MPD $ \_ -> return (Right a)
 113     m >>= f  = MPD $ \conn -> runMPD m conn >>=
 114                               either (return . Left) (flip runMPD conn . f)
 115     fail err = MPD $ \_ -> return $ Left (Custom err)
 116
 117 instance MonadIO MPD where
 118     liftIO m = MPD $ \_ -> liftM Right m
 119
 120 -- | Throw an exception.
 121 throwMPD :: ACK -> MPD ()
 122 throwMPD e = MPD $ \_ -> return (Left e)
 123
 124 -- | Catch an exception from an action.
 125 catchMPD :: MPD a -> (ACK -> MPD a) -> MPD a
 126 catchMPD m h = MPD $ \conn ->
 127     runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
 128
 129 {-
 130 --
 131 -- Basic connection functions
 132 --
 133 -}
 134
 135 -- | Run an MPD action against a server.
 136 withMPDEx :: String            -- ^ Host name.
 137           -> Integer           -- ^ Port number.
 138           -> IO (Maybe String) -- ^ An action that supplies passwords.
 139           -> MPD a             -- ^ The action to run.
 140           -> IO (Either ACK a)
 141 withMPDEx host port getpw m = do
 142     hRef <- newIORef Nothing
 143     connect host port hRef
 144     readIORef hRef >>= maybe (return $ Left NoMPD)
 145         (\_ -> finally (runMPD m (Conn host port hRef getpw)) (closeIO hRef))
 146
 147 -- Connect to an MPD server.
 148 connect :: String -> Integer -- host and port
 149         -> IORef (Maybe Handle) -> IO ()
 150 connect host port hRef =
 151     withSocketsDo $ do
 152         closeIO hRef
 153         handle <- connectTo host . PortNumber $ fromInteger port
 154         writeIORef hRef (Just handle)
 155         checkConn handle >>= flip unless (closeIO hRef)
 156
 157 -- Check that an MPD daemon is at the other end of a connection.
 158 checkConn :: Handle -> IO Bool
 159 checkConn h = isPrefixOf "OK MPD" `liftM` hGetLine h
 160
 161 -- Close a connection.
 162 closeIO :: IORef (Maybe Handle) -> IO ()
 163 closeIO hRef = do
 164     readIORef hRef >>= maybe (return ())
 165                              (\h -> hPutStrLn h "close" >> hClose h)
 166     writeIORef hRef Nothing
 167
 168 -- | Refresh a connection.
 169 reconnect :: MPD ()
 170 reconnect = MPD $ \(Conn host port hRef _) -> do
 171     connect host port hRef
 172     liftM (maybe (Left NoMPD) (const $ Right ())) (readIORef hRef)
 173
 174 -- XXX this doesn't use the password supplying feature.
 175 --
 176 -- | Kill the server. Obviously, the connection is then invalid.
 177 kill :: MPD ()
 178 kill = MPD $ \conn -> do
 179     readIORef (connHandle conn) >>=
 180         maybe (return ()) (\h -> hPutStrLn h "kill" >> hClose h)
 181     writeIORef (connHandle conn) Nothing
 182     return (Left NoMPD)
 183
 184 -- | Send a command to the MPD and return the result.
 185 getResponse :: String -> MPD [String]
 186 getResponse cmd = MPD $ \conn -> do
 187     readIORef (connHandle conn) >>=
 188         maybe (return $ Left NoMPD)
 189               (\h -> hPutStrLn h cmd >> hFlush h >>
 190                      loop h (tryPassword conn (getResponse cmd)) [])
 191     where loop h tryPw acc = do
 192               getln h (\l -> parseResponse (loop h tryPw) l acc >>= either
 193                           (\x -> case x of Auth -> tryPw; _ -> return (Left x))
 194                           (return . Right))
 195           getln h cont =
 196               catch (liftM Right $ hGetLine h) (return . Left) >>=
 197                   either (\e -> if isEOFError e then return (Left TimedOut)
 198                                                 else ioError e)
 199                          cont
 200
 201 -- Send a password to MPD and run an action on success, return an ACK
 202 -- on failure.
 203 tryPassword :: Connection
 204             -> MPD a  -- run on success
 205             -> IO (Either ACK a)
 206 tryPassword conn cont = do
 207     readIORef (connHandle conn) >>= maybe (return $ Left NoMPD)
 208         (\h -> connGetPass conn >>= maybe (return $ Left Auth)
 209                    (\pw -> do hPutStrLn h ("password " ++ pw) >> hFlush h
 210                               result <- hGetLine h
 211                               case result of "OK" -> runMPD cont conn
 212                                              _    -> tryPassword conn cont))
 213
 214 splitAck :: String -> (String, String, String)
 215 splitAck s = (take 3 prefix, code, drop 2 msg)
 216   where
 217     (_, msg)       = break (== '}') msg'
 218     (code, msg')   = break (== ' ') rest
 219     (prefix, rest) = splitAt 4 s
 220
 221 -- > parseAck "ACK [5@0] {} unknown command \"pong\"" = Custom "unknown
 222 -- command \"pong\""
 223 parseAck :: String -> ACK
 224 parseAck s = case code of
 225                   "[4@0]"  -> Auth
 226                   "[54@0]" -> Busy
 227                   "[2@0]"  -> InvalidArgument msg
 228                   "[3@0]"  -> InvalidPassword
 229                   "[51@0]" -> PlaylistMax
 230                   "[52@0]" -> System msg
 231                   "[53@0]" -> PlaylistLoad
 232                   "[55@0]" -> NotPlaying
 233                   "[5@0]"  -> UnknownCommand msg
 234                   "[50@0]" -> FileNotFound
 235                   "[56@0]" -> FileExists msg
 236                   _        -> Custom msg
 237     where (_, code, msg) = splitAck s
 238
 239 -- Consume response and return a Response.
 240 parseResponse :: ([String] -> IO (Either ACK [String]))
 241               -> String -> [String] -> IO (Either ACK [String])
 242 parseResponse f s acc
 243     | isPrefixOf "ACK" s = return $ Left (parseAck s)
 244     | isPrefixOf "OK" s  = return $ Right (reverse acc)
 245     | otherwise          = f (s:acc)
 246
 247 -- XXX this doesn't use the password supplying feature.
 248 --
 249 -- | Clear the current error message in status.
 250 clearerror :: MPD ()
 251 clearerror = MPD $ \conn -> do
 252     readIORef (connHandle conn) >>= maybe (return $ Left NoMPD)
 253         (\h -> hPutStrLn h "clearerror" >> hFlush h >> return (Right ()))
 254
 255 -- | Close an MPD connection.
 256 close :: MPD ()
 257 close = MPD $ \conn -> closeIO (connHandle conn) >> return (Right ())