{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Module    : Network.MPD.Core
-- Copyright   : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010
-- License     : MIT (see LICENSE)
-- Maintainer  : Joachim Fasting <joachifm@fastmail.fm>
-- Stability   : alpha
--
-- The core datatypes and operations are defined here, including the
-- primary instance of the 'MonadMPD' class, 'MPD'.

module Network.MPD.Core (
    -- * Classes
    MonadMPD(..),
    -- * Data types
    MPD, MPDError(..), ACKType(..), Response, Host, Port, Password,
    -- * Running
    withMPDEx,
    -- * Interacting
    getResponse, kill,
    ) where

import           Network.MPD.Util
import           Network.MPD.Core.Class
import           Network.MPD.Core.Error

import           Data.Char (isDigit)
import qualified Control.Exception as E
import           Control.Exception.Safe (catch, catchAny)
import           Control.Monad (ap, unless)
import           Control.Monad.Except (ExceptT(..),runExceptT, MonadError(..))
import           Control.Monad.Reader (ReaderT(..), ask)
import           Control.Monad.State (StateT, MonadIO(..), modify, gets, evalStateT)
import qualified Data.Foldable as F
import           System.IO (IOMode(..))
import Network.Socket
  ( Family(..)
  , SockAddr(..)
  , SocketType(..)
  , addrAddress
  , addrFamily
  , addrProtocol
  , addrSocketType
  , connect
  , defaultHints
  , getAddrInfo
  , socket
  , socketToHandle
  , withSocketsDo
  )
import           System.IO (Handle, hPutStrLn, hReady, hClose, hFlush)
import           System.IO.Error (isEOFError, tryIOError, ioeGetErrorType)
import           Text.Printf (printf)
import qualified GHC.IO.Exception as GE

import qualified Prelude
import           Prelude hiding (break, drop, dropWhile, read)
import           Data.ByteString.Char8 (ByteString, isPrefixOf, break, drop, dropWhile)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.UTF8 as UTF8
--
-- Data types.
--

type Host = String
type Port = Integer

--
-- IO based MPD client implementation.
--

-- | The main implementation of an MPD client.  It actually connects
--   to a server and interacts with it.
--
-- To use the error throwing\/catching capabilities:
--
-- > import Control.Monad.Except (throwError, catchError)
--
-- To run IO actions within the MPD monad:
--
-- > import Control.Monad.Trans (liftIO)

newtype MPD a =
    MPD { MPD a
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
runMPD :: ExceptT MPDError
                    (StateT MPDState
                     (ReaderT (Host, Port) IO)) a
        } deriving (a -> MPD b -> MPD a
(a -> b) -> MPD a -> MPD b
(forall a b. (a -> b) -> MPD a -> MPD b)
-> (forall a b. a -> MPD b -> MPD a) -> Functor MPD
forall a b. a -> MPD b -> MPD a
forall a b. (a -> b) -> MPD a -> MPD b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> MPD b -> MPD a
$c<$ :: forall a b. a -> MPD b -> MPD a
fmap :: (a -> b) -> MPD a -> MPD b
$cfmap :: forall a b. (a -> b) -> MPD a -> MPD b
Functor, Applicative MPD
a -> MPD a
Applicative MPD
-> (forall a b. MPD a -> (a -> MPD b) -> MPD b)
-> (forall a b. MPD a -> MPD b -> MPD b)
-> (forall a. a -> MPD a)
-> Monad MPD
MPD a -> (a -> MPD b) -> MPD b
MPD a -> MPD b -> MPD b
forall a. a -> MPD a
forall a b. MPD a -> MPD b -> MPD b
forall a b. MPD a -> (a -> MPD b) -> MPD b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> MPD a
$creturn :: forall a. a -> MPD a
>> :: MPD a -> MPD b -> MPD b
$c>> :: forall a b. MPD a -> MPD b -> MPD b
>>= :: MPD a -> (a -> MPD b) -> MPD b
$c>>= :: forall a b. MPD a -> (a -> MPD b) -> MPD b
$cp1Monad :: Applicative MPD
Monad, Monad MPD
Monad MPD -> (forall a. IO a -> MPD a) -> MonadIO MPD
IO a -> MPD a
forall a. IO a -> MPD a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> MPD a
$cliftIO :: forall a. IO a -> MPD a
$cp1MonadIO :: Monad MPD
MonadIO, MonadError MPDError)

instance Applicative MPD where
    <*> :: MPD (a -> b) -> MPD a -> MPD b
(<*>) = MPD (a -> b) -> MPD a -> MPD b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    pure :: a -> MPD a
pure  = a -> MPD a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance MonadMPD MPD where
    open :: MPD ()
open  = MPD ()
mpdOpen
    close :: MPD ()
close = MPD ()
mpdClose
    send :: Host -> MPD [ByteString]
send  = Host -> MPD [ByteString]
mpdSend
    getPassword :: MPD Host
getPassword    = ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Host
-> MPD Host
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Host
 -> MPD Host)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Host
-> MPD Host
forall a b. (a -> b) -> a -> b
$ (MPDState -> Host)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Host
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets MPDState -> Host
stPassword
    setPassword :: Host -> MPD ()
setPassword Host
pw = ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> MPD ()
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
 -> MPD ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> MPD ()
forall a b. (a -> b) -> a -> b
$ (MPDState -> MPDState)
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\MPDState
st -> MPDState
st { stPassword :: Host
stPassword = Host
pw })
    getVersion :: MPD (Int, Int, Int)
getVersion     = ExceptT
  MPDError
  (StateT MPDState (ReaderT (Host, Port) IO))
  (Int, Int, Int)
-> MPD (Int, Int, Int)
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT
   MPDError
   (StateT MPDState (ReaderT (Host, Port) IO))
   (Int, Int, Int)
 -> MPD (Int, Int, Int))
-> ExceptT
     MPDError
     (StateT MPDState (ReaderT (Host, Port) IO))
     (Int, Int, Int)
-> MPD (Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ (MPDState -> (Int, Int, Int))
-> ExceptT
     MPDError
     (StateT MPDState (ReaderT (Host, Port) IO))
     (Int, Int, Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets MPDState -> (Int, Int, Int)
stVersion

-- | Inner state for MPD
data MPDState =
    MPDState { MPDState -> Maybe Handle
stHandle   :: Maybe Handle
             , MPDState -> Host
stPassword :: String
             , MPDState -> (Int, Int, Int)
stVersion  :: (Int, Int, Int)
             }

-- | A response is either an 'MPDError' or some result.
type Response = Either MPDError

-- | The most configurable API for running an MPD action.
withMPDEx :: Host -> Port -> Password -> MPD a -> IO (Response a)
withMPDEx :: Host -> Port -> Host -> MPD a -> IO (Response a)
withMPDEx Host
host Port
port Host
pw MPD a
x = IO (Response a) -> IO (Response a)
forall a. IO a -> IO a
withSocketsDo (IO (Response a) -> IO (Response a))
-> IO (Response a) -> IO (Response a)
forall a b. (a -> b) -> a -> b
$
    ReaderT (Host, Port) IO (Response a)
-> (Host, Port) -> IO (Response a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT MPDState (ReaderT (Host, Port) IO) (Response a)
-> MPDState -> ReaderT (Host, Port) IO (Response a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> StateT MPDState (ReaderT (Host, Port) IO) (Response a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
 -> StateT MPDState (ReaderT (Host, Port) IO) (Response a))
-> (MPD a
    -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a)
-> MPD a
-> StateT MPDState (ReaderT (Host, Port) IO) (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MPD a
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
forall a.
MPD a
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
runMPD (MPD a -> StateT MPDState (ReaderT (Host, Port) IO) (Response a))
-> MPD a -> StateT MPDState (ReaderT (Host, Port) IO) (Response a)
forall a b. (a -> b) -> a -> b
$ MPD ()
forall (m :: * -> *). MonadMPD m => m ()
open MPD () -> MPD a -> MPD a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (MPD a
x MPD a -> MPD () -> MPD a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* MPD ()
forall (m :: * -> *). MonadMPD m => m ()
close)) MPDState
initState)
               (Host
host, Port
port)
    where initState :: MPDState
initState = Maybe Handle -> Host -> (Int, Int, Int) -> MPDState
MPDState Maybe Handle
forall a. Maybe a
Nothing Host
pw (Int
0, Int
0, Int
0)

mpdOpen :: MPD ()
mpdOpen :: MPD ()
mpdOpen = ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> MPD ()
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
 -> MPD ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> MPD ()
forall a b. (a -> b) -> a -> b
$ do
    (Host
host, Port
port) <- ExceptT
  MPDError (StateT MPDState (ReaderT (Host, Port) IO)) (Host, Port)
forall r (m :: * -> *). MonadReader r m => m r
ask
    MPD ()
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall a.
MPD a
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
runMPD MPD ()
forall (m :: * -> *). MonadMPD m => m ()
close
    AddrInfo
addr:[AddrInfo]
_ <- IO [AddrInfo]
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [AddrInfo]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [AddrInfo]
 -> ExceptT
      MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [AddrInfo])
-> IO [AddrInfo]
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [AddrInfo]
forall a b. (a -> b) -> a -> b
$ Host -> Port -> IO [AddrInfo]
forall a. Show a => Host -> a -> IO [AddrInfo]
getAddr Host
host Port
port
    Socket
sock <- IO Socket
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Socket
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Socket
 -> ExceptT
      MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Socket)
-> IO Socket
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Socket
forall a b. (a -> b) -> a -> b
$ Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
    Maybe Handle
mHandle <- IO (Maybe Handle)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) (Maybe Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Socket, SockAddr) -> IO (Maybe Handle)
safeConnectTo (Socket
sock,(AddrInfo -> SockAddr
addrAddress AddrInfo
addr)))
    (MPDState -> MPDState)
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\MPDState
st -> MPDState
st { stHandle :: Maybe Handle
stHandle = Maybe Handle
mHandle })
    Maybe Handle
-> (Handle
    -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe Handle
mHandle ((Handle
  -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
 -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> (Handle
    -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall a b. (a -> b) -> a -> b
$ \Handle
_ -> MPD Bool
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
forall a.
MPD a
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
runMPD MPD Bool
checkConn ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
-> (Bool
    -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` MPD ()
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall a.
MPD a
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
runMPD MPD ()
forall (m :: * -> *). MonadMPD m => m ()
close)
    where
        getAddr :: Host -> a -> IO [AddrInfo]
getAddr addr :: Host
addr@(Char
'/':Host
_) a
_ = [AddrInfo] -> IO [AddrInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [
                AddrInfo
defaultHints { addrFamily :: Family
addrFamily = Family
AF_UNIX
                             , addrSocketType :: SocketType
addrSocketType = SocketType
Stream
                             , addrAddress :: SockAddr
addrAddress = Host -> SockAddr
SockAddrUnix Host
addr
                             }
            ]

        getAddr Host
host a
port = Maybe AddrInfo -> Maybe Host -> Maybe Host -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints) (Host -> Maybe Host
forall a. a -> Maybe a
Just Host
host) (Host -> Maybe Host
forall a. a -> Maybe a
Just (Host -> Maybe Host) -> Host -> Maybe Host
forall a b. (a -> b) -> a -> b
$ a -> Host
forall a. Show a => a -> Host
show a
port)

        safeConnectTo :: (Socket, SockAddr) -> IO (Maybe Handle)
safeConnectTo (Socket
sock,SockAddr
addr) =
            (Socket -> SockAddr -> IO ()
connect Socket
sock SockAddr
addr) IO () -> IO (Maybe Handle) -> IO (Maybe Handle)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode)
            IO (Maybe Handle)
-> (SomeException -> IO (Maybe Handle)) -> IO (Maybe Handle)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO (Maybe Handle) -> SomeException -> IO (Maybe Handle)
forall a b. a -> b -> a
const (Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing)
        checkConn :: MPD Bool
checkConn = do
            [ByteString]
singleMsg <- Host -> MPD [ByteString]
forall (m :: * -> *). MonadMPD m => Host -> m [ByteString]
send Host
""
            let [ByteString
msg] = [ByteString]
singleMsg
            if ByteString
"OK MPD" ByteString -> ByteString -> Bool
`isPrefixOf` ByteString
msg
                then ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
-> MPD Bool
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
 -> MPD Bool)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
-> MPD Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Int, Int)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
forall (m :: * -> *).
(MonadError MPDError m, MonadState MPDState m) =>
Maybe (Int, Int, Int) -> m Bool
checkVersion (Maybe (Int, Int, Int)
 -> ExceptT
      MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool)
-> Maybe (Int, Int, Int)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (Int, Int, Int)
parseVersion ByteString
msg
                else Bool -> MPD Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        checkVersion :: Maybe (Int, Int, Int) -> m Bool
checkVersion Maybe (Int, Int, Int)
Nothing = MPDError -> m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MPDError -> m Bool) -> MPDError -> m Bool
forall a b. (a -> b) -> a -> b
$ Host -> MPDError
Custom Host
"Couldn't determine MPD version"
        checkVersion (Just (Int, Int, Int)
version)
            | (Int, Int, Int)
version (Int, Int, Int) -> (Int, Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Int, Int)
requiredVersion =
                MPDError -> m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MPDError -> m Bool) -> MPDError -> m Bool
forall a b. (a -> b) -> a -> b
$ Host -> MPDError
Custom (Host -> MPDError) -> Host -> MPDError
forall a b. (a -> b) -> a -> b
$ Host -> Host -> Host -> Host
forall r. PrintfType r => Host -> r
printf
                    Host
"MPD %s is not supported, upgrade to MPD %s or above!"
                    ((Int, Int, Int) -> Host
formatVersion (Int, Int, Int)
version) ((Int, Int, Int) -> Host
formatVersion (Int, Int, Int)
requiredVersion)
            | Bool
otherwise = do
                (MPDState -> MPDState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\MPDState
st -> MPDState
st { stVersion :: (Int, Int, Int)
stVersion = (Int, Int, Int)
version })
                Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            where
                requiredVersion :: (Int, Int, Int)
requiredVersion = (Int
0, Int
19, Int
0)

        parseVersion :: ByteString -> Maybe (Int, Int, Int)
parseVersion = Char
-> (ByteString -> Maybe Int) -> ByteString -> Maybe (Int, Int, Int)
forall a.
Char -> (ByteString -> Maybe a) -> ByteString -> Maybe (a, a, a)
parseTriple Char
'.' ByteString -> Maybe Int
forall a. (Read a, Integral a) => ByteString -> Maybe a
parseNum (ByteString -> Maybe (Int, Int, Int))
-> (ByteString -> ByteString)
-> ByteString
-> Maybe (Int, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit)

        formatVersion :: (Int, Int, Int) -> String
        formatVersion :: (Int, Int, Int) -> Host
formatVersion (Int
x, Int
y, Int
z) = Host -> Int -> Int -> Int -> Host
forall r. PrintfType r => Host -> r
printf Host
"%d.%d.%d" Int
x Int
y Int
z


mpdClose :: MPD ()
mpdClose :: MPD ()
mpdClose =
    ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> MPD ()
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
 -> MPD ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
-> MPD ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe Handle
mHandle <- (MPDState -> Maybe Handle)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) (Maybe Handle)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets MPDState -> Maybe Handle
stHandle
        Maybe Handle
-> (Handle
    -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe Handle
mHandle ((Handle
  -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
 -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> (Handle
    -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          (MPDState -> MPDState)
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((MPDState -> MPDState)
 -> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ())
-> (MPDState -> MPDState)
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall a b. (a -> b) -> a -> b
$ \MPDState
st -> MPDState
st{stHandle :: Maybe Handle
stHandle = Maybe Handle
forall a. Maybe a
Nothing}
          Maybe MPDError
r <- IO (Maybe MPDError)
-> ExceptT
     MPDError
     (StateT MPDState (ReaderT (Host, Port) IO))
     (Maybe MPDError)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe MPDError)
 -> ExceptT
      MPDError
      (StateT MPDState (ReaderT (Host, Port) IO))
      (Maybe MPDError))
-> IO (Maybe MPDError)
-> ExceptT
     MPDError
     (StateT MPDState (ReaderT (Host, Port) IO))
     (Maybe MPDError)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (Maybe MPDError)
sendClose Handle
h
          Maybe MPDError
-> (MPDError
    -> ExceptT
         MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Any)
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe MPDError
r MPDError
-> ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) Any
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    where
        sendClose :: Handle -> IO (Maybe MPDError)
sendClose Handle
handle =
            (Handle -> Host -> IO ()
hPutStrLn Handle
handle Host
"close" IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO Bool
hReady Handle
handle IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
handle IO () -> IO (Maybe MPDError) -> IO (Maybe MPDError)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe MPDError -> IO (Maybe MPDError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MPDError
forall a. Maybe a
Nothing)
            IO (Maybe MPDError)
-> (IOError -> IO (Maybe MPDError)) -> IO (Maybe MPDError)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOError -> IO (Maybe MPDError)
forall (m :: * -> *). Monad m => IOError -> m (Maybe MPDError)
handler

        handler :: IOError -> m (Maybe MPDError)
handler IOError
err
            | IOError -> Bool
isEOFError IOError
err = Maybe MPDError -> m (Maybe MPDError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MPDError
forall a. Maybe a
Nothing
            | Bool
otherwise      = (Maybe MPDError -> m (Maybe MPDError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MPDError -> m (Maybe MPDError))
-> (IOError -> Maybe MPDError) -> IOError -> m (Maybe MPDError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MPDError -> Maybe MPDError
forall a. a -> Maybe a
Just (MPDError -> Maybe MPDError)
-> (IOError -> MPDError) -> IOError -> Maybe MPDError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> MPDError
ConnectionError) IOError
err

mpdSend :: String -> MPD [ByteString]
mpdSend :: Host -> MPD [ByteString]
mpdSend Host
str = MPD [ByteString]
send' MPD [ByteString]
-> (MPDError -> MPD [ByteString]) -> MPD [ByteString]
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` MPDError -> MPD [ByteString]
handler
    where
        handler :: MPDError -> MPD [ByteString]
handler MPDError
err
          | ConnectionError IOError
e <- MPDError
err, IOError -> Bool
isRetryable IOError
e = MPD ()
mpdOpen MPD () -> MPD [ByteString] -> MPD [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MPD [ByteString]
send'
          | Bool
otherwise = MPDError -> MPD [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MPDError
err

        send' :: MPD [ByteString]
        send' :: MPD [ByteString]
send' = ExceptT
  MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
-> MPD [ByteString]
forall a.
ExceptT MPDError (StateT MPDState (ReaderT (Host, Port) IO)) a
-> MPD a
MPD (ExceptT
   MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
 -> MPD [ByteString])
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
-> MPD [ByteString]
forall a b. (a -> b) -> a -> b
$ (MPDState -> Maybe Handle)
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) (Maybe Handle)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets MPDState -> Maybe Handle
stHandle ExceptT
  MPDError (StateT MPDState (ReaderT (Host, Port) IO)) (Maybe Handle)
-> (Maybe Handle
    -> ExceptT
         MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString])
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT
  MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
-> (Handle
    -> ExceptT
         MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString])
-> Maybe Handle
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MPDError
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MPDError
NoMPD) Handle
-> ExceptT
     MPDError (StateT MPDState (ReaderT (Host, Port) IO)) [ByteString]
forall (m :: * -> *).
(MonadIO m, MonadState MPDState m, MonadError MPDError m) =>
Handle -> m [ByteString]
go

        go :: Handle -> m [ByteString]
go Handle
handle = (IO (Either IOError [ByteString]) -> m (Either IOError [ByteString])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError [ByteString])
 -> m (Either IOError [ByteString]))
-> (IO [ByteString] -> IO (Either IOError [ByteString]))
-> IO [ByteString]
-> m (Either IOError [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [ByteString] -> IO (Either IOError [ByteString])
forall a. IO a -> IO (Either IOError a)
tryIOError (IO [ByteString] -> m (Either IOError [ByteString]))
-> IO [ByteString] -> m (Either IOError [ByteString])
forall a b. (a -> b) -> a -> b
$ do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Host -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Host
str) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPutStrLn Handle
handle (Host -> ByteString
UTF8.fromString Host
str) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
handle
            Handle -> [ByteString] -> IO [ByteString]
getLines Handle
handle [])
                m (Either IOError [ByteString])
-> (Either IOError [ByteString] -> m [ByteString])
-> m [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOError -> m [ByteString])
-> ([ByteString] -> m [ByteString])
-> Either IOError [ByteString]
-> m [ByteString]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\IOError
err -> (MPDState -> MPDState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\MPDState
st -> MPDState
st { stHandle :: Maybe Handle
stHandle = Maybe Handle
forall a. Maybe a
Nothing })
                                 m () -> m [ByteString] -> m [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MPDError -> m [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IOError -> MPDError
ConnectionError IOError
err)) [ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return

        getLines :: Handle -> [ByteString] -> IO [ByteString]
        getLines :: Handle -> [ByteString] -> IO [ByteString]
getLines Handle
handle [ByteString]
acc = do
            ByteString
l <- Handle -> IO ByteString
B.hGetLine Handle
handle
            if ByteString
"OK" ByteString -> ByteString -> Bool
`isPrefixOf` ByteString
l Bool -> Bool -> Bool
|| ByteString
"ACK" ByteString -> ByteString -> Bool
`isPrefixOf` ByteString
l
                then ([ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> ([ByteString] -> [ByteString])
-> [ByteString]
-> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse) (ByteString
lByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc)
                else Handle -> [ByteString] -> IO [ByteString]
getLines Handle
handle (ByteString
lByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc)

-- | Re-connect and retry for these Exceptions.
isRetryable :: E.IOException -> Bool
isRetryable :: IOError -> Bool
isRetryable IOError
e = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ IOError -> Bool
isEOFError IOError
e, IOError -> Bool
isResourceVanished IOError
e ]

-- | Predicate to identify ResourceVanished exceptions.
-- Note: these are GHC only!
isResourceVanished :: GE.IOException -> Bool
isResourceVanished :: IOError -> Bool
isResourceVanished IOError
e = IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
GE.ResourceVanished

--
-- Other operations.
--

-- | Kill the server. Obviously, the connection is then invalid.
kill :: (MonadMPD m) => m ()
kill :: m ()
kill = Host -> m [ByteString]
forall (m :: * -> *). MonadMPD m => Host -> m [ByteString]
send Host
"kill" m [ByteString] -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Send a command to the MPD server and return the result.
getResponse :: (MonadMPD m) => String -> m [ByteString]
getResponse :: Host -> m [ByteString]
getResponse Host
cmd = (Host -> m [ByteString]
forall (m :: * -> *). MonadMPD m => Host -> m [ByteString]
send Host
cmd m [ByteString]
-> ([ByteString] -> m [ByteString]) -> m [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString] -> m [ByteString]
forall (m :: * -> *).
MonadError MPDError m =>
[ByteString] -> m [ByteString]
parseResponse) m [ByteString] -> (MPDError -> m [ByteString]) -> m [ByteString]
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` MPDError -> m [ByteString]
forall (m :: * -> *). MonadMPD m => MPDError -> m [ByteString]
sendpw
    where
        sendpw :: MPDError -> m [ByteString]
sendpw e :: MPDError
e@(ACK ACKType
Auth Host
_) = do
            Host
pw <- m Host
forall (m :: * -> *). MonadMPD m => m Host
getPassword
            if Host -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Host
pw then MPDError -> m [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MPDError
e
                else Host -> m [ByteString]
forall (m :: * -> *). MonadMPD m => Host -> m [ByteString]
send (Host
"password " Host -> Host -> Host
forall a. [a] -> [a] -> [a]
++ Host
pw) m [ByteString]
-> ([ByteString] -> m [ByteString]) -> m [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString] -> m [ByteString]
forall (m :: * -> *).
MonadError MPDError m =>
[ByteString] -> m [ByteString]
parseResponse
                  m [ByteString] -> m [ByteString] -> m [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Host -> m [ByteString]
forall (m :: * -> *). MonadMPD m => Host -> m [ByteString]
send Host
cmd m [ByteString]
-> ([ByteString] -> m [ByteString]) -> m [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ByteString] -> m [ByteString]
forall (m :: * -> *).
MonadError MPDError m =>
[ByteString] -> m [ByteString]
parseResponse
        sendpw MPDError
e =
            MPDError -> m [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MPDError
e

-- Consume response and return a Response.
parseResponse :: (MonadError MPDError m) => [ByteString] -> m [ByteString]
parseResponse :: [ByteString] -> m [ByteString]
parseResponse [ByteString]
xs
    | [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
xs                    = MPDError -> m [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MPDError -> m [ByteString]) -> MPDError -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ MPDError
NoMPD
    | ByteString
"ACK" ByteString -> ByteString -> Bool
`isPrefixOf` ByteString
x       = MPDError -> m [ByteString]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MPDError -> m [ByteString]) -> MPDError -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> MPDError
parseAck ByteString
x
    | Bool
otherwise                  = [ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> m [ByteString]) -> [ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.takeWhile (ByteString
"OK" ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=) [ByteString]
xs
    where
        x :: ByteString
x = [ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
xs

-- Turn MPD ACK into the corresponding 'MPDError'
parseAck :: ByteString -> MPDError
parseAck :: ByteString -> MPDError
parseAck ByteString
s = ACKType -> Host -> MPDError
ACK ACKType
ack (ByteString -> Host
UTF8.toString ByteString
msg)
    where
        ack :: ACKType
ack = case Int
code of
                Int
2  -> ACKType
InvalidArgument
                Int
3  -> ACKType
InvalidPassword
                Int
4  -> ACKType
Auth
                Int
5  -> ACKType
UnknownCommand
                Int
50 -> ACKType
FileNotFound
                Int
51 -> ACKType
PlaylistMax
                Int
52 -> ACKType
System
                Int
53 -> ACKType
PlaylistLoad
                Int
54 -> ACKType
Busy
                Int
55 -> ACKType
NotPlaying
                Int
56 -> ACKType
FileExists
                Int
_  -> ACKType
UnknownACK
        (Int
code, ByteString
_, ByteString
msg) = ByteString -> (Int, ByteString, ByteString)
splitAck ByteString
s

-- Break an ACK into (error code, current command, message).
-- ACKs are of the form:
-- ACK [error@command_listNum] {current_command} message_text\n
splitAck :: ByteString -> (Int, ByteString, ByteString)
splitAck :: ByteString -> (Int, ByteString, ByteString)
splitAck ByteString
s = (ByteString -> Int
forall a. Read a => ByteString -> a
read ByteString
code, ByteString
cmd, ByteString
msg)
    where
        (ByteString
code, ByteString
notCode) = Char -> Char -> ByteString -> (ByteString, ByteString)
between Char
'[' Char
'@' ByteString
s
        (ByteString
cmd, ByteString
notCmd)   = Char -> Char -> ByteString -> (ByteString, ByteString)
between Char
'{' Char
'}' ByteString
notCode
        msg :: ByteString
msg             = Int -> ByteString -> ByteString
drop Int
1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
dropWhile (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ByteString
notCmd

        -- take whatever is between 'f' and 'g'.
        between :: Char -> Char -> ByteString -> (ByteString, ByteString)
between Char
a Char
b ByteString
xs  = let (ByteString
_, ByteString
y) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
a) ByteString
xs
                          in (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b) (Int -> ByteString -> ByteString
drop Int
1 ByteString
y)