Move qbar to a dedicated repository.

.gitignore

+.stack-work/
+qbar.cabal
+*~
+/TODO
\ No newline at end of file

ChangeLog.md

+# Changelog for qbar
+
+## Unreleased changes

LICENSE

+Copyright Jens Nolte (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Jens Nolte nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

+# qbar

Setup.hs

+import Distribution.Simple
+main = defaultMain

app/Main.hs

+module Main where
+
+import QBar.Cli
+import QBar.ControlSocket
+import QBar.DefaultConfig
+import QBar.Filter
+import QBar.Server
+
+main :: IO ()
+main = parseOptions >>= runQBar
+
+runQBar :: MainOptions -> IO ()
+runQBar options@MainOptions{barCommand} = runCommand barCommand
+  where
+    runCommand BarServer = runI3BarConfiguration generateDefaultBarConfig options
+    runCommand NoFilter = sendIpc options $ SetFilter $ StaticFilter None
+    runCommand RainbowFilter = sendIpc options $ SetFilter $ AnimatedFilter Rainbow
\ No newline at end of file

install

+#!/bin/sh
+
+set -e
+
+EXECUTABLE_NAME=qbar
+
+LOCAL_BIN=`stack path --local-bin`
+
+EXECUTABLE_PATH=$LOCAL_BIN/$EXECUTABLE_NAME
+
+stack install
+
+if [ -d "$LOCAL_ZSH_COMPLETION_PATH" ]; then
+	ZSH_COMPLETION_SCRIPT_PATH=$LOCAL_ZSH_COMPLETION_PATH/_$EXECUTABLE_NAME
+	$EXECUTABLE_PATH --zsh-completion-script $EXECUTABLE_PATH > $ZSH_COMPLETION_SCRIPT_PATH
+	echo
+	echo "Installed zsh completions for $EXECUTABLE_NAME to $ZSH_COMPLETION_SCRIPT_PATH";
+fi

package.yaml

+name:                qbar
+version:             0.1.0.0
+#github:              "githubuser/qbar"
+license:             BSD3
+author:              "Jens Nolte"
+#maintainer:          "example@example.com"
+copyright:           "2019 Jens Nolte"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/githubuser/qbar#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- aeson
+- async
+- attoparsec
+- bytestring
+- colour
+- concurrent-extra
+- directory
+- filepath
+- mtl
+- network
+- optparse-applicative
+- pipes
+- pipes-aeson
+- pipes-concurrency
+- pipes-network
+- pipes-parse
+- stm
+- text
+- time
+- typed-process
+- unix
+- unordered-containers
+
+default-extensions:
+- OverloadedStrings
+- NamedFieldPuns
+
+ghc-options:
+- -fwarn-unused-do-bind
+- -fwarn-tabs
+- -Wall
+- -Werror
+- -O2
+
+library:
+  source-dirs: src
+
+executables:
+  qbar:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - qbar
+
+tests:
+  qbar-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - qbar

run-sway

+#!/bin/sh
+
+set -e
+
+DEFAULT_BAR_COMMAND="qbar server"
+EXECUTABLE_NAME=qbar
+SWAY_BAR_ID=bar-0
+
+stack build
+
+TEMP_DIR=$(mktemp -d)
+STDERR=$TEMP_DIR/stderr
+mkfifo $STDERR
+
+trap "swaymsg bar $SWAY_BAR_ID status_command $DEFAULT_BAR_COMMAND; rm -rf $TEMP_DIR" EXIT INT HUP TERM
+
+swaymsg bar $SWAY_BAR_ID status_command "exec $(stack path --local-install-root)/bin/$EXECUTABLE_NAME -- server 2> $STDERR"
+
+# show output and run forever (use Ctrl-C to stop)
+cat $STDERR

src/QBar/Blocks.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module QBar.Blocks where
+
+import QBar.Core
+import QBar.Time
+
+import qualified Data.Text.Lazy as T
+import Data.Time.Format
+import Data.Time.LocalTime
+import Pipes
+import Pipes.Concurrent
+
+dateBlock :: IO Block
+dateBlock = do
+  zonedTime <- getZonedTime
+  let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
+  let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
+  --let text = (T.pack "📅 ") <> T.pack (formatTime defaultTimeLocale "%a %F <span color='#ffffff'>%R</span>" zonedTime)
+  let text = (T.pack "📅 ") <> date <> " " <> (coloredText activeColor time)
+  return $ setBlockName "date" $ pangoMarkup $ createBlock text
+
+dateBlockProducer :: BarUpdateChannel -> BlockProducer
+dateBlockProducer barUpdateChannel = do
+  initialDateBlock <- lift dateBlock
+  (output, input) <- lift $ spawn $ latest initialDateBlock
+  lift $ void $ forkIO $ update output
+  fromInput input
+  where
+    update :: Output Block -> IO ()
+    update output = do
+      sleepUntil =<< nextMinute
+      block <- dateBlock
+      void $ atomically $ send output block
+      updateBar barUpdateChannel
+      update output
+

src/QBar/Cli.hs

+{-# LANGUAGE ApplicativeDo #-}
+
+module QBar.Cli where
+
+import qualified Data.Text as T
+import Options.Applicative
+
+data BarCommand = BarServer | NoFilter | RainbowFilter
+
+barCommandParser :: Parser BarCommand
+barCommandParser = hsubparser
+  ( command "server" (info (pure BarServer) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
+    command "default" (info (pure NoFilter) (progDesc "Send a message to a running qbar server.")) <>
+    command "rainbow" (info (pure RainbowFilter) (progDesc "Send a message to a running qbar server."))
+  )
+
+data MainOptions = MainOptions {
+  verbose :: Bool,
+  socketLocation :: Maybe T.Text,
+  barCommand :: BarCommand
+}
+
+mainOptionsParser :: Parser MainOptions
+mainOptionsParser = do
+  verbose <- switch $ long "verbose" <> short 'v' <> help "Print more diagnostic output to stderr (including a copy of every bar update)."
+  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, socketLocation, barCommand}
+
+parser :: ParserInfo MainOptions
+parser = info (mainOptionsParser <**> helper)
+  (fullDesc <> header "q - queezles tools")
+
+parserPrefs :: ParserPrefs
+parserPrefs = prefs showHelpOnEmpty
+
+parseOptions :: IO MainOptions
+parseOptions = customExecParser parserPrefs parser
\ No newline at end of file

src/QBar/ControlSocket.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module QBar.ControlSocket where
+
+import QBar.Cli (MainOptions(..))
+-- TODO: remove dependency?
+import QBar.Filter
+
+import Control.Monad (forever, void, when)
+import Control.Monad.STM (atomically)
+import Control.Concurrent (forkFinally)
+import Control.Concurrent.Async
+import Control.Concurrent.STM.TChan (TChan, writeTChan)
+import Data.Aeson.TH
+import Data.Either (either)
+import Data.Text.Lazy (Text, pack)
+import qualified Data.Text as T
+import Network.Socket
+import Pipes
+import Pipes.Parse
+import Pipes.Aeson (decode, DecodingError)
+import Pipes.Aeson.Unchecked (encode)
+import Pipes.Network.TCP (fromSocket, toSocket)
+import System.Directory (removeFile, doesFileExist)
+import System.Environment (getEnv)
+import System.FilePath ((</>), (<.>))
+import System.IO
+
+type CommandChan = TChan Command
+
+data Command = SetFilter Filter
+  deriving Show
+
+data SocketResponse = Success | Error Text
+  deriving Show
+
+$(deriveJSON defaultOptions ''Command)
+$(deriveJSON defaultOptions ''SocketResponse)
+
+ipcSocketAddress :: MainOptions -> IO FilePath
+ipcSocketAddress MainOptions{socketLocation} = maybe defaultSocketPath (return . T.unpack) socketLocation
+  where
+    defaultSocketPath :: IO FilePath
+    defaultSocketPath = do
+      xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
+      waylandDisplay <- getEnv "WAYLAND_DISPLAY"
+      return $ xdgRuntimeDir </> waylandDisplay <.> "qbar"
+
+sendIpc :: MainOptions -> Command -> IO ()
+sendIpc options@MainOptions{verbose} request = do
+  socketPath <- ipcSocketAddress options
+  sock <- socket AF_UNIX Stream defaultProtocol
+  connect sock $ SockAddrUnix socketPath
+  runEffect $ encode request >-> toSocket sock
+
+  decodeResult <- evalStateT decode $ fromSocket sock 4096
+  maybe exitEmptyStream (either exitInvalidResult showResponse) decodeResult
+  where
+    exitEmptyStream :: IO ()
+    exitEmptyStream = hPutStrLn stderr "Empty stream"
+    exitInvalidResult :: DecodingError -> IO ()
+    exitInvalidResult = hPrint stderr
+    showResponse :: SocketResponse -> IO ()
+    showResponse Success = when verbose $ hPutStrLn stderr "Success"
+    showResponse (Error message) = hPrint stderr message
+
+listenUnixSocketAsync :: MainOptions -> CommandChan -> IO (Async ())
+listenUnixSocketAsync options commandChan = async $ listenUnixSocket options commandChan
+
+listenUnixSocket :: MainOptions -> CommandChan -> IO ()
+listenUnixSocket options commandChan = do
+  socketPath <- ipcSocketAddress options
+  hPutStrLn stderr $ "Creating control socket at " <> socketPath
+  socketExists <- doesFileExist socketPath
+  when socketExists $ removeFile socketPath
+  sock <- socket AF_UNIX Stream defaultProtocol
+  setCloseOnExecIfNeeded $ fdSocket sock
+  bind sock (SockAddrUnix socketPath)
+  listen sock 5
+  forever $ do
+    (conn, _) <- accept sock
+    void $ forkFinally (socketHandler conn) (\_ -> close conn)
+  where
+    socketHandler :: Socket -> IO ()
+    socketHandler sock = do
+      decodeResult <- evalStateT decode $ fromSocket sock 4096
+      response <- maybe (errorResponse "Empty stream") (either (errorResponse . pack . show) commandHandler) decodeResult
+      let consumer = toSocket sock
+      runEffect (encode response >-> consumer)
+    commandHandler :: Command -> IO SocketResponse
+    commandHandler command = do
+      atomically $ writeTChan commandChan command
+      return Success
+    errorResponse :: Text -> IO SocketResponse
+    errorResponse message = return $ Error message
\ No newline at end of file

src/QBar/Core.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module QBar.Core where
+
+import QBar.Pango
+
+import Control.Exception (catch, finally, IOException)
+import Control.Monad (forever)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async
+import Control.Concurrent.Event as Event
+import Control.Concurrent.MVar
+import Data.Aeson.TH
+import qualified Data.ByteString.Lazy.Char8 as C8
+import qualified Data.HashMap.Lazy as HM
+import Data.Int (Int64)
+import Data.Maybe (fromMaybe, catMaybes)
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.Encoding as E
+import qualified Data.Text.Lazy.IO as TIO
+import Numeric (showHex)
+import Pipes
+import Pipes.Concurrent
+import qualified Pipes.Prelude as PP
+import System.Exit
+import System.IO
+import System.Process.Typed (shell, withProcessWait, setStdin, setStdout, getStdout, closed, createPipe, readProcessStdout)
+
+import Data.Colour.RGBSpace
+
+data Block = Block {
+  values :: HM.HashMap T.Text T.Text,
+  clickAction :: Maybe (IO ())
+}
+instance Show Block where
+  show Block{values} = show values
+
+data Click = Click {
+  name :: T.Text
+} deriving Show
+$(deriveJSON defaultOptions ''Click)
+
+type BlockProducer = Producer Block IO ()
+
+data BarUpdateChannel = BarUpdateChannel (IO ())
+type BarUpdateEvent = Event.Event
+
+defaultColor :: T.Text
+defaultColor = "#969896"
+
+activeColor :: T.Text
+activeColor = "#ffffff"
+
+updatingColor :: T.Text
+--updatingColor = "#444444"
+updatingColor = "#96989677"
+
+createBlock :: T.Text -> Block
+createBlock text = setColor defaultColor $ Block {
+  values = HM.singleton "full_text" text,
+  clickAction = Nothing
+}
+
+createErrorBlock :: T.Text -> Block
+createErrorBlock = setColor "ff0000" . createBlock
+
+setValue :: T.Text -> T.Text -> Block -> Block
+setValue key val block = block {
+  values = HM.insert key val (values block)
+}
+
+getValue :: T.Text -> Block -> Maybe T.Text
+getValue key block = HM.lookup key (values block)
+
+adjustValue :: (T.Text -> T.Text) -> T.Text -> Block -> Block
+adjustValue f k block = block {
+  values = HM.adjust f k (values block)
+}
+
+emptyBlock :: Block
+emptyBlock = createBlock ""
+
+shortText :: T.Text -> Block -> Block
+shortText = setValue "short_text"
+
+fullText :: T.Text -> Block -> Block
+fullText = setValue "full_text"
+
+getFullText :: Block -> T.Text
+getFullText = fromMaybe "" . getValue "full_text"
+
+setColor :: T.Text -> Block -> Block
+setColor = setValue "color"
+
+setBlockName :: T.Text -> Block -> Block
+setBlockName = setValue "name"
+
+getBlockName :: Block -> Maybe T.Text
+getBlockName = getValue "name"
+
+pangoMarkup :: Block -> Block
+pangoMarkup = setValue "markup" "pango"
+
+adjustText :: (T.Text -> T.Text) -> Block -> Block
+adjustText f = adjustValue f "full_text" . adjustValue f "short_text"
+
+coloredText :: T.Text -> T.Text -> T.Text
+coloredText color text = "<span color='" <> color <> "'>" <> text <> "</span>"
+
+addIcon :: T.Text -> Block -> Block
+addIcon icon block = prefixIcon "full_text" $ prefixIcon "short_text" block
+  where
+    prefixIcon = adjustValue ((icon <> " ") <>)
+
+removePango :: Block -> Block
+removePango block
+  | getValue "markup" block == Just "pango" = adjustText removePangoFromText $ block {
+      values = HM.delete "markup" (values block)
+    }
+  | otherwise = block
+  where
+    removePangoFromText :: T.Text -> T.Text
+    removePangoFromText text =
+      case parsePango text of
+        Left _ -> text
+        Right parsed -> removeFormatting parsed
+
+modify :: (Block -> Block) -> Pipe Block Block IO ()
+modify = PP.map
+
+autoPadding :: Pipe Block Block IO ()
+autoPadding = autoPadding' 0 0
+  where
+    autoPadding' :: Int64 -> Int64 -> Pipe Block Block IO ()
+    autoPadding' fullLength shortLength = do
+      block <- await
+      let values' = (values block)
+      let fullLength' = T.length $ HM.lookupDefault "" "full_text" values'
+      let shortLength' = T.length $ HM.lookupDefault "" "short_text" values'
+      let values'' = HM.adjust (<> (T.take (fullLength - fullLength') $ T.repeat ' ')) "full_text" values'
+      let values''' = HM.adjust (<> (T.take (shortLength - shortLength') $ T.repeat ' ')) "short_text" values''
+      yield block { values = values''' }
+      autoPadding' (max fullLength fullLength') (max shortLength shortLength')
+
+-- | Create a shared interval. Takes a BarUpdateChannel to signal bar updates and an interval (in seconds).Data.Maybe
+-- Returns an IO action that can be used to attach blocks to the shared interval and an async that contains a reference to the scheduler thread.
+sharedInterval :: BarUpdateChannel -> Int -> IO (IO Block -> BlockProducer, Async ())
+sharedInterval barUpdateChannel seconds = do
+  clientsMVar <- newMVar ([] :: [(IO Block, Output Block)])
+
+  task <- async $ forever $ do
+    threadDelay $ seconds * 1000000
+    -- Updates all client blocks
+    -- If send returns 'False' the clients mailbox has been closed, so it is removed
+    modifyMVar_ clientsMVar (fmap catMaybes . mapConcurrently runAndFilterClient)
+    -- Then update the bar
+    updateBar barUpdateChannel
+
+  return (addClient clientsMVar, task)
+    where
+      runAndFilterClient :: (IO Block, Output Block) -> IO (Maybe (IO Block, Output Block))
+      runAndFilterClient client = do
+        result <- runClient client
+        return $ if result then Just client else Nothing
+      runClient :: (IO Block, Output Block) -> IO Bool
+      runClient (blockAction, output) = do
+        result <- blockAction
+        atomically $ send output result {
+          clickAction = Just (updateClickHandler result)
+        }
+        where
+          updateClickHandler :: Block -> IO ()
+          updateClickHandler block = do
+            -- Give user feedback that the block is updating
+            let outdatedBlock = setColor updatingColor $ removePango block
+            void $ atomically $ send output $ outdatedBlock
+            -- Notify bar about changed block state to display the feedback
+            updateBar barUpdateChannel
+            -- Run a normal block update to update the block to the new value
+            void $ runClient (blockAction, output)
+            -- Notify bar about changed block state, this is usually done by the shared interval handler
+            updateBar barUpdateChannel
+      addClient :: MVar [(IO Block, Output Block)] -> IO Block -> BlockProducer
+      addClient clientsMVar blockAction = do
+        -- Spawn the mailbox that preserves the latest block
+        (output, input) <- lift $ spawn $ latest emptyBlock
+
+        -- Generate initial block and send it to the mailbox
+        lift $ void $ runClient (blockAction, output)
+
+        -- Register the client for regular updates
+        lift $ modifyMVar_ clientsMVar $ \ clients -> return ((blockAction, output):clients)
+
+        -- Return a block producer from the mailbox
+        fromInput input
+
+blockScript :: FilePath -> IO Block
+blockScript path = do
+  -- The exit code is used for i3blocks signaling but ignored here (=not implemented)
+  -- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it
+  (exitCode, output) <- readProcessStdout $ shell path
+  case exitCode of
+    ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
+      (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
+      (text:short:_) -> shortText short $ createScriptBlock text
+      (text:_) -> createScriptBlock text
+      [] -> createScriptBlock "-"
+    (ExitFailure nr) -> return $ createErrorBlock $ "[" <> (T.pack $ show nr) <> "]"
+  where
+    createScriptBlock :: T.Text -> Block
+    createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
+
+startPersistentBlockScript :: BarUpdateChannel -> FilePath -> Producer Block IO ()
+startPersistentBlockScript barUpdateChannel path = do
+  (output, input, seal) <- lift $ spawn' $ latest $ emptyBlock
+  initialDataEvent <- lift $ Event.new
+  task <- lift $ async $ do
+    let processConfig = setStdin closed $ setStdout createPipe $ shell path
+    finally (
+      catch (
+        withProcessWait processConfig $ \ process -> do
+          let handle = getStdout process
+          runEffect $ (fromHandle handle) >-> signalFirstBlock initialDataEvent >-> toOutput output
+        )
+        ( \ e ->
+          -- output error
+          runEffect $ (yield $ createErrorBlock $ "[" <> (T.pack $ show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
+        )
+      )
+      (atomically seal)
+  lift $ link task
+  lift $ Event.wait initialDataEvent
+  fromInput input
+  where
+    signalFirstBlock :: Event.Event -> Pipe Block Block IO ()
+    signalFirstBlock event = do
+      -- Await first block
+      await >>= yield
+      lift $ Event.set event
+      -- Replace with cat
+      cat
+    fromHandle :: Handle -> Producer Block IO ()
+    fromHandle handle = forever $ do
+      line <- lift $ TIO.hGetLine handle
+      yield $ pangoMarkup $ createBlock line
+      lift $ updateBar barUpdateChannel
+
+pangoColor :: RGB Double -> T.Text
+pangoColor (RGB r g b) =
+  let r' = hexColorComponent r
+      g' = hexColorComponent g
+      b' = hexColorComponent b
+  in "#" <> r' <> g' <> b'
+  where
+    hexColorComponent :: Double -> T.Text
+    hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 $ (truncate (val * 255) :: Int)) ""
+    paddedHexComponent hex =
+      let len = 2 - T.length hex
+          padding = if len == 1 then "0" else ""
+      in padding <> hex
+
+updateBar :: BarUpdateChannel -> IO ()
+updateBar (BarUpdateChannel updateAction) = updateAction

src/QBar/DefaultConfig.hs

+module QBar.DefaultConfig where
+
+import QBar.Blocks
+import QBar.Core
+
+import Control.Concurrent.Async
+import Pipes
+
+generateDefaultBarConfig :: BarUpdateChannel -> IO [BlockProducer]
+generateDefaultBarConfig barUpdateChannel = do
+  (systemInfoInterval, systemInfoIntervalTask) <- sharedInterval barUpdateChannel 10
+  link systemInfoIntervalTask
+  --let irc = (systemInfoInterval $ blockScript "/home/jens/run/blocks/irc")
+  let todo = (systemInfoInterval $ blockScript "/home/jens/run/blocks/todo")
+  let wifi = (systemInfoInterval $ blockScript "/home/jens/run/blocks/wifi2 wlan") >-> modify (addIcon "📡")
+  let networkEnvironment = (systemInfoInterval $ blockScript "/home/jens/run/blocks/network-environment")
+  let cpu = (systemInfoInterval $ blockScript "/home/jens/run/blocks/cpu_usage") >-> modify (setBlockName "cpu" . addIcon "💻") >-> autoPadding
+  let ram = (systemInfoInterval $ blockScript "/home/jens/run/blocks/memory") >-> modify (addIcon "🐏") >-> autoPadding
+  let temperature = (systemInfoInterval $ blockScript "/home/jens/run/blocks/temperature") >-> autoPadding
+  let volumeBlock = startPersistentBlockScript barUpdateChannel "/home/jens/run/blocks/volume-pulseaudio -S -F3"
+  let battery = (systemInfoInterval $ blockScript "/home/jens/run/blocks/battery2")
+  let date = dateBlockProducer barUpdateChannel
+  return [todo, wifi, networkEnvironment, cpu, ram, temperature, volumeBlock, battery, date]
\ No newline at end of file

src/QBar/Filter.hs

+{-# LANGUAGE TemplateHaskell #-}
+
+module QBar.Filter where
+
+import QBar.Core
+
+import Control.Monad.State.Lazy (State, evalState, get, put)
+import Data.Aeson.TH
+import Data.Colour.RGBSpace.HSV (hsv)
+import qualified Data.Text.Lazy as T
+
+data Filter = StaticFilter StaticFilter
+  | AnimatedFilter AnimatedFilter
+  deriving Show
+
+data StaticFilter = None
+  deriving Show
+
+data AnimatedFilter = Rainbow
+  deriving Show
+
+$(deriveJSON defaultOptions ''Filter)
+$(deriveJSON defaultOptions ''StaticFilter)
+$(deriveJSON defaultOptions ''AnimatedFilter)
+
+isAnimatedFilter :: Filter -> Bool
+isAnimatedFilter (AnimatedFilter _) = True
+isAnimatedFilter _ = False
+
+applyFilter :: Filter -> Double -> [Block] -> [Block]
+applyFilter (StaticFilter None) = static id
+applyFilter (AnimatedFilter Rainbow) = rainbow
+
+static :: a -> Double -> a
+static fn _ = fn
+
+rainbow :: Double -> [Block] -> [Block]
+rainbow time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
+  where
+    rainbowBlock :: Block -> State Integer Block
+    rainbowBlock block = do
+      let cleanBlock = removePango block
+      let text = getFullText cleanBlock
+      let chars = T.unpack . T.reverse $ text
+      coloredChars <- mapM rainbowChar chars
+      let rainbowText = T.concat . reverse $ coloredChars
+      return $ pangoMarkup $ fullText rainbowText $ cleanBlock
+    rainbowChar :: Char -> State Integer T.Text
+    rainbowChar char = do
+      color <- nextRainbowColor
+      return $ coloredText color $ T.singleton char
+    nextRainbowColor :: State Integer T.Text
+    -- nextRainbowColor = state $ \index -> (rainbowColor (fromInteger index), index + 1)
+    nextRainbowColor = do
+      index <- get
+      put $ index + 1
+      return $ rainbowColor (fromInteger index + time * 10)
+
+rainbowColor :: Double -> T.Text
+rainbowColor position =
+  let hue' = position * 3
+      color = hsv hue' 0.8 1.0
+  in pangoColor color

src/QBar/Pango.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module QBar.Pango (Pango, parsePango, removeFormatting) where
+
+import Control.Applicative ((<|>))
+import Control.Monad (void)
+import qualified Data.Text.Lazy as T
+import Data.Attoparsec.Text.Lazy as A
+
+data Pango = PText T.Text
+  | PTag T.Text [(T.Text, T.Text)] Pango
+  | PList [Pango]
+  deriving Show
+
+pList :: [Pango] -> Pango
+pList [one] = one
+pList more = PList more
+
+pangoParser :: Parser Pango
+pangoParser = pList <$> many' (choice [normalTextParser, tagParser])
+  where
+    normalTextParser :: Parser Pango
+    normalTextParser  = PText . T.fromStrict <$> A.takeWhile1 (notInClass "<>")
+
+    tagParser :: Parser Pango
+    tagParser = do
+      tagName <- char '<' >> identifier
+      attributes <- many' $ do
+        space >> skipSpace
+        attributeName <- identifier
+        void $ char '='
+        value <- char '\'' *> many' (notChar '\'') <* char '\''
+          <|> char '"' *> many' (notChar '"') <* char '"'
+        return (attributeName, T.pack value)
+      void $ char '>'
+      content <- pangoParser
+      -- close tag
+      void $ string $ T.toStrict $ "</" <> tagName <> ">"
+      return $ PTag tagName attributes content
+
+    identifier :: Parser T.Text
+    identifier = T.pack <$> many1 (letter <|> digit)
+
+parsePango :: T.Text -> Either String Pango
+parsePango text = parseOnly (pangoParser <* endOfInput) (T.toStrict text)
+
+removeFormatting :: Pango -> T.Text
+removeFormatting (PText text) = text
+removeFormatting (PTag _ _ child) = removeFormatting child
+removeFormatting (PList list) = mconcat $ map removeFormatting list
\ No newline at end of file

src/QBar/Server.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module QBar.Server where
+
+import QBar.Blocks
+import QBar.Core
+import QBar.Cli
+import QBar.ControlSocket
+import QBar.Filter
+
+import Control.Monad (forever, when, unless)
+import Control.Monad.STM (atomically)
+import Control.Concurrent (threadDelay, forkFinally)
+import Control.Concurrent.Async
+import Control.Concurrent.Event as Event
+import Control.Concurrent.STM.TChan (newTChanIO, readTChan)
+import Data.Aeson (encode, decode)
+import Data.ByteString.Lazy (hPut)
+import qualified Data.ByteString.Char8 as BSSC8
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as C8
+import Data.IORef
+import Data.Maybe (isJust, fromJust, fromMaybe, catMaybes, mapMaybe)
+import qualified Data.Text.Lazy as T
+import Data.Time.Clock.POSIX
+import Pipes
+import System.IO (stdin, stdout, stderr, hFlush, hPutStrLn)
+import System.Posix.Signals
+
+data Handle = Handle {
+  handleActionList :: IORef [(T.Text, IO ())],
+  handleActiveFilter :: IORef Filter
+}
+
+renderIndicator :: BlockProducer
+renderIndicator = forever $ each $ map createBlock ["/", "-", "\\", "|"]
+
+runBlock :: BlockProducer -> IO (Maybe (Block, BlockProducer))
+runBlock producer = do
+  next' <- next producer
+  return $ case next' of
+    Left _ -> Nothing
+    Right (block, newProducer) -> Just (block, newProducer)
+
+runBlocks :: [BlockProducer] -> IO ([Block], [BlockProducer])
+runBlocks blockProducers = unzip . catMaybes <$> mapM runBlock blockProducers
+
+renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> [BlockProducer] -> IO ()
+renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent = renderLoop'
+  where
+    renderLoop' :: BS.ByteString -> [BlockProducer] -> IO ()
+    renderLoop' previousBarOutput blockProducers = do
+      blockFilter <- readIORef handleActiveFilter
+
+      -- Wait for an event (unless the filter is animated)
+      unless (isAnimatedFilter blockFilter) $ Event.wait barUpdateEvent
+
+      -- Wait for 10ms after first events to catch (almost-)simultaneous event updates
+      threadDelay 10000
+      Event.clear barUpdateEvent
+
+      (blocks, blockProducers') <- runBlocks blockProducers
+
+      currentBarOutput <- renderLine options handle blockFilter blocks previousBarOutput
+
+      -- Wait for 100ms after rendering a line to limit cpu load of rapid events
+      threadDelay 100000
+
+      renderLoop' currentBarOutput blockProducers'
+
+renderLine :: MainOptions -> Handle -> Filter -> [Block] -> BS.ByteString -> IO BS.ByteString
+renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks previousEncodedOutput = do
+  time <- fromRational . toRational <$> getPOSIXTime
+  let filteredBlocks = applyFilter blockFilter time blocks
+  let encodedOutput = encode $ map values filteredBlocks
+  let changed = previousEncodedOutput /= encodedOutput
+  when changed $ do
+    hPut stdout encodedOutput
+    putStrLn ","
+    hFlush stdout
+    -- Echo output to stderr when verbose flag is set
+    when verbose $ do
+      hPut stderr encodedOutput
+      hPut stderr "\n"
+      hFlush stderr
+
+  when verbose $ unless changed $ hPutStrLn stderr "Output unchanged"
+
+  -- Register click handlers regardless of bar changes, because we cannot easily check if any handler has changed
+  writeIORef handleActionList clickActionList
+
+  return encodedOutput
+  where
+    clickActionList :: [(T.Text, IO ())]
+    clickActionList = mapMaybe getClickAction blocks
+    getClickAction :: Block -> Maybe (T.Text, IO ())
+    getClickAction block = if hasBlockName && hasClickAction then Just (fromJust maybeBlockName, fromJust maybeClickAction) else Nothing
+      where
+        maybeBlockName = getBlockName block
+        hasBlockName = isJust maybeBlockName
+        maybeClickAction = clickAction block
+        hasClickAction = isJust maybeClickAction
+
+createBarUpdateChannel :: IO (BarUpdateChannel, BarUpdateEvent)
+createBarUpdateChannel = do
+  event <- Event.newSet
+  return (BarUpdateChannel $ Event.set event, event)
+
+handleStdin :: MainOptions -> IORef [(T.Text, IO ())] -> IO ()
+handleStdin options actionListIORef = forever $ do
+  line <- BSSC8.hGetLine stdin
+
+  unless (line == "[") $ do
+    -- Echo input to stderr when verbose flag is set
+    when (verbose options) $ do
+      BSSC8.hPutStrLn stderr line
+      hFlush stderr
+
+    clickActionList <- readIORef actionListIORef
+    let maybeParsedClick = decode $ removeComma $ BS.fromStrict line
+    let clickAction' = getClickAction clickActionList maybeParsedClick
+    async (fromMaybe (return ()) clickAction') >>= link
+
+  where
+    getClickAction :: [(T.Text, IO ())] -> Maybe Click -> Maybe (IO ())
+    getClickAction clickActionList maybeParsedClick = do
+      parsedClick <- maybeParsedClick
+      let blockName = name parsedClick
+      lookup blockName clickActionList
+    removeComma :: C8.ByteString -> C8.ByteString
+    removeComma line
+      | C8.head line == ',' = C8.tail line
+      | C8.last line == ',' = C8.init line
+      | otherwise = line
+
+installSignalHandlers :: BarUpdateChannel -> IO ()
+installSignalHandlers barUpdateChannel = void $ installHandler sigCONT (Catch sigContAction) Nothing
+  where
+    sigContAction :: IO ()
+    sigContAction = do
+      hPutStrLn stderr "SIGCONT received"
+      updateBar barUpdateChannel
+
+runI3BarConfiguration :: (BarUpdateChannel -> IO [BlockProducer]) -> MainOptions -> IO ()
+runI3BarConfiguration generateBarConfig options = do
+  -- Create IORef for mouse click callbacks
+  actionList <- newIORef []
+  --link =<< async (handleStdin options actionList)
+  void $ forkFinally (handleStdin options actionList) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
+
+  -- Create IORef to contain the active filter
+  let initialBlockFilter = StaticFilter None
+  activeFilter <- newIORef initialBlockFilter
+
+  let handle = Handle {
+    handleActionList = actionList,
+    handleActiveFilter = activeFilter
+  }
+
+  putStrLn "{\"version\":1,\"click_events\":true}"
+  putStrLn "["
+
+  date <- dateBlock
+  let initialBlocks = [date]
+
+  -- Attach spinner indicator when verbose flag is set
+  let initialBlocks' = if verbose options then initialBlocks <> [createBlock "*"] else initialBlocks
+
+  -- Render initial time block so the bar is not empty after startup
+  initialOutput <- renderLine options handle initialBlockFilter initialBlocks' ""
+
+  -- Create and initialzie blocks
+  (barUpdateChannel, barUpdateEvent) <- createBarUpdateChannel
+  blockProducers <- generateBarConfig barUpdateChannel
+
+  -- Install signal handler for SIGCONT
+  installSignalHandlers barUpdateChannel
+
+  -- Create control socket
+  commandChan <- createCommandChan
+  controlSocketAsync <- listenUnixSocketAsync options commandChan
+  link controlSocketAsync
+
+  -- Update bar on control socket messages
+  socketUpdateAsync <- async $ forever $ do
+    command <- atomically $ readTChan commandChan
+    case command of
+      SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
+    updateBar barUpdateChannel
+  link socketUpdateAsync
+
+  -- Attach spinner indicator when verbose flag is set
+  let blockProducers' = if verbose options then blockProducers <> [renderIndicator] else blockProducers
+
+  renderLoop options handle barUpdateEvent initialOutput blockProducers'
+
+createCommandChan :: IO CommandChan
+createCommandChan = newTChanIO
\ No newline at end of file

src/QBar/Time.hs

+module QBar.Time (sleepUntil, nextMinute) where
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (when)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime)
+
+sleepUntil :: UTCTime -> IO ()
+sleepUntil time = do
+  now <- getCurrentTime
+  let timeUntil = diffUTCTime time now
+  when (timeUntil > 0) $
+    if timeUntil > 1
+      then threadDelay 1000000 >> sleepUntil time
+      else threadDelay $ ceiling $ toRational timeUntil * 1000000
+
+nextMinute :: IO UTCTime
+nextMinute = do
+  now <- getCurrentTime
+  let dayTime = utctDayTime now
+  let daySeconds = floor dayTime
+  let dayMinute = daySeconds `div` 60
+  return now {
+    utctDayTime = fromInteger $ (dayMinute + 1) * 60
+  }
\ No newline at end of file

stack.yaml

+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-13.27
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.9"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

test/Spec.hs

+main :: IO ()
+main = putStrLn "Test suite not yet implemented"