summaryrefslogtreecommitdiff
path: root/app/Foobar/Services/Config.hs
diff options
context:
space:
mode:
Diffstat (limited to 'app/Foobar/Services/Config.hs')
-rw-r--r--app/Foobar/Services/Config.hs178
1 files changed, 108 insertions, 70 deletions
diff --git a/app/Foobar/Services/Config.hs b/app/Foobar/Services/Config.hs
index ed1a3ca..d2d3a75 100644
--- a/app/Foobar/Services/Config.hs
+++ b/app/Foobar/Services/Config.hs
@@ -1,14 +1,15 @@
-{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, OverloadedLabels, DuplicateRecordFields, ScopedTypeVariables, FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, OverloadedLabels, DuplicateRecordFields, ScopedTypeVariables,
+ FlexibleInstances, UndecidableInstances #-}
-- |
-- Module : Foobar.Services.Config
-- Description: Retrieval of data in the configuration file.
module Foobar.Services.Config
- ( observeConfiguration
- , loadConfiguration
- , initConfiguration
- , defaultConfiguration
+ ( observeConfig
+ , loadConfig
+ , initConfig
+ , defaultConfig
) where
import Data.Text hiding (filter, elem)
@@ -22,28 +23,24 @@ import Foreign.C (CString, CChar, peekCString, withCString)
import Foreign.Marshal.Alloc (free)
import Foreign (Ptr, nullPtr)
import Foobar.Models.Config
+import Foobar.Services.Coalescing
import qualified GI.GLib as GLib
import qualified GI.Gio as Gio
-foreign import ccall "realpath" cRealpath :: CString -> CString -> IO (Ptr CChar)
-
-getRealPath :: FilePath -> IO FilePath
-getRealPath p = withCString p $ \cPath -> do
- cRes <- cRealpath cPath nullPtr
- res <- if cRes /= nullPtr then peekCString cRes else pure p
- free cRes
- pure res
-
data MonitoringData
= MonitoringData { actualPath :: !FilePath
, actualMonitor :: !Gio.FileMonitor
, actualHandlerId :: !SignalHandlerId }
-observeConfiguration :: IO () -> IO ()
-observeConfiguration handler = do
+-- | Observe the config file for changes.
+observeConfig
+ :: IO () -- ^ Callback invoked whenever the config changes.
+ -> IO ()
+observeConfig handler = do
path <- getConfigPath
actualData <- newIORef (Nothing :: Maybe MonitoringData)
+ scheduler <- mkEventScheduler 250
let createMonitor :: FilePath -> IO (Maybe Gio.FileMonitor)
createMonitor p = do
file <- Gio.fileNewForPath p
@@ -53,8 +50,8 @@ observeConfiguration handler = do
Right m' -> Just m'
let actualMonitorHandler :: Gio.File -> Maybe Gio.File -> Gio.FileMonitorEvent -> IO ()
actualMonitorHandler _ _ eventType = case eventType of
- Gio.FileMonitorEventCreated -> handler
- Gio.FileMonitorEventChanged -> handler
+ Gio.FileMonitorEventCreated -> scheduleEvent scheduler handler
+ Gio.FileMonitorEventChanged -> scheduleEvent scheduler handler
_ -> pure ()
let clearActualMonitor :: IO ()
clearActualMonitor = do
@@ -76,9 +73,9 @@ observeConfiguration handler = do
realPath <- getRealPath path
let actualPath' = if realPath == path then Nothing else Just realPath
actualData' <- readIORef actualData
- when ((actualPath <$> actualData') == actualPath') $
- do clearActualMonitor
- setActualMonitor actualPath'
+ when ((actualPath <$> actualData') /= actualPath') $ do
+ clearActualMonitor
+ setActualMonitor actualPath'
let monitorHandler :: Gio.File -> Maybe Gio.File -> Gio.FileMonitorEvent -> IO ()
monitorHandler file otherFile eventType = do
updateActualMonitor
@@ -91,28 +88,31 @@ observeConfiguration handler = do
Nothing -> pure ()
-loadConfiguration :: IO Config
-loadConfiguration = do
+-- | Load the config file, falling back to a default config if it is invalid.
+loadConfig :: IO Config
+loadConfig = do
path <- getConfigPath
f <- GLib.keyFileNew
let process = do convertError (throw . ValidationError) $ f.loadFromFile path []
loadSection f ""
let handleError (ValidationError msg) = do putStrLn $ "Could not read config: " ++ unpack msg
- pure defaultConfiguration
+ pure defaultConfig
catch process handleError
-initConfiguration :: IO Config
-initConfiguration = do
+-- | Create the config file if it doesn't exist, otherwise read it.
+initConfig :: IO Config
+initConfig = do
path <- getConfigPath
exists <- GLib.fileTest path [GLib.FileTestExists]
- if exists then loadConfiguration
+ if exists then loadConfig
else do f <- GLib.keyFileNew
- storeSection f "" defaultConfiguration
+ storeSection f "" defaultConfig
void (try $ f.saveToFile (pack path) :: IO (Either GError ()))
- pure defaultConfiguration
+ pure defaultConfig
-defaultConfiguration :: Config
-defaultConfiguration =
+-- | The default configuration.
+defaultConfig :: Config
+defaultConfig =
Config { general = GeneralConfig { stylesheet = "resource:///foobar/styles/default.css" }
, panel = PanelConfig { position = ScreenEdgeLeft
, margin = 16
@@ -138,25 +138,25 @@ defaultConfiguration =
, spacing = 16
, closeButtonInset = -6
, timeFormat = "%H:%M" } }
- where panelItems = [ PanelItemIcon (PanelItemConfiguration { name = "launcher"
- , position = PanelItemPositionStart })
- (PanelIconConfiguration { iconName = "fluent-grid-dots-symbolic"
- , action = ActionLauncher })
- , PanelItemWorkspaces (PanelItemConfiguration { name = "workspaces"
- , position = PanelItemPositionStart })
- (PanelWorkspacesConfiguration { buttonSize = 20
- , spacing = 6 })
- , PanelItemClock (PanelItemConfiguration { name = "clock"
- , position = PanelItemPositionCenter })
- (PanelClockConfiguration { format = "%H\n%M"
- , action = ActionNone })
- , PanelItemStatus (PanelItemConfiguration { name = "status"
- , position = PanelItemPositionEnd })
- (PanelStatusConfiguration { items = statusItems
- , spacing = 6
- , showLabels = False
- , enableScrolling = False
- , action = ActionControlCenter }) ]
+ where panelItems = [ PanelItemIcon (PanelItemConfig { name = "launcher"
+ , position = PanelItemPositionStart })
+ (PanelIconConfig { iconName = "fluent-grid-dots-symbolic"
+ , action = ActionLauncher })
+ , PanelItemWorkspaces (PanelItemConfig { name = "workspaces"
+ , position = PanelItemPositionStart })
+ (PanelWorkspacesConfig { buttonSize = 20
+ , spacing = 6 })
+ , PanelItemClock (PanelItemConfig { name = "clock"
+ , position = PanelItemPositionCenter })
+ (PanelClockConfig { format = "%H\n%M"
+ , action = ActionNone })
+ , PanelItemStatus (PanelItemConfig { name = "status"
+ , position = PanelItemPositionEnd })
+ (PanelStatusConfig { items = statusItems
+ , spacing = 6
+ , showLabels = False
+ , enableScrolling = False
+ , action = ActionControlCenter }) ]
statusItems = [ PanelStatusItemBattery
, PanelStatusItemBrightness
, PanelStatusItemAudio
@@ -167,11 +167,14 @@ defaultConfiguration =
, ControlCenterRowAudioOutput
, ControlCenterRowBrightness ]
+-- | Config file path.
getConfigPath :: IO FilePath
getConfigPath = do
dir <- GLib.getUserConfigDir
pure (dir </> "foobar.conf")
+-- Validation errors
+
newtype ValidationError = ValidationError Text
deriving (Show)
@@ -182,6 +185,8 @@ instance Exception ValidationError
throwValidationError :: Text -> Text -> Text -> IO a
throwValidationError s k description = throw $ ValidationError $ s <> ":" <> k <> ": " <> description
+-- Key File Serialization
+
class KeyFileSection a where
loadSection :: GLib.KeyFile -> Text -> IO a
storeSection :: GLib.KeyFile -> Text -> a -> IO ()
@@ -287,41 +292,43 @@ instance KeyFileSection PanelItem where
storeSection f s x
storeSection f s y
-instance KeyFileSection PanelItemConfiguration where
- loadSection f s = PanelItemConfiguration n <$> loadValue f s "position" []
+instance KeyFileSection PanelItemConfig where
+ loadSection f s = PanelItemConfig n <$> loadValue f s "position" []
where n = Data.Text.drop 1 $ snd $ breakOn "." s
storeSection f s c = do storeValue f s "position" c.position
-instance KeyFileSection PanelIconConfiguration where
- loadSection f s = PanelIconConfiguration <$> loadValue f s "icon-name" []
- <*> loadValue f s "action" []
+instance KeyFileSection PanelIconConfig where
+ loadSection f s = PanelIconConfig <$> loadValue f s "icon-name" []
+ <*> loadValue f s "action" []
storeSection f s c = do storeValue f s "icon-name" c.iconName
storeValue f s "action" c.action
-instance KeyFileSection PanelClockConfiguration where
- loadSection f s = PanelClockConfiguration <$> loadValue f s "format" []
- <*> loadValue f s "action" []
+instance KeyFileSection PanelClockConfig where
+ loadSection f s = PanelClockConfig <$> loadValue f s "format" []
+ <*> loadValue f s "action" []
storeSection f s c = do storeValue f s "format" c.format
storeValue f s "action" c.action
-instance KeyFileSection PanelWorkspacesConfiguration where
- loadSection f s = PanelWorkspacesConfiguration <$> loadValue f s "button-size" [ validateNonNegative, validateNonZero ]
- <*> loadValue f s "spacing" [ validateNonNegative ]
+instance KeyFileSection PanelWorkspacesConfig where
+ loadSection f s = PanelWorkspacesConfig <$> loadValue f s "button-size" [ validateNonNegative, validateNonZero ]
+ <*> loadValue f s "spacing" [ validateNonNegative ]
storeSection f s c = do storeValue f s "button-size" c.buttonSize
storeValue f s "spacing" c.spacing
-instance KeyFileSection PanelStatusConfiguration where
- loadSection f s = PanelStatusConfiguration <$> loadValue f s "items" [ validateDistinct ]
- <*> loadValue f s "spacing" [ validateNonNegative ]
- <*> loadValue f s "show-labels" []
- <*> loadValue f s "enable-scrolling" []
- <*> loadValue f s "action" []
+instance KeyFileSection PanelStatusConfig where
+ loadSection f s = PanelStatusConfig <$> loadValue f s "items" [ validateDistinct ]
+ <*> loadValue f s "spacing" [ validateNonNegative ]
+ <*> loadValue f s "show-labels" []
+ <*> loadValue f s "enable-scrolling" []
+ <*> loadValue f s "action" []
storeSection f s c = do storeValue f s "items" c.items
storeValue f s "spacing" c.spacing
storeValue f s "show-labels" c.showLabels
storeValue f s "enable-scrolling" c.enableScrolling
storeValue f s "action" c.action
+-- Options
+
class (Bounded o, Enum o, Eq o) => Option o where
readOption :: Text -> Maybe o
showOption :: o -> Text
@@ -450,10 +457,22 @@ instance {-# OVERLAPS #-} Option o => KeyFileValue o where
validate s k validators val
storeValue f s k val = f.setString s k (showOption val)
-convertError :: (Text -> IO a) -> IO a -> IO a
+-- Helpers
+
+-- | Convert GErrors into other exceptions.
+convertError
+ :: (Text -> IO a) -- ^ Conversion function which throws an exception with a given message.
+ -> IO a -- ^ Operation possibly throwing an exception.
+ -> IO a -- ^ The same operation throwing the converted exception.
convertError t a = catch a (gerrorMessage >=> t)
-parseOption :: forall o. Option o => Text -> Text -> Text -> IO o
+-- | Parse an option string, otherwise throw a matching validation error.
+parseOption
+ :: forall o. Option o
+ => Text -- ^ Section name.
+ -> Text -- ^ Key name.
+ -> Text -- ^ Option value string.
+ -> IO o -- ^ The parsed option.
parseOption s k str = case readOption str of
Just o -> pure o
Nothing -> let values = [minBound..] :: [o] in
@@ -461,10 +480,18 @@ parseOption s k str = case readOption str of
let msg = "Invalid enum value \"" <> str <> "\" (allowed values: " <> allowed <> ")" in
throwValidationError s k msg
-validate :: Text -> Text -> [Validator a] -> a -> IO a
+-- | Apply validators to an input, throwing a matching validation error if one validator fails.
+validate
+ :: Text -- ^ Section name.
+ -> Text -- ^ Key name.
+ -> [Validator a] -- ^ List of validators.
+ -> a -- ^ The input.
+ -> IO a -- ^ The validated input.
validate s k validators val = val <$ forM_ validators (singleValidate val)
where singleValidate val' v = v val' >>= mapM_ (throwValidationError s k)
+-- Validators
+
validateFileURL :: Validator Text
validateFileURL url = do
f <- Gio.fileNewForUri url
@@ -484,3 +511,14 @@ validateDistinct :: Option o => Validator [o]
validateDistinct (x:xs) = if x `elem` xs then pure $ Just $ "Duplicate value \"" <> showOption x <> "\" not allowed."
else validateDistinct xs
validateDistinct [] = pure Nothing
+
+-- C Wrappers
+
+foreign import ccall "realpath" cRealpath :: CString -> CString -> IO (Ptr CChar)
+
+getRealPath :: FilePath -> IO FilePath
+getRealPath p = withCString p $ \cPath -> do
+ cRes <- cRealpath cPath nullPtr
+ res <- if cRes /= nullPtr then peekCString cRes else pure p
+ free cRes
+ pure res
generated by cgit v1.3.1 (git 2.54.0) at 2026-11-10 15:14:39 +0000