diff --git a/ChangeLog.md b/ChangeLog.md
deleted file mode 100644
index 26a2a1a9294076bcba354b833189edc594d2214d..0000000000000000000000000000000000000000
--- a/ChangeLog.md
+++ /dev/null
@@ -1,3 +0,0 @@
-# Changelog for qbar
-
-## Unreleased changes
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000000000000000000000000000000000000..f44a24c63747ed4eb654da9ca84338cf1e223380
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1 @@
+packages: */*.cabal
diff --git a/flake.lock b/flake.lock
index 35b657e4658a528143693aad6920d6f020c6d802..a24b15b2964169b6d762803f27508d02e10f9d9e 100644
--- a/flake.lock
+++ b/flake.lock
@@ -16,25 +16,11 @@
"type": "github"
}
},
- "nixpkgs_2": {
- "locked": {
- "lastModified": 1681303793,
- "narHash": "sha256-JEdQHsYuCfRL2PICHlOiH/2ue3DwoxUX7DJ6zZxZXFk=",
- "owner": "NixOS",
- "repo": "nixpkgs",
- "rev": "fe2ecaf706a5907b5e54d979fbde4924d84b65fc",
- "type": "github"
- },
- "original": {
- "owner": "NixOS",
- "ref": "nixos-unstable",
- "repo": "nixpkgs",
- "type": "github"
- }
- },
"quasar": {
"inputs": {
- "nixpkgs": "nixpkgs_2"
+ "nixpkgs": [
+ "nixpkgs"
+ ]
},
"locked": {
"lastModified": 1682474992,
diff --git a/flake.nix b/flake.nix
index 3a8d4b95966b946083a50b64ac878a1d244d22c4..7895b1dd5ee8825cbcb32cdd1dd93044226da216 100644
--- a/flake.nix
+++ b/flake.nix
@@ -2,6 +2,7 @@
inputs = {
nixpkgs.url = github:NixOS/nixpkgs/nixos-unstable;
quasar.url = github:queezle42/quasar;
+ quasar.inputs.nixpkgs.follows = "nixpkgs";
};
outputs = { self, nixpkgs, quasar }:
@@ -19,10 +20,13 @@
in {
packages = forAllSystems (system:
let
- pkgs = import nixpkgs { inherit system; overlays = [
- self.overlays.default
- quasar.overlays.default
- ]; };
+ pkgs = import nixpkgs {
+ inherit system;
+ overlays = [
+ self.overlays.default
+ quasar.overlays.default
+ ];
+ };
haskellPackages = getHaskellPackages pkgs "ghc94.";
results = {
qbar = haskellPackages.qbar;
@@ -36,17 +40,20 @@
haskell = prev.haskell // {
packageOverrides = hfinal: hprev: prev.haskell.packageOverrides hfinal hprev // {
qbar = hfinal.generateOptparseApplicativeCompletions ["qbar"]
- (hfinal.callCabal2nix "qbar" ./. {});
+ (hfinal.callCabal2nix "qbar" ./qbar {});
};
};
};
devShells = forAllSystems (system:
let
- pkgs = import nixpkgs { inherit system; overlays = [
- self.overlays.default
- quasar.overlays.default
- ]; };
+ pkgs = import nixpkgs {
+ inherit system;
+ overlays = [
+ self.overlays.default
+ quasar.overlays.default
+ ];
+ };
haskellPackages = getHaskellPackages pkgs "ghc94.";
in rec {
default = haskellPackages.shellFor {
@@ -54,16 +61,17 @@
hpkgs.qbar
];
nativeBuildInputs = [
+ haskellPackages.haskell-language-server
pkgs.cabal-install
- pkgs.zsh
+ pkgs.hlint
+
+ # in addition, for ghcid-wrapper
pkgs.entr
pkgs.ghcid
- haskellPackages.haskell-language-server
- pkgs.hlint
+ pkgs.zsh
];
};
}
);
};
}
-
diff --git a/ghcid b/ghcid
deleted file mode 100755
index c3d50ccb6cab4f1a767993720c0832b6f8b6c2b5..0000000000000000000000000000000000000000
--- a/ghcid
+++ /dev/null
@@ -1,16 +0,0 @@
-#!/usr/bin/env -S nix develop . -c zsh
-
-print -P %F{yellow}Cleaning repository%f
-nix develop -c cabal clean
-
-(git ls-files test; git ls-files '*.cabal'; git ls-files 'flake.*') | \
- entr -r \
- nix develop -c \
- ghcid \
- --warnings \
- "--command=cabal repl lib:qbar" \
- "--test=:! \
- cabal test --disable-optimisation --enable-debug-info=2 --test-show-details=direct --ghc-option -fdiagnostics-color=always && \
- cabal build --disable-optimisation --enable-debug-info=2 --ghc-option -fdiagnostics-color=always && \
- zsh -c 'print -P %F{green}Build and tests passed%f' \
- "
diff --git a/ghcid-wrapper b/ghcid-wrapper
new file mode 100755
index 0000000000000000000000000000000000000000..dbee7e5b31ad6fb1af93191ab2db846c6de3bb7f
--- /dev/null
+++ b/ghcid-wrapper
@@ -0,0 +1,38 @@
+#!/usr/bin/env -S nix develop -L -c zsh
+
+set -euo pipefail
+
+readonly target=${1:-lib:qbar}
+readonly executable=${2:-}
+
+if [[ -n $executable ]]
+then
+ run_executable="cabal run \
+ --disable-optimisation \
+ --ghc-option -fdiagnostics-color=always \
+ $executable \
+ "
+else
+ run_executable=true
+fi
+
+print -P %F{yellow}Cleaning repository%f
+cabal clean
+
+(
+ git ls-files 'examples/*' '*/test' '*/*.cabal' 'flake.*'
+ echo "ghcid-wrapper"
+) | \
+ entr -r \
+ nix develop -L -c \
+ ghcid \
+ --warnings \
+ "--command=cabal repl $target" \
+ "--test=:! \
+ cabal test \
+ --disable-optimisation \
+ --test-show-details=direct \
+ --ghc-option -fdiagnostics-color=always && \
+ $run_executable && \
+ zsh -c 'print -P %F{green}Build and tests passed%f' \
+ "
diff --git a/hie.yaml b/hie.yaml
new file mode 100644
index 0000000000000000000000000000000000000000..04cd24395e4d108febbd22b6ce41a92f7fe0d065
--- /dev/null
+++ b/hie.yaml
@@ -0,0 +1,2 @@
+cradle:
+ cabal:
diff --git a/app/Main.hs b/qbar/app/Main.hs
similarity index 72%
rename from app/Main.hs
rename to qbar/app/Main.hs
index c0e6c83e0cec08954c428283893755a185739d33..3631ce6f3c4515b040237ce205e0b30f1bd17abb 100644
--- a/app/Main.hs
+++ b/qbar/app/Main.hs
@@ -1,4 +1,4 @@
-module Main where
+module Main (main) where
import QBar.Cli
import QBar.Prelude
diff --git a/qbar.cabal b/qbar/qbar.cabal
similarity index 68%
rename from qbar.cabal
rename to qbar/qbar.cabal
index 4fc91965916e8c41f3256bdcd3cb5ab43702a3dd..ef2477f16a48f200d083afea92e73d74413a6886 100644
--- a/qbar.cabal
+++ b/qbar/qbar.cabal
@@ -1,80 +1,41 @@
cabal-version: 3.0
name: qbar
+
version: 0.1.0.0
author: Jens Nolte
maintainer: Jens Nolte
copyright: 2019 Jens Nolte
license: BSD-3-Clause
-license-file: LICENSE
build-type: Simple
-extra-source-files:
- README.md
- ChangeLog.md
--source-repository head
-- type: git
--- location: https://git.c3pb.de/jens/qbar.git
+-- location: https:////git.c3pb.de/jens/qbar.git
common shared-properties
+ default-language: GHC2021
default-extensions:
- AllowAmbiguousTypes
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveGeneric
- DerivingStrategies
- DisambiguateRecordFields
+ ApplicativeDo
DuplicateRecordFields
- ExistentialQuantification
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- ImportQualifiedPost
- InstanceSigs
LambdaCase
- -- Enable once 9.0.1 is required
- --LexicalNegation
- MultiParamTypeClasses
- NamedFieldPuns
+ MultiWayIf
NoImplicitPrelude
- NumericUnderscores
OverloadedStrings
- PolyKinds
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- ViewPatterns
- default-language: Haskell2010
ghc-options:
-Weverything
-Wno-all-missed-specialisations
- -Wno-missing-safe-haskell-mode
- -Wno-missing-kind-signatures
+ -Wno-missing-deriving-strategies
+ -Wno-implicit-prelude
-Wno-missing-import-lists
+ -Wno-missing-kind-signatures
+ -Wno-missing-safe-haskell-mode
-Wno-unsafe
-Werror=incomplete-patterns
-Werror=missing-fields
-Werror=missing-home-modules
-Werror=missing-methods
-common shared-executable-properties
- import: shared-properties
- ghc-options:
- -threaded
- -rtsopts
- "-with-rtsopts=-N -I0"
-
library
import: shared-properties
build-depends:
@@ -140,24 +101,29 @@ library
QBar.Theme
QBar.Time
QBar.Utils
+ other-modules:
hs-source-dirs:
src
- default-extensions:
- MultiWayIf
executable qbar
- import: shared-executable-properties
- main-is: Main.hs
- other-modules:
- Paths_qbar
- hs-source-dirs:
- app
+ import: shared-properties
+ ghc-options:
+ -threaded
+ -rtsopts
+ "-with-rtsopts=-N -I0"
build-depends:
qbar,
+ hs-source-dirs:
+ app
+ main-is: Main.hs
test-suite qbar-test
- import: shared-executable-properties
+ import: shared-properties
type: exitcode-stdio-1.0
+ ghc-options:
+ -threaded
+ -rtsopts
+ "-with-rtsopts=-N -I0"
main-is: Spec.hs
other-modules:
Paths_qbar
@@ -165,4 +131,3 @@ test-suite qbar-test
test
build-depends:
base >=4.7 && <5,
- qbar,
diff --git a/src/QBar/BlockHelper.hs b/qbar/src/QBar/BlockHelper.hs
similarity index 94%
rename from src/QBar/BlockHelper.hs
rename to qbar/src/QBar/BlockHelper.hs
index 6707c2a1f36de18472b13df63d660083d2225964..102ec89a440216459fa49ad07e8dd6d3bcd7ee54 100644
--- a/src/QBar/BlockHelper.hs
+++ b/qbar/src/QBar/BlockHelper.hs
@@ -1,4 +1,21 @@
-module QBar.BlockHelper where
+module QBar.BlockHelper (
+ PollBlock',
+ PollBlock,
+ PollSignal,
+ Signal(..),
+ SignalBlock,
+ SignalBlockConfiguration(..),
+ respondBlockUpdate,
+ respondEmptyBlockUpdate,
+ runPollBlock',
+ runPollBlock,
+ runSignalBlock,
+ runSignalBlockConfiguration,
+ runSignalBlockFn',
+ runSignalBlockFn,
+ yieldBlockUpdate,
+ yieldEmptyBlockUpdate,
+) where
import QBar.BlockOutput
import QBar.Core
@@ -6,7 +23,7 @@ import QBar.Prelude
import QBar.Time
import Control.Concurrent.Async
-import qualified Control.Concurrent.Event as Event
+import Control.Concurrent.Event qualified as Event
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TVar
import Control.Monad.Reader (ReaderT)
@@ -110,7 +127,7 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
liftIO $ Event.wait renderEvent
liftIO $ Event.clear renderEvent
- currentState <- liftIO . atomically $ readTVar renderStateVar
+ currentState <- liftIO (readTVarIO renderStateVar)
renderer' currentState
where
renderer' :: (Maybe BlockUpdate, Bool) -> Block
@@ -178,7 +195,9 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
sendSignal signal = do
maybeOutput <- request signal
- let updateInvalidatedState = if isEventSignal signal then (_2 .~ False) else id
+ let
+ updateInvalidatedState :: (Maybe BlockUpdate, Bool) -> (Maybe BlockUpdate, Bool)
+ updateInvalidatedState = if isEventSignal signal then _2 .~ False else id
let blockUpdate = (mkBlockStateWithHandler maybeOutput, signalToReason signal)
liftIO . atomically $ modifyTVar renderStateVar ((_1 . _Just .~ blockUpdate) . updateInvalidatedState)
diff --git a/src/QBar/BlockOutput.hs b/qbar/src/QBar/BlockOutput.hs
similarity index 83%
rename from src/QBar/BlockOutput.hs
rename to qbar/src/QBar/BlockOutput.hs
index 35b1016775e2125fcbe11dbcf362951a3c51d8fb..f1ece12691d21c79a2688c20a6ee84c9bc117ec3 100644
--- a/src/QBar/BlockOutput.hs
+++ b/qbar/src/QBar/BlockOutput.hs
@@ -1,15 +1,53 @@
+{-# OPTIONS_GHC -Wno-partial-fields #-}
{-# LANGUAGE TemplateHaskell #-}
-module QBar.BlockOutput where
+module QBar.BlockOutput (
+ BlockOutput(..),
+ BlockText(..),
+ BlockTextSegment(..),
+ Importance(..),
+ activeImportantText,
+ activeText,
+ addIcon,
+ blockName,
+ criticalImportant',
+ criticalImportant,
+ emptyBlock,
+ errorImportant',
+ errorImportant,
+ fullText,
+ importantText,
+ invalid,
+ invalidateBlock,
+ isCritical,
+ isError,
+ isNormal,
+ isWarning,
+ mkBlockOutput',
+ mkBlockOutput,
+ mkErrorOutput,
+ mkStyledText,
+ mkText,
+ normalImportant',
+ normalImportant,
+ normalText,
+ printedLength,
+ rawText,
+ shortText,
+ surroundWith,
+ toImportance,
+ warnImportant',
+ warnImportant,
+) where
import QBar.Color
import QBar.Prelude
import Control.Lens
import Data.Aeson
-import Data.Aeson.TH
import Data.Int (Int64)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
+import GHC.Generics
data BlockOutput = BlockOutput {
@@ -18,11 +56,10 @@ data BlockOutput = BlockOutput {
_blockName :: Maybe T.Text,
_invalid :: Bool
}
- deriving (Eq, Show)
-
+ deriving (Eq, Show, Generic)
newtype BlockText = BlockText [BlockTextSegment]
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
instance Semigroup BlockText where
(BlockText a) <> (BlockText b) = BlockText (a <> b)
instance Monoid BlockText where
@@ -38,18 +75,24 @@ data BlockTextSegment = BlockTextSegment {
color :: Maybe Color,
backgroundColor :: Maybe Color
}
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
data Importance = NormalImportant Float | WarnImportant Float | ErrorImportant Float | CriticalImportant Float
- deriving (Eq, Show)
+ deriving (Eq, Show, Generic)
+instance FromJSON BlockOutput
+instance ToJSON BlockOutput
-$(deriveJSON defaultOptions ''BlockOutput)
-makeLenses ''BlockOutput
-$(deriveJSON defaultOptions ''Importance)
-$(deriveJSON defaultOptions ''BlockTextSegment)
-$(deriveJSON defaultOptions ''BlockText)
+instance FromJSON BlockText
+instance ToJSON BlockText
+
+instance FromJSON BlockTextSegment
+instance ToJSON BlockTextSegment
+instance FromJSON Importance
+instance ToJSON Importance
+
+makeLenses ''BlockOutput
mkBlockOutput :: BlockText -> BlockOutput
mkBlockOutput text = BlockOutput {
diff --git a/qbar/src/QBar/Blocks.hs b/qbar/src/QBar/Blocks.hs
new file mode 100644
index 0000000000000000000000000000000000000000..0fb55d9f58dd1509f68c56db8ee73e9e5791619f
--- /dev/null
+++ b/qbar/src/QBar/Blocks.hs
@@ -0,0 +1,22 @@
+module QBar.Blocks (
+ QBar.Blocks.Battery.batteryBlock,
+ QBar.Blocks.CpuUsage.cpuUsageBlock,
+ QBar.Blocks.Date.dateBlock,
+ QBar.Blocks.DiskUsage.diskUsageBlock,
+ QBar.Blocks.NetworkManager.networkManagerBlock,
+ QBar.Blocks.Qubes.diskUsageQubesBlock,
+ QBar.Blocks.Qubes.qubesMonitorPropertyBlock,
+ QBar.Blocks.Qubes.qubesVMCountBlock,
+ QBar.Blocks.Script.scriptBlock,
+ QBar.Blocks.Script.pollScriptBlock,
+ QBar.Blocks.Squeekboard.squeekboardBlock,
+) where
+
+import QBar.Blocks.Battery qualified
+import QBar.Blocks.CpuUsage qualified
+import QBar.Blocks.Date qualified
+import QBar.Blocks.DiskUsage qualified
+import QBar.Blocks.NetworkManager qualified
+import QBar.Blocks.Qubes qualified
+import QBar.Blocks.Script qualified
+import QBar.Blocks.Squeekboard qualified
diff --git a/src/QBar/Blocks/Battery.hs b/qbar/src/QBar/Blocks/Battery.hs
similarity index 96%
rename from src/QBar/Blocks/Battery.hs
rename to qbar/src/QBar/Blocks/Battery.hs
index a93b6f83104972024da6fafaea3641d1c149be33..3779bbc5be5ea2de7382aed9572afeaf5eb19326 100644
--- a/src/QBar/Blocks/Battery.hs
+++ b/qbar/src/QBar/Blocks/Battery.hs
@@ -1,4 +1,6 @@
-module QBar.Blocks.Battery where
+module QBar.Blocks.Battery (
+ batteryBlock,
+) where
import QBar.BlockHelper
import QBar.Core
@@ -8,8 +10,8 @@ import QBar.Prelude
import Control.Lens
import Data.Maybe (catMaybes, mapMaybe)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as TIO
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.IO qualified as TIO
import System.Directory
data BatteryStatus = BatteryCharging | BatteryDischarging | BatteryOther
@@ -95,7 +97,7 @@ batteryBlock = runPollBlock $ forever $ do
updateBatteryBlock :: Bool -> [BatteryState] -> PollBlock' ()
updateBatteryBlock _ [] = yieldEmptyBlockUpdate
-updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText.~shortText') $ mkBlockOutput fullText'
+updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText .~ shortText') $ mkBlockOutput fullText'
where
fullText' :: BlockText
fullText' = overallPercentage <> optionalEachBattery <> optionalOverallEstimate
diff --git a/src/QBar/Blocks/CpuUsage.hs b/qbar/src/QBar/Blocks/CpuUsage.hs
similarity index 97%
rename from src/QBar/Blocks/CpuUsage.hs
rename to qbar/src/QBar/Blocks/CpuUsage.hs
index f74b05b9a1f1f8f4f4d7bdedd7cc6288f957d35b..ad54bc9d1912d7c2cb7be1e1b4118c3f9a63ff78 100644
--- a/src/QBar/Blocks/CpuUsage.hs
+++ b/qbar/src/QBar/Blocks/CpuUsage.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE TemplateHaskell #-}
-module QBar.Blocks.CpuUsage where
+module QBar.Blocks.CpuUsage (
+ cpuUsageBlock,
+) where
import QBar.BlockHelper
import QBar.BlockOutput
@@ -11,8 +13,8 @@ import QBar.Prelude
import Control.Applicative ((<|>))
import Control.Lens
import Control.Monad.State (StateT, evalStateT, lift)
-import qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
+import Data.Attoparsec.Text.Lazy qualified as AT
+import Data.Text.Lazy qualified as T
{-
For time accounting the guest fields need to be ignored according to the kernel source code
diff --git a/src/QBar/Blocks/Date.hs b/qbar/src/QBar/Blocks/Date.hs
similarity index 83%
rename from src/QBar/Blocks/Date.hs
rename to qbar/src/QBar/Blocks/Date.hs
index b60119e3f5186c2103778c1dcb68dba8186d7277..29d46fe576e2f3437cf71da749ce47f7836e8ae2 100644
--- a/src/QBar/Blocks/Date.hs
+++ b/qbar/src/QBar/Blocks/Date.hs
@@ -1,4 +1,6 @@
-module QBar.Blocks.Date where
+module QBar.Blocks.Date (
+ dateBlock,
+) where
import QBar.BlockHelper
import QBar.BlockOutput
@@ -6,15 +8,15 @@ import QBar.Core
import QBar.Prelude
import QBar.Time
-import qualified Data.Text.Lazy as T
import Data.Time.Format
import Data.Time.LocalTime
+import Data.Text.Lazy qualified as T
dateBlock :: Block
dateBlock = runPollBlock' (everyNSeconds 60) $ forever $ do
zonedTime <- liftIO getZonedTime
- let logo = "📅\xFE0E "
+ let logo :: Text = "📅\xFE0E "
let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
let text = normalText (logo <> date <> " ") <> activeText time
diff --git a/src/QBar/Blocks/DiskUsage.hs b/qbar/src/QBar/Blocks/DiskUsage.hs
similarity index 77%
rename from src/QBar/Blocks/DiskUsage.hs
rename to qbar/src/QBar/Blocks/DiskUsage.hs
index e93adc89111d3cf91472113c5db1e0f8319ab5ce..2417f35dcb971130ef5067b83192bb6a19056c81 100644
--- a/src/QBar/Blocks/DiskUsage.hs
+++ b/qbar/src/QBar/Blocks/DiskUsage.hs
@@ -1,13 +1,15 @@
-module QBar.Blocks.DiskUsage where
+module QBar.Blocks.DiskUsage (
+ diskUsageBlock,
+) where
import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
import QBar.Prelude
-import qualified Data.ByteString.Lazy.Char8 as C8
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as T
+import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.Encoding qualified as T
import System.Exit
import System.Process.Typed (shell, readProcessStdout)
@@ -27,6 +29,6 @@ diskUsageBlock path = runPollBlock $ forever $ do
(ExitFailure nr) -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
createBlockOutput :: C8.ByteString -> BlockOutput
createBlockOutput output = case map T.decodeUtf8 (C8.lines output) of
- [] -> mkErrorOutput $ "no output"
- [_header] -> mkErrorOutput $ "invalid output"
+ [] -> mkErrorOutput "no output"
+ [_header] -> mkErrorOutput "invalid output"
(_header:values) -> mkBlockOutput $ normalText $ T.intercalate " " $ map T.strip values
diff --git a/src/QBar/Blocks/NetworkManager.hs b/qbar/src/QBar/Blocks/NetworkManager.hs
similarity index 94%
rename from src/QBar/Blocks/NetworkManager.hs
rename to qbar/src/QBar/Blocks/NetworkManager.hs
index 7aca6e6a375e8077be0ecb0937baff379456fa09..dd9eeb5d08aa4780aa35af50e99835323c7bfab5 100644
--- a/src/QBar/Blocks/NetworkManager.hs
+++ b/qbar/src/QBar/Blocks/NetworkManager.hs
@@ -1,10 +1,14 @@
-module QBar.Blocks.NetworkManager where
+module QBar.Blocks.NetworkManager (
+ getDBusProperty,
+ networkManagerBlock,
+ runExceptT_,
+) where
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
-import qualified DBus
-import qualified DBus.Client as DBus
-import qualified Data.Map as Map
-import qualified Data.Text.Lazy as T
+import DBus qualified
+import DBus.Client qualified as DBus
+import Data.Map qualified as Map
+import Data.Text.Lazy qualified as T
import Data.Word (Word32, Word8)
import QBar.BlockHelper
import QBar.BlockOutput
@@ -70,8 +74,13 @@ networkManagerBlock = runSignalBlockConfiguration $ SignalBlockConfiguration {
return client
release :: DBus.Client -> BarIO ()
release = liftIO . DBus.disconnect
+
networkManagerBlock' :: DBus.Client -> SignalBlock ()
- networkManagerBlock' client = (liftBarIO . networkManagerBlock'' client) >=> respondBlockUpdate >=> networkManagerBlock' client
+ networkManagerBlock' client
+ = (liftBarIO . networkManagerBlock'' client)
+ >=> (\x -> respondBlockUpdate x) -- why doesn't this type check without \->?
+ >=> networkManagerBlock' client
+
networkManagerBlock'' :: DBus.Client -> Signal () -> BarIO BlockOutput
networkManagerBlock'' client _ = do
primaryConnection <- runExceptT_ $ getPrimaryConnectionPath client
diff --git a/src/QBar/Blocks/Pipe.hs b/qbar/src/QBar/Blocks/Pipe.hs
similarity index 73%
rename from src/QBar/Blocks/Pipe.hs
rename to qbar/src/QBar/Blocks/Pipe.hs
index 05b26a98ee1712a56fa88ef1efb5c8f608573a9e..f485be37c4da4b1f62491cf8db0fbe4fdc4edc15 100644
--- a/src/QBar/Blocks/Pipe.hs
+++ b/qbar/src/QBar/Blocks/Pipe.hs
@@ -1,4 +1,6 @@
-module QBar.Blocks.Pipe where
+module QBar.Blocks.Pipe (
+ runPipeClient,
+) where
import QBar.ControlSocket
import QBar.Core
@@ -7,11 +9,11 @@ import QBar.TagParser
import Control.Concurrent.Async
import Data.Aeson (encode)
-import qualified Data.ByteString.Lazy.Char8 as BSC
-import qualified Data.Text.Lazy as T
+import Data.ByteString.Lazy.Char8 qualified as BSC
+import Data.Text.Lazy qualified as T
import Pipes
import Pipes.Concurrent
-import qualified Pipes.Prelude as PP
+import Pipes.Prelude qualified as PP
import System.IO
runPipeClient :: Bool -> MainOptions -> IO ()
@@ -21,7 +23,7 @@ runPipeClient enableEvents mainOptions = do
inputTask <- async $ runEffect $ PP.stdinLn >-> toOutput output
void $ waitEitherCancel hostTask inputTask
where
- -- |Special block that reads the processes stdin line-by-line and shows the latest line in the block. Must never be used in a 'server' process or when stdin/stdout is used in another way.
+ -- Special block that reads the processes stdin line-by-line and shows the latest line in the block. Must never be used in a 'server' process or when stdin/stdout is used in another way.
pipeBlock :: Producer String BarIO () -> Block
pipeBlock source = ExitBlock <$ source >-> pack
where
diff --git a/src/QBar/Blocks/Qubes.hs b/qbar/src/QBar/Blocks/Qubes.hs
similarity index 67%
rename from src/QBar/Blocks/Qubes.hs
rename to qbar/src/QBar/Blocks/Qubes.hs
index 092907a43c720c82441f6daf07303d9ce550660c..45c88a9aed096be5dbf6647854fdb52c00a97d01 100644
--- a/src/QBar/Blocks/Qubes.hs
+++ b/qbar/src/QBar/Blocks/Qubes.hs
@@ -1,16 +1,31 @@
-module QBar.Blocks.Qubes where
+module QBar.Blocks.Qubes (
+ diskUsageQubesBlock,
+ qubesMonitorPropertyBlock,
+ qubesVMCountBlock,
+) where
import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
import QBar.Prelude
-import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..), qubesListVMs, qubesListVMsP, QubesVMState (..), vmState)
+import QBar.Qubes.AdminAPI (
+ QubesPropertyInfo(..),
+ QubesVMState(..),
+ QubesVMInfo(..),
+ qubesEvents,
+ qubesGetProperty,
+ qubesListVMs,
+ qubesListVMsP,
+ qubesMonitorProperty,
+ qubesUsageOfDefaultPool,
+ vmState,
+ )
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Map as M
-import qualified Data.Text.Lazy as T
-import Data.Text.Lazy.Encoding (decodeUtf8With)
+import Data.ByteString.Lazy qualified as BL
+import Data.Map qualified as M
import Data.Text.Encoding.Error (lenientDecode)
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.Encoding (decodeUtf8With)
import Pipes as P
import Pipes.Core as P
@@ -26,12 +41,17 @@ diskUsageQubesBlock = runPollBlock $ forever $ do
action = liftIO qubesUsageOfDefaultPool >>= \case
(Just usage, Just size) -> return $ createBlockOutput $ size - usage
_ -> return $ mkErrorOutput "unknown"
+
createBlockOutput :: Int -> BlockOutput
createBlockOutput free =
mkBlockOutput $ chooseColor free $ formatSize free
+
+ chooseColor :: Int -> Text -> BlockText
chooseColor free = if free < 40 * 1024*1024*1024
then activeText
else normalText
+
+ sizeUnits :: [(Text, Int)]
sizeUnits = [
("T", 1024*1024*1024*1024),
("G", 1024*1024*1024),
@@ -39,7 +59,7 @@ diskUsageQubesBlock = runPollBlock $ forever $ do
("k", 1024),
(" bytes", 1)
]
- formatSize size = case filter ((<size) . snd) sizeUnits of
+ formatSize size = case filter ((< size) . snd) sizeUnits of
((unit, factor) : _) -> T.pack (show $ size `div` factor) <> unit
_ -> T.pack (show size) <> " bytes"
@@ -48,8 +68,10 @@ pipeBlockWithEvents prod block = runSignalBlock Nothing (Just produce) sblock
where
produce :: (a -> IO ()) -> BarIO ()
produce yield' = runEffect $ prod >-> forever (await >>= liftIO . yield')
+
sblock :: Signal a -> P.Server (Signal a) (Maybe BlockOutput) BarIO ExitBlock
sblock = lift . sblock' >=> respond >=> sblock
+
sblock' :: Signal a -> BarIO (Maybe BlockOutput)
sblock' RegularSignal = return Nothing -- ignore timer
sblock' (UserSignal x) = block $ Right x
@@ -58,12 +80,20 @@ pipeBlockWithEvents prod block = runSignalBlock Nothing (Just produce) sblock
qubesMonitorPropertyBlock :: BL.ByteString -> Block
qubesMonitorPropertyBlock name = pipeBlockWithEvents (qubesMonitorProperty qubesEvents name) handle
where
+ handle :: Either a QubesPropertyInfo -> BarIO (Maybe BlockOutput)
handle = fmap handle' . either (const $ liftIO $ qubesGetProperty name) return
+
handle' QubesPropertyInfo {propValue, propIsDefault} = Just $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "")
decode = decodeUtf8With lenientDecode
qubesVMCountBlock :: Block
-qubesVMCountBlock = pipeBlockWithEvents qubesListVMsP $ fmap countVMs . either (const $ liftIO $ qubesListVMs) return where
- countVMs = Just . format . M.size . M.filterWithKey isRunningVM
- isRunningVM name x = vmState x == VMRunning && name /= "dom0"
- format n = mkBlockOutput $ normalText $ T.pack (show n) <> " Qube" <> (if n /= 1 then "s" else "")
+qubesVMCountBlock = pipeBlockWithEvents qubesListVMsP $ fmap countVMs . either (const $ liftIO qubesListVMs) return
+ where
+ countVMs :: M.Map BL.ByteString QubesVMInfo -> Maybe BlockOutput
+ countVMs = Just . format . M.size . M.filterWithKey isRunningVM
+
+ isRunningVM :: BL.ByteString -> QubesVMInfo -> Bool
+ isRunningVM name x = vmState x == VMRunning && name /= "dom0"
+
+ format :: Int -> BlockOutput
+ format n = mkBlockOutput $ normalText $ T.pack (show n) <> " Qube" <> (if n /= 1 then "s" else "")
diff --git a/src/QBar/Blocks/Script.hs b/qbar/src/QBar/Blocks/Script.hs
similarity index 84%
rename from src/QBar/Blocks/Script.hs
rename to qbar/src/QBar/Blocks/Script.hs
index 3d1ffbd5c52c788596b08c7c77c4a38b91fe0295..3f5d2ac7f243e953e318d00bd446c1f914d21508 100644
--- a/src/QBar/Blocks/Script.hs
+++ b/qbar/src/QBar/Blocks/Script.hs
@@ -1,4 +1,7 @@
-module QBar.Blocks.Script where
+module QBar.Blocks.Script (
+ pollScriptBlock,
+ scriptBlock,
+) where
import QBar.BlockHelper
import QBar.BlockOutput
@@ -7,25 +10,42 @@ import QBar.Prelude
import QBar.TagParser
import QBar.Time
-import Control.Exception (IOException, handle)
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Exception (IOException, handle)
import Data.Aeson (encode)
-import qualified Data.ByteString.Lazy.Char8 as C8
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as E
-import qualified Data.Text.Lazy.IO as TIO
+import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.Encoding qualified as E
+import Data.Text.Lazy.IO qualified as TIO
import Pipes
import Pipes.Safe (catchP)
import System.Exit
import System.IO hiding (stdin, stdout)
import System.IO.Error (isEOFError)
-import System.Process.Typed (Process, shell, setStdin, setStdout,
- getStdin, getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess, getExitCode)
+import System.Process.Typed (
+ Process,
+ ProcessConfig,
+ closed,
+ createPipe,
+ getExitCode,
+ getStdin,
+ getStdout,
+ readProcessStdout,
+ setStdin,
+ setStdout,
+ shell,
+ startProcess,
+ stopProcess,
+ )
pollScriptBlock :: Interval -> FilePath -> Block
-pollScriptBlock interval path = runPollBlock' interval $ forever $ yieldBlockUpdate =<< (lift blockScriptAction)
+pollScriptBlock interval path = runPollBlock' interval $ forever $ do
+ -- Why doesn't this typecheck when using >>= instead?
+ x <- lift blockScriptAction
+ yieldBlockUpdate x
+
where
blockScriptAction :: BarIO BlockOutput
blockScriptAction = do
@@ -55,6 +75,7 @@ scriptBlock clickEvents path = startScriptProcess
startScriptProcess
Right x -> x
where
+ result :: Either Text Block
result = case (isEOFError exc, exitCode) of
(True, Just ExitSuccess) -> Right exitBlock
(True, Just (ExitFailure nr)) ->
@@ -62,11 +83,11 @@ scriptBlock clickEvents path = startScriptProcess
(True, Nothing) ->
-- This will happen if we hit the race condition (see below)
-- or the process closes its stdout without exiting.
- Left $ "exit code unavailable"
+ Left "exit code unavailable"
_ -> Left $ T.pack (show exc)
ignoreIOException :: a -> IO a -> IO a
ignoreIOException errValue = handle $ \(_ :: IOException) -> return errValue
- handleErrorWithProcess :: (Process i o e) -> IOException -> Block
+ handleErrorWithProcess :: Process i o e -> IOException -> Block
handleErrorWithProcess process exc = do
-- We want to know whether the process has already exited or we are
-- killing it because of some other error. stopProcess determines
@@ -89,7 +110,9 @@ scriptBlock clickEvents path = startScriptProcess
else startScriptProcessNoEvents
startScriptProcessNoEvents :: Block
startScriptProcessNoEvents = do
- let processConfig = setStdin closed $ setStdout createPipe $ shell path
+ let
+ processConfig :: ProcessConfig () Handle ()
+ processConfig = setStdin closed $ setStdout createPipe $ shell path
process <- startProcess processConfig
-- The inner catchP catches errors that happen after the process has been created
-- This handler will also make sure the process is stopped
diff --git a/src/QBar/Blocks/Squeekboard.hs b/qbar/src/QBar/Blocks/Squeekboard.hs
similarity index 96%
rename from src/QBar/Blocks/Squeekboard.hs
rename to qbar/src/QBar/Blocks/Squeekboard.hs
index 9b6b89617ffba1fe72b846d37f1289978a964cea..b96b0690576f169837fc7fcbbb23ced742808049 100644
--- a/src/QBar/Blocks/Squeekboard.hs
+++ b/qbar/src/QBar/Blocks/Squeekboard.hs
@@ -1,17 +1,20 @@
-module QBar.Blocks.Squeekboard where
+module QBar.Blocks.Squeekboard (
+ squeekboardBlock,
+) where
-import Control.Monad.Except (MonadError)
-import Data.Either (isRight)
-import qualified DBus
-import qualified DBus.Client as DBus
-import DBus.Internal.Message (signalBody)
-import Pipes.Core
import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Blocks.NetworkManager (getDBusProperty, runExceptT_)
import QBar.Core
import QBar.Prelude
+import Control.Monad.Except (MonadError)
+import DBus qualified
+import DBus.Client qualified as DBus
+import DBus.Internal.Message (signalBody)
+import Data.Either (isRight)
+import Pipes.Core
+
squeekboardBlock :: Bool -> Block
squeekboardBlock autoHide = runSignalBlockConfiguration $ SignalBlockConfiguration {
aquire,
diff --git a/src/QBar/Blocks/Utils.hs b/qbar/src/QBar/Blocks/Utils.hs
similarity index 79%
rename from src/QBar/Blocks/Utils.hs
rename to qbar/src/QBar/Blocks/Utils.hs
index c894acc833566b7e8f29fb789767cef65d467a5a..23c04992d80610959bc44eee0ff6ad6bd3a9d521 100644
--- a/src/QBar/Blocks/Utils.hs
+++ b/qbar/src/QBar/Blocks/Utils.hs
@@ -1,11 +1,17 @@
-module QBar.Blocks.Utils where
+module QBar.Blocks.Utils (
+ ensure,
+ formatFloatN,
+ parseFile,
+ tryMaybe',
+ tryMaybe,
+) where
import QBar.Prelude
import Control.Exception (SomeException, catch)
-import qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as TIO
+import Data.Attoparsec.Text.Lazy qualified as AT
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.IO qualified as TIO
import Numeric (showFFloat)
formatFloatN :: RealFloat a => Int -> a -> T.Text
diff --git a/src/QBar/Cli.hs b/qbar/src/QBar/Cli.hs
similarity index 97%
rename from src/QBar/Cli.hs
rename to qbar/src/QBar/Cli.hs
index 4689340241e0321cf5cbf2824d82694a26c02161..26a9d9bbe4ca1589db66224b1dfdfa24244d600b 100644
--- a/src/QBar/Cli.hs
+++ b/qbar/src/QBar/Cli.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TemplateHaskell #-}
-module QBar.Cli where
+module QBar.Cli (
+ runQBar,
+) where
import QBar.Blocks
import QBar.Blocks.Pipe
@@ -9,14 +10,14 @@ import QBar.ControlSocket
import QBar.Core
import QBar.DefaultConfig
import QBar.Prelude
+import QBar.Qubes.AdminAPI (printEvents, qubesVMStats, qubesEvents)
import QBar.Server
import QBar.Theme
import QBar.Time
-import QBar.Qubes.AdminAPI (printEvents, qubesVMStats, qubesEvents)
import Control.Monad (join)
import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
import Development.GitRev
import Options.Applicative
@@ -120,7 +121,7 @@ scriptBlockParser = helper <*> do
-- HACK optparse-applicative does not support options of style --poll[=INTERVAL],
-- so we add a second option to specify the interval explicitly instead
-- https://github.com/pcapriotti/optparse-applicative/issues/243
- pollInterval <- fromMaybe defaultInterval <$> (optional $ IntervalSeconds <$> option auto (
+ pollInterval <- fromMaybe defaultInterval <$> optional (IntervalSeconds <$> option auto (
long "interval" <>
short 'i' <>
metavar "SECONDS" <>
diff --git a/src/QBar/Color.hs b/qbar/src/QBar/Color.hs
similarity index 66%
rename from src/QBar/Color.hs
rename to qbar/src/QBar/Color.hs
index 1b79b237549db8a7d28d73bf5e4320f1e2c3cdf4..806803a15d523728ab27cc97768bb2386251a687 100644
--- a/src/QBar/Color.hs
+++ b/qbar/src/QBar/Color.hs
@@ -1,19 +1,27 @@
-module QBar.Color where
+module QBar.Color (
+ Color(..),
+ colorParser,
+ hexColorText,
+) where
import QBar.Prelude
import Data.Aeson
+import Data.Aeson.Types qualified as AT
+import Data.Attoparsec.Text.Lazy as A
import Data.Bits ((.|.), shiftL)
import Data.Char (ord)
-import Data.Attoparsec.Text.Lazy as A
import Data.Colour.RGBSpace
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
import Numeric (showHex)
data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
deriving (Eq, Show)
+
instance FromJSON Color where
- parseJSON = withText "Color" $ either fail pure . parseOnly (colorParser <* endOfInput)
+ parseJSON :: Value -> AT.Parser Color
+ parseJSON = withText "Color" $ either fail pure . A.parseOnly (colorParser <* endOfInput) . T.fromStrict
+
instance ToJSON Color where
toJSON = String . T.toStrict . hexColorText
@@ -35,27 +43,29 @@ hexColorText = hexColor'
paddedHexComponent :: Text -> Text
paddedHexComponent hex =
let len = 2 - T.length hex
- padding = if len == 1 then "0" else ""
+ padding :: Text = if len == 1 then "0" else ""
in padding <> hex
-colorParser :: Parser Color
+colorParser :: A.Parser Color
colorParser = do
void $ char '#'
rgb <- RGB <$> doubleFromHex2 <*> doubleFromHex2 <*> doubleFromHex2
option (ColorRGB rgb) (ColorRGBA rgb <$> doubleFromHex2)
where
- doubleFromHex2 :: Parser Double
+ doubleFromHex2 :: A.Parser Double
doubleFromHex2 = (/ 256) . fromIntegral <$> hexadecimal'' 2
- -- |Variant of 'Data.Attoparsec.Text.hexadecimal' that parses a fixed amount of digits.
- hexadecimal'' :: Int -> Parser Int
+ -- Variant of 'Data.Attoparsec.Text.hexadecimal' that parses a fixed amount of digits.
+ hexadecimal'' :: Int -> A.Parser Int
hexadecimal'' digits = foldl step 0 <$> count digits (satisfy isHexDigit)
where
isHexDigit c = (c >= '0' && c <= '9') ||
(c >= 'a' && c <= 'f') ||
(c >= 'A' && c <= 'F')
- step a c | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48)
- | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87)
- | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55)
+
+ step :: Int -> Char -> Int
+ step a c | w >= 48 && w <= 57 = (a `shiftL` 4) .|. (w - 48)
+ | w >= 97 = (a `shiftL` 4) .|. (w - 87)
+ | otherwise = (a `shiftL` 4) .|. (w - 55)
where w = ord c
diff --git a/src/QBar/ControlSocket.hs b/qbar/src/QBar/ControlSocket.hs
similarity index 94%
rename from src/QBar/ControlSocket.hs
rename to qbar/src/QBar/ControlSocket.hs
index 4986dec267e07eba65134ff4f8a035e7683897a6..80ee0204b29862a4a7b12063393e29afbc8c26da 100644
--- a/src/QBar/ControlSocket.hs
+++ b/qbar/src/QBar/ControlSocket.hs
@@ -1,7 +1,17 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.ControlSocket where
+{-# LANGUAGE TypeFamilies #-}
+
+module QBar.ControlSocket (
+ Command(..),
+ CommandResult(..),
+ Down,
+ Up,
+ addServerMirrorStream,
+ listenUnixSocketAsync,
+ sendBlockStream,
+ sendBlockStreamStdio,
+ sendIpc,
+) where
import QBar.BlockOutput
import QBar.Core
@@ -14,22 +24,22 @@ import Control.Concurrent (forkFinally)
import Control.Concurrent.Async
import Control.Exception (SomeException, IOException, handle, onException)
import Data.Aeson (FromJSON, ToJSON)
-import Data.Aeson.TH
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BSC
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BSC
import Data.Text.Lazy (pack)
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.IO qualified as T
import Data.Time.Clock (getCurrentTime, addUTCTime)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as T
+import GHC.Generics
import Network.Socket
import Pipes
-import Pipes.Concurrent as PC (Output, spawn, spawn', unbounded, newest, toOutput, fromInput, send, atomically)
-import Pipes.Parse
-import qualified Pipes.Prelude as PP
-import Pipes.Safe (catch)
import Pipes.Aeson (decode, DecodingError)
import Pipes.Aeson.Unchecked (encode)
+import Pipes.Concurrent as PC (Output, spawn, spawn', unbounded, newest, toOutput, fromInput, send, atomically)
import Pipes.Network.TCP (fromSocket, toSocket)
+import Pipes.Parse
+import Pipes.Prelude qualified as PP
+import Pipes.Safe (catch)
import System.Directory (removeFile, doesFileExist)
import System.Environment (getEnv)
import System.Exit (exitSuccess)
@@ -134,13 +144,19 @@ decodeStreamSafe MainOptions{verbose} inputStream = decodeStream inputStream >->
Right v -> yield v >> failOnDecodingError'
-data StreamType = BlockStreamType BlockStream | MirrorStreamType MirrorStream
+data StreamType
+ = BlockStreamType BlockStream
+ | MirrorStreamType MirrorStream
+ deriving Generic
+
mapStreamType :: StreamType -> (forall a. IsStream a => a -> b) -> b
mapStreamType (BlockStreamType a) f = f a
mapStreamType (MirrorStreamType a) f = f a
data BlockStream = BlockStream
+ deriving Generic
+
instance IsStream BlockStream where
type Up BlockStream = [BlockOutput]
type Down BlockStream = BlockEvent
@@ -180,6 +196,8 @@ instance IsStream BlockStream where
data MirrorStream = MirrorStream
+ deriving Generic
+
instance IsStream MirrorStream where
type Up MirrorStream = BlockEvent
type Down MirrorStream = [BlockOutput]
@@ -195,12 +213,13 @@ instance IsStream MirrorStream where
data Request = Command Command | StartStream StreamType
+ deriving Generic
data Command = SetTheme T.Text | CheckServer
- deriving Show
+ deriving (Show, Generic)
data CommandResult = Success | Error Text
- deriving Show
+ deriving (Show, Generic)
ipcSocketAddress :: MainOptions -> IO FilePath
@@ -389,10 +408,20 @@ listenUnixSocket options@MainOptions{verbose} bar commandHandler = do
errorResponse :: Text -> Producer ByteString IO ()
errorResponse message = encode $ Error message
+instance FromJSON BlockStream
+instance ToJSON BlockStream
+
+instance FromJSON Command
+instance ToJSON Command
+
+instance FromJSON CommandResult
+instance ToJSON CommandResult
+
+instance FromJSON MirrorStream
+instance ToJSON MirrorStream
+
+instance FromJSON Request
+instance ToJSON Request
-$(deriveJSON defaultOptions ''Request)
-$(deriveJSON defaultOptions ''Command)
-$(deriveJSON defaultOptions ''CommandResult)
-$(deriveJSON defaultOptions ''StreamType)
-$(deriveJSON defaultOptions ''BlockStream)
-$(deriveJSON defaultOptions ''MirrorStream)
+instance FromJSON StreamType
+instance ToJSON StreamType
diff --git a/src/QBar/Core.hs b/qbar/src/QBar/Core.hs
similarity index 88%
rename from src/QBar/Core.hs
rename to qbar/src/QBar/Core.hs
index 945c47994179d62014c888e4066810fdcd6e5fe4..5ccc60cbf38e0688071d78718ab9bf36fdb8b0d7 100644
--- a/src/QBar/Core.hs
+++ b/qbar/src/QBar/Core.hs
@@ -1,6 +1,45 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.Core where
+module QBar.Core (
+ Bar(..),
+ BarIO,
+ BarUpdateChannel(..),
+ BarUpdateEvent,
+ Block',
+ Block,
+ BlockCache,
+ BlockEvent(..),
+ BlockEventHandler,
+ BlockState,
+ BlockUpdate,
+ BlockUpdateReason(..),
+ ExitBlock(..),
+ IsCachable(..),
+ MainOptions(..),
+ MonadBarIO(..),
+ addBlock,
+ addBlockCache,
+ askBar,
+ autoPadding,
+ barAsync,
+ defaultInterval,
+ exitBlock,
+ hasEventHandler,
+ invalidateBlockState,
+ mkBlockState',
+ mkBlockState,
+ modify,
+ newCache',
+ newCache,
+ newCacheIO,
+ pushBlockUpdate',
+ pushBlockUpdate,
+ pushEmptyBlockUpdate,
+ runBarIO,
+ updateBar',
+ updateBar,
+ updateBarDefault',
+ updateBarDefault,
+ updateEventHandler,
+) where
import QBar.BlockOutput
import QBar.Prelude
@@ -8,21 +47,22 @@ import QBar.Time
import QBar.Utils
import Control.Concurrent.Async
-import qualified Control.Concurrent.Event as Event
+import Control.Concurrent.Event qualified as Event
import Control.Concurrent.MVar
import Control.Concurrent.STM.TChan
import Control.Lens
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.State (StateT)
import Control.Monad.Writer (WriterT)
-import Data.Aeson.TH
+import Data.Aeson
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
+import GHC.Generics
import Pipes
import Pipes.Concurrent
+import Pipes.Prelude qualified as PP
import Pipes.Safe (SafeT, runSafeT)
-import qualified Pipes.Prelude as PP
data MainOptions = MainOptions {
verbose :: Bool,
@@ -33,9 +73,10 @@ data MainOptions = MainOptions {
data BlockEvent = Click {
name :: T.Text,
button :: Int
-} deriving (Eq, Show)
-$(deriveJSON defaultOptions ''BlockEvent)
+} deriving (Eq, Show, Generic)
+instance FromJSON BlockEvent
+instance ToJSON BlockEvent
data ExitBlock = ExitBlock
@@ -207,7 +248,7 @@ newCache'' = do
-- |Creates a cache from a block.
cacheBlock :: Block -> BlockCache
-- 'Block's 'yield' an update whenever they want to update the cache.
-cacheBlock pushBlock = newCache $ () <$ (pushBlock >-> updateBarP >-> addBlockName >-> PP.map (\a -> [a]))
+cacheBlock pushBlock = newCache $ void $ pushBlock >-> updateBarP >-> addBlockName >-> PP.map (: [])
where
updateBarP :: Pipe BlockUpdate BlockState BarIO r
updateBarP = forever $ do
@@ -215,7 +256,7 @@ cacheBlock pushBlock = newCache $ () <$ (pushBlock >-> updateBarP >-> addBlockNa
yield state
updateBar reason
- -- |Sets 'blockName' to a random (but static) identifier if an event handler is set but the 'blockName' is not set.
+ -- Sets 'blockName' to a random (but static) identifier if an event handler is set but the 'blockName' is not set.
addBlockName :: Pipe BlockState BlockState BarIO r
addBlockName = do
defaultBlockName <- randomIdentifier
@@ -235,9 +276,9 @@ autoPadding = autoPadding' 0 0
maybeBlock <- await
case maybeBlock of
(Just (block, eventHandler), reason) -> do
- let fullLength' = max fullLength . printedLength $ block^.fullText
- let shortLength' = max shortLength . printedLength $ block^.shortText._Just
- yield $ (Just (padFullText fullLength' . padShortText shortLength' $ block, eventHandler), reason)
+ let fullLength' = max fullLength . printedLength $ block ^. fullText
+ let shortLength' = max shortLength . printedLength $ block ^. shortText._Just
+ yield (Just (padFullText fullLength' . padShortText shortLength' $ block, eventHandler), reason)
autoPadding' fullLength' shortLength'
(Nothing, reason) -> do
yield (Nothing, reason)
diff --git a/src/QBar/DefaultConfig.hs b/qbar/src/QBar/DefaultConfig.hs
similarity index 88%
rename from src/QBar/DefaultConfig.hs
rename to qbar/src/QBar/DefaultConfig.hs
index 8743526ff6aa33bbfa269d2f89fe8c440d04b4eb..0193190f30f9d41c894104859eb010093a51b635 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/qbar/src/QBar/DefaultConfig.hs
@@ -1,4 +1,6 @@
-module QBar.DefaultConfig where
+module QBar.DefaultConfig (
+ defaultBarConfig
+) where
import QBar.Blocks
import QBar.Core
diff --git a/src/QBar/Host.hs b/qbar/src/QBar/Host.hs
similarity index 93%
rename from src/QBar/Host.hs
rename to qbar/src/QBar/Host.hs
index db471003f3ae89f2493c34f5fd124b7324067cd2..4bfa6f1bb26fc2517f7e79d7eb839bed1cec5a8a 100644
--- a/src/QBar/Host.hs
+++ b/qbar/src/QBar/Host.hs
@@ -1,4 +1,14 @@
-module QBar.Host where
+module QBar.Host (
+ HostHandle(..),
+ attachBarOutput,
+ eventDispatcher,
+ filterDuplicates,
+ installSignalHandlers,
+ requestBarUpdateHandler,
+ runBarHost',
+ runBarHost,
+ runBlocks,
+) where
import QBar.BlockOutput
import QBar.Core
@@ -8,7 +18,7 @@ import QBar.Utils
import Control.Concurrent (forkIO, forkFinally, threadDelay)
import Control.Concurrent.Async (async, wait, waitAny)
-import qualified Control.Concurrent.Event as Event
+import Control.Concurrent.Event qualified as Event
import Control.Concurrent.MVar
import Control.Concurrent.STM.TChan
import Control.Exception (SomeException, catch, fromException)
@@ -16,7 +26,7 @@ import Control.Lens hiding (each, (.=))
import Control.Monad.STM (atomically)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (catMaybes, mapMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
import Pipes
import Pipes.Concurrent (spawn, unbounded, toOutput, fromInput)
import System.Exit (ExitCode, exitWith)
@@ -113,13 +123,13 @@ runBlocks bar HostHandle{barUpdateEvent, barUpdatedEvent, followupEventWaitTimeM
writeIORef eventHandlerListIORef eventHandlerList
where
eventHandlerList :: [(T.Text, BlockEventHandler)]
- eventHandlerList = mapMaybe getEventHandler $ blockStates
+ eventHandlerList = mapMaybe getEventHandler blockStates
getEventHandler :: BlockState -> Maybe (T.Text, BlockEventHandler)
getEventHandler Nothing = Nothing
getEventHandler (Just (_, Nothing)) = Nothing
getEventHandler (Just (blockOutput, Just eventHandler)) = do
- blockName' <- blockOutput^.blockName
+ blockName' <- blockOutput ^. blockName
return (blockName', eventHandler)
@@ -230,11 +240,14 @@ runBarHost' initializeBarAction = do
attachBarOutputImpl :: MVar ExitCode -> Producer [BlockOutput] IO () -> Consumer BlockEvent IO () -> (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
attachBarOutputImpl exitMVar blockOutputProducer eventConsumer (barOutputConsumer, barEventProducer) = do
-
- let handleBarEventInput = liftIO $ runEffect $ barEventProducer >-> eventConsumer
+ let
+ handleBarEventInput :: IO ()
+ handleBarEventInput = liftIO $ runEffect $ barEventProducer >-> eventConsumer
liftIO $ void $ forkFinally handleBarEventInput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "An event input handler failed: " <> show result)
- let handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
+ let
+ handleBarOutput :: IO ()
+ handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
liftIO $ void $ forkFinally handleBarOutput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "A bar output handler failed: " <> show result)
where
diff --git a/src/QBar/Pango.hs b/qbar/src/QBar/Pango.hs
similarity index 93%
rename from src/QBar/Pango.hs
rename to qbar/src/QBar/Pango.hs
index bbfa830fefd7091b2419d050ab11fe27d5fbc839..4be97b74ed8cbb5cd36a6036b7dd169ad4b27d53 100644
--- a/src/QBar/Pango.hs
+++ b/qbar/src/QBar/Pango.hs
@@ -1,4 +1,7 @@
-module QBar.Pango (PangoText, renderPango) where
+module QBar.Pango (
+ PangoText,
+ renderPango,
+) where
import QBar.Color
import QBar.Prelude
diff --git a/src/QBar/Prelude.hs b/qbar/src/QBar/Prelude.hs
similarity index 70%
rename from src/QBar/Prelude.hs
rename to qbar/src/QBar/Prelude.hs
index efa804626921596bc0eff39fc4edfdccf527d122..ff966db660225353fae1fa6c9fed2de9ee0e1097 100644
--- a/src/QBar/Prelude.hs
+++ b/qbar/src/QBar/Prelude.hs
@@ -1,32 +1,31 @@
-module QBar.Prelude
- ( module Prelude,
- ByteString.ByteString,
- (>=>),
- (<=<),
- Control.Monad.forever,
- Control.Monad.unless,
- Control.Monad.void,
- Control.Monad.when,
- Control.Monad.IO.Class.MonadIO,
- Control.Monad.IO.Class.liftIO,
- Text.Text,
- Maybe.listToMaybe,
- error,
- errorWithoutStackTrace,
- head,
- intercalate,
- trace,
- traceId,
- traceShow,
- traceShowId,
- traceM,
- traceShowM,
- traceIO,
- traceShowIO,
- traceShowIdIO,
- undefined,
- )
-where
+module QBar.Prelude (
+ module Prelude,
+ (<=<),
+ (>=>),
+ ByteString.ByteString,
+ Control.Monad.IO.Class.MonadIO,
+ Control.Monad.IO.Class.liftIO,
+ Control.Monad.forever,
+ Control.Monad.unless,
+ Control.Monad.void,
+ Control.Monad.when,
+ Maybe.listToMaybe,
+ Text.Text,
+ error,
+ errorWithoutStackTrace,
+ head,
+ intercalate,
+ trace,
+ traceIO,
+ traceId,
+ traceM,
+ traceShow,
+ traceShowIO,
+ traceShowId,
+ traceShowIdIO,
+ traceShowM,
+ undefined,
+) where
import Prelude hiding
( error,
@@ -34,15 +33,15 @@ import Prelude hiding
head,
undefined,
)
-import qualified Prelude as P
-import qualified Control.Monad
import Control.Monad ((>=>), (<=<))
-import qualified Control.Monad.IO.Class
-import qualified Data.ByteString as ByteString
-import qualified Data.Maybe as Maybe
-import qualified Data.Text.Lazy as Text
-import qualified Debug.Trace as Trace
-import qualified GHC.Stack.Types
+import Control.Monad qualified
+import Control.Monad.IO.Class qualified
+import Data.ByteString qualified as ByteString
+import Data.Maybe qualified as Maybe
+import Data.Text.Lazy qualified as Text
+import Debug.Trace qualified as Trace
+import GHC.Stack.Types
+import Prelude qualified as P
{-# DEPRECATED head "Partial Function." #-}
head :: [a] -> a
diff --git a/src/QBar/Qubes/AdminAPI.hs b/qbar/src/QBar/Qubes/AdminAPI.hs
similarity index 84%
rename from src/QBar/Qubes/AdminAPI.hs
rename to qbar/src/QBar/Qubes/AdminAPI.hs
index 7fcac49795f5d7830176cdbd15cef1a0f18d06d2..e80e0baeae960a206df541e15679231fc7a633bc 100644
--- a/src/QBar/Qubes/AdminAPI.hs
+++ b/qbar/src/QBar/Qubes/AdminAPI.hs
@@ -1,23 +1,38 @@
-module QBar.Qubes.AdminAPI where
+{-# OPTIONS_GHC -Wno-partial-fields #-}
+
+module QBar.Qubes.AdminAPI (
+ QubesPropertyInfo(..),
+ QubesVMInfo(..),
+ QubesVMState(..),
+ printEvents,
+ qubesEvents,
+ qubesGetProperty,
+ qubesListLabelNames,
+ qubesListProperties,
+ qubesListVMs,
+ qubesListVMsP,
+ qubesMonitorProperty,
+ qubesUsageOfDefaultPool,
+ qubesVMStats,
+) where
import QBar.Prelude
-import Control.Monad (forM_, guard)
+import Control.Monad (forM_)
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Char8 as BLC
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Char (isAlphaNum)
import Data.Function ((&))
-import qualified Data.Map as Map
+import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Network.HostName
-import Numeric (showHex, readHex)
import Pipes
-import qualified Pipes.Prelude as P
-import qualified Pipes.Safe as P
+import Pipes.Prelude qualified as P
+import Pipes.Safe qualified as P
import System.IO (Handle, hSetBinaryMode)
import System.Process.Typed
import Text.Read (readMaybe)
@@ -64,6 +79,8 @@ instance Binary QubesAdminReturn where
where
getPairs = untilZeroByte $ (,) <$> getLazyByteStringNul <*> getLazyByteStringNul
getFields = untilZeroByte getLazyByteStringNul
+
+ untilZeroByte :: Get a -> Get [a]
untilZeroByte inner = lookAhead getWord8 >>= \case
0x00 -> getWord8 >> return []
_ -> inner >>= \x -> (x:) <$> untilZeroByte inner
@@ -71,7 +88,7 @@ instance Binary QubesAdminReturn where
qubesAdminConnect :: BL.ByteString -> [BL.ByteString] -> IO (Process () Handle ())
qubesAdminConnect serviceName args = do
hostname <- getHostName
- let concatArgs sep = mconcat (map (sep<>) args)
+ let concatArgs sep = mconcat (map (sep <>) args)
let cmd = if hostname == "dom0"
then "qubesd-query dom0 " <> serviceName <> " dom0" <> concatArgs " "
else "qrexec-client-vm dom0 " <> serviceName <> concatArgs "+"
@@ -95,11 +112,12 @@ qubesTryAdminCall serviceName args = do
qubesAdminCall :: BL.ByteString -> [BL.ByteString] -> IO BL.ByteString
qubesAdminCall serviceName args = qubesTryAdminCall serviceName args >>= extract where
+ extract :: QubesAdminReturn -> IO BLC.ByteString
extract Ok {okContent} = return okContent
extract x@Exception {} = fail $ "service has returned an exception: " <> show x
extract Event {} = fail "service has returned events instead of a reply"
-qubesAdminCallP :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesAdminCallP :: forall m. (P.MonadSafe m, MonadFail m)
=> BL.ByteString -> [BL.ByteString] -> Producer QubesAdminReturn m ()
qubesAdminCallP serviceName args = do
process <- liftIO $ qubesAdminConnect serviceName args
@@ -122,7 +140,7 @@ qubesAdminCallP serviceName args = do
go (runGetIncremental get)
`P.finally` stopProcess process
-qubesAdminEvents :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesAdminEvents :: forall m. (P.MonadSafe m, MonadFail m)
=> BL.ByteString -> [BL.ByteString] -> Producer QubesAdminReturn m ()
qubesAdminEvents serviceName args = qubesAdminCallP serviceName args >-> onlyEvents
where
@@ -132,14 +150,14 @@ qubesAdminEvents serviceName args = qubesAdminCallP serviceName args >-> onlyEve
Exception {} -> fail $ "service has returned an exception: " ++ show reply
Event {} -> yield reply
-qubesVMStatsRaw :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesVMStatsRaw :: forall m. (P.MonadSafe m, MonadFail m)
=> Producer QubesAdminReturn m ()
qubesVMStatsRaw = qubesAdminEvents "admin.vm.Stats" []
data QubesVMStats = QubesVMStats { statsVMName :: BL.ByteString, memoryKB :: Int, cpuTime :: Int, cpuUsageRaw :: Int, cpuUsage :: Int }
deriving (Eq, Ord, Show, Read)
-qubesVMStats :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesVMStats :: forall m. (P.MonadSafe m, MonadFail m)
=> Producer QubesVMStats m ()
qubesVMStats = qubesVMStatsRaw >-> P.mapFoldable parse where
parse :: QubesAdminReturn -> Maybe QubesVMStats
@@ -149,7 +167,9 @@ qubesVMStats = qubesVMStatsRaw >-> P.mapFoldable parse where
| otherwise = Nothing -- shouldn't happen -> report error?
parse _ = Nothing -- shouldn't happen -> report error?
- absent = (-1)
+ absent :: Int = -1
+
+ readBL :: BLC.ByteString -> Int
readBL = read . BLC.unpack
addProperties :: [(BL.ByteString, BL.ByteString)] -> QubesVMStats -> QubesVMStats
@@ -173,11 +193,11 @@ data QubesEvent
| PropertyDel { domainName :: BL.ByteString, changedProperty :: BL.ByteString, oldValue :: BL.ByteString } -- reset to default value
deriving (Eq, Ord, Show, Read)
-qubesEventsRaw :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesEventsRaw :: forall m. (P.MonadSafe m, MonadFail m)
=> Producer QubesAdminReturn m ()
qubesEventsRaw = qubesAdminEvents "admin.Events" []
-qubesEvents :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesEvents :: forall m. (P.MonadSafe m, MonadFail m)
=> Producer QubesEvent m ()
qubesEvents = qubesEventsRaw >-> P.mapFoldable parse where
parse :: QubesAdminReturn -> Maybe QubesEvent
@@ -193,7 +213,7 @@ qubesEvents = qubesEventsRaw >-> P.mapFoldable parse where
DomainUpdatesAvailable evSubject (boolPropViaInt "value") (boolPropViaInt "oldvalue")
"domain-start-failed" ->
DomainStartFailed evSubject (fromMaybe "" $ getProp "reason")
- _ -> case BLC.break (==':') evEvent of
+ _ -> case BLC.break (== ':') evEvent of
("property-set", _) ->
PropertySet evSubject (fromMaybe "" $ getProp "name") (fromMaybe "" $ getProp "newvalue") (fromMaybe "" $ getProp "oldvalue")
("property-del", _) ->
@@ -209,11 +229,11 @@ qubesEvents = qubesEventsRaw >-> P.mapFoldable parse where
boolProp :: BL.ByteString -> Maybe Bool
boolProp = readProp
boolPropViaInt :: BL.ByteString -> Bool
- boolPropViaInt = fromMaybe False . fmap (/=0) . intProp
+ boolPropViaInt = maybe False (/= 0) . intProp
parse _ = Nothing -- shouldn't happen -> report error?
printEvents :: Show a => Producer a (P.SafeT IO) () -> IO ()
-printEvents prod = P.runSafeT $ runEffect $ prod >-> (forever $ await >>= liftIO . print)
+printEvents prod = P.runSafeT $ runEffect $ prod >-> forever (await >>= liftIO . print)
data QubesVMState = VMRunning | VMHalted | UnknownState
deriving (Eq, Ord, Enum)
@@ -239,19 +259,23 @@ instance Read QubesVMState where
qubesAdminCallLines :: BL.ByteString -> [BL.ByteString] -> IO [BL.ByteString]
qubesAdminCallLines serviceName args = qubesAdminCall serviceName args >>= parse
where
+ parse :: BLC.ByteString -> IO [BLC.ByteString]
parse reply = BLC.split '\n' reply
- & filter (/="")
+ & filter (/= "")
& return
qubesListVMs :: IO (Map.Map BL.ByteString QubesVMInfo)
qubesListVMs = parse <$> qubesAdminCallLines "admin.vm.List" []
where
+ parse :: [BLC.ByteString] -> Map.Map BLC.ByteString QubesVMInfo
parse = Map.fromList . map parseLine
+
+ parseLine :: BLC.ByteString -> (BLC.ByteString, QubesVMInfo)
parseLine line =
(vmName, QubesVMInfo (readPropEmpty "state") (tryReadProp "class" & fromMaybe UnknownClass))
where
(vmName : propsRaw) = BLC.split ' ' line
- props = map (fmap BLC.tail . BLC.break (=='=')) propsRaw
+ props = map (fmap BLC.tail . BLC.break (== '=')) propsRaw
getProp :: BL.ByteString -> Maybe BL.ByteString
getProp name = lookup name props
readPropEmpty :: Read a => BL.ByteString -> a
@@ -259,7 +283,7 @@ qubesListVMs = parse <$> qubesAdminCallLines "admin.vm.List" []
tryReadProp :: Read a => BL.ByteString -> Maybe a
tryReadProp name = readMaybe . BLC.unpack =<< getProp name
-qubesListVMsP :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesListVMsP :: forall m. (P.MonadSafe m, MonadFail m)
=> Producer (Map.Map BL.ByteString QubesVMInfo) m ()
qubesListVMsP = liftIO qubesListVMs >>= yield >> qubesEvents >-> P.mapM (const $ liftIO qubesListVMs)
@@ -271,12 +295,9 @@ qubesGetProperty name = parse <$> qubesAdminCall "admin.property.Get" [name]
where
parse reply = QubesPropertyInfo (isDefault == "default=True") (BL.drop 5 typeStr) value
where
- splitOn ch = fmap BLC.tail . BLC.break (==ch)
+ splitOn ch = fmap BLC.tail . BLC.break (== ch)
(isDefault, (typeStr, value)) = splitOn ' ' reply & fmap (splitOn ' ')
-qubesListPropertyNames :: IO [BL.ByteString]
-qubesListPropertyNames = qubesAdminCallLines "admin.property.List" []
-
qubesListProperties :: IO [(BL.ByteString, QubesPropertyInfo)]
qubesListProperties = qubesListLabelNames >>= mapM (toSndM qubesGetProperty)
where
@@ -289,47 +310,28 @@ qubesGetDefaultPool = propValue <$> qubesGetProperty "default_pool"
qubesGetPoolInfo :: BL.ByteString -> IO [(BL.ByteString, BL.ByteString)]
qubesGetPoolInfo name = map parseLine <$> qubesAdminCallLines "admin.pool.Info" [name]
where
- parseLine = fmap BLC.tail . BLC.break (=='=')
+ parseLine = fmap BLC.tail . BLC.break (== '=')
qubesUsageOfDefaultPool :: IO (Maybe Int, Maybe Int)
qubesUsageOfDefaultPool = qubesGetDefaultPool >>= qubesGetPoolInfo >>= extract
where
+ extract :: [(BLC.ByteString, BLC.ByteString)] -> IO (Maybe Int, Maybe Int)
extract props = return (tryReadProp "usage" props, tryReadProp "size" props)
tryReadProp :: Read a => BL.ByteString -> [(BL.ByteString, BL.ByteString)] -> Maybe a
tryReadProp name props = readMaybe . BLC.unpack =<< lookup name props
-newtype QubesLabelColor = QubesLabelColor { fromQubesLabelColor :: Int }
- deriving (Eq, Ord)
-
-instance Show QubesLabelColor where
- showsPrec _ (QubesLabelColor x) = \s -> "0x" <> pad 6 (showHex x "") <> s
- where pad l s = replicate (l - length s) '0' <> s
-
-instance Read QubesLabelColor where
- readsPrec _ ('0' : 'x' : xs) = do
- let (num, remainder) = splitAt 6 xs
- guard $ length num == 6
- (num', []) <- readHex num
- [(QubesLabelColor num', remainder)]
- readsPrec _ _ = []
-
-qubesGetLabelColor :: BL.ByteString -> IO QubesLabelColor
-qubesGetLabelColor name = read . BLC.unpack <$> qubesAdminCall "admin.label.Get" [name]
qubesListLabelNames :: IO [BL.ByteString]
qubesListLabelNames = qubesAdminCallLines "admin.label.List" []
-qubesListLabels :: IO [(BL.ByteString, QubesLabelColor)]
-qubesListLabels = qubesListLabelNames >>= mapM (toSndM qubesGetLabelColor)
- where
- toSndM :: Applicative m => (a -> m b) -> a -> m (a, b)
- toSndM f x = sequenceA (x, f x)
-
-qubesMonitorProperty :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m)
+qubesMonitorProperty :: forall m. MonadIO m
=> Producer QubesEvent m () -> BL.ByteString -> Producer QubesPropertyInfo m ()
qubesMonitorProperty events name = events >-> P.filter isRelevant >-> fetchValue
where
+ fetchValue :: Proxy () QubesEvent () QubesPropertyInfo m b
fetchValue = liftIO (qubesGetProperty name) >>= go
+
+ go :: QubesPropertyInfo -> Proxy () QubesEvent () QubesPropertyInfo m b
go x = do
yield x
ev <- await
@@ -337,6 +339,7 @@ qubesMonitorProperty events name = events >-> P.filter isRelevant >-> fetchValue
PropertySet {newValue} -> go $ x { propIsDefault = False, propValue = newValue }
PropertyDel {} -> fetchValue
_ -> go x
+
isRelevant PropertySet {changedProperty} = name == changedProperty
isRelevant PropertyDel {changedProperty} = name == changedProperty
isRelevant _ = False
diff --git a/src/QBar/Server.hs b/qbar/src/QBar/Server.hs
similarity index 92%
rename from src/QBar/Server.hs
rename to qbar/src/QBar/Server.hs
index ff8d4d81a2d0f8b37c095c2c4f049ce3affafcd6..80f816012999a61be3764d17d1d480de17ba625c 100644
--- a/src/QBar/Server.hs
+++ b/qbar/src/QBar/Server.hs
@@ -1,34 +1,35 @@
-module QBar.Server where
+module QBar.Server (
+ runBarServer,
+ runBarServerMirror,
+) where
import QBar.BlockOutput
-import QBar.Core
import QBar.ControlSocket
+import QBar.Core
import QBar.Host
-import QBar.Prelude
import QBar.Pango
+import QBar.Prelude
import QBar.Theme
import QBar.Utils
-import Control.Monad (forM_)
import Control.Concurrent.Async (async, link)
import Control.Concurrent.Event as Event
import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_)
import Control.Exception (throw)
+import Control.Monad (forM_)
import Data.Aeson (encode, decode, ToJSON, toJSON, object, (.=))
+import Data.Aeson.Types qualified as AT
+import Data.ByteString.Char8 qualified as BSSC8
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.ByteString.Lazy qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as C8
import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
import Pipes
import Pipes.Concurrent (Input, spawn, latest, toOutput, fromInput)
-import qualified Pipes.Prelude as PP
+import Pipes.Prelude qualified as PP
import System.IO (stdin, stdout, stderr, hFlush)
-data ServerMode = Host | Mirror
-data ServerOutput = Sway | Headless
-
renderIndicators :: [Text]
renderIndicators = ["*"] <> cycle ["/", "-", "\\", "|"]
@@ -41,9 +42,16 @@ instance ToJSON PangoBlock where
toJSON PangoBlock{pangoBlockFullText, pangoBlockShortText, pangoBlockName} = object $
fullText' <> shortText' <> blockName' <> pango'
where
+ fullText' :: [AT.Pair]
fullText' = [ "full_text" .= pangoBlockFullText ]
+
+ shortText' :: [AT.Pair]
shortText' = fromMaybe (\s -> ["short_text" .= s]) mempty pangoBlockShortText
+
+ blockName' :: [AT.Pair]
blockName' = fromMaybe (\s -> ["name" .= s]) mempty pangoBlockName
+
+ pango' :: [AT.Pair]
pango' = [ "markup" .= ("pango" :: T.Text) ]
@@ -61,7 +69,9 @@ swayBarInput MainOptions{verbose} = swayBarInput'
liftIO $ BSSC8.hPutStrLn stderr line
hFlush stderr
- let maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
+ let
+ maybeBlockEvent :: Maybe BlockEvent
+ maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
forM_ maybeBlockEvent yield
swayBarInput'
@@ -109,7 +119,7 @@ swayBarOutput options@MainOptions{indicator} = do
hPut stderr "\n"
hFlush stderr
encodeOutput :: [ThemedBlockOutput] -> BS.ByteString
- encodeOutput blocks = encode $ map renderPangoBlock $ blocks
+ encodeOutput blocks = encode $ map renderPangoBlock blocks
renderPangoBlock :: ThemedBlockOutput -> PangoBlock
renderPangoBlock ThemedBlockOutput{_fullText, _shortText, _blockName} = PangoBlock {
pangoBlockFullText = renderPango _fullText,
diff --git a/src/QBar/TagParser.hs b/qbar/src/QBar/TagParser.hs
similarity index 91%
rename from src/QBar/TagParser.hs
rename to qbar/src/QBar/TagParser.hs
index a81c59c518ffa3dd3c5b486dfe729dfe2da19456..f029a097a9edcf7e000ea2eb0add5e089f24499d 100644
--- a/src/QBar/TagParser.hs
+++ b/qbar/src/QBar/TagParser.hs
@@ -1,4 +1,9 @@
-module QBar.TagParser where
+module QBar.TagParser (
+ TagState,
+ parseTags,
+ parseTags',
+ parseTags'',
+) where
import QBar.BlockOutput
import QBar.Color
@@ -8,8 +13,8 @@ import Control.Applicative ((<|>))
import Data.Attoparsec.Text.Lazy as A
import Data.Functor (($>))
import Data.Maybe (catMaybes)
-import qualified Data.Text as TS
-import qualified Data.Text.Lazy as T
+import Data.Text qualified as TS
+import Data.Text.Lazy qualified as T
type TagState = (Bool, Importance)
@@ -55,7 +60,7 @@ tagParser = parser (False, normalImportant)
spanParser :: Parser BlockText
spanParser = do
void $ string "<span"
- (colors, backgrounds) <- unzip <$> (many' $ colorAttribute <|> backgroundAttribute)
+ (colors, backgrounds) <- unzip <$> many' (colorAttribute <|> backgroundAttribute)
let color = listToMaybe . catMaybes $ colors
let background = listToMaybe . catMaybes $ backgrounds
void $ char '>'
@@ -85,7 +90,7 @@ tagParser = parser (False, normalImportant)
parseTags :: T.Text -> Either String BlockText
-parseTags text = parseOnly (tagParser <* endOfInput) (T.toStrict text)
+parseTags = parseOnly (tagParser <* endOfInput)
parseTags' :: T.Text -> BlockOutput
parseTags' = either (mkErrorOutput . T.pack) mkBlockOutput . parseTags
diff --git a/src/QBar/Theme.hs b/qbar/src/QBar/Theme.hs
similarity index 93%
rename from src/QBar/Theme.hs
rename to qbar/src/QBar/Theme.hs
index cb518506579bc96c5ad3f652e82c571bf0d4360e..cf70679f16bf8454725236e1ba4f6262c46560c8 100644
--- a/src/QBar/Theme.hs
+++ b/qbar/src/QBar/Theme.hs
@@ -1,4 +1,17 @@
-module QBar.Theme where
+module QBar.Theme (
+ Theme(..),
+ ThemedBlockOutput(..),
+ ThemedBlockText(..),
+ ThemedBlockTextSegment(..),
+ defaultTheme,
+ findTheme,
+ isAnimated,
+ mkTheme,
+ mkThemedBlockOutput,
+ themeNames,
+ themes,
+ whiteThemedBlockOutput,
+) where
import QBar.BlockOutput
import QBar.Color
@@ -9,9 +22,9 @@ import Control.Lens ((^.))
import Control.Monad.State.Lazy (State, evalState, get, put)
import Data.Colour.RGBSpace
import Data.Colour.RGBSpace.HSV (hsv)
-import qualified Data.HashMap.Lazy as HM
+import Data.HashMap.Lazy qualified as HM
import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
import Data.Time.Clock.POSIX (getPOSIXTime)
import Pipes
@@ -37,7 +50,6 @@ data ThemedBlockTextSegment = ThemedBlockTextSegment {
}
deriving (Eq, Show)
-
data Theme = StaticTheme StaticTheme | AnimatedTheme AnimatedTheme
type StaticTheme = [BlockOutput] -> [ThemedBlockOutput]
@@ -65,6 +77,7 @@ themes = HM.fromList themesList
findTheme :: Text -> Either Text Theme
findTheme themeName = maybe invalidThemeName Right $ HM.lookup themeName themes
where
+ invalidThemeName :: Either Text Theme
invalidThemeName = Left $ "Invalid theme: " <> themeName
mkTheme :: SimplifiedTheme -> Theme
@@ -109,7 +122,6 @@ mkThemedSegment (color, backgroundColor) text = ThemedBlockTextSegment{themedSeg
whiteThemedBlockOutput :: Text -> ThemedBlockOutput
whiteThemedBlockOutput = mkThemedBlockOutput (ColorRGB (RGB 1 1 1), Nothing)
-
invalidColor :: Color
invalidColor = ColorRGBA (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)) (0x77 / 255)
@@ -129,7 +141,6 @@ defaultTheme = mkTheme defaultTheme'
defaultTheme' True (NormalImportant _) = (ColorRGB (RGB 1 1 1), Nothing)
defaultTheme' False (NormalImportant _) = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
-
rainbowTheme :: Theme
rainbowTheme = AnimatedTheme rainbowThemePipe
where
@@ -146,7 +157,7 @@ rainbowTheme = AnimatedTheme rainbowThemePipe
let text = rawText $ block ^. fullText
let chars = T.unpack . T.reverse $ text
coloredChars <- mapM rainbowChar chars
- let rainbowText = reverse $ coloredChars
+ let rainbowText = reverse coloredChars
return $ ThemedBlockOutput {
_blockName,
_fullText = ThemedBlockText rainbowText,
diff --git a/src/QBar/Time.hs b/qbar/src/QBar/Time.hs
similarity index 90%
rename from src/QBar/Time.hs
rename to qbar/src/QBar/Time.hs
index c57d2978af80e12893f29c6b5b30ac5c010d40f7..2a97cd15030f8c34fc2de02f1fb91facb2f0fcfb 100644
--- a/src/QBar/Time.hs
+++ b/qbar/src/QBar/Time.hs
@@ -1,15 +1,28 @@
{-# LANGUAGE OverloadedLists #-}
-module QBar.Time (SleepScheduler, HasSleepScheduler(..), Interval(..), createSleepScheduler, sleepUntil, sleepUntil', sleepUntilInterval, sleepUntilInterval', everyMinute, everyNSeconds, nextIntervalTime, humanReadableInterval) where
+module QBar.Time (
+ HasSleepScheduler(..),
+ Interval(..),
+ SleepScheduler,
+ createSleepScheduler,
+ everyMinute,
+ everyNSeconds,
+ humanReadableInterval,
+ nextIntervalTime,
+ sleepUntil',
+ sleepUntil,
+ sleepUntilInterval',
+ sleepUntilInterval,
+) where
import QBar.Prelude
import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
import Control.Concurrent.MVar
-import qualified Control.Concurrent.Event as Event
-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
-import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
import Data.Ord (comparing)
+import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
newtype Interval = IntervalSeconds Integer
deriving (Read, Show)
@@ -26,7 +39,7 @@ nextIntervalTime :: MonadIO m => Interval -> m UTCTime
nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
now <- getCurrentTime
let dayTime = utctDayTime now
- let daySeconds = floor dayTime
+ let daySeconds :: Integer = floor dayTime
let intervalId = daySeconds `div` intervalSeconds
return now {
utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
@@ -50,7 +63,7 @@ class HasSleepScheduler m where
createSleepScheduler :: MonadIO m => m SleepScheduler
createSleepScheduler = liftIO $ do
scheduler <- SleepScheduler <$> newMVar ([], []) <*> Event.new
- link =<< (async $ schedulerThread scheduler)
+ link =<< async (schedulerThread scheduler)
return scheduler
where
schedulerThread :: SleepScheduler -> IO ()
@@ -74,7 +87,7 @@ createSleepScheduler = liftIO $ do
schedulerThread' start
- -- |Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
+ -- Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
waitForEvent :: UTCTime -> IO Bool
waitForEvent eventTime = do
now <- getCurrentTime
@@ -96,7 +109,7 @@ createSleepScheduler = liftIO $ do
Event.clear trigger
return (futureEvents, [])
- -- |Predicate to check if an event should be fired.
+ -- Predicate to check if an event should be fired.
checkEvent :: UTCTime -> ScheduledEvent -> Bool
checkEvent now ScheduledEvent{time} = now >= time
diff --git a/src/QBar/Utils.hs b/qbar/src/QBar/Utils.hs
similarity index 96%
rename from src/QBar/Utils.hs
rename to qbar/src/QBar/Utils.hs
index e00ab4e135761b07a052e0f35d6de822b8eb4501..ca6848f6578c4cbf2e4013e77ae96e77c3272de7 100644
--- a/src/QBar/Utils.hs
+++ b/qbar/src/QBar/Utils.hs
@@ -1,4 +1,9 @@
-module QBar.Utils where
+module QBar.Utils (
+ mkBroadcastCacheP,
+ mkBroadcastP,
+ randomIdentifier,
+ signalEventPipe,
+) where
import QBar.Prelude
diff --git a/test/Spec.hs b/qbar/test/Spec.hs
similarity index 100%
rename from test/Spec.hs
rename to qbar/test/Spec.hs
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
deleted file mode 100644
index 1dccb3a9fced84b13d587f68fb78578812ddb6c7..0000000000000000000000000000000000000000
--- a/src/QBar/Blocks.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module QBar.Blocks
- ( QBar.Blocks.Battery.batteryBlock,
- QBar.Blocks.CpuUsage.cpuUsageBlock,
- QBar.Blocks.Date.dateBlock,
- QBar.Blocks.DiskUsage.diskUsageBlock,
- QBar.Blocks.NetworkManager.networkManagerBlock,
- QBar.Blocks.Qubes.diskUsageQubesBlock,
- QBar.Blocks.Qubes.qubesMonitorPropertyBlock,
- QBar.Blocks.Qubes.qubesVMCountBlock,
- QBar.Blocks.Script.scriptBlock,
- QBar.Blocks.Script.pollScriptBlock,
- QBar.Blocks.Squeekboard.squeekboardBlock,
- )
-where
-
-import qualified QBar.Blocks.Battery
-import qualified QBar.Blocks.CpuUsage
-import qualified QBar.Blocks.Date
-import qualified QBar.Blocks.DiskUsage
-import qualified QBar.Blocks.NetworkManager
-import qualified QBar.Blocks.Qubes
-import qualified QBar.Blocks.Script
-import qualified QBar.Blocks.Squeekboard