Network/MPD/Prim.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-
   3     libmpd for Haskell, an MPD client library.
   4     Copyright (C) 2005-2007  Ben Sinclair <bsinclai@turing.une.edu.au>
   5
   6     This library is free software; you can redistribute it and/or
   7     modify it under the terms of the GNU Lesser General Public
   8     License as published by the Free Software Foundation; either
   9     version 2.1 of the License, or (at your option) any later version.
  10
  11     This library is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14     Lesser General Public License for more details.
  15
  16     You should have received a copy of the GNU Lesser General Public
  17     License along with this library; if not, write to the Free Software
  18     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  19 -}
  20
  21 -- | Module    : Network.MPD.Prim
  22 -- Copyright   : (c) Ben Sinclair 2005-2007
  23 -- License     : LGPL
  24 -- Maintainer  : bsinclai@turing.une.edu.au
  25 -- Stability   : alpha
  26 -- Portability : not Haskell 98 (uses MultiParamTypeClasses)
  27 --
  28 -- Core functionality.
  29
  30 module Network.MPD.Prim (
  31     -- * Type classes
  32     Conn(..),
  33     -- * Data types
  34     MPD(..), MPDError(..), ACKType(..), Response,
  35     -- * Interacting
  36     getResponse, close, reconnect, kill,
  37     ) where
  38
  39 import Control.Monad (liftM)
  40 import Control.Monad.Error (Error(..), MonadError(..))
  41 import Control.Monad.Trans
  42 import Prelude hiding (repeat)
  43 import Data.List (isPrefixOf)
  44 import Data.Maybe
  45 import System.IO
  46
  47 --
  48 -- Data types.
  49 --
  50
  51 -- | A class of transports with which to connect to MPD servers.
  52 class Conn a where
  53     connOpen  :: a -> IO ()
  54     connClose :: a -> IO ()
  55     connRead  :: a -> IO (Response String)
  56     connWrite :: a -> String -> IO (Response ())
  57     connGetPW :: a -> IO (Maybe String)
  58
  59 -- | The MPDError type is used to signal errors, both from the MPD and
  60 -- otherwise.
  61 data MPDError = NoMPD              -- ^ MPD not responding
  62               | TimedOut           -- ^ The connection timed out
  63               | Custom String      -- ^ Used for misc. errors
  64               | ACK ACKType String -- ^ ACK type and a message from the
  65                                    --   server.
  66
  67 instance Show MPDError where
  68     show NoMPD      = "Could not connect to MPD"
  69     show TimedOut   = "MPD connection timed out"
  70     show (Custom s) = s
  71     show (ACK _ s)  = s
  72
  73 -- | Represents various MPD errors (aka. ACKs).
  74 data ACKType = InvalidArgument  -- ^ Invalid argument passed (ACK 2)
  75              | InvalidPassword  -- ^ Invalid password supplied (ACK 3)
  76              | Auth             -- ^ Authentication required (ACK 4)
  77              | UnknownCommand   -- ^ Unknown command (ACK 5)
  78              | FileNotFound     -- ^ File or directory not found ACK 50)
  79              | PlaylistMax      -- ^ Playlist at maximum size (ACK 51)
  80              | System           -- ^ A system error (ACK 52)
  81              | PlaylistLoad     -- ^ Playlist loading failed (ACK 53)
  82              | Busy             -- ^ Update already running (ACK 54)
  83              | NotPlaying       -- ^ An operation requiring playback
  84                                 --   got interrupted (ACK 55)
  85              | FileExists       -- ^ File already exists (ACK 56)
  86              | UnknownACK       -- ^ An unknown ACK (aka. bug)
  87
  88 -- | A response is either an 'MPDError' or some result.
  89 type Response a = Either MPDError a
  90
  91 -- Export the type name but not the constructor or the field.
  92 -- | The MPD monad is basically a state and an error monad
  93 -- combined.
  94 --
  95 -- To use the error throwing\/catching capabilities:
  96 --
  97 -- > import Control.Monad.Error
  98 --
  99 -- To run IO actions within the MPD monad:
 100 --
 101 -- > import Control.Monad.Trans
 102 data MPD c a =
 103     (Conn c) => MPD { runMPD :: c -> IO (Response a) }
 104
 105 instance (Conn c) => Functor (MPD c) where
 106     fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn
 107
 108 instance (Conn c) => Monad (MPD c) 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 (Conn c) => MonadIO (MPD c) where
 115     liftIO m = MPD $ \_ -> liftM Right m
 116
 117 instance (Conn c) => MonadError MPDError (MPD c) where
 118     throwError e   = MPD $ \_ -> return (Left e)
 119     catchError m h = MPD $ \conn ->
 120         runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
 121
 122 instance Error MPDError where
 123     noMsg  = Custom "An error occurred"
 124     strMsg = Custom
 125
 126 --
 127 -- Basic connection functions
 128 --
 129
 130 -- | Refresh a connection.
 131 reconnect :: (Conn c) => MPD c ()
 132 reconnect = MPD $ \conn -> connOpen conn >>= return . Right
 133
 134 -- | Kill the server. Obviously, the connection is then invalid.
 135 kill :: (Conn c) => MPD c ()
 136 kill = getResponse "kill" `catchError` cleanup >> return ()
 137     where
 138       cleanup TimedOut = MPD $ \conn -> connClose conn >> return (Right [])
 139       cleanup x = throwError x >> return []
 140
 141 -- | Close an MPD connection.
 142 close :: (Conn c) => MPD c ()
 143 close = MPD $ \conn -> connClose conn >> return (Right ())
 144
 145 --
 146 -- Sending messages and handling responses.
 147 --
 148
 149 -- | Send a command to the MPD and return the result.
 150 getResponse :: (Conn c) => String -> MPD c [String]
 151 getResponse cmd = MPD $ \conn -> respRead (sendCmd conn) reader (givePW conn)
 152     where sendCmd c = connWrite c cmd >>= return . either Left (const $ Right c)
 153           reader c = connRead c >>= return . (either Left parseResponse)
 154           givePW c cont (ACK Auth _) = tryPassword c cont
 155           givePW _ _ ack = return (Left ack)
 156
 157 -- Send a password to MPD and run an action on success.
 158 tryPassword :: (Conn c) => c -> IO (Response a) -> IO (Response a)
 159 tryPassword conn cont = connGetPW conn >>= maybe failAuth send
 160     where
 161         send pw = connWrite conn ("password " ++ pw) >>=
 162                   either (return . Left)
 163                          (const $ connRead conn >>= either (return . Left) parse)
 164         parse "OK" = cont
 165         parse _    = tryPassword conn cont
 166         failAuth = return . Left $ ACK Auth "Password required"
 167
 168 -- XXX suggestions for names welcome.
 169 --
 170 -- Run a setup action before a recurrent reader. If the reader returns
 171 -- Nothing it has finished reading. If an error is returned a handler
 172 -- is called with an action that, when invoked, will run the setup
 173 -- action again and continue.
 174 respRead :: IO (Either e a)                               -- setup
 175          -> (a -> IO (Either e (Maybe b)))                -- reader
 176          -> (IO (Either e [b]) -> e -> IO (Either e [b])) -- handler
 177          -> IO (Either e [b])
 178 respRead sup rdr onErr = start []
 179     where start acc = sup >>= either (return . Left) (\x -> readAll x acc)
 180           readAll x acc =
 181               rdr x >>= either (onErr (start acc))
 182                                (maybe result (\y -> readAll x (y:acc)))
 183               where result = return . Right $ reverse acc
 184
 185 -- Consume response and return a Response.
 186 parseResponse :: String -> Response (Maybe String)
 187 parseResponse s | isPrefixOf "ACK" s = Left  $ parseAck s -- an error occurred
 188                 | isPrefixOf "OK" s  = Right Nothing      -- done parsing
 189                 | otherwise          = Right $ Just s     -- continue
 190
 191 parseAck :: String -> MPDError
 192 parseAck s = ACK ack msg
 193     where
 194         ack = case code of
 195                 "2"  -> InvalidArgument
 196                 "3"  -> InvalidPassword
 197                 "4"  -> Auth
 198                 "5"  -> UnknownCommand
 199                 "50" -> FileNotFound
 200                 "51" -> PlaylistMax
 201                 "52" -> System
 202                 "53" -> PlaylistLoad
 203                 "54" -> Busy
 204                 "55" -> NotPlaying
 205                 "56" -> FileExists
 206                 _    -> UnknownACK
 207         (code, _, msg) = splitAck s
 208
 209 -- Break an ACK into (error code, current command, message).
 210 -- ACKs are of the form:
 211 -- ACK [error@command_listNum] {current_command} message_text\n
 212 splitAck :: String -> (String, String, String)
 213 splitAck s = (code, cmd, msg)
 214     where (code, notCode) = between (== '[') (== '@') s
 215           (cmd, notCmd)   = between (== '{') (== '}') notCode
 216           msg             = drop 1 . snd $ break (== ' ') notCmd
 217
 218           -- take whatever is between 'f' and 'g'.
 219           between f g xs  = let (_, y) = break f xs
 220                             in break g (drop 1 y)