diff --git a/app/Main.hs b/app/Main.hs index 6a8109f4163bde1bb214ceed5cdd77a134318691..1aa42b0923dce019a467df72fe88294e432c0544 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 986afc3987be793e14fab823af085d7becf2dd61..d23996a80873e27ac855e5082cbead7ba0f21dc5 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 8faa26a961c9e389c0ca93a164bcc9808073205d..632d48659bcf5c5c6690216cd4916996b2cc4c05 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 b25a1e6099834420e8ffe06097cee2260a2b534b..46bd95c8ec4ca28ab0c4a217388cec09568c459f 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 d47cb7206584302a1878d34fe15dea649bc8a234..ee421743c62d8c8836ff7d821ad7cae31c75bd8a 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 899d3cac41542d83ab5386787987cd3279bcc950..d36cbf0a55866081183edfc96b4d1865975439eb 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