1 files changed, 127 insertions, 0 deletions

diff --git a/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs b/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs
new file mode 100644
index 00000000..e6accdcc
--- /dev/null
+++ b/accounts/gkleen@sif/xmonad/lib/XMonad/Mpv.hs
@@ -0,0 +1,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