ENH use dhall for config
This commit is contained in:
parent
f09f636f56
commit
74070ebb30
178
app/rofi-dev.hs
178
app/rofi-dev.hs
|
|
@ -1,5 +1,9 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# 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
|
||||
case res of
|
||||
Left e -> print e >> return Nothing
|
||||
Right c -> return $ Just c
|
||||
-- res <- decodeFileEither p
|
||||
res <- inputFile auto p
|
||||
return $ Just (res :: StaticConfig)
|
||||
-- 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 = 2
|
||||
-- defaultTries :: Integer
|
||||
-- defaultTries = 2
|
||||
|
||||
(.:&) :: FromJSON a => Object -> Key -> Parser (V.Vector a)
|
||||
(.:&) o t = o .:? t .!= V.empty
|
||||
-- (.:&) :: FromJSON a => Object -> Key -> Parser (V.Vector a)
|
||||
-- (.:&) o t = o .:? t .!= V.empty
|
||||
|
||||
data MountConfig = MountConfig
|
||||
{ mountMountpoint :: FilePath
|
||||
, mountLabel :: Maybe String
|
||||
} deriving Show
|
||||
} deriving (Show, Generic, FromDhall)
|
||||
|
||||
instance FromJSON MountConfig where
|
||||
parseJSON = withObject "mount" $ \o -> MountConfig
|
||||
<$> o .: "mountpoint"
|
||||
<*> o .:? "label"
|
||||
-- instance FromJSON MountConfig where
|
||||
-- parseJSON = withObject "mount" $ \o -> MountConfig
|
||||
-- <$> o .: "mountpoint"
|
||||
-- <*> o .:? "label"
|
||||
|
||||
data BitwardenConfig = BitwardenConfig
|
||||
{ bitwardenKey :: String
|
||||
, bitwardenTries :: Integer }
|
||||
deriving Show
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
instance FromJSON BitwardenConfig where
|
||||
parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
|
||||
<$> o .: "key"
|
||||
<*> o .:? "tries" .!= defaultTries
|
||||
-- instance FromJSON BitwardenConfig where
|
||||
-- parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
|
||||
-- <$> o .: "key"
|
||||
-- <*> o .:? "tries" .!= defaultTries
|
||||
|
||||
newtype LibSecretConfig = LibSecretConfig
|
||||
{ libsecretAttributes :: M.Map String String }
|
||||
deriving Show
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
instance FromJSON LibSecretConfig where
|
||||
parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
|
||||
<$> o .: "attributes"
|
||||
-- instance FromJSON LibSecretConfig where
|
||||
-- parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
|
||||
-- <$> o .: "attributes"
|
||||
|
||||
newtype PromptConfig = PromptConfig
|
||||
{ promptTries :: Integer }
|
||||
deriving Show
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
instance FromJSON PromptConfig where
|
||||
parseJSON = withObject "prompt" $ \o -> PromptConfig
|
||||
<$> o .:? "tries" .!= defaultTries
|
||||
-- instance FromJSON PromptConfig where
|
||||
-- parseJSON = withObject "prompt" $ \o -> PromptConfig
|
||||
-- <$> o .:? "tries" .!= defaultTries
|
||||
|
||||
data PasswordConfig = PwdBW BitwardenConfig
|
||||
| PwdLS LibSecretConfig
|
||||
| PwdPr PromptConfig
|
||||
deriving Show
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
instance FromJSON PasswordConfig where
|
||||
parseJSON = withObject "password" $ \o -> do
|
||||
br <- fmap PwdBW <$> o .:? "bitwarden"
|
||||
ls <- maybe (fmap PwdLS <$> o .:? "libsecret") (return . Just) br
|
||||
-- TODO this is silly because I need to pass 'prompt: {}' instead of
|
||||
-- just 'prompt:' if I just want the defaults
|
||||
maybe (PwdPr <$> o .: "prompt") return ls
|
||||
-- instance FromJSON PasswordConfig where
|
||||
-- parseJSON = withObject "password" $ \o -> do
|
||||
-- br <- fmap PwdBW <$> o .:? "bitwarden"
|
||||
-- ls <- maybe (fmap PwdLS <$> o .:? "libsecret") (return . Just) br
|
||||
-- -- TODO this is silly because I need to pass 'prompt: {}' instead of
|
||||
-- -- just 'prompt:' if I just want the defaults
|
||||
-- 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
|
||||
parseJSON = withObject "options" $ \o -> CIFSOptsConfig
|
||||
<$> o .:? "username"
|
||||
<*> o .:? "workgroup"
|
||||
<*> o .:? "uid"
|
||||
<*> o .:? "gid"
|
||||
<*> o .:? "isocharset"
|
||||
-- instance FromJSON CIFSOptsConfig where
|
||||
-- parseJSON = withObject "options" $ \o -> CIFSOptsConfig
|
||||
-- <$> o .:? "username"
|
||||
-- <*> o .:? "workgroup"
|
||||
-- <*> o .:? "uid"
|
||||
-- <*> o .:? "gid"
|
||||
-- <*> 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
|
||||
parseJSON = withObject "devices" $ \o -> do
|
||||
devType <- o .: "type"
|
||||
deps <- o .:& "depends"
|
||||
mountconf <- o .: "mount"
|
||||
devData <- case (devType :: String) of
|
||||
"cifs" -> CIFSConfig <$> (CIFSData
|
||||
<$> o .: "remote"
|
||||
<*> o .:? "sudo" .!= False
|
||||
<*> o .:? "password"
|
||||
<*> o .:? "options")
|
||||
"sshfs" -> SSHFSConfig <$> (SSHFSData
|
||||
<$> o .: "remote"
|
||||
<*> o .:? "password")
|
||||
"veracrypt" -> VeracryptConfig <$> (VeracryptData
|
||||
<$> o .: "volume"
|
||||
<*> o .:? "password")
|
||||
-- TODO make this skip adding an entry to the map rather than
|
||||
-- skipping the map entirely
|
||||
_ -> fail $ "unknown device type: " ++ devType
|
||||
return $ TreeConfig
|
||||
{ treeParent = DeviceConfig
|
||||
{ deviceMount = mountconf
|
||||
, deviceData = devData
|
||||
}
|
||||
, treeconfigChildren = deps
|
||||
}
|
||||
-- instance FromJSON TreeConfig where
|
||||
-- parseJSON = withObject "devices" $ \o -> do
|
||||
-- devType <- o .: "type"
|
||||
-- deps <- o .:& "depends"
|
||||
-- mountconf <- o .: "mount"
|
||||
-- devData <- case (devType :: String) of
|
||||
-- "cifs" -> CIFSConfig <$> (CIFSData
|
||||
-- <$> o .: "remote"
|
||||
-- <*> o .:? "sudo" .!= False
|
||||
-- <*> o .:? "password"
|
||||
-- <*> o .:? "options")
|
||||
-- "sshfs" -> SSHFSConfig <$> (SSHFSData
|
||||
-- <$> o .: "remote"
|
||||
-- <*> o .:? "password")
|
||||
-- "veracrypt" -> VeracryptConfig <$> (VeracryptData
|
||||
-- <$> o .: "volume"
|
||||
-- <*> o .:? "password")
|
||||
-- -- TODO make this skip adding an entry to the map rather than
|
||||
-- -- skipping the map entirely
|
||||
-- _ -> fail $ "unknown device type: " ++ devType
|
||||
-- return $ TreeConfig
|
||||
-- { treeParent = DeviceConfig
|
||||
-- { deviceMount = mountconf
|
||||
-- , deviceData = devData
|
||||
-- }
|
||||
-- , 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
|
||||
parseJSON = withObject "devices" $ \o -> StaticConfig
|
||||
<$> o .:? "mountdir"
|
||||
<*> o .:? "verbose"
|
||||
<*> o .: "devices"
|
||||
-- instance FromJSON StaticConfig where
|
||||
-- parseJSON = withObject "devices" $ \o -> StaticConfig
|
||||
-- <$> o .:? "mountdir"
|
||||
-- <*> o .:? "verbose"
|
||||
-- <*> o .: "devices"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Static devices trees
|
||||
|
|
|
|||
|
|
@ -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/
|
||||
|
|
|
|||
Loading…
Reference in New Issue