Network/MPD/Core.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.Core
  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.Core (
  31     -- * Data types
  32     MPD(..), Conn(..), MPDError(..), ACKType(..), Response,
  33     -- * Interacting
  34     getResponse, close, reconnect, kill,
  35     ) where
  36
  37 import Control.Monad (liftM)
  38 import Control.Monad.Error (Error(..), MonadError(..))
  39 import Control.Monad.Trans
  40 import Prelude hiding (repeat)
  41 import Data.List (isPrefixOf)
  42 import Data.Maybe
  43 import System.IO
  44
  45 --
  46 -- Data types.
  47 --
  48
  49 -- A class of transports with which to connect to MPD servers.
  50 data Conn = Conn { cOpen  :: IO ()                          -- Open connection
  51                  , cClose :: IO ()                          -- Close connection
  52                  , cSend  :: String -> IO (Response String) -- Write to connection
  53                  , cGetPW :: IO (Maybe String) }            -- Password function
  54
  55 -- | The MPDError type is used to signal errors, both from the MPD and
  56 -- otherwise.
  57 data MPDError = NoMPD              -- ^ MPD not responding
  58               | TimedOut           -- ^ The connection timed out
  59               | Custom String      -- ^ Used for misc. errors
  60               | ACK ACKType String -- ^ ACK type and a message from the
  61                                    --   server
  62                 deriving Eq
  63
  64 instance Show MPDError where
  65     show NoMPD      = "Could not connect to MPD"
  66     show TimedOut   = "MPD connection timed out"
  67     show (Custom s) = s
  68     show (ACK _ s)  = s
  69
  70 -- | Represents various MPD errors (aka. ACKs).
  71 data ACKType = InvalidArgument  -- ^ Invalid argument passed (ACK 2)
  72              | InvalidPassword  -- ^ Invalid password supplied (ACK 3)
  73              | Auth             -- ^ Authentication required (ACK 4)
  74              | UnknownCommand   -- ^ Unknown command (ACK 5)
  75              | FileNotFound     -- ^ File or directory not found ACK 50)
  76              | PlaylistMax      -- ^ Playlist at maximum size (ACK 51)
  77              | System           -- ^ A system error (ACK 52)
  78              | PlaylistLoad     -- ^ Playlist loading failed (ACK 53)
  79              | Busy             -- ^ Update already running (ACK 54)
  80              | NotPlaying       -- ^ An operation requiring playback
  81                                 --   got interrupted (ACK 55)
  82              | FileExists       -- ^ File already exists (ACK 56)
  83              | UnknownACK       -- ^ An unknown ACK (aka. bug)
  84                deriving (Eq)
  85
  86 -- | A response is either an 'MPDError' or some result.
  87 type Response a = Either MPDError a
  88
  89 -- Export the type name but not the constructor or the field.
  90 -- | The MPD monad is basically a reader and error monad
  91 -- combined.
  92 --
  93 -- To use the error throwing\/catching capabilities:
  94 --
  95 -- > import Control.Monad.Error
  96 --
  97 -- To run IO actions within the MPD monad:
  98 --
  99 -- > import Control.Monad.Trans
 100 data MPD a = MPD { runMPD :: Conn -> IO (Response a) }
 101
 102 instance Functor MPD where
 103     fmap f m = MPD $ \conn -> either Left (Right . f) `liftM` runMPD m conn
 104
 105 instance Monad MPD where
 106     return a = MPD $ \_ -> return $ Right a
 107     m >>= f  = MPD $ \conn -> runMPD m conn >>=
 108                               either (return . Left) (flip runMPD conn . f)
 109     fail err = MPD $ \_ -> return . Left $ Custom err
 110
 111 instance MonadIO MPD where
 112     liftIO m = MPD $ \_ -> liftM Right m
 113
 114 instance MonadError MPDError MPD where
 115     throwError e   = MPD $ \_ -> return (Left e)
 116     catchError m h = MPD $ \conn ->
 117         runMPD m conn >>= either (flip runMPD conn . h) (return . Right)
 118
 119 instance Error MPDError where
 120     noMsg  = Custom "An error occurred"
 121     strMsg = Custom
 122
 123 --
 124 -- Basic connection functions
 125 --
 126
 127 -- | Refresh a connection.
 128 reconnect :: MPD ()
 129 reconnect = MPD $ \conn -> Right `liftM` cOpen conn
 130
 131 -- | Kill the server. Obviously, the connection is then invalid.
 132 kill :: MPD ()
 133 kill = getResponse "kill" `catchError` cleanup >> return ()
 134     where
 135       cleanup TimedOut = MPD $ \conn -> cClose conn >> return (Right [])
 136       cleanup x = throwError x >> return []
 137
 138 -- | Close an MPD connection.
 139 close :: MPD ()
 140 close = MPD $ \conn -> cClose conn >> return (Right ())
 141
 142 --
 143 -- Sending messages and handling responses.
 144 --
 145
 146 -- | Send a command to the MPD and return the result.
 147 getResponse :: String -> MPD [String]
 148 getResponse cmd = MPD f
 149     where
 150         f conn = catchAuth . either Left parseResponse =<< cSend conn cmd
 151             where
 152                 catchAuth (Left (ACK Auth _)) = tryPassword conn (f conn)
 153                 catchAuth x = return x
 154
 155 -- Send a password to MPD and run an action on success.
 156 tryPassword :: Conn -> IO (Response a) -> IO (Response a)
 157 tryPassword conn cont = do
 158     resp <- cGetPW conn >>= maybe failAuth (cSend conn . ("password " ++))
 159     case resp of
 160         Left  e -> return $ Left e
 161         Right x -> either (return . Left) (const cont) $ parseResponse x
 162     where failAuth = return . Left $ ACK Auth "Password required"
 163
 164 -- Consume response and return a Response.
 165 parseResponse :: String -> Response [String]
 166 parseResponse s | null xs                    = Left  $ NoMPD
 167                 | isPrefixOf "ACK" (head xs) = Left  $ parseAck s
 168                 | otherwise                  = Right $ takeWhile ("OK" /=) xs
 169     where xs = lines s
 170
 171 parseAck :: String -> MPDError
 172 parseAck s = ACK ack msg
 173     where
 174         ack = case code of
 175                 "2"  -> InvalidArgument
 176                 "3"  -> InvalidPassword
 177                 "4"  -> Auth
 178                 "5"  -> UnknownCommand
 179                 "50" -> FileNotFound
 180                 "51" -> PlaylistMax
 181                 "52" -> System
 182                 "53" -> PlaylistLoad
 183                 "54" -> Busy
 184                 "55" -> NotPlaying
 185                 "56" -> FileExists
 186                 _    -> UnknownACK
 187         (code, _, msg) = splitAck s
 188
 189 -- Break an ACK into (error code, current command, message).
 190 -- ACKs are of the form:
 191 -- ACK [error@command_listNum] {current_command} message_text\n
 192 splitAck :: String -> (String, String, String)
 193 splitAck s = (code, cmd, msg)
 194     where (code, notCode) = between (== '[') (== '@') s
 195           (cmd, notCmd)   = between (== '{') (== '}') notCode
 196           msg             = drop 1 . snd $ break (== ' ') notCmd
 197
 198           -- take whatever is between 'f' and 'g'.
 199           between f g xs  = let (_, y) = break f xs
 200                             in break g (drop 1 y)