initial commit

main
Ricard Illa 2020-11-04 17:12:03 +01:00
commit f26f36281b
11 changed files with 576 additions and 0 deletions

4
.gitignore vendored Normal file
View File

@ -0,0 +1,4 @@
.stack-work/
*~
hmonitors.cabal
stack.yaml.lock

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright Author name here (c) 2020
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 Author name here 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.

11
README.md Normal file
View File

@ -0,0 +1,11 @@
# hmonitors
This is a collection of monitors the I use as widgets in xmobar.
Currently implemented:
* battery (throug acpi)
* volume (throuugh alsa)
* network (through network-manager)
They are all one-shot scripts, intended for xmobar to run periodically.
They are very ad-hoc to my use case. Even the icons (using NerdFonts) and
colors (I use the gruvbox color scheme) are hard-coded.

24
app/Main.hs Normal file
View File

@ -0,0 +1,24 @@
module Main where
import Text.Printf
import System.Environment
import Monitors.Battery (queryBattery)
import Monitors.Date (queryDate)
import Monitors.Net (queryNet)
import Monitors.Volume (queryVolume)
usage :: IO String
usage = printf "%s battery | volume | net" <$> getProgName
main :: IO ()
main = do
args <- getArgs
output <- case args of
[ "bat" ] -> queryBattery
[ "vol" ] -> queryVolume
[ "net" ] -> queryNet
[ "date" ] -> queryDate True
[ "date-min" ] -> queryDate False
_ -> usage
putStrLn output

36
package.yaml Normal file
View File

@ -0,0 +1,36 @@
name: hmonitors
version: 0.1.0.0
license: BSD3
author: "Ricard Illa"
maintainer: "r.illa.pujagut@gmail.com"
copyright: "2020 Ricard Illa Pujagut"
extra-source-files:
- README.md
description: Please see README.md
dependencies:
- base
- containers
- process
- regex-compat
- split
- time
library:
source-dirs: src
executables:
hmonitors-query:
main: Main.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -O2
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- hmonitors

134
src/Monitors/Battery.hs Normal file
View File

@ -0,0 +1,134 @@
module Monitors.Battery (queryBattery) where
import Data.List
import Data.Maybe
import System.Process
import Text.Printf
import Text.Regex
import qualified Data.Map as M
import Monitors.Common
data BatteryData = BatteryData
{ battery :: String
, state :: String
, percent :: Int
, time :: Maybe (Int,Int)
}
dischargingIcons :: M.Map Int String
dischargingIcons = M.map buildIcon $ M.fromList
[ ( 0 , 62861 )
, ( 10 , 62841 )
, ( 20 , 62842 )
, ( 30 , 62843 )
, ( 40 , 62844 )
, ( 50 , 62845 )
, ( 60 , 62846 )
, ( 70 , 62847 )
, ( 80 , 62848 )
, ( 90 , 62849 )
, ( 100 , 62840 )
]
chargingIcons :: M.Map Int String
chargingIcons = M.map buildIcon $ M.fromList
[ ( 20 , 62853 )
, ( 30 , 62854 )
, ( 40 , 62855 )
, ( 60 , 62856 )
, ( 80 , 62857 )
, ( 90 , 62858 )
, ( 100 , 62852 )
]
alertIcon :: String
alertIcon = buildIcon 62850
unknownIcon :: String
unknownIcon = buildIcon 62864
fullIcon :: String
fullIcon = buildIcon 62851
getColor :: Int -> String
getColor charge = fromMaybe def (M.lookup getKey colors)
where
getKey
| charge < 20 = "red"
| charge >= 20 && charge < 80 = "yellow"
| charge >= 80 && charge <= 100 = "green"
| otherwise = "active"
def = "#ffffff"
iconSel :: Ord a => a -> M.Map a String -> String
iconSel a xs = fromMaybe def $ findKey a xs >>= lookupKey xs
where
findKey b ys = getNextAbove b (M.keys ys)
lookupKey = flip M.lookup
getNextAbove a = listToMaybe . dropWhile (< a) . sort
def = unknownIcon
getIcon :: BatteryData -> String
getIcon BatteryData { state = "Charging", percent = charge } = iconSel charge chargingIcons
getIcon BatteryData { state = "Discharging", percent = charge } = iconSel charge dischargingIcons
getIcon BatteryData { state = "Full" } = fullIcon
getIcon BatteryData { state = "Unknown" } = unknownIcon
getIcon _ = unknownIcon
parseBatteryInfo :: String -> Maybe BatteryData
parseBatteryInfo = fmap fmtBattery . matchRegex regex
where
regex = mkRegex "^(.+): (.+), ([0-9]+)%(, ([0-9]+):([0-9]+):[0-9]+ .+)?"
fmtBattery [b,s,p,_,h,m] =
let
t = if h /= "" && m /= ""
then Just (read h,read m)
else Nothing
in BatteryData
{ battery = b
, state = s
, percent = read p
, time = t
}
getColorIcon :: BatteryData -> String
getColorIcon BatteryData { state = "Full" } = colorize (colors M.! "active") fullIcon
getColorIcon x@BatteryData { percent = charge } = colorize (getColor charge) (getIcon x)
getStatus :: BatteryData -> String
getStatus x@BatteryData { state = "Full" } = getColorIcon x
getStatus x@BatteryData { state = "Unknown", percent = charge }
| charge >= 95 = getStatus x{ state="Full" }
| otherwise =
let
fmt = "%s %d"
colorIcon = getColorIcon x
in printf fmt colorIcon charge
getStatus x@BatteryData { state = "Charging", percent = charge } =
let
fmt = "%s %d"
colorIcon = getColorIcon x
in printf fmt colorIcon charge
getStatus x@BatteryData { state = "Discharging", percent = charge, time = (Just (h,m)) } =
let
fmt = "%s %d (%d:%02d)"
colorIcon = getColorIcon x
in printf fmt colorIcon charge h m
getStatus _ = colorize (colors M.! "active") unknownIcon
parseAcpiStdout :: String -> [BatteryData]
parseAcpiStdout = mapMaybe parseBatteryInfo . lines
fmtData :: [BatteryData] -> String
fmtData = (separator ++ ) . intercalate separator . map getStatus
runAcpi :: IO String
runAcpi = readProcess "acpi" ["-b"] ""
queryBattery :: IO String
queryBattery = fmtData . parseAcpiStdout <$> runAcpi

29
src/Monitors/Common.hs Normal file
View File

@ -0,0 +1,29 @@
module Monitors.Common
( colors
, colorize
, separator
, buildIcon
) where
import qualified Data.Map as M
import Text.Printf
import Data.Char
colors :: M.Map String String
colors = M.fromList
[ ( "active" , "#ebdbb2" )
, ( "inactive" , "#a89974" )
, ( "red" , "#fb4944" )
, ( "yellow" , "#fabd2f" )
, ( "green" , "#b8bb26" )
, ( "blue" , "#83a587" )
]
colorize :: String -> String -> String
colorize = printf "<fc=%s>%s</fc>"
separator :: String
separator = printf " %s " . colorize (colors M.! "inactive") $ "|"
buildIcon :: Int -> String
buildIcon = printf "<fn=1>%c</fn>" . chr

31
src/Monitors/Date.hs Normal file
View File

@ -0,0 +1,31 @@
module Monitors.Date (queryDate) where
import Data.Time
import Text.Printf
import qualified Data.Map as M
import Monitors.Common
icons :: M.Map String String
icons = M.map buildIcon $ M.fromList
[ ( "clock" , 63055 )
, ( "calendar" , 62957 )
]
fullFmtter :: Bool -> String -> String -> String
fullFmtter True icon x = printf "%s %s" (icons M.! icon) x
fullFmtter _ _ x = x
fmtter :: FormatTime t => Bool -> String -> String -> t -> String
fmtter full icon fmt = (fullFmtter full icon) . (formatTime defaultTimeLocale fmt)
fmtTime :: FormatTime t => Bool -> t -> String
fmtTime full time =
let
date = fmtter full "calendar" "%m/%d" time
hour = fmtter full "clock" "%H:%M" time
in printf "%s%s%s%s " separator date separator hour
queryDate :: Bool -> IO String
queryDate full = fmtTime full <$> getZonedTime

124
src/Monitors/Net.hs Normal file
View File

@ -0,0 +1,124 @@
module Monitors.Net (queryNet) where
import Data.List.Split
import Data.List
import Data.Maybe
import System.Process
import Text.Printf
import Text.Regex
import qualified Data.Map as M
import Monitors.Common
data DeviceType = Wifi | Ethernet | OtherDevice
data DeviceData = DeviceData
{ deviceName :: String
, deviceType :: DeviceType
, connected :: Bool
, signal :: Maybe Int
}
icons :: M.Map String String
icons = M.map buildIcon $ M.fromList
[ ( "wifi" , 64168 )
, ( "wifi-off" , 64169 )
, ( "ethernet" , 63231 )
]
offline :: String
offline = colorize (colors M.! "inactive") (icons M.! "wifi-off")
getConnectivity :: IO String
getConnectivity = head . lines <$> readProcess "nmcli" args ""
where args = ["networking", "connectivity", "check"]
getDevStatus :: IO [DeviceData]
getDevStatus = readProcess "nmcli" args "" >>= mapM buildDeviceData . lines
where
args = ["--terse", "--fields", "device,type,state", "device", "status"]
buildDeviceData :: String -> IO DeviceData
buildDeviceData x =
let
[d,t,state] = splitOn ":" x
deviceType = readDeviceType t
connected = state == "connected"
in do
signal <- getWifiSignal deviceType d
return DeviceData
{ deviceName = d
, deviceType = deviceType
, connected = connected
, signal = signal
}
readDeviceType :: String -> DeviceType
readDeviceType "wifi" = Wifi
readDeviceType "ethernet" = Ethernet
readDeviceType _ = OtherDevice
getWifiSignal :: DeviceType -> String -> IO (Maybe Int)
getWifiSignal Wifi dev = parseStdout <$> readProcess "nmcli" args ""
where
args =
[ "--terse"
, "--fields", "in-use,signal"
, "device", "wifi", "list"
, "ifname", dev
]
splt = splitOn ":"
isActive = (=="*") . head . splt
readVal = read . (!! 1) . splt
parseStdout = fmap readVal . find isActive . lines
getWifiSignal _ _ = return Nothing
getActiveDevs :: IO [DeviceData]
getActiveDevs = filter activeDev <$> getDevStatus
where
activeDev :: DeviceData -> Bool
activeDev DeviceData { deviceType = Wifi, connected = True } = True
activeDev DeviceData { deviceType = Ethernet, connected = True } = True
activeDev _ = False
getSignalColor :: Maybe Int -> String
getSignalColor x = fromMaybe (colors M.! def) (M.lookup (getKey x) colors)
where
def = "active"
getKey Nothing = def
getKey (Just x)
| x < 30 = "red"
| x >= 30 && x < 60 = "yellow"
| x >= 60 && x <= 100 = "green"
| otherwise = def
makeDevIcon :: DeviceData -> String
makeDevIcon DeviceData { deviceType = Ethernet } =
colorize (colors M.! "active") (icons M.! "ethernet")
makeDevIcon DeviceData { deviceType = Wifi, signal = signal@(Just s) } =
let
colorIcon = colorize (getSignalColor signal) (icons M.! "wifi")
txt = colorize (colors M.! "active") (show s)
in printf "%s %s" colorIcon txt
makeDevIcon DeviceData { deviceType = Wifi, signal = Nothing } =
colorize (getSignalColor Nothing) (icons M.! "wifi")
makeDevIcon _ = offline
getStatus :: [DeviceData] -> String
getStatus = intercalate separator . map makeDevIcon
queryNet :: IO String
queryNet = do
connectivity <- getConnectivity
--icon <- if connectivity `elem` ["none", "limited"]
icon <- if connectivity == "none"
then return offline
else getStatus <$> getActiveDevs
return $ separator ++ icon

86
src/Monitors/Volume.hs Normal file
View File

@ -0,0 +1,86 @@
module Monitors.Volume (queryVolume) where
import Data.List
import Data.Maybe
import System.Process
import Text.Printf
import Text.Regex
import qualified Data.Map as M
import Monitors.Common
mixer :: String
mixer = "Master"
icons :: M.Map String String
icons = M.map buildIcon $ M.fromList
[ ( "high" , 64125 )
, ( "low" , 64126 )
, ( "mid" , 64127 )
, ( "off" , 64128 )
, ( "mute" , 64605 )
]
data MixerData = MixerData
{ mute :: Bool
, vol :: Int
}
deriving Eq
getIcon :: MixerData -> String
getIcon x = fromMaybe (icons M.! def) $ M.lookup (iconKey x) icons
where
iconKey MixerData { mute = True } = "mute"
iconKey MixerData { vol = vol }
| vol >= 80 = "high"
| vol >= 10 && vol < 80 = "mid"
| vol < 10 = "low"
| otherwise = def
def = "high"
getColor :: MixerData -> String
getColor x = fromMaybe (colors M.! def) $ M.lookup (colorKey x) colors
where
colorKey MixerData { mute = True } = "inactive"
colorKey MixerData { vol = vol }
| vol > 110 = "red"
| vol > 100 && vol <= 110 = "yellow"
| vol > 70 && vol <= 100 = "green"
| vol > 0 && vol <= 70 = "blue"
| vol == 0 = "inactive"
| otherwise = def
def = "active"
getStatus :: MixerData -> String
getStatus x@MixerData { mute = mute, vol = vol } =
let
txtColor = if mute then colors M.! "inactive" else colors M.! "active"
icon = colorize (getColor x) (getIcon x)
txt = colorize txtColor $ show vol
in printf "%s %s" icon txt
parseMixerInfo :: String -> Maybe MixerData
parseMixerInfo = fmap fmtMixer . matchRegex regex
where
regex = mkRegex ".+: Playback [0-9]+ \\[([0-9]+)%\\] (\\[.+dB\\] )?\\[(on|off)\\]"
fmtMixer [volume,_,state] =
let
mute = case state of
"on" -> False
"off" -> True
_ -> False
vol = read volume
in MixerData { mute = mute, vol = vol }
parseAmixerStdout :: String -> [MixerData]
parseAmixerStdout = nub . mapMaybe parseMixerInfo . lines
fmtData :: [MixerData] -> String
fmtData = (separator ++ ) . intercalate separator . map getStatus
runAmixer :: String -> IO String
runAmixer mixer = readProcess "amixer" ["get", mixer] ""
queryVolume :: IO String
queryVolume = fmtData . parseAmixerStdout <$> runAmixer mixer

67
stack.yaml Normal file
View File

@ -0,0 +1,67 @@
# 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:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/20.yaml
# 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
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# 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: ">=2.5"
#
# 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