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