content: {-
      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) =
  #if MIN_VERSION_network(3,0,0)
    Fd <$> unsafeFdSocket s
  #else
    pure . Fd $ fdSocket s
  #endif
  
  
  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
  