ENH import dhall types dynamically
This commit is contained in:
parent
09ce10a942
commit
9fcdd1b5f1
155
app/rofi-dev.hs
155
app/rofi-dev.hs
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -12,16 +13,14 @@ module Main (main) where
|
|||
|
||||
import Bitwarden.Internal
|
||||
import qualified Data.Text.IO as TI
|
||||
import Data.Typeable
|
||||
import Dhall hiding (maybe, sequence, void)
|
||||
import qualified Dhall.Map as DM
|
||||
import Dhall.TH
|
||||
import RIO
|
||||
import RIO.Directory
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.List.Partial as LP
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import qualified RIO.Vector.Boxed as V
|
||||
import Rofi.Command
|
||||
import System.Console.GetOpt
|
||||
import System.Environment
|
||||
|
|
@ -29,6 +28,28 @@ import System.FilePath.Posix
|
|||
import System.Posix.User (getEffectiveUserName)
|
||||
import System.Process
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Static device configuration (dhall)
|
||||
|
||||
makeHaskellTypesWith
|
||||
(defaultGenerateOptions {generateToDhallInstance = False})
|
||||
[ MultipleConstructors "PasswordConfig" "(./dhall/rofi-dev.dhall).PasswordConfig"
|
||||
, MultipleConstructors "DataConfig" "(./dhall/rofi-dev.dhall).DataConfig"
|
||||
, SingleConstructor "TreeMap" "TreeMap" "(./dhall/rofi-dev.dhall).TreeMap"
|
||||
, SingleConstructor "SecretMap" "SecretMap" "(./dhall/rofi-dev.dhall).SecretMap"
|
||||
, SingleConstructor "StaticConfig" "StaticConfig" "(./dhall/rofi-dev.dhall).StaticConfig"
|
||||
, SingleConstructor "PromptConfig" "PromptConfig" "(./dhall/rofi-dev.dhall).PromptConfig"
|
||||
, SingleConstructor "TreeConfig" "TreeConfig" "(./dhall/rofi-dev.dhall).TreeConfig"
|
||||
, SingleConstructor "DeviceConfig" "DeviceConfig" "(./dhall/rofi-dev.dhall).DeviceConfig"
|
||||
, SingleConstructor "SecretConfig" "SecretConfig" "(./dhall/rofi-dev.dhall).SecretConfig"
|
||||
, SingleConstructor "MountConfig" "MountConfig" "(./dhall/rofi-dev.dhall).MountConfig"
|
||||
, SingleConstructor "BitwardenConfig" "BitwardenConfig" "(./dhall/rofi-dev.dhall).BitwardenConfig"
|
||||
, SingleConstructor "VeracryptData" "VeracryptData" "(./dhall/rofi-dev.dhall).VeracryptData"
|
||||
, SingleConstructor "CIFSData" "CIFSData" "(./dhall/rofi-dev.dhall).CIFSData"
|
||||
, SingleConstructor "CIFSOpts" "CIFSOpts" "(./dhall/rofi-dev.dhall).CIFSOpts"
|
||||
, SingleConstructor "SSHFSData" "SSHFSData" "(./dhall/rofi-dev.dhall).SSHFSData"
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= parse
|
||||
|
||||
|
|
@ -84,8 +105,8 @@ runMounts :: Opts -> IO ()
|
|||
runMounts opts = do
|
||||
static <- join <$> traverse parseStaticConfig (optsConfig opts)
|
||||
defaultTmpPath <- ("/tmp/media" </>) <$> getEffectiveUserName
|
||||
let tmpPath = fromMaybe defaultTmpPath $ scTmpPath =<< static
|
||||
let staticDevs = maybe M.empty scDevices static
|
||||
let tmpPath = fromMaybe defaultTmpPath $ (fmap T.unpack . scTmpPath) =<< static
|
||||
let staticDevs = maybe M.empty (M.fromList . fmap (\(TreeMap k v) -> (k, v)) . scDevices) static
|
||||
let verbose = fromMaybe False $ scVerbose =<< static
|
||||
let mountconf =
|
||||
MountConf
|
||||
|
|
@ -100,34 +121,10 @@ runMounts opts = do
|
|||
|
||||
parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
|
||||
parseStaticConfig p = do
|
||||
res <- try $ inputFileWithSettings es auto p
|
||||
res <- try $ inputFile auto p
|
||||
case res of
|
||||
Left e -> TI.putStrLn (T.pack $ show (e :: SomeException)) >> return Nothing
|
||||
Right c -> return $ Just (c :: StaticConfig)
|
||||
where
|
||||
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, LP.maximum $ expected a)) $
|
||||
listToMaybe $
|
||||
snd $
|
||||
splitTyConApp $
|
||||
typeOf a
|
||||
|
||||
runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
|
||||
runPrompt gs =
|
||||
|
|
@ -184,6 +181,7 @@ alignEntries ps = zip (align es) as
|
|||
. L.transpose
|
||||
. mapToLast pad
|
||||
. L.transpose
|
||||
-- TODO not DRY (this is just a pad operation)
|
||||
pad xs = let m = getMax xs in fmap (\x -> T.append x (T.replicate (m - T.length x) " ")) xs
|
||||
getMax = LP.maximum . fmap T.length
|
||||
mapToLast _ [] = []
|
||||
|
|
@ -199,7 +197,8 @@ data MountConf = MountConf
|
|||
, mountconfStaticDevs :: M.Map T.Text TreeConfig
|
||||
, mountconfVerbose :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- deriving (Show)
|
||||
|
||||
instance RofiConf MountConf where
|
||||
defArgs MountConf {mountconfRofiArgs = a} = a
|
||||
|
|
@ -307,89 +306,6 @@ instance Ord Header where
|
|||
|
||||
data ProtoAction a = ProtoAction a (RofiMountIO ())
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Static device configuration (dhall)
|
||||
|
||||
data MountConfig = MountConfig
|
||||
{ mpPath :: FilePath
|
||||
, mpLabel :: Maybe T.Text
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data BitwardenConfig = BitwardenConfig
|
||||
{ bwKey :: T.Text
|
||||
, bwTries :: Integer
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
newtype SecretConfig = SecretConfig
|
||||
{secretAttributes :: M.Map T.Text T.Text}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
newtype PromptConfig = PromptConfig
|
||||
{promptTries :: Integer}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data PasswordConfig
|
||||
= PwdBW BitwardenConfig
|
||||
| PwdLS SecretConfig
|
||||
| PwdPr PromptConfig
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data CIFSOpts = CIFSOpts
|
||||
{ cifsoptsUsername :: Maybe T.Text
|
||||
, cifsoptsWorkgroup :: Maybe T.Text
|
||||
, cifsoptsUID :: Maybe Integer
|
||||
, cifsoptsGID :: Maybe Integer
|
||||
, cifsoptsIocharset :: Maybe T.Text
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data DataConfig
|
||||
= VeracryptConfig VeracryptData
|
||||
| SSHFSConfig SSHFSData
|
||||
| CIFSConfig CIFSData
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data VeracryptData = VeracryptData
|
||||
{ vcVolume :: T.Text
|
||||
, vcPassword :: Maybe PasswordConfig
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data SSHFSData = SSHFSData
|
||||
{ sshfsRemote :: T.Text
|
||||
, sshfsPassword :: Maybe PasswordConfig
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data CIFSData = CIFSData
|
||||
{ cifsRemote :: T.Text
|
||||
, cifsSudo :: Bool
|
||||
, cifsPassword :: Maybe PasswordConfig
|
||||
, cifsOpts :: Maybe CIFSOpts
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data DeviceConfig = DeviceConfig
|
||||
{ deviceMount :: MountConfig
|
||||
, deviceData :: DataConfig
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data TreeConfig = TreeConfig
|
||||
{ tcParent :: DeviceConfig
|
||||
, tcChildren :: V.Vector T.Text
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
data StaticConfig = StaticConfig
|
||||
{ scTmpPath :: Maybe FilePath
|
||||
, scVerbose :: Maybe Bool
|
||||
, scDevices :: M.Map T.Text TreeConfig
|
||||
}
|
||||
deriving (Show, Generic, FromDhall)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Static devices trees
|
||||
|
||||
|
|
@ -433,7 +349,8 @@ configToTree' devMap = configToTree devMap <$> M.elems devMap
|
|||
|
||||
configToTree :: M.Map T.Text TreeConfig -> TreeConfig -> StaticConfigTree
|
||||
configToTree devMap TreeConfig {tcParent = p, tcChildren = c} =
|
||||
Tree p $ fmap go V.toList c
|
||||
-- TODO wut?
|
||||
Tree p $ fmap go id c
|
||||
where
|
||||
go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
|
||||
|
||||
|
|
@ -498,7 +415,7 @@ instance Mountable DeviceConfig where
|
|||
getLabel
|
||||
DeviceConfig
|
||||
{ deviceMount = MountConfig {mpPath = p, mpLabel = l}
|
||||
} = fromMaybe (T.pack $ takeFileName p) l
|
||||
} = fromMaybe (T.pack $ takeFileName $ T.unpack p) l
|
||||
|
||||
mountSSHFS :: FilePath -> Maybe PasswordConfig -> T.Text -> IO MountResult
|
||||
mountSSHFS mountpoint pwdConfig remote =
|
||||
|
|
@ -565,7 +482,7 @@ veracryptMountState mc = do
|
|||
|
||||
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
|
||||
getAbsMountpoint MountConfig {mpPath = m} =
|
||||
asks $ flip appendRoot m . mountconfVolatilePath
|
||||
asks $ flip appendRoot (T.unpack m) . mountconfVolatilePath
|
||||
|
||||
getStaticActions :: RofiMountIO [(Header, ProtoAction [T.Text])]
|
||||
getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
|
||||
|
|
@ -585,7 +502,7 @@ runBitwarden pname =
|
|||
((password . login) <=< L.find (\i -> name i == pname))
|
||||
<$> getItems
|
||||
|
||||
runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter
|
||||
runPromptLoop :: Natural -> PasswordGetter -> PasswordGetter
|
||||
runPromptLoop n pwd = do
|
||||
res <- pwd
|
||||
if isNothing res
|
||||
|
|
@ -610,7 +527,7 @@ runPromptLoop n pwd = do
|
|||
configToPwd :: PasswordConfig -> PasswordGetter
|
||||
configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) =
|
||||
runPromptLoop n $ runBitwarden k
|
||||
configToPwd (PwdLS s) = runSecret $ secretAttributes s
|
||||
configToPwd (PwdLS s) = runSecret $ M.fromList $ fmap (\(SecretMap k v) -> (k, v)) $ secretAttributes s
|
||||
configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
|
||||
|
||||
withPasswordGetter
|
||||
|
|
|
|||
|
|
@ -0,0 +1,66 @@
|
|||
let MountConfig = { mpPath : Text, mpLabel : Optional Text }
|
||||
|
||||
let BitwardenConfig = { bwKey : Text, bwTries : Natural }
|
||||
|
||||
let SecretMap = { sKey : Text, sVal : Text }
|
||||
|
||||
let SecretConfig = { secretAttributes : List SecretMap }
|
||||
|
||||
let PromptConfig = { promptTries : Natural }
|
||||
|
||||
let PasswordConfig =
|
||||
< PwdBW : BitwardenConfig | PwdLS : SecretConfig | PwdPr : PromptConfig >
|
||||
|
||||
let SSHFSData = { sshfsRemote : Text, sshfsPassword : Optional PasswordConfig }
|
||||
|
||||
let CIFSOpts =
|
||||
{ cifsoptsUsername : Optional Text
|
||||
, cifsoptsWorkgroup : Optional Text
|
||||
, cifsoptsUID : Optional Natural
|
||||
, cifsoptsGID : Optional Natural
|
||||
, cifsoptsIocharset : Optional Text
|
||||
}
|
||||
|
||||
let CIFSData =
|
||||
{ cifsRemote : Text
|
||||
, cifsSudo : Bool
|
||||
, cifsPassword : Optional PasswordConfig
|
||||
, cifsOpts : Optional CIFSOpts
|
||||
}
|
||||
|
||||
let VeracryptData = { vcVolume : Text, vcPassword : Optional PasswordConfig }
|
||||
|
||||
let DataConfig =
|
||||
< VeracryptConfig : VeracryptData
|
||||
| SSHFSConfig : SSHFSData
|
||||
| CIFSConfig : CIFSData
|
||||
>
|
||||
|
||||
let DeviceConfig = { deviceMount : MountConfig, deviceData : DataConfig }
|
||||
|
||||
let TreeConfig = { tcParent : DeviceConfig, tcChildren : List Text }
|
||||
|
||||
let TreeMap = { tKey : Text, tVal : TreeConfig }
|
||||
|
||||
let StaticConfig =
|
||||
{ scTmpPath : Optional Text
|
||||
, scVerbose : Optional Bool
|
||||
, scDevices : List TreeMap
|
||||
}
|
||||
|
||||
in { StaticConfig
|
||||
, TreeConfig
|
||||
, DeviceConfig
|
||||
, DataConfig
|
||||
, VeracryptData
|
||||
, CIFSData
|
||||
, CIFSOpts
|
||||
, SSHFSData
|
||||
, PasswordConfig
|
||||
, SecretConfig
|
||||
, MountConfig
|
||||
, BitwardenConfig
|
||||
, PromptConfig
|
||||
, TreeMap
|
||||
, SecretMap
|
||||
}
|
||||
|
|
@ -17,7 +17,7 @@
|
|||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-19.17
|
||||
resolver: lts-20.11
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 619161
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
|
||||
sha256: 7f47507fd037228a8d23cf830f5844e1f006221acebdd7cb49f2f5fb561e0546
|
||||
original: lts-19.17
|
||||
sha256: adbc602422dde10cc330175da7de8609e70afc41449a7e2d6e8b1827aa0e5008
|
||||
size: 649342
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/11.yaml
|
||||
original: lts-20.11
|
||||
|
|
|
|||
Loading…
Reference in New Issue