-
Notifications
You must be signed in to change notification settings - Fork 26
/
Core.hs
275 lines (239 loc) · 9.12 KB
/
Core.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
{-# 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 { runMPD :: ExceptT MPDError
(StateT MPDState
(ReaderT (Host, Port) IO)) a
} deriving (Functor, Monad, MonadIO, MonadError MPDError)
instance Applicative MPD where
(<*>) = ap
pure = return
instance MonadMPD MPD where
open = mpdOpen
close = mpdClose
send = mpdSend
getPassword = MPD $ gets stPassword
setPassword pw = MPD $ modify (\st -> st { stPassword = pw })
getVersion = MPD $ gets stVersion
-- | Inner state for MPD
data MPDState =
MPDState { stHandle :: Maybe Handle
, stPassword :: String
, 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 pw x = withSocketsDo $
runReaderT (evalStateT (runExceptT . runMPD $ open >> (x <* close)) initState)
(host, port)
where initState = MPDState Nothing pw (0, 0, 0)
mpdOpen :: MPD ()
mpdOpen = MPD $ do
(host, port) <- ask
runMPD close
addr:_ <- liftIO $ getAddr host port
sock <- liftIO $ socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
mHandle <- liftIO (safeConnectTo (sock,(addrAddress addr)))
modify (\st -> st { stHandle = mHandle })
F.forM_ mHandle $ \_ -> runMPD checkConn >>= (`unless` runMPD close)
where
getAddr addr@('/':_) _ = return [
defaultHints { addrFamily = AF_UNIX
, addrSocketType = Stream
, addrAddress = SockAddrUnix addr
}
]
getAddr host port = getAddrInfo (Just defaultHints) (Just host) (Just $ show port)
safeConnectTo (sock,addr) =
(connect sock addr) >> (Just <$> socketToHandle sock ReadWriteMode)
`catchAny` const (return Nothing)
checkConn = do
singleMsg <- send ""
let [msg] = singleMsg
if "OK MPD" `isPrefixOf` msg
then MPD $ checkVersion $ parseVersion msg
else return False
checkVersion Nothing = throwError $ Custom "Couldn't determine MPD version"
checkVersion (Just version)
| version < requiredVersion =
throwError $ Custom $ printf
"MPD %s is not supported, upgrade to MPD %s or above!"
(formatVersion version) (formatVersion requiredVersion)
| otherwise = do
modify (\st -> st { stVersion = version })
return True
where
requiredVersion = (0, 19, 0)
parseVersion = parseTriple '.' parseNum . dropWhile (not . isDigit)
formatVersion :: (Int, Int, Int) -> String
formatVersion (x, y, z) = printf "%d.%d.%d" x y z
mpdClose :: MPD ()
mpdClose =
MPD $ do
mHandle <- gets stHandle
F.forM_ mHandle $ \h -> do
modify $ \st -> st{stHandle = Nothing}
r <- liftIO $ sendClose h
F.forM_ r throwError
where
sendClose handle =
(hPutStrLn handle "close" >> hReady handle >> hClose handle >> return Nothing)
`catch` handler
handler err
| isEOFError err = return Nothing
| otherwise = (return . Just . ConnectionError) err
mpdSend :: String -> MPD [ByteString]
mpdSend str = send' `catchError` handler
where
handler err
| ConnectionError e <- err, isRetryable e = mpdOpen >> send'
| otherwise = throwError err
send' :: MPD [ByteString]
send' = MPD $ gets stHandle >>= maybe (throwError NoMPD) go
go handle = (liftIO . tryIOError $ do
unless (null str) $ B.hPutStrLn handle (UTF8.fromString str) >> hFlush handle
getLines handle [])
>>= either (\err -> modify (\st -> st { stHandle = Nothing })
>> throwError (ConnectionError err)) return
getLines :: Handle -> [ByteString] -> IO [ByteString]
getLines handle acc = do
l <- B.hGetLine handle
if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l
then (return . reverse) (l:acc)
else getLines handle (l:acc)
-- | Re-connect and retry for these Exceptions.
isRetryable :: E.IOException -> Bool
isRetryable e = or [ isEOFError e, isResourceVanished e ]
-- | Predicate to identify ResourceVanished exceptions.
-- Note: these are GHC only!
isResourceVanished :: GE.IOException -> Bool
isResourceVanished e = ioeGetErrorType e == GE.ResourceVanished
--
-- Other operations.
--
-- | Kill the server. Obviously, the connection is then invalid.
kill :: (MonadMPD m) => m ()
kill = send "kill" >> return ()
-- | Send a command to the MPD server and return the result.
getResponse :: (MonadMPD m) => String -> m [ByteString]
getResponse cmd = (send cmd >>= parseResponse) `catchError` sendpw
where
sendpw e@(ACK Auth _) = do
pw <- getPassword
if null pw then throwError e
else send ("password " ++ pw) >>= parseResponse
>> send cmd >>= parseResponse
sendpw e =
throwError e
-- Consume response and return a Response.
parseResponse :: (MonadError MPDError m) => [ByteString] -> m [ByteString]
parseResponse xs
| null xs = throwError $ NoMPD
| "ACK" `isPrefixOf` x = throwError $ parseAck x
| otherwise = return $ Prelude.takeWhile ("OK" /=) xs
where
x = head xs
-- Turn MPD ACK into the corresponding 'MPDError'
parseAck :: ByteString -> MPDError
parseAck s = ACK ack (UTF8.toString msg)
where
ack = case code of
2 -> InvalidArgument
3 -> InvalidPassword
4 -> Auth
5 -> UnknownCommand
50 -> FileNotFound
51 -> PlaylistMax
52 -> System
53 -> PlaylistLoad
54 -> Busy
55 -> NotPlaying
56 -> FileExists
_ -> UnknownACK
(code, _, msg) = splitAck 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 s = (read code, cmd, msg)
where
(code, notCode) = between '[' '@' s
(cmd, notCmd) = between '{' '}' notCode
msg = drop 1 $ dropWhile (' ' ==) notCmd
-- take whatever is between 'f' and 'g'.
between a b xs = let (_, y) = break (== a) xs
in break (== b) (drop 1 y)