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
|
{-# 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
|
