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              withMPD, withMPD_,
  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          | Auth                  -- ^ ACK [4\@0]
  72          | Busy                  -- ^ ACK [54\@0]
  73          | UnknownCommand String -- ^ ACK [5\@0]
  74          | Custom String
  75
  76 instance Show ACK where
  77     show NoMPD              = "Could not connect to MPD"
  78     show Auth               = "Password needed"
  79     show Busy               = "Already updating"
  80     show (UnknownCommand s) = "Unknown command: " ++ s
  81     show (Custom s)         = s
  82
  83
  84
  85 -- Export the type name but not the constructor or the field.
  86 --
  87 -- This is basically a state and an error monad combined. It's just
  88 -- nice if we can have a few custom functions that fiddle with the
  89 -- internals.
  90 newtype MPD a = MPD { runMPD :: Connection -> IO (Either ACK a) }
  91
  92 instance Functor MPD where
  93     fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn
  94
  95 instance Monad MPD where
  96     return a = MPD $ \_ -> return (Right a)
  97     m >>= f  = MPD $ \conn -> runMPD m conn >>=
  98                               either (return . Left) (flip runMPD conn . f)
  99     fail err = MPD $ \_ -> return $ Left (Custom err)
 100
 101 instance MonadIO MPD where
 102     liftIO m = MPD $ \_ -> liftM Right m
 103
 104
 105 -- | Throw an exception.
 106 throwMPD :: ACK -> MPD ()
 107 throwMPD e = MPD $ \_ -> return (Left e)
 108
 109 -- | Catch an exception from an action.
 110 catchMPD :: MPD a -> (ACK -> MPD a) -> MPD a
 111 catchMPD m h = MPD $ \conn ->
 112     runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
 113
 114
 115 {-
 116 --
 117 -- Basic connection functions
 118 --
 119 -}
 120
 121 -- | Run an MPD action against a server.
 122 withMPD :: String            -- ^ Host name.
 123         -> Integer           -- ^ Port number.
 124         -> IO (Maybe String) -- ^ An action that supplies passwords.
 125         -> MPD a             -- ^ The action to run.
 126         -> IO (Either ACK a)
 127 withMPD host port getpw m = do
 128     hRef <- newIORef Nothing
 129     connect host port hRef
 130     readIORef hRef >>= maybe (return $ Left NoMPD)
 131         (\_ -> finally (runMPD m (Conn host port hRef getpw)) (closeIO hRef))
 132
 133 -- | Run an MPD action against a server with no provision for passwords.
 134 withMPD_ :: String -> Integer -> MPD a -> IO (Either ACK a)
 135 withMPD_ = flip (flip . withMPD) (return Nothing)
 136
 137 -- Connect to an MPD server.
 138 connect :: String -> Integer -- host and port
 139         -> IORef (Maybe Handle) -> IO ()
 140 connect host port hRef =
 141     withSocketsDo $ do
 142         closeIO hRef
 143         handle <- connectTo host . PortNumber $ fromInteger port
 144         writeIORef hRef (Just handle)
 145         checkConn handle >>= flip unless (closeIO hRef)
 146
 147 -- Check that an MPD daemon is at the other end of a connection.
 148 checkConn :: Handle -> IO Bool
 149 checkConn h = isPrefixOf "OK MPD" `liftM` hGetLine h
 150
 151 -- Close a connection.
 152 closeIO :: IORef (Maybe Handle) -> IO ()
 153 closeIO hRef = do
 154     readIORef hRef >>= maybe (return ())
 155                              (\h -> hPutStrLn h "close" >> hClose h)
 156     writeIORef hRef Nothing
 157
 158 -- Refresh a connection.
 159 reconnect :: MPD ()
 160 reconnect = MPD $ \(Conn host port hRef _) -> do
 161     connect host port hRef
 162     liftM (maybe (Left NoMPD) (const $ Right ())) (readIORef hRef)
 163
 164 -- XXX this doesn't use the password supplying feature.
 165 --
 166 -- | Kill the server. Obviously, the connection is then invalid.
 167 kill :: MPD ()
 168 kill = MPD $ \conn -> do
 169     readIORef (connHandle conn) >>=
 170         maybe (return ()) (\h -> hPutStrLn h "kill" >> hClose h)
 171     writeIORef (connHandle conn) Nothing
 172     return (Left NoMPD)
 173
 174 -- | Send a command to the MPD and return the result.
 175 getResponse :: String -> MPD [String]
 176 getResponse cmd = MPD $ \conn -> do
 177     readIORef (connHandle conn) >>=
 178         maybe (return $ Left NoMPD)
 179               (\h -> hPutStrLn h cmd >> hFlush h >>
 180                      loop h (tryPassword conn (getResponse cmd)) [])
 181     where loop h tryPw acc = do
 182               getln h (\l -> parseResponse (loop h tryPw) l acc >>= either
 183                           (\x -> case x of Auth -> tryPw; _ -> return (Left x))
 184                           (return . Right))
 185           getln h cont =
 186               catch (liftM Right $ hGetLine h) (return . Left) >>=
 187                   either (\e -> if isEOFError e then return (Left NoMPD)
 188                                                 else ioError e)
 189                          cont
 190
 191 -- Send a password to MPD and run an action on success, return an ACK
 192 -- on failure.
 193 tryPassword :: Connection
 194             -> MPD a  -- run on success
 195             -> IO (Either ACK a)
 196 tryPassword conn cont = do
 197     readIORef (connHandle conn) >>= maybe (return $ Left NoMPD)
 198         (\h -> connGetPass conn >>= maybe (return $ Left Auth)
 199                    (\pw -> do hPutStrLn h ("password " ++ pw) >> hFlush h
 200                               result <- hGetLine h
 201                               case result of "OK" -> runMPD cont conn
 202                                              _    -> tryPassword conn cont))
 203
 204 splitAck :: String -> (String, String, String)
 205 splitAck s = (take 3 prefix, code, drop 2 msg)
 206   where
 207     (_, msg)       = break (== '}') msg'
 208     (code, msg')   = break (== ' ') rest
 209     (prefix, rest) = splitAt 4 s
 210
 211 -- > parseAck "ACK [5@0] {} unknown command \"pong\"" = Custom "unknown
 212 -- command \"pong\""
 213 parseAck :: String -> ACK
 214 parseAck s = case code of
 215                   "[4@0]"  -> Auth
 216                   "[54@0]" -> Busy
 217                   _       -> Custom msg
 218     where (_, code, msg) = splitAck s
 219
 220 -- Consume response and return a Response.
 221 parseResponse :: ([String] -> IO (Either ACK [String]))
 222               -> String -> [String] -> IO (Either ACK [String])
 223 parseResponse f s acc
 224     | isPrefixOf "ACK" s = return $ Left (parseAck s)
 225     | isPrefixOf "OK" s  = return $ Right (reverse acc)
 226     | otherwise          = f (s:acc)
 227
 228 -- XXX this doesn't use the password supplying feature.
 229 --
 230 -- | Clear the current error message in status.
 231 clearerror :: MPD ()
 232 clearerror = MPD $ \conn -> do
 233     readIORef (connHandle conn) >>= maybe (return $ Left NoMPD)
 234         (\h -> hPutStrLn h "clearerror" >> hFlush h >> return (Right ()))
 235
 236 -- | Close an MPD connection.
 237 close :: MPD ()
 238 close = MPD $ \conn -> closeIO (connHandle conn) >> return (Right ())