ENH use dhall for config

app/rofi-dev.hs

@@ -1,5 +1,9 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveAnyClass     #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE OverloadedStrings  #-}
+
 
 --------------------------------------------------------------------------------
 -- | rofi-dev - a rofi prompt for mountable devices
@@ -15,13 +19,15 @@ import           Bitwarden.Internal
 import           Control.Monad
 import           Control.Monad.Reader
 
-import           Data.Aeson
+-- import           Data.Aeson
 import           Data.List
 import           Data.List.Split       (splitOn)
 import qualified Data.Map              as M
 import           Data.Maybe
 import qualified Data.Vector           as V
-import           Data.Yaml
+-- import           Data.Yaml
+
+import           Dhall                 (FromDhall, Generic, auto, inputFile)
 
 import           Rofi.Command
 
@@ -97,10 +103,12 @@ runMounts opts = do
 
 parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
 parseStaticConfig p = do
-  res <- decodeFileEither p
+  -- res <- decodeFileEither p
-  case res of
+  res <- inputFile auto p
-    Left e  -> print e >> return Nothing
+  return $ Just (res :: StaticConfig)
-    Right c -> return $ Just c
+  -- case res of
+  --   Left e  -> print e >> return Nothing
+  --   Right c -> return $ Just c
 
 runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
 runPrompt gs = selectAction $ emptyMenu
@@ -261,60 +269,60 @@ data ProtoAction a = ProtoAction a (RofiMountIO ())
 -- Static devices are defined in a YAML file. These types/instances describe how
 -- to parse said YAML file.
 
-defaultTries :: Integer
+-- defaultTries :: Integer
-defaultTries = 2
+-- defaultTries = 2
 
-(.:&) :: FromJSON a => Object -> Key -> Parser (V.Vector a)
+-- (.:&) :: FromJSON a => Object -> Key -> Parser (V.Vector a)
-(.:&) o t = o .:? t .!= V.empty
+-- (.:&) o t = o .:? t .!= V.empty
 
 data MountConfig = MountConfig
   { mountMountpoint :: FilePath
   , mountLabel      :: Maybe String
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
-instance FromJSON MountConfig where
+-- instance FromJSON MountConfig where
-  parseJSON = withObject "mount" $ \o -> MountConfig
+--   parseJSON = withObject "mount" $ \o -> MountConfig
-    <$> o .: "mountpoint"
+--     <$> o .: "mountpoint"
-    <*> o .:? "label"
+--     <*> o .:? "label"
 
 data BitwardenConfig = BitwardenConfig
   { bitwardenKey   :: String
   , bitwardenTries :: Integer }
-  deriving Show
+  deriving (Show, Generic, FromDhall)
 
-instance FromJSON BitwardenConfig where
+-- instance FromJSON BitwardenConfig where
-  parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
+--   parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
-    <$> o .: "key"
+--     <$> o .: "key"
-    <*> o .:? "tries" .!= defaultTries
+--     <*> o .:? "tries" .!= defaultTries
 
 newtype LibSecretConfig = LibSecretConfig
   { libsecretAttributes :: M.Map String String }
-  deriving Show
+  deriving (Show, Generic, FromDhall)
 
-instance FromJSON LibSecretConfig where
+-- instance FromJSON LibSecretConfig where
-  parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
+--   parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
-    <$> o .: "attributes"
+--     <$> o .: "attributes"
 
 newtype PromptConfig = PromptConfig
   { promptTries :: Integer }
-  deriving Show
+  deriving (Show, Generic, FromDhall)
 
-instance FromJSON PromptConfig where
+-- instance FromJSON PromptConfig where
-  parseJSON = withObject "prompt" $ \o -> PromptConfig
+--   parseJSON = withObject "prompt" $ \o -> PromptConfig
-    <$> o .:? "tries" .!= defaultTries
+--     <$> o .:? "tries" .!= defaultTries
 
 data PasswordConfig = PwdBW BitwardenConfig
   | PwdLS LibSecretConfig
   | PwdPr PromptConfig
-  deriving Show
+  deriving (Show, Generic, FromDhall)
 
-instance FromJSON PasswordConfig where
+-- instance FromJSON PasswordConfig where
-  parseJSON = withObject "password" $ \o -> do
+--   parseJSON = withObject "password" $ \o -> do
-    br <- fmap PwdBW <$> o .:? "bitwarden"
+--     br <- fmap PwdBW <$> o .:? "bitwarden"
-    ls <- maybe (fmap PwdLS <$> o .:? "libsecret") (return . Just) br
+--     ls <- maybe (fmap PwdLS <$> o .:? "libsecret") (return . Just) br
-    -- TODO this is silly because I need to pass 'prompt: {}' instead of
+--     -- TODO this is silly because I need to pass 'prompt: {}' instead of
-    -- just 'prompt:' if I just want the defaults
+--     -- just 'prompt:' if I just want the defaults
-    maybe (PwdPr <$> o .: "prompt") return ls
+--     maybe (PwdPr <$> o .: "prompt") return ls
 
 data CIFSOptsConfig = CIFSOptsConfig
   { cifsoptsUsername  :: Maybe String
@@ -322,87 +330,87 @@ data CIFSOptsConfig = CIFSOptsConfig
   , cifsoptsUID       :: Maybe Integer
   , cifsoptsGID       :: Maybe Integer
   , cifsoptsIocharset :: Maybe String
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
-instance FromJSON CIFSOptsConfig where
+-- instance FromJSON CIFSOptsConfig where
-  parseJSON = withObject "options" $ \o -> CIFSOptsConfig
+--   parseJSON = withObject "options" $ \o -> CIFSOptsConfig
-    <$> o .:? "username"
+--     <$> o .:? "username"
-    <*> o .:? "workgroup"
+--     <*> o .:? "workgroup"
-    <*> o .:? "uid"
+--     <*> o .:? "uid"
-    <*> o .:? "gid"
+--     <*> o .:? "gid"
-    <*> o .:? "isocharset"
+--     <*> o .:? "isocharset"
 
 data DataConfig = VeracryptConfig VeracryptData
   | SSHFSConfig SSHFSData
   | CIFSConfig CIFSData
-  deriving Show
+  deriving (Show, Generic, FromDhall)
 
 data VeracryptData = VeracryptData
   { veracryptVolume   :: String
   , veracryptPassword :: Maybe PasswordConfig
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
 data SSHFSData = SSHFSData
   { sshfsRemote   :: String
   , sshfsPassword :: Maybe PasswordConfig
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
 data CIFSData = CIFSData
   { cifsRemote   :: String
   , cifsSudo     :: Bool
   , cifsPassword :: Maybe PasswordConfig
   , cifsOpts     :: Maybe CIFSOptsConfig
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
 data DeviceConfig = DeviceConfig
   { deviceMount :: MountConfig
   , deviceData  :: DataConfig
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
 data TreeConfig = TreeConfig
   { treeParent         :: DeviceConfig
   , treeconfigChildren :: V.Vector String
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
-instance FromJSON TreeConfig where
+-- instance FromJSON TreeConfig where
-  parseJSON = withObject "devices" $ \o -> do
+--   parseJSON = withObject "devices" $ \o -> do
-    devType <- o .: "type"
+--     devType <- o .: "type"
-    deps <- o .:& "depends"
+--     deps <- o .:& "depends"
-    mountconf <- o .: "mount"
+--     mountconf <- o .: "mount"
-    devData <- case (devType :: String) of
+--     devData <- case (devType :: String) of
-                 "cifs"      -> CIFSConfig <$> (CIFSData
+--                  "cifs"      -> CIFSConfig <$> (CIFSData
-                   <$> o .: "remote"
+--                    <$> o .: "remote"
-                   <*> o .:? "sudo" .!= False
+--                    <*> o .:? "sudo" .!= False
-                   <*> o .:? "password"
+--                    <*> o .:? "password"
-                   <*> o .:? "options")
+--                    <*> o .:? "options")
-                 "sshfs"     -> SSHFSConfig <$> (SSHFSData
+--                  "sshfs"     -> SSHFSConfig <$> (SSHFSData
-                   <$> o .: "remote"
+--                    <$> o .: "remote"
-                   <*> o .:? "password")
+--                    <*> o .:? "password")
-                 "veracrypt" -> VeracryptConfig <$> (VeracryptData
+--                  "veracrypt" -> VeracryptConfig <$> (VeracryptData
-                   <$> o .: "volume"
+--                    <$> o .: "volume"
-                   <*> o .:? "password")
+--                    <*> o .:? "password")
-                 -- TODO make this skip adding an entry to the map rather than
+--                  -- TODO make this skip adding an entry to the map rather than
-                 -- skipping the map entirely
+--                  -- skipping the map entirely
-                 _           -> fail $ "unknown device type: " ++ devType
+--                  _           -> fail $ "unknown device type: " ++ devType
-    return $ TreeConfig
+--     return $ TreeConfig
-      { treeParent = DeviceConfig
+--       { treeParent = DeviceConfig
-                      { deviceMount = mountconf
+--                       { deviceMount = mountconf
-                      , deviceData = devData
+--                       , deviceData = devData
-                      }
+--                       }
-      , treeconfigChildren = deps
+--       , treeconfigChildren = deps
-      }
+--       }
 
 data StaticConfig = StaticConfig
   { staticconfigTmpPath :: Maybe String
   , staticconfigVerbose :: Maybe Bool
   , staticconfigDevices :: M.Map String TreeConfig
-  } deriving Show
+  } deriving (Show, Generic, FromDhall)
 
-instance FromJSON StaticConfig where
+-- instance FromJSON StaticConfig where
-  parseJSON = withObject "devices" $ \o -> StaticConfig
+--   parseJSON = withObject "devices" $ \o -> StaticConfig
-    <$> o .:? "mountdir"
+--     <$> o .:? "mountdir"
-    <*> o .:? "verbose"
+--     <*> o .:? "verbose"
-    <*> o .: "devices"
+--     <*> o .: "devices"
 
 --------------------------------------------------------------------------------
 -- | Static devices trees

package.yaml

@@ -40,6 +40,7 @@ dependencies:
 - yaml >= 0.11.1.2
 - vector >= 0.12.0.3
 - bimap >= 0.2.4
+- dhall >= 1.40.2
 
 library:
   source-dirs: lib/