{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module MSU.Monitors
( Monitors(..)
, readMonitorsFileThrow
, readMonitorsYaml
, findMonitors
, createMonitor
, writeMonitorsFile
)
where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List (find)
import qualified Data.Yaml as Yaml
import GHC.Generics (Generic)
import MSU.Context (Context)
import qualified MSU.Context as Context
import MSU.Match
import qualified MSU.Xrandr.Parse as Xrandr
import System.Directory (doesFileExist)
data Monitors = Monitors
{ Monitors -> String
name :: String
, Monitors -> MatchContext
match :: MatchContext
, Monitors -> String
exec :: String
}
deriving stock (forall x. Monitors -> Rep Monitors x)
-> (forall x. Rep Monitors x -> Monitors) -> Generic Monitors
forall x. Rep Monitors x -> Monitors
forall x. Monitors -> Rep Monitors x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Monitors x -> Monitors
$cfrom :: forall x. Monitors -> Rep Monitors x
Generic
deriving anyclass (Value -> Parser [Monitors]
Value -> Parser Monitors
(Value -> Parser Monitors)
-> (Value -> Parser [Monitors]) -> FromJSON Monitors
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Monitors]
$cparseJSONList :: Value -> Parser [Monitors]
parseJSON :: Value -> Parser Monitors
$cparseJSON :: Value -> Parser Monitors
FromJSON, [Monitors] -> Encoding
[Monitors] -> Value
Monitors -> Encoding
Monitors -> Value
(Monitors -> Value)
-> (Monitors -> Encoding)
-> ([Monitors] -> Value)
-> ([Monitors] -> Encoding)
-> ToJSON Monitors
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Monitors] -> Encoding
$ctoEncodingList :: [Monitors] -> Encoding
toJSONList :: [Monitors] -> Value
$ctoJSONList :: [Monitors] -> Value
toEncoding :: Monitors -> Encoding
$ctoEncoding :: Monitors -> Encoding
toJSON :: Monitors -> Value
$ctoJSON :: Monitors -> Value
ToJSON)
data MatchContext = MatchContext
{ MatchContext -> Maybe (Match [String])
displays :: Maybe (Match [String])
, MatchContext -> Maybe (Match String)
wifi :: Maybe (Match String)
}
deriving stock (forall x. MatchContext -> Rep MatchContext x)
-> (forall x. Rep MatchContext x -> MatchContext)
-> Generic MatchContext
forall x. Rep MatchContext x -> MatchContext
forall x. MatchContext -> Rep MatchContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MatchContext x -> MatchContext
$cfrom :: forall x. MatchContext -> Rep MatchContext x
Generic
deriving anyclass (Value -> Parser [MatchContext]
Value -> Parser MatchContext
(Value -> Parser MatchContext)
-> (Value -> Parser [MatchContext]) -> FromJSON MatchContext
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MatchContext]
$cparseJSONList :: Value -> Parser [MatchContext]
parseJSON :: Value -> Parser MatchContext
$cparseJSON :: Value -> Parser MatchContext
FromJSON, [MatchContext] -> Encoding
[MatchContext] -> Value
MatchContext -> Encoding
MatchContext -> Value
(MatchContext -> Value)
-> (MatchContext -> Encoding)
-> ([MatchContext] -> Value)
-> ([MatchContext] -> Encoding)
-> ToJSON MatchContext
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MatchContext] -> Encoding
$ctoEncodingList :: [MatchContext] -> Encoding
toJSONList :: [MatchContext] -> Value
$ctoJSONList :: [MatchContext] -> Value
toEncoding :: MatchContext -> Encoding
$ctoEncoding :: MatchContext -> Encoding
toJSON :: MatchContext -> Value
$ctoJSON :: MatchContext -> Value
ToJSON)
readMonitorsFileThrow :: MonadIO m => FilePath -> m [Monitors]
readMonitorsFileThrow :: String -> m [Monitors]
readMonitorsFileThrow = String -> m [Monitors]
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow
readMonitorsYaml :: ByteString -> Either String [Monitors]
readMonitorsYaml :: ByteString -> Either String [Monitors]
readMonitorsYaml = (ParseException -> String)
-> Either ParseException [Monitors] -> Either String [Monitors]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException [Monitors] -> Either String [Monitors])
-> (ByteString -> Either ParseException [Monitors])
-> ByteString
-> Either String [Monitors]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException [Monitors]
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither'
findMonitors :: Context -> [Monitors] -> Maybe Monitors
findMonitors :: Context -> [Monitors] -> Maybe Monitors
findMonitors Context
context = (Monitors -> Bool) -> [Monitors] -> Maybe Monitors
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Monitors -> Bool) -> [Monitors] -> Maybe Monitors)
-> (Monitors -> Bool) -> [Monitors] -> Maybe Monitors
forall a b. (a -> b) -> a -> b
$ \Monitors {String
MatchContext
exec :: String
match :: MatchContext
name :: String
exec :: Monitors -> String
match :: Monitors -> MatchContext
name :: Monitors -> String
..} ->
let
connected :: [Display]
connected = (Display -> Bool) -> [Display] -> [Display]
forall a. (a -> Bool) -> [a] -> [a]
filter Display -> Bool
Xrandr.connected ([Display] -> [Display]) -> [Display] -> [Display]
forall a b. (a -> b) -> a -> b
$ Context -> [Display]
Context.displays Context
context
names :: [String]
names = (Display -> String) -> [Display] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Display -> String
Xrandr.name [Display]
connected
mEssid :: Maybe String
mEssid = Wifi -> String
Context.essid (Wifi -> String) -> Maybe Wifi -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Maybe Wifi
Context.wifi Context
context
in MatchContext -> Maybe (Match [String])
displays MatchContext
match Maybe (Match [String]) -> [String] -> Bool
forall a. Eq a => Maybe (Match a) -> a -> Bool
`matches` [String]
names Bool -> Bool -> Bool
&& MatchContext -> Maybe (Match String)
wifi MatchContext
match Maybe (Match String) -> Maybe String -> Bool
forall a. Eq a => Maybe (Match a) -> Maybe a -> Bool
`matchesMaybe` Maybe String
mEssid
createMonitor :: Context -> Monitors
createMonitor :: Context -> Monitors
createMonitor Context
context = Monitors :: String -> MatchContext -> String -> Monitors
Monitors
{ name :: String
name = String
"created"
, match :: MatchContext
match = MatchContext :: Maybe (Match [String]) -> Maybe (Match String) -> MatchContext
MatchContext
{ displays :: Maybe (Match [String])
displays = Match [String] -> Maybe (Match [String])
forall a. a -> Maybe a
Just (Match [String] -> Maybe (Match [String]))
-> Match [String] -> Maybe (Match [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Match [String]
forall a. a -> Match a
Eq [String]
connectedNames
, wifi :: Maybe (Match String)
wifi = String -> Match String
forall a. a -> Match a
Eq (String -> Match String)
-> (Wifi -> String) -> Wifi -> Match String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wifi -> String
Context.essid (Wifi -> Match String) -> Maybe Wifi -> Maybe (Match String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Maybe Wifi
Context.wifi Context
context
}
, exec :: String
exec = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"xrandr" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Display -> [String]) -> [Display] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Display -> [String]
xrandrArg ([Display] -> [String]) -> [Display] -> [String]
forall a b. (a -> b) -> a -> b
$ Context -> [Display]
Context.displays
Context
context
}
where
connectedNames :: [String]
connectedNames =
(Display -> String) -> [Display] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Display -> String
Xrandr.name ([Display] -> [String]) -> [Display] -> [String]
forall a b. (a -> b) -> a -> b
$ (Display -> Bool) -> [Display] -> [Display]
forall a. (a -> Bool) -> [a] -> [a]
filter Display -> Bool
Xrandr.connected ([Display] -> [Display]) -> [Display] -> [Display]
forall a b. (a -> b) -> a -> b
$ Context -> [Display]
Context.displays Context
context
xrandrArg :: Display -> [String]
xrandrArg Display
display =
[String
"--output", Display -> String
Xrandr.name Display
display]
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> if Display -> Bool
Xrandr.connected Display
display then Display -> [String]
xrandrMode Display
display else []
xrandrMode :: Display -> [String]
xrandrMode Display
display = case Display -> [(Int, Int)]
Xrandr.modes Display
display of
((Int
x, Int
y) : [(Int, Int)]
_) -> [String
"--mode", Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
y]
[(Int, Int)]
_ -> []
writeMonitorsFile :: MonadIO m => FilePath -> Monitors -> m ()
writeMonitorsFile :: String -> Monitors -> m ()
writeMonitorsFile String
path Monitors
monitors = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- String -> IO Bool
doesFileExist String
path
if Bool
exists
then String -> ByteString -> IO ()
BS.appendFile String
path (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
encoded
else String -> ByteString -> IO ()
BS.writeFile String
path ByteString
encoded
where
prefix :: ByteString
prefix = ByteString
"\n# TODO: created automatically\n"
encoded :: ByteString
encoded = [Monitors] -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode [Monitors
monitors]