ENH inject config types into dhall code

This commit is contained in:
Nathan Dwarshuis 2022-08-07 13:55:41 -04:00
parent 74070ebb30
commit d06d5d5a0b
2 changed files with 63 additions and 121 deletions

View File

@ -4,7 +4,6 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | rofi-dev - a rofi prompt for mountable devices -- | rofi-dev - a rofi prompt for mountable devices
-- --
@ -16,18 +15,21 @@ module Main (main) where
import Bitwarden.Internal import Bitwarden.Internal
-- import Control.Exception
import Control.Lens
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
-- import Data.Aeson
import Data.List import Data.List
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import qualified Data.Text as T
import Data.Typeable
import qualified Data.Vector as V import qualified Data.Vector as V
-- import Data.Yaml
import Dhall (FromDhall, Generic, auto, inputFile) import Dhall hiding (maybe, sequence, void)
import qualified Dhall.Map as DM
import Rofi.Command import Rofi.Command
@ -88,9 +90,9 @@ runMounts :: Opts -> IO ()
runMounts opts = do runMounts opts = do
static <- join <$> traverse parseStaticConfig (optsConfig opts) static <- join <$> traverse parseStaticConfig (optsConfig opts)
defaultTmpPath <- ("/tmp/media" </>) <$> getEffectiveUserName defaultTmpPath <- ("/tmp/media" </>) <$> getEffectiveUserName
let tmpPath = fromMaybe defaultTmpPath $ staticconfigTmpPath =<< static let tmpPath = fromMaybe defaultTmpPath $ scTmpPath =<< static
let staticDevs = maybe M.empty staticconfigDevices static let staticDevs = maybe M.empty scDevices static
let verbose = fromMaybe False $ staticconfigVerbose =<< static let verbose = fromMaybe False $ scVerbose =<< static
let mountconf = MountConf let mountconf = MountConf
{ mountconfVolatilePath = tmpPath { mountconfVolatilePath = tmpPath
, mountconfRofiArgs = optsRofiArgs opts , mountconfRofiArgs = optsRofiArgs opts
@ -103,12 +105,28 @@ runMounts opts = do
parseStaticConfig :: FilePath -> IO (Maybe StaticConfig) parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
parseStaticConfig p = do parseStaticConfig p = do
-- res <- decodeFileEither p res <- try $ inputFileWithSettings es auto p
res <- inputFile auto p case res of
return $ Just (res :: StaticConfig) Left e -> print (e :: SomeException) >> return Nothing
-- case res of Right c -> return $ Just (c :: StaticConfig)
-- Left e -> print e >> return Nothing where
-- Right c -> return $ Just c es = over substitutions (DM.union vars) defaultEvaluateSettings
vars = DM.fromList $ catMaybes
[ toVar (auto :: Decoder TreeConfig)
, toVar (auto :: Decoder DeviceConfig)
, toVar (auto :: Decoder DataConfig)
, toVar (auto :: Decoder CIFSData)
, toVar (auto :: Decoder CIFSOpts)
, toVar (auto :: Decoder SSHFSData)
, toVar (auto :: Decoder VeracryptData)
, toVar (auto :: Decoder PasswordConfig)
, toVar (auto :: Decoder PromptConfig)
, toVar (auto :: Decoder SecretConfig)
, toVar (auto :: Decoder BitwardenConfig)
, toVar (auto :: Decoder MountConfig)
]
toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
$ listToMaybe $ snd $ splitTyConApp $ typeOf a
runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c () runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
runPrompt gs = selectAction $ emptyMenu runPrompt gs = selectAction $ emptyMenu
@ -264,67 +282,32 @@ instance Ord Header where
data ProtoAction a = ProtoAction a (RofiMountIO ()) data ProtoAction a = ProtoAction a (RofiMountIO ())
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Static device configuration -- | Static device configuration (dhall)
--
-- Static devices are defined in a YAML file. These types/instances describe how
-- to parse said YAML file.
-- defaultTries :: Integer
-- defaultTries = 2
-- (.:&) :: FromJSON a => Object -> Key -> Parser (V.Vector a)
-- (.:&) o t = o .:? t .!= V.empty
data MountConfig = MountConfig data MountConfig = MountConfig
{ mountMountpoint :: FilePath { mpPath :: FilePath
, mountLabel :: Maybe String , mpLabel :: Maybe String
} deriving (Show, Generic, FromDhall) } deriving (Show, Generic, FromDhall)
-- instance FromJSON MountConfig where
-- parseJSON = withObject "mount" $ \o -> MountConfig
-- <$> o .: "mountpoint"
-- <*> o .:? "label"
data BitwardenConfig = BitwardenConfig data BitwardenConfig = BitwardenConfig
{ bitwardenKey :: String { bwKey :: String
, bitwardenTries :: Integer } , bwTries :: Integer }
deriving (Show, Generic, FromDhall) deriving (Show, Generic, FromDhall)
-- instance FromJSON BitwardenConfig where newtype SecretConfig = SecretConfig
-- parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig { secretAttributes :: M.Map String String }
-- <$> o .: "key"
-- <*> o .:? "tries" .!= defaultTries
newtype LibSecretConfig = LibSecretConfig
{ libsecretAttributes :: M.Map String String }
deriving (Show, Generic, FromDhall) deriving (Show, Generic, FromDhall)
-- instance FromJSON LibSecretConfig where
-- parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
-- <$> o .: "attributes"
newtype PromptConfig = PromptConfig newtype PromptConfig = PromptConfig
{ promptTries :: Integer } { promptTries :: Integer }
deriving (Show, Generic, FromDhall) deriving (Show, Generic, FromDhall)
-- instance FromJSON PromptConfig where
-- parseJSON = withObject "prompt" $ \o -> PromptConfig
-- <$> o .:? "tries" .!= defaultTries
data PasswordConfig = PwdBW BitwardenConfig data PasswordConfig = PwdBW BitwardenConfig
| PwdLS LibSecretConfig | PwdLS SecretConfig
| PwdPr PromptConfig | PwdPr PromptConfig
deriving (Show, Generic, FromDhall) deriving (Show, Generic, FromDhall)
-- instance FromJSON PasswordConfig where data CIFSOpts = CIFSOpts
-- 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 { cifsoptsUsername :: Maybe String
, cifsoptsWorkgroup :: Maybe String , cifsoptsWorkgroup :: Maybe String
, cifsoptsUID :: Maybe Integer , cifsoptsUID :: Maybe Integer
@ -332,22 +315,14 @@ data CIFSOptsConfig = CIFSOptsConfig
, cifsoptsIocharset :: Maybe String , cifsoptsIocharset :: Maybe String
} deriving (Show, Generic, FromDhall) } deriving (Show, Generic, FromDhall)
-- instance FromJSON CIFSOptsConfig where
-- parseJSON = withObject "options" $ \o -> CIFSOptsConfig
-- <$> o .:? "username"
-- <*> o .:? "workgroup"
-- <*> o .:? "uid"
-- <*> o .:? "gid"
-- <*> o .:? "isocharset"
data DataConfig = VeracryptConfig VeracryptData data DataConfig = VeracryptConfig VeracryptData
| SSHFSConfig SSHFSData | SSHFSConfig SSHFSData
| CIFSConfig CIFSData | CIFSConfig CIFSData
deriving (Show, Generic, FromDhall) deriving (Show, Generic, FromDhall)
data VeracryptData = VeracryptData data VeracryptData = VeracryptData
{ veracryptVolume :: String { vcVolume :: String
, veracryptPassword :: Maybe PasswordConfig , vcPassword :: Maybe PasswordConfig
} deriving (Show, Generic, FromDhall) } deriving (Show, Generic, FromDhall)
data SSHFSData = SSHFSData data SSHFSData = SSHFSData
@ -359,7 +334,7 @@ data CIFSData = CIFSData
{ cifsRemote :: String { cifsRemote :: String
, cifsSudo :: Bool , cifsSudo :: Bool
, cifsPassword :: Maybe PasswordConfig , cifsPassword :: Maybe PasswordConfig
, cifsOpts :: Maybe CIFSOptsConfig , cifsOpts :: Maybe CIFSOpts
} deriving (Show, Generic, FromDhall) } deriving (Show, Generic, FromDhall)
data DeviceConfig = DeviceConfig data DeviceConfig = DeviceConfig
@ -368,50 +343,16 @@ data DeviceConfig = DeviceConfig
} deriving (Show, Generic, FromDhall) } deriving (Show, Generic, FromDhall)
data TreeConfig = TreeConfig data TreeConfig = TreeConfig
{ treeParent :: DeviceConfig { tcParent :: DeviceConfig
, treeconfigChildren :: V.Vector String , tcChildren :: V.Vector String
} deriving (Show, Generic, FromDhall) } 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
-- }
data StaticConfig = StaticConfig data StaticConfig = StaticConfig
{ staticconfigTmpPath :: Maybe String { scTmpPath :: Maybe String
, staticconfigVerbose :: Maybe Bool , scVerbose :: Maybe Bool
, staticconfigDevices :: M.Map String TreeConfig , scDevices :: M.Map String TreeConfig
} deriving (Show, Generic, FromDhall) } deriving (Show, Generic, FromDhall)
-- instance FromJSON StaticConfig where
-- parseJSON = withObject "devices" $ \o -> StaticConfig
-- <$> o .:? "mountdir"
-- <*> o .:? "verbose"
-- <*> o .: "devices"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Static devices trees -- | Static devices trees
-- --
@ -442,7 +383,7 @@ instance Actionable (Tree DeviceConfig) where
where where
target (CIFSConfig (CIFSData { cifsRemote = r })) = r target (CIFSConfig (CIFSData { cifsRemote = r })) = r
target (SSHFSConfig (SSHFSData { sshfsRemote = r })) = r target (SSHFSConfig (SSHFSData { sshfsRemote = r })) = r
target (VeracryptConfig (VeracryptData { veracryptVolume = v })) = v target (VeracryptConfig (VeracryptData { vcVolume = v })) = v
groupHeader (Tree DeviceConfig{ deviceData = d } _) = groupHeader (Tree DeviceConfig{ deviceData = d } _) =
case d of case d of
@ -454,7 +395,7 @@ configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
configToTree' devMap = configToTree devMap <$> M.elems devMap configToTree' devMap = configToTree devMap <$> M.elems devMap
configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
configToTree devMap TreeConfig{ treeParent = p, treeconfigChildren = c } = configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
Tree p $ fmap go V.toList c Tree p $ fmap go V.toList c
where where
go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
@ -485,8 +426,8 @@ instance Mountable DeviceConfig where
}) -> }) ->
mountCIFS s r m' o p mountCIFS s r m' o p
VeracryptConfig (VeracryptData VeracryptConfig (VeracryptData
{ veracryptPassword = p { vcPassword = p
, veracryptVolume = v , vcVolume = v
}) -> }) ->
mountVeracrypt m' p v mountVeracrypt m' p v
@ -513,7 +454,7 @@ instance Mountable DeviceConfig where
return $ if b then Mounted else Unmounted return $ if b then Mounted else Unmounted
getLabel DeviceConfig getLabel DeviceConfig
{ deviceMount = MountConfig { mountMountpoint = p, mountLabel = l } { deviceMount = MountConfig { mpPath = p, mpLabel = l }
} = fromMaybe (takeFileName p) l } = fromMaybe (takeFileName p) l
mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
@ -522,7 +463,7 @@ mountSSHFS mountpoint pwdConfig remote =
where where
run other = runMount "sshfs" (other ++ [remote, mountpoint]) run other = runMount "sshfs" (other ++ [remote, mountpoint])
mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOptsConfig mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOpts
-> Maybe PasswordConfig -> IO MountResult -> Maybe PasswordConfig -> IO MountResult
mountCIFS useSudo remote mountpoint opts pwdConfig = mountCIFS useSudo remote mountpoint opts pwdConfig =
withPasswordGetter pwdConfig runPwd run withPasswordGetter pwdConfig runPwd run
@ -531,7 +472,7 @@ mountCIFS useSudo remote mountpoint opts pwdConfig =
runPwd p = runMountSudoMaybe' useSudo "mount.cifs" args [("PASSWD", p)] runPwd p = runMountSudoMaybe' useSudo "mount.cifs" args [("PASSWD", p)]
args = [remote, mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts args = [remote, mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts
fromCIFSOpts :: CIFSOptsConfig -> String fromCIFSOpts :: CIFSOpts -> String
fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
where where
fs = [ ("username", cifsoptsUsername) fs = [ ("username", cifsoptsUsername)
@ -574,7 +515,7 @@ veracryptMountState mc = do
_ -> Nothing _ -> Nothing
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
getAbsMountpoint MountConfig{ mountMountpoint = m } = getAbsMountpoint MountConfig{ mpPath = m } =
asks $ flip appendRoot m . mountconfVolatilePath asks $ flip appendRoot m . mountconfVolatilePath
getStaticActions :: RofiMountIO [(Header, ProtoAction [String])] getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
@ -609,17 +550,17 @@ runPromptLoop n pwd = do
-- } = -- } =
-- getBW b `runMaybe` getLS s `runMaybe` getPrompt p -- getBW b `runMaybe` getLS s `runMaybe` getPrompt p
-- where -- where
-- getBW (Just BitwardenConfig{ bitwardenKey = k, bitwardenTries = n }) = -- getBW (Just BitwardenConfig{ bwKey = k, bwTries = n }) =
-- runPromptLoop n $ runBitwarden k -- runPromptLoop n $ runBitwarden k
-- getBW _ = return Nothing -- getBW _ = return Nothing
-- getLS = maybe (return Nothing) (runSecret . libsecretAttributes) -- getLS = maybe (return Nothing) (runSecret . secretAttributes)
-- getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries) -- getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries)
-- runMaybe x y = (\r -> if isNothing r then y else return r) =<< x -- runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
configToPwd :: PasswordConfig -> PasswordGetter configToPwd :: PasswordConfig -> PasswordGetter
configToPwd (PwdBW (BitwardenConfig { bitwardenKey = k, bitwardenTries = n })) = configToPwd (PwdBW (BitwardenConfig { bwKey = k, bwTries = n })) =
runPromptLoop n $ runBitwarden k runPromptLoop n $ runBitwarden k
configToPwd (PwdLS s) = runSecret $ libsecretAttributes s configToPwd (PwdLS s) = runSecret $ secretAttributes s
configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult) withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)

View File

@ -41,6 +41,7 @@ dependencies:
- vector >= 0.12.0.3 - vector >= 0.12.0.3
- bimap >= 0.2.4 - bimap >= 0.2.4
- dhall >= 1.40.2 - dhall >= 1.40.2
- lens >= 5.0.1
library: library:
source-dirs: lib/ source-dirs: lib/