summaryrefslogtreecommitdiff
path: root/Monky/MPD.hs
blob: 500c88da388c874f639ed92d86e0c9f15c5000bd (plain)
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
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
{-
    Copyright 2015 Markus Ongyerth, Stephan Guenther

    This file is part of Monky.

    Monky is free software: you can redistribute it and/or modify
    it under the terms of the GNU Lesser General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    Monky is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public License
    along with Monky.  If not, see <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-|
Module      : Monky.MPD
Description : Allows to query information from an mpd server
Maintainer  : ongy
Stability   : testing
Portability : Linux

This module creates a persistant connection to an mpd server and allows to query
information or react to events waited for with MPDs idle
-}
module Monky.MPD
  ( MPDSocket
  , State(..)
  , TagCollection(..)
  , SongInfo(..)
  , Status(..)
  , getMPDStatus
  , getMPDSong
  , getMPDSocket
  , closeMPDSocket
  , getMPDFd
  , readOk
  , goIdle
  , doQuery -- This might not stay
  )
where

import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Read as R

import System.IO.Error
import GHC.IO.Exception
import Control.Exception (try)
import Control.Monad (join, void, unless)
import Control.Monad.Trans
import Control.Monad.Trans.Except
import Data.Char (isSpace)
import Data.List (isPrefixOf)
import Data.Maybe (isJust,fromJust)
import System.Posix.Types (Fd(..))
import System.Timeout (timeout)
import Network.Socket hiding (recv)
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as M

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative ((<$>))
#endif

type MPDSock = Socket
-- |A type safe socket for this module, basically a handle
newtype MPDSocket = MPDSocket MPDSock

-- |The current state of the MPD player submodule
data State
  = Playing -- ^Playing
  | Stopped -- ^Stopped
  | Paused  -- ^Paused
  deriving (Show, Eq) -- If it wasn't obvious

-- |Collection of tags MPD supports
data TagCollection = TagCollection
  {
    tagArtist          :: Maybe Text
  , tagArtistSort      :: Maybe Text
  , tagAlbum           :: Maybe Text
  , tagAlbumSort       :: Maybe Text
  , tagAlbumArtist     :: Maybe Text
  , tagAlbumArtistSort :: Maybe Text
  , tagTitle           :: Maybe Text
  , tagTrack           :: Maybe Text
  , tagName            :: Maybe Text
  , tagGenre           :: Maybe Text
  , tagDate            :: Maybe Text
  , tagComposer        :: Maybe Text
  , tagPerformer       :: Maybe Text
  , tagComment         :: Maybe Text
  , tagDisc            :: Maybe Text
  , tagMArtistid       :: Maybe Text
  , tagMAlbumid        :: Maybe Text
  , tagMAlbumArtistid  :: Maybe Text
  , tagMTrackid        :: Maybe Text
  , tagMReleaseTrackid :: Maybe Text
  } deriving (Show, Eq)

-- |Information about an song
data SongInfo = SongInfo
  {
    songFile     :: Text
  , songRange    :: Maybe (Float, Float)
  , songMTime    :: Maybe Text
  , songTime     :: Maybe Int
  , songDuration :: Maybe Float
  , songTags     :: TagCollection
  , songPos      :: Maybe Int
  , songInfoId   :: Maybe Int
  , songPriority :: Maybe Int
  } deriving (Show, Eq)

-- |Haskell type for the data returned by MPDs status command
data Status = Status
  {  -- We get those values every time with current versions (maybe for outdated mpd)
    volume         :: Int
  , repeats        :: Bool
  , random         :: Bool
  , single         :: Maybe Bool --added with 0.15
  , consume        :: Maybe Bool --added with 0.15
  , playlist       :: Int
  , playlistLength :: Int
  , state          :: State
  , mixrAmpdb      :: Float

  -- Those values may be sent with the state for current versions
  , xfade          :: Maybe Int
  , mixrAmpDelay   :: Maybe Int
  , song           :: Maybe Int --playlist song number
  , songId         :: Maybe Int --playlist songid
  , nextSong       :: Maybe Int --added with 0.15
  , nextSongId     :: Maybe Int --added with 0.15
  , time           :: Maybe Int
  , elapsed        :: Maybe Float --added with 0.16
  , bitrate        :: Maybe Int
  , duration       :: Maybe Int --added with 0.20
  , audio          :: Maybe (Int,Int,Int)
  , updating       :: Maybe Int
  , mpderror       :: Maybe Text
  } deriving (Show, Eq)

-- This isn't nice, but OK for now
readText :: Integral a => Text -> a
readText t = let (Right (x, _)) = R.decimal t in x


rethrowSExcpt :: String -> IOError -> ExceptT String IO a
rethrowSExcpt xs e = throwE (xs ++ ": " ++ show e)


trySExcpt :: String -> IO a -> ExceptT String IO a
trySExcpt l f = liftIO (try f) >>= rethrow
  where rethrow (Left x) = rethrowSExcpt l x
        rethrow (Right x) = return x

-- |Close the 'MPDSocket' when it is no longer required
closeMPDSocket :: MPDSocket -> IO ()
closeMPDSocket (MPDSocket sock) = close sock

-- Is this connection exception recoverable or should we just die?
recoverableCon :: IOError -> Bool
recoverableCon x
  | ioeGetErrorType x == NoSuchThing = True
  | otherwise = False


tryConnect :: [AddrInfo] -> MPDSock -> ExceptT String IO MPDSock
tryConnect [] _ = error "Tryed to connect with non existing socket"
tryConnect (x:xs) sock =
  liftIO (try $connect sock (addrAddress x)) >>= handleExcpt
  where handleExcpt (Right _) = return sock
        handleExcpt (Left y) = if recoverableCon y
          then liftIO (close sock) >> openMPDSocket xs
          else rethrowSExcpt "Connect" y


doMPDConnInit :: MPDSock -> IO (Maybe String)
doMPDConnInit s = join <$> timeout (500 * 1000) (do
  v <- BS.unpack <$> recv s 64
  if "OK MPD " `isPrefixOf` v
    then return . Just $ drop 7 v
    else return Nothing)

-- |Open one MPDSock connected to a host specified by one of the 'MPDInfo'
-- or throw an exception (either ran out of hosts or something underlying failed)
openMPDSocket :: [AddrInfo] -> ExceptT String IO MPDSock
openMPDSocket [] = throwE "Could not open connection"
openMPDSocket ys@(x:xs) = do
  sock <- trySExcpt "socket" $ openSocket x
  csock <- tryConnect ys sock
  version <- trySExcpt "readInit" $ doMPDConnInit csock
  if isJust version
    then liftIO $ return csock
    else liftIO (close sock) >> openMPDSocket xs
  where openSocket y = socket (addrFamily y) (addrSocketType y) (addrProtocol y)

-- |Get a new 'MPDSocket'
getMPDSocket
  :: String -- ^The host the server is on
  -> String -- ^The port the server listens on
  -> IO (Either String MPDSocket)
getMPDSocket host port = do
  xs <- getAddrInfo (Just $ defaultHints {addrFlags = [AI_V4MAPPED]}) (Just host) (Just port)
  sock <- runExceptT $ openMPDSocket xs
  return $ fmap MPDSocket sock

-- |Get the raw 'Fd' from the 'MPDSocket' for eventing api
getMPDFd :: MPDSocket -> IO Fd
getMPDFd (MPDSocket s) = return . Fd $fdSocket s


recvMessage :: MPDSock -> ExceptT String IO [Text]
recvMessage sock =
  trySExcpt "receive" $ T.lines . E.decodeUtf8 <$> recv sock 4096


sendMessage :: MPDSock -> String -> ExceptT String IO ()
sendMessage sock message = void $
  trySExcpt "send" (sendAll sock $BS.pack message)

{- |Send a query to the MPD server and return a list of answers (line by line)

This does not filter out errors, error checking has to be done by the user.
This does filter out the last OK though
-}
doQuery :: MPDSocket -> String -> ExceptT String IO [Text]
doQuery (MPDSocket s) m = sendMessage s (m ++ "\n") >> (f <$> recvMessage s)
  where f = filter (/= "OK")

-- |Get the OK sent by mpd after idle out of the pipe
readOk :: MPDSocket -> IO (Either String ())
readOk (MPDSocket s) = runExceptT $ do
  resp <- recvMessage s
  unless (resp == ["OK"]) (throwE . T.unpack . T.concat $ resp)

{- |Go into MPDs 'idle' mode, this does return, but MPD wont time us out and
will notify us if something happens
-}
goIdle
  :: MPDSocket
  -> String -- ^The string that should be send with idle (list of subsystems)
  -> IO (Either String ())
goIdle (MPDSocket s) xs = runExceptT $ void $ sendMessage s ("idle" ++ xs ++ "\n")


getAudioTuple :: Text -> (Int,Int,Int)
getAudioTuple xs =
  let (Right (x, ys)) = R.decimal xs
      (Right (y, zs)) = R.decimal $ T.tail ys
      (Right (z, _))  = R.decimal $ T.tail zs
    in (x, y, z)


getState :: Text -> State
getState "play"  = Playing
getState "stop"  = Stopped
getState "pause" = Paused
getState xs = error ("Got unknown state: " ++ T.unpack xs)


parseStatusRec :: M.Map Text Text -> [Text] -> Status
parseStatusRec m (x:xs) = let (key,value) = T.break (== ' ') x in
  parseStatusRec (M.insert (T.init key) (T.tail value) m) xs
parseStatusRec m [] = Status
  { volume         = fromJust $ getInt "volume"
  , repeats        = fromJust $ getBool "repeat"
  , random         = fromJust $ getBool "random"
  , single         = getBool "single"
  , consume        = getBool "consume"
  , playlist       = fromJust $ getInt "playlist"
  , playlistLength = fromJust $ getInt "playlistlength"
  , state          = getState_ m
  , song           = getInt "song"
  , songId         = getInt "songid"
  , nextSong       = getInt "nextsong"
  , nextSongId     = getInt "nextsongid"
  , time           = fmap (readText . T.takeWhile (/= ':')) $getVal "time"
  , elapsed        = read . T.unpack <$> M.lookup "elapsed" m
  , duration       = getInt "duration"
  , bitrate        = getInt "bitrate"
  , xfade          = getInt "xfade"
  , mixrAmpdb      = fromJust . fmap readF $ getVal "mixrampdb"
  , mixrAmpDelay   = getInt "mixrampdelay"
  , audio          = getAudio m
  , updating       = getInt "updating_db"
  , mpderror       = M.lookup "error" m
  }
  where getVal = flip M.lookup m
        getBool = fmap (== ("1" :: Text)) . getVal
        getInt = fmap readText . getVal
        getState_ = getState . fromJust . M.lookup "state"
        getAudio = fmap getAudioTuple . M.lookup "audio"
        readF t = let (Right (x, _)) = R.rational t in x


parseSongInfoRec :: M.Map Text Text -> [Text] -> SongInfo
-- use init to drop the ':' for keys
-- use break instead of words because of comment or artist
parseSongInfoRec m (x:xs) = let (key, value) = T.break isSpace x in
  parseSongInfoRec (M.insert (T.init key) (T.tail value) m) xs
parseSongInfoRec m [] = let tags = TagCollection {
    tagArtist          = M.lookup "Artist" m
  , tagArtistSort      = M.lookup "ArtistSort" m
  , tagAlbum           = M.lookup "Album" m
  , tagAlbumSort       = M.lookup "AlbumSort" m
  , tagAlbumArtist     = M.lookup "AlbumArtist" m
  , tagAlbumArtistSort = M.lookup "AlbumArtistSort" m
  , tagTitle           = M.lookup "Title" m
  , tagTrack           = M.lookup "Track" m
  , tagName            = M.lookup "Name" m
  , tagGenre           = M.lookup "Genre" m
  , tagDate            = M.lookup "Date" m
  , tagComposer        = M.lookup "Composer" m
  , tagPerformer       = M.lookup "Performer" m
  , tagComment         = M.lookup "Comment" m
  , tagDisc            = M.lookup "Disc" m

  , tagMArtistid       = M.lookup "MUSICBRAINZ_ARTISTID" m
  , tagMAlbumid        = M.lookup "MUSICBRAINZ_ALBUMID" m
  , tagMAlbumArtistid  = M.lookup "MUSICBRAINZ_ALBUMARTISTID" m
  , tagMTrackid        = M.lookup "MUSICBRAINZ_TRACKID" m
  , tagMReleaseTrackid = M.lookup "MUSICBRAINZ_RELEASETRACKID" m
  } in
    SongInfo {
      songFile     = fromJust $M.lookup "file" m
    , songRange    = readT <$> M.lookup "Range" m
    , songMTime    = M.lookup "Last-Modified" m
    , songTime     = mRead "Time"
    , songDuration = readF <$> M.lookup "duration" m
    , songTags     = tags
    , songPos      = mRead "Pos"
    , songInfoId   = mRead "Id"
    , songPriority = mRead "Prio"
    }
  where readT xs =
          let (Right (x, ys)) = R.rational xs
              (Right (y, _))  = R.rational . T.tail $ ys in
            (x, y)
        mRead = fmap (readText) . flip M.lookup m
        readF t = let (Right (x, _)) = R.rational t in x


parseStatus :: [Text] -> Status
parseStatus [] = error "Called parseStatus with []"
parseStatus xs@(x:_) = if "ACK" `T.isPrefixOf` x
  then error (T.unpack x)
  else parseStatusRec M.empty xs

-- |Get the current status or an error from the MPD server
getMPDStatus :: MPDSocket -> IO (Either String Status)
getMPDStatus s = do
  resp <- runExceptT $ doQuery s "status"
  return $ fmap parseStatus resp

parseSongInfo :: [Text] -> SongInfo
parseSongInfo [] = error "Called parseSongInfo with []"
parseSongInfo xs@(x:_) = if "ACK" `T.isPrefixOf` x
  then error (T.unpack x)
  else parseSongInfoRec M.empty xs

-- |Get the information about the song currently beeing player from the MPD server
getMPDSong :: MPDSocket -> IO (Either String SongInfo)
getMPDSong s = do
  resp <- runExceptT $ doQuery s "currentsong"
  return $ fmap parseSongInfo resp