diff --git a/app/rofi-dev.hs b/app/rofi-dev.hs index 2849d5e..6ba7917 100644 --- a/app/rofi-dev.hs +++ b/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 diff --git a/dhall/rofi-dev.dhall b/dhall/rofi-dev.dhall new file mode 100644 index 0000000..06d49b2 --- /dev/null +++ b/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 + } diff --git a/stack.yaml b/stack.yaml index 53c538a..db201ed 100644 --- a/stack.yaml +++ b/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. diff --git a/stack.yaml.lock b/stack.yaml.lock index 9648c3f..90e049c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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