From 7245fc097567ad6b5493b2e97f599547d7535ec3 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Tue, 18 Feb 2020 16:11:21 +0100
Subject: [PATCH] Allow configuration of blocks from cli
This reverses the control flow between 'Cli' and 'Server'
---
app/Main.hs | 4 +--
src/QBar/Cli.hs | 70 ++++++++++++++++++++++-----------------
src/QBar/ControlSocket.hs | 21 ++++++------
src/QBar/Core.hs | 6 ++++
src/QBar/DefaultConfig.hs | 4 +--
src/QBar/Server.hs | 14 ++------
6 files changed, 61 insertions(+), 58 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
index 6a8109f..1aa42b0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,8 +1,6 @@
module Main where
import QBar.Cli
-import QBar.DefaultConfig
-import QBar.Server
main :: IO ()
-main = parseOptions >>= runQBar generateDefaultBarConfig
\ No newline at end of file
+main = runQBar
\ No newline at end of file
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index 986afc3..d23996a 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -2,47 +2,55 @@
module QBar.Cli where
+import QBar.ControlSocket
+import QBar.Core
+import QBar.DefaultConfig
+import QBar.Server
import QBar.Theme
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
+import Control.Monad (join, sequence_)
+import qualified Data.Text.Lazy as T
import Options.Applicative
-data BarCommand = BarServerCommand | SetThemeCommand Text | ConnectSocket
+-- |Entry point.
+runQBar :: IO ()
+runQBar = join parseMain
-barCommandParser :: Parser BarCommand
-barCommandParser = hsubparser (
- command "server" (info (pure BarServerCommand) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
- command "connect" (info (pure ConnectSocket) (progDesc "Run blocks on this process but display them on the qbar server.")) <>
- command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server.")) <>
- command "default" (info (pure $ SetThemeCommand "default") (progDesc "Shortcut for 'qbar theme default'.")) <>
- command "rainbow" (info (pure $ SetThemeCommand "rainbow") (progDesc "Shortcut for 'qbar theme rainbow'."))
- )
-
-themeCommandParser :: Parser BarCommand
-themeCommandParser = SetThemeCommand <$> strArgument (metavar "THEME" <> completeWith (map TL.unpack themeNames))
+parseMain :: IO (IO ())
+parseMain = customExecParser parserPrefs parser
+ where
+ parser :: ParserInfo (IO ())
+ parser = info (mainParser <**> helper)
+ (fullDesc <> header "qbar - queezles {i3,sway}bar infrastructure")
-data MainOptions = MainOptions {
- verbose :: Bool,
- indicator :: Bool,
- socketLocation :: Maybe T.Text,
- barCommand :: BarCommand
-}
+ parserPrefs :: ParserPrefs
+ parserPrefs = prefs showHelpOnEmpty
-mainOptionsParser :: Parser MainOptions
-mainOptionsParser = do
+mainParser :: Parser (IO ())
+mainParser = do
verbose <- switch $ long "verbose" <> short 'v' <> help "Print more diagnostic output to stderr (including a copy of every bar update)."
indicator <- switch $ long "indicator" <> short 'i' <> help "Show render indicator."
socketLocation <- optional $ strOption $ long "socket" <> short 's' <> metavar "SOCKET" <> help "Control socket location. By default determined by WAYLAND_SOCKET location."
barCommand <- barCommandParser
- return MainOptions {verbose, indicator, socketLocation, barCommand}
+ return (barCommand MainOptions {verbose, indicator, socketLocation})
-parser :: ParserInfo MainOptions
-parser = info (mainOptionsParser <**> helper)
- (fullDesc <> header "qbar - queezles {i3,sway}bar infrastructure")
-
-parserPrefs :: ParserPrefs
-parserPrefs = prefs showHelpOnEmpty
+barCommandParser :: Parser (MainOptions -> IO ())
+barCommandParser = hsubparser (
+ command "server" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
+ command "connect" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but display them on the qbar server.")) <>
+ command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server.")) <>
+ command "default" (info (pure $ sendIpc . SetTheme $ "default") (progDesc "Shortcut for 'qbar theme default'.")) <>
+ command "rainbow" (info (pure $ sendIpc . SetTheme $ "rainbow") (progDesc "Shortcut for 'qbar theme rainbow'."))
+ )
-parseOptions :: IO MainOptions
-parseOptions = customExecParser parserPrefs parser
\ No newline at end of file
+themeCommandParser :: Parser (MainOptions -> IO ())
+themeCommandParser = sendIpc . SetTheme <$> strArgument (metavar "THEME" <> completeWith (map T.unpack themeNames))
+
+barConfigurationParser :: Parser (BarIO ())
+barConfigurationParser = do
+ blocks <- many $ hsubparser (
+ command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks."))
+ )
+ pure $ case blocks of
+ [] -> defaultBarConfig
+ l -> sequence_ l
diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index 8faa26a..632d486 100644
--- a/src/QBar/ControlSocket.hs
+++ b/src/QBar/ControlSocket.hs
@@ -9,7 +9,6 @@
module QBar.ControlSocket where
import QBar.BlockOutput
-import QBar.Cli (MainOptions(..))
import QBar.Core
import QBar.Host
import QBar.Util
@@ -27,8 +26,7 @@ import System.IO
import Data.Either (either)
import Data.Maybe (maybe)
import Data.Text.Lazy (Text, pack)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy as T
import Network.Socket
import Pipes
import Pipes.Concurrent as PC (Output, spawn', unbounded, fromInput, send, atomically)
@@ -110,12 +108,15 @@ instance IsStream BlockStream where
type Down BlockStream = BlockEvent
toStreamType = BlockStreamType
streamHandler _ = do
- (cache, updateC, seal) <- newCache'
+ (cache, updateCacheC, sealCache) <- newCache'
(eventOutput, eventInput, eventSeal) <- liftIO $ spawn' unbounded
bar <- askBar
addBlock cache
prefix <- liftIO $ (<> "_") <$> randomIdentifier
- return (updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateC, fromInput eventInput, seal >> atomically eventSeal)
+ let blockConsumer = updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateCacheC
+ let eventProducer = fromInput eventInput
+ let seal = sealCache >> atomically eventSeal >> updateBar' bar
+ return (blockConsumer, eventProducer, seal)
where
attachHandlerP :: Output BlockEvent -> Text -> Pipe [BlockOutput] [BlockState] IO ()
attachHandlerP eventOutput prefix = attachHandlerP'
@@ -145,7 +146,7 @@ instance IsStream BlockStream where
data Request = Command Command | StartStream StreamType
-data Command = SetTheme TL.Text
+data Command = SetTheme T.Text
deriving Show
data CommandResult = Success | Error Text
@@ -189,8 +190,8 @@ $(deriveJSON defaultOptions ''CommandResult)
$(deriveJSON defaultOptions ''StreamType)
$(deriveJSON defaultOptions ''BlockStream)
-sendIpc :: MainOptions -> Command -> IO ()
-sendIpc options@MainOptions{verbose} command = do
+sendIpc :: Command -> MainOptions -> IO ()
+sendIpc command options@MainOptions{verbose} = do
let request = Command command
sock <- connectIpcSocket options
runEffect $ encode request >-> toSocket sock
@@ -206,8 +207,8 @@ sendIpc options@MainOptions{verbose} command = do
showResponse Success = when verbose $ hPutStrLn stderr "Success"
showResponse (Error message) = hPrint stderr message
-sendBlockStream :: MainOptions -> BarIO () -> IO ()
-sendBlockStream = runBarHost . streamClient BlockStream
+sendBlockStream :: BarIO () -> MainOptions -> IO ()
+sendBlockStream loadBlocks options = runBarHost (streamClient BlockStream options) loadBlocks
listenUnixSocketAsync :: MainOptions -> Bar -> CommandHandler -> IO (Async ())
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index b25a1e6..46bd95c 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -33,6 +33,12 @@ import System.Process.Typed (Process, shell, setStdin, setStdout,
getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
+data MainOptions = MainOptions {
+ verbose :: Bool,
+ indicator :: Bool,
+ socketLocation :: Maybe T.Text
+}
+
data BlockEvent = Click {
name :: T.Text,
button :: Int
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index d47cb72..ee42174 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -11,8 +11,8 @@ import Control.Lens
blockLocation :: String -> FilePath
blockLocation name = "~/.config/qbar/blocks/" <> name
-generateDefaultBarConfig :: BarIO ()
-generateDefaultBarConfig = do
+defaultBarConfig :: BarIO ()
+defaultBarConfig = do
systemInfoInterval <- sharedInterval 10
let todo = systemInfoInterval (blockScript $ blockLocation "todo")
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index 899d3ca..d36cbf0 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -5,7 +5,6 @@ module QBar.Server where
import QBar.BlockOutput
import QBar.Core
-import QBar.Cli
import QBar.ControlSocket
import QBar.Host
import QBar.Pango
@@ -117,8 +116,8 @@ swayBarOutput options@MainOptions{indicator} = do
pangoBlockName = _blockName
}
-runBarServer :: MainOptions -> BarIO () -> IO ()
-runBarServer options = runBarHost barServer
+runBarServer :: BarIO () -> MainOptions -> IO ()
+runBarServer loadBlocks options = runBarHost barServer loadBlocks
where
barServer :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
barServer = do
@@ -190,12 +189,3 @@ runBarServer options = runBarHost barServer
Right theme -> do
setTheme' theme
return Success
-
-
--- |Entry point.
-runQBar :: BarIO () -> MainOptions -> IO ()
-runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
- where
- runCommand BarServerCommand = runBarServer options barConfiguration
- runCommand ConnectSocket = sendBlockStream options barConfiguration
- runCommand (SetThemeCommand themeName) = sendIpc options $ SetTheme themeName
--
GitLab