151 lines
6.3 KiB
Haskell
151 lines
6.3 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE ExtendedDefaultRules #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
import qualified Control.Concurrent
|
|
import qualified Control.Concurrent as Concurrent
|
|
import qualified Control.Concurrent.Async as Async
|
|
import qualified Control.Concurrent.STM as STM
|
|
import Control.Exception (catch, onException)
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import Data.String.Interpolate (i)
|
|
import qualified Data.Text as Text
|
|
import Relude
|
|
import Say (sayErr)
|
|
import Shh (ExecReference (Absolute), captureTrim, exe, ignoreFailure, load, (|>))
|
|
import System.Directory (listDirectory)
|
|
|
|
data Mode = Klausur | Orga | Communication | Code | Leisure | Unrestricted deriving (Eq, Ord, Show, Enum, Bounded)
|
|
|
|
load Absolute ["git", "khal", "playerctl", "notmuch"]
|
|
|
|
modes = enumFrom Klausur
|
|
|
|
getMode = do
|
|
name <- Text.strip <$> readFileText "/home/maralorn/.mode" `onException` sayErr "File /home/maralorn/.mode not found."
|
|
maybe (sayErr [i|Unknown mode #{name}|] >> error [i|Unknown mode #{name}|]) pure $ find (\mode -> name == Text.toLower (show mode)) modes
|
|
|
|
isDirty gitDir = ((/= "") <$> (git "--no-optional-locks" "-C" gitDir "status" "--porcelain" |> captureTrim)) `catch` (\(_ :: SomeException) -> pure True)
|
|
isUnpushed gitDir = do
|
|
revs <- tryCmd (git "--no-optional-locks" "-C" gitDir "branch" "-r" "--contains" "HEAD")
|
|
pure $ LBS.null revs
|
|
|
|
tryCmd x = ignoreFailure x |> captureTrim
|
|
|
|
data Var a = MkVar
|
|
{ value :: TVar a
|
|
, update :: TMVar ()
|
|
}
|
|
newVar :: a -> IO (Var a)
|
|
newVar initial_value = atomically $ MkVar <$> newTVar initial_value <*> newEmptyTMVar
|
|
|
|
newMaybeVar :: IO (Var (Maybe a))
|
|
newMaybeVar = atomically $ MkVar <$> newTVar Nothing <*> newEmptyTMVar
|
|
|
|
type Vars = [Var (Maybe Text)]
|
|
type Module a = Var a -> IO Void
|
|
|
|
repeatM :: IO a -> IO Void
|
|
repeatM action = fix (action >>)
|
|
|
|
writeVars :: Vars -> IO Void
|
|
writeVars vars = repeatM do
|
|
outputs <- atomically $ do
|
|
updates <- forM vars $ \MkVar{update} -> tryTakeTMVar update
|
|
STM.check $ any isJust updates
|
|
forM vars \MkVar{value} -> readTVar value
|
|
writeFileText "/run/user/1000/status-bar" $
|
|
Text.replace "&" "&" $
|
|
Text.unwords $
|
|
("<executor.markup.true>" :) $
|
|
catMaybes outputs
|
|
|
|
runModules :: [Module (Maybe Text)] -> IO ()
|
|
runModules modules = do
|
|
(vars, actions) <-
|
|
unzip <$> forM modules \module' -> do
|
|
var <- newMaybeVar
|
|
pure (var, module' var)
|
|
foldConcurrently_ (writeVars vars : actions)
|
|
|
|
foldConcurrently_ :: Foldable f => f (IO a) -> IO ()
|
|
foldConcurrently_ = Async.mapConcurrently_ id
|
|
|
|
oneSecond :: Int
|
|
oneSecond = 1000000
|
|
|
|
updateVarIfChanged :: Eq a => Var a -> a -> STM ()
|
|
updateVarIfChanged MkVar{value, update} new_value = do
|
|
old_value <- readTVar value
|
|
unless (old_value == new_value) do
|
|
writeTVar value new_value
|
|
putTMVar update ()
|
|
|
|
simpleModule :: Eq a => Int -> IO a -> Module a
|
|
simpleModule delay action var = repeatM do
|
|
atomically . updateVarIfChanged var =<< action
|
|
Concurrent.threadDelay delay
|
|
|
|
main :: IO ()
|
|
main = do
|
|
mode_var <- newVar Orga
|
|
let read_mode = readTVarIO (value mode_var)
|
|
modules =
|
|
[ simpleModule (5 * oneSecond) $ do
|
|
appointments <- lines . decodeUtf8 <$> tryCmd (khal ["list", "-a", "Standard", "-a", "Planung", "-a", "Uni", "-a", "Maltaire", "now", "2h", "-df", ""])
|
|
pure $
|
|
if null appointments
|
|
then Nothing
|
|
else Just [i|<span foreground='\#bbb0fb'>#{Text.intercalate "; " appointments}</span>|]
|
|
, simpleModule oneSecond $
|
|
Just . Text.replace "Stopped -" "⏹" . Text.replace "Playing -" "▶" . Text.replace "Paused -" "⏸" . Text.intercalate " - " . fmap decodeUtf8 . filter (/= "") <$> mapM tryCmd [playerctl "status", playerctl "metadata" "title", playerctl "metadata" "album", playerctl "metadata" "artist"]
|
|
, simpleModule oneSecond $ do
|
|
mode <- read_mode
|
|
unread <-
|
|
if mode >= Orga
|
|
then notmuch "count" "folder:hera/Inbox" "tag:unread" |> captureTrim
|
|
else pure "0"
|
|
pure $ memptyIfFalse (unread /= "0") (Just [i|<span foreground='\#DC143C'>Unread: #{unread}</span>|])
|
|
, simpleModule oneSecond $ do
|
|
mode <- read_mode
|
|
inbox <-
|
|
if mode == Leisure
|
|
then notmuch "count" "folder:hera/Inbox" |> captureTrim
|
|
else pure "0"
|
|
pure $ memptyIfFalse (inbox /= "0") (Just [i|<span foreground='\#7fff00'>Inbox: #{inbox}</span>|])
|
|
, simpleModule oneSecond $ do
|
|
mode <- read_mode
|
|
codeMails <-
|
|
if mode == Code
|
|
then notmuch "count" "folder:hera/Code" |> captureTrim
|
|
else pure "0"
|
|
pure $ memptyIfFalse (codeMails /= "0") (Just [i|<span foreground='\#20c420'>Code Mails: #{codeMails}</span>|])
|
|
, simpleModule (5 * oneSecond) $ do
|
|
mode <- read_mode
|
|
codeUpdates <-
|
|
if mode == Code
|
|
then fromMaybe 0 . readMaybe . toString . Text.replace " unread articles" "" . decodeUtf8 <$> tryCmd (exe "software-updates" "-x" "print-unread")
|
|
else pure 0
|
|
pure $ memptyIfFalse (codeUpdates /= 0) (Just [i|<span foreground='\#20c420'>Code Updates: #{codeUpdates}</span>|])
|
|
, simpleModule (5 * oneSecond) $ do
|
|
dirs <- listDirectory "/home/maralorn/git"
|
|
dirty <- fmap toText <$> filterM (isDirty . ("/home/maralorn/git/" <>)) dirs
|
|
pure $ memptyIfFalse (not (null dirty)) (Just [i|<span foreground='\#ff9f50'>Dirty: #{Text.intercalate " " dirty}</span>|])
|
|
, simpleModule (5 * oneSecond) $ do
|
|
dirs <- listDirectory "/home/maralorn/git"
|
|
unpushed <- fmap toText <$> filterM (isUnpushed . ("/home/maralorn/git/" <>)) dirs
|
|
pure $ memptyIfFalse (not (null unpushed)) (Just [i|<span foreground='\#f2995e'>Unpushed: #{Text.intercalate " " unpushed}</span>|])
|
|
, simpleModule 1 $ do
|
|
atomically $ takeTMVar (update mode_var)
|
|
mode <- read_mode
|
|
pure $ Just [i|<span foreground='\#a0a0ff'>#{show mode}</span>|]
|
|
]
|
|
foldConcurrently_
|
|
[ void $ simpleModule oneSecond getMode mode_var
|
|
, runModules modules
|
|
]
|