Prim.hs

   1 {-
   2     libmpd for Haskell, an MPD client library.
   3     Copyright (C) 2005-2007  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-2007
  22 -- License     : LGPL
  23 -- Maintainer  : bsinclai@turing.une.edu.au
  24 -- Stability   : alpha
  25 -- Portability : Haskell 98
  26 --
  27 -- Core functionality.
  28
  29 module Prim (
  30              -- * Data types
  31              MPD, ACK(..), ACKType(..), Response,
  32
  33              -- * Running an action
  34              withMPDEx,
  35
  36              -- * Errors
  37              throwMPD, catchMPD,
  38
  39              -- * Interacting
  40              getResponse, clearerror, close, reconnect, kill,
  41             ) where
  42
  43 import Control.Monad (liftM, unless)
  44 import Control.Exception (finally)
  45 import Control.Monad.Trans
  46 import Prelude hiding (repeat)
  47 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
  48 import Data.List (isPrefixOf)
  49 import Data.Maybe
  50 import Network
  51 import System.IO
  52 import System.IO.Error (isEOFError)
  53
  54 --
  55 -- Data types.
  56 --
  57
  58 -- | A connection to an MPD server.
  59 -- don't export the field names.
  60 data Connection = Conn { connHostName :: String
  61                        , connPortNum  :: Integer
  62                        , connHandle   :: IORef (Maybe Handle)
  63                        , connGetPass  :: IO (Maybe String)
  64                        }
  65
  66 -- | The ACK type is used to signal errors, both from the MPD and otherwise.
  67 data ACK = NoMPD              -- ^ MPD not responding
  68          | TimedOut           -- ^ The connection timed out
  69          | Custom String      -- ^ Used for misc. errors
  70          | ACK ACKType String -- ^ ACK type and a message from the server.
  71
  72 instance Show ACK where
  73     show NoMPD      = "Could not connect to MPD"
  74     show TimedOut   = "MPD connection timed out"
  75     show (Custom s) = s
  76     show (ACK _ s)  = s
  77
  78 -- | Represents various MPD errors (aka. ACKs).
  79 data ACKType = InvalidArgument  -- ^ Invalid argument passed (ACK 2)
  80              | InvalidPassword  -- ^ Invalid password supplied (ACK 3)
  81              | Auth             -- ^ Authentication required (ACK 4)
  82              | UnknownCommand   -- ^ Unknown command (ACK 5)
  83              | FileNotFound     -- ^ File or directory not found ACK 50)
  84              | PlaylistMax      -- ^ Playlist at maximum size (ACK 51)
  85              | System           -- ^ A system error (ACK 52)
  86              | PlaylistLoad     -- ^ Playlist loading failed (ACK 53)
  87              | Busy             -- ^ Update already running (ACK 54)
  88              | NotPlaying       -- ^ An operation requiring playback
  89                                 --   got interrupted (ACK 55)
  90              | FileExists       -- ^ File already exists (ACK 56)
  91              | UnknownACK       -- ^ An unknown ACK (aka. bug)
  92
  93 -- | A response is either an ACK or some result.
  94 type Response a = Either ACK a
  95
  96 -- Export the type name but not the constructor or the field.
  97 --
  98 -- This is basically a state and an error monad combined. It's just
  99 -- nice if we can have a few custom functions that fiddle with the
 100 -- internals.
 101 newtype MPD a = MPD { runMPD :: Connection -> IO (Response a) }
 102
 103 instance Functor MPD where
 104     fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn
 105
 106 instance Monad MPD where
 107     return a = MPD $ \_ -> return (Right a)
 108     m >>= f  = MPD $ \conn -> runMPD m conn >>=
 109                               either (return . Left) (flip runMPD conn . f)
 110     fail err = MPD $ \_ -> return . Left $ Custom err
 111
 112 instance MonadIO MPD where
 113     liftIO m = MPD $ \_ -> liftM Right m
 114
 115 -- | Throw an exception.
 116 throwMPD :: ACK -> MPD ()
 117 throwMPD e = MPD $ \_ -> return (Left e)
 118
 119 -- | Catch an exception from an action.
 120 catchMPD :: MPD a -> (ACK -> MPD a) -> MPD a
 121 catchMPD m h = MPD $ \conn ->
 122     runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
 123
 124 {-
 125 --
 126 -- Basic connection functions
 127 --
 128 -}
 129
 130 -- | Run an MPD action against a server.
 131 withMPDEx :: String            -- ^ Host name.
 132           -> Integer           -- ^ Port number.
 133           -> IO (Maybe String) -- ^ An action that supplies passwords.
 134           -> MPD a             -- ^ The action to run.
 135           -> IO (Response a)
 136 withMPDEx host port getpw m = do
 137     hRef <- newIORef Nothing
 138     connect host port hRef
 139     readIORef hRef >>= maybe (return $ Left NoMPD)
 140         (\_ -> finally (runMPD m (Conn host port hRef getpw)) (closeIO hRef))
 141
 142 -- Connect to an MPD server.
 143 connect :: String -> Integer -- host and port
 144         -> IORef (Maybe Handle) -> IO ()
 145 connect host port hRef =
 146     withSocketsDo $ do
 147         closeIO hRef
 148         --handle <- connectTo host . PortNumber $ fromInteger port
 149         handle <- safeConnectTo host port
 150         writeIORef hRef handle
 151         maybe (return ()) (\h -> checkConn h >>= flip unless (closeIO hRef))
 152               handle
 153
 154 safeConnectTo :: String -> Integer -> IO (Maybe Handle)
 155 safeConnectTo host port =
 156     catch (liftM Just $ connectTo host (PortNumber $ fromInteger port))
 157           (const $ return Nothing)
 158
 159 -- Check that an MPD daemon is at the other end of a connection.
 160 checkConn :: Handle -> IO Bool
 161 checkConn h = isPrefixOf "OK MPD" `liftM` hGetLine h
 162
 163 -- Close a connection.
 164 closeIO :: IORef (Maybe Handle) -> IO ()
 165 closeIO hRef = do
 166     readIORef hRef >>= maybe (return ())
 167                              (\h -> hPutStrLn h "close" >> hClose h)
 168     writeIORef hRef Nothing
 169
 170 -- | Refresh a connection.
 171 reconnect :: MPD ()
 172 reconnect = MPD $ \(Conn host port hRef _) -> do
 173     connect host port hRef
 174     liftM (maybe (Left NoMPD) (const $ Right ())) (readIORef hRef)
 175
 176 -- XXX this doesn't use the password supplying feature.
 177 --
 178 -- | Kill the server. Obviously, the connection is then invalid.
 179 kill :: MPD ()
 180 kill = MPD $ \conn -> do
 181     readIORef (connHandle conn) >>=
 182         maybe (return ()) (\h -> hPutStrLn h "kill" >> hClose h)
 183     writeIORef (connHandle conn) Nothing
 184     return (Left NoMPD)
 185
 186 -- XXX this doesn't use the password supplying feature.
 187 --
 188 -- | Clear the current error message in status.
 189 clearerror :: MPD ()
 190 clearerror = MPD $ \conn -> do
 191     readIORef (connHandle conn) >>= maybe (return $ Left NoMPD)
 192         (\h -> hPutStrLn h "clearerror" >> hFlush h >> return (Right ()))
 193
 194 -- | Close an MPD connection.
 195 close :: MPD ()
 196 close = MPD $ \conn -> closeIO (connHandle conn) >> return (Right ())
 197
 198 -- | Send a command to the MPD and return the result.
 199 getResponse :: String -> MPD [String]
 200 getResponse cmd = MPD $ \conn -> do
 201     readIORef (connHandle conn) >>=
 202         maybe (return $ Left NoMPD)
 203               (\h -> hPutStrLn h cmd >> hFlush h >>
 204                      loop h (tryPassword conn (getResponse cmd)) [])
 205     where loop h tryPw acc = do
 206               getln h (\l -> parseResponse (loop h tryPw) l acc >>= either
 207                           (\x -> case x of
 208                                       ACK Auth _ -> tryPw
 209                                       _          -> return $ Left x)
 210                           (return . Right))
 211           getln h cont =
 212               catch (liftM Right $ hGetLine h) (return . Left) >>=
 213                   either (\e -> if isEOFError e then return (Left TimedOut)
 214                                                 else ioError e)
 215                          cont
 216
 217 -- Send a password to MPD and run an action on success, return an ACK
 218 -- on failure.
 219 tryPassword :: Connection
 220             -> MPD a  -- run on success
 221             -> IO (Response a)
 222 tryPassword conn cont = do
 223     readIORef (connHandle conn) >>= maybe (return $ Left NoMPD)
 224         (\h -> connGetPass conn >>= maybe (return . Left $
 225                                             ACK Auth "Password required")
 226                    (\pw -> do hPutStrLn h ("password " ++ pw) >> hFlush h
 227                               result <- hGetLine h
 228                               case result of "OK" -> runMPD cont conn
 229                                              _    -> tryPassword conn cont))
 230
 231 -- Break an ACK into (error code, current command, message).
 232 -- ACKs are of the form:
 233 -- ACK [error@command_listNum] {current_command} message_text\n
 234 splitAck :: String -> (String, String, String)
 235 splitAck s = (code, cmd, msg)
 236     where (code, notCode) = between (== '[') (== '@') s
 237           (cmd, notCmd)   = between (== '{') (== '}') notCode
 238           msg             = drop 1 . snd $ break (== ' ') notCmd
 239
 240           -- take whatever is between 'f' and 'g'.
 241           between f g xs  = let (_, y) = break f xs
 242                             in break g (drop 1 y)
 243
 244 parseAck :: String -> ACK
 245 parseAck s = ACK ack msg
 246
 247     where
 248         ack = case code of
 249                 "2"  -> InvalidArgument
 250                 "3"  -> InvalidPassword
 251                 "4"  -> Auth
 252                 "5"  -> UnknownCommand
 253                 "50" -> FileNotFound
 254                 "51" -> PlaylistMax
 255                 "52" -> System
 256                 "53" -> PlaylistLoad
 257                 "54" -> Busy
 258                 "55" -> NotPlaying
 259                 "56" -> FileExists
 260                 _    -> UnknownACK
 261         (code, _, msg) = splitAck s
 262
 263 -- Consume response and return a Response.
 264 parseResponse :: ([String] -> IO (Response [String])) -> String -> [String]
 265               -> IO (Response [String])
 266 parseResponse f s acc
 267     | isPrefixOf "ACK" s = return . Left $ parseAck s
 268     | isPrefixOf "OK" s  = return . Right $ reverse acc
 269     | otherwise          = f (s:acc)