ENH import dhall types dynamically

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 tmpPath = fromMaybe defaultTmpPath $ (fmap T.unpack . scTmpPath) =<< static
-  let staticDevs = maybe M.empty scDevices 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

dhall/rofi-dev.dhall

@@ -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
+    }

stack.yaml

@@ -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.

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 619161
+    sha256: adbc602422dde10cc330175da7de8609e70afc41449a7e2d6e8b1827aa0e5008
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/17.yaml
+    size: 649342
-    sha256: 7f47507fd037228a8d23cf830f5844e1f006221acebdd7cb49f2f5fb561e0546
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/11.yaml
-  original: lts-19.17
+  original: lts-20.11