{-# LANGUAGE DeriveGeneric, OverloadedLists, OverloadedStrings, ViewPatterns, ExistentialQuantification, MultiWayIf #-}

module XMonad.Mpv
  ( MpvCommand(..), MpvResponse(..), MpvException(..)
  , mpv
  , mpvDir
  , mpvAll, mpvOne
  , mpvResponse
  ) where

import Data.Aeson

import Data.Monoid

import Network.Socket hiding (recv)
import Network.Socket.ByteString

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.ByteString.Lazy as LBS

import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.String (IsString(..))

import Control.Exception

import System.IO.Temp (getCanonicalTemporaryDirectory)

import Control.Monad
import Control.Exception (bracket)
import Control.Monad.IO.Class (MonadIO(..))

import System.FilePath
import System.Directory (getDirectoryContents)

import Data.List
import Data.Either
import Data.Maybe

import Debug.Trace


data MpvCommand
  = forall a. ToJSON a => MpvSetProperty String a
  | MpvGetProperty String
data MpvResponse
  = MpvError String
  | MpvSuccess (Maybe Value)
  deriving (Read, Show, Generic, Eq)
data MpvException = MpvException String
                  | MpvNoValue
                  | MpvNoParse String
  deriving (Generic, Typeable, Read, Show)
instance Exception MpvException


instance ToJSON MpvCommand where
  toJSON (MpvSetProperty name val) = Array ["set_property", fromString name, toJSON val]
  toJSON (MpvGetProperty name)     = Array ["get_property", fromString name]

instance FromJSON MpvResponse where
  parseJSON = withObject "response object" $ \obj -> do
    mval <- obj .:? "data"
    err <- obj .: "error"

    let ret
          | err == "success" = MpvSuccess mval
          | otherwise        = MpvError err

    return ret

mpvSocket :: FilePath -> (Socket -> IO a) -> IO a
mpvSocket sockPath = withSocketsDo . bracket mkSock close
  where
    mkSock = do
      sock <- socket AF_UNIX Stream defaultProtocol
      connect sock $ SockAddrUnix (traceId sockPath)
      return sock

mpvResponse :: FromJSON v => MpvResponse -> IO v
mpvResponse (MpvError str) = throwIO $ MpvException str
mpvResponse (MpvSuccess Nothing) = throwIO MpvNoValue
mpvResponse (MpvSuccess (Just v)) = case fromJSON v of
  Success v' -> return v'
  Error str  -> throwIO $ MpvNoParse str

mpv :: FilePath -> MpvCommand -> IO MpvResponse
mpv sockPath cmd = mpvSocket sockPath $ \sock -> do
  let message = (`BS.append` "\n") . LBS.toStrict . encode $ Object [("command", toJSON cmd)]
  traceIO $ show message
  sendAll sock message
  let recvAll = do
        prefix <- recv sock 4096
        if
          | (prefix', rest) <- CBS.break (== '\n') prefix
          , not (BS.null rest) -> return prefix'
          | BS.null prefix     -> return prefix
          | otherwise          -> BS.append prefix <$> recvAll
  response <- recvAll
  traceIO  $ show response
  either (ioError . userError) return . traceShowId $ eitherDecodeStrict' response

mpvDir :: Exception e => FilePath -> (FilePath -> [(FilePath, Either e MpvResponse)] -> Maybe MpvCommand) -> IO [(FilePath, Either e MpvResponse)]
mpvDir dir step = do
  socks <- filter (".sock" `isSuffixOf`) <$> getDirectoryContents dir
  go [] socks
  where
    go acc [] = return acc
    go acc (sock:socks)
      | Just cmd <- step sock acc = do
          res <- try $ mpv (dir </> sock) cmd
          go ((sock, res) : acc) socks
      | otherwise =
          go acc socks

mpvAll :: FilePath -> MpvCommand -> IO [MpvResponse]
mpvAll dir cmd = do
  results <- map snd <$> (mpvDir dir (\_ _ -> Just cmd) :: IO [(FilePath, Either SomeException MpvResponse)])
  mapM (either throwIO return) results

mpvOne :: FilePath -> MpvCommand -> IO (Maybe MpvResponse)
mpvOne dir cmd = listToMaybe . snd . partitionEithers . map snd <$> (mpvDir dir step :: IO [(FilePath, Either SomeException MpvResponse)])
  where
    step _ results
      | any (isRight . snd) results = Nothing
      | otherwise = Just cmd