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