Compare commits

..

No commits in common. "fix_config" and "master" have entirely different histories.

4 changed files with 48 additions and 100 deletions

View File

@ -37,17 +37,17 @@ makeHaskellTypesWith
, MultipleConstructors "DataConfig" "(./dhall/rofi-dev.dhall).DataConfig" , MultipleConstructors "DataConfig" "(./dhall/rofi-dev.dhall).DataConfig"
, SingleConstructor "TreeMap" "TreeMap" "(./dhall/rofi-dev.dhall).TreeMap" , SingleConstructor "TreeMap" "TreeMap" "(./dhall/rofi-dev.dhall).TreeMap"
, SingleConstructor "SecretMap" "SecretMap" "(./dhall/rofi-dev.dhall).SecretMap" , SingleConstructor "SecretMap" "SecretMap" "(./dhall/rofi-dev.dhall).SecretMap"
, SingleConstructor "StaticConfig" "StaticConfig" "(./dhall/rofi-dev.dhall).StaticConfig.Type" , SingleConstructor "StaticConfig" "StaticConfig" "(./dhall/rofi-dev.dhall).StaticConfig"
, SingleConstructor "PromptConfig" "PromptConfig" "(./dhall/rofi-dev.dhall).PromptConfig.Type" , SingleConstructor "PromptConfig" "PromptConfig" "(./dhall/rofi-dev.dhall).PromptConfig"
, SingleConstructor "TreeConfig" "TreeConfig" "(./dhall/rofi-dev.dhall).TreeConfig.Type" , SingleConstructor "TreeConfig" "TreeConfig" "(./dhall/rofi-dev.dhall).TreeConfig"
, SingleConstructor "DeviceConfig" "DeviceConfig" "(./dhall/rofi-dev.dhall).DeviceConfig" , SingleConstructor "DeviceConfig" "DeviceConfig" "(./dhall/rofi-dev.dhall).DeviceConfig"
, SingleConstructor "SecretConfig" "SecretConfig" "(./dhall/rofi-dev.dhall).SecretConfig" , SingleConstructor "SecretConfig" "SecretConfig" "(./dhall/rofi-dev.dhall).SecretConfig"
, SingleConstructor "MountConfig" "MountConfig" "(./dhall/rofi-dev.dhall).MountConfig" , SingleConstructor "MountConfig" "MountConfig" "(./dhall/rofi-dev.dhall).MountConfig"
, SingleConstructor "BitwardenConfig" "BitwardenConfig" "(./dhall/rofi-dev.dhall).BitwardenConfig.Type" , SingleConstructor "BitwardenConfig" "BitwardenConfig" "(./dhall/rofi-dev.dhall).BitwardenConfig"
, SingleConstructor "VeracryptData" "VeracryptData" "(./dhall/rofi-dev.dhall).VeracryptData.Type" , SingleConstructor "VeracryptData" "VeracryptData" "(./dhall/rofi-dev.dhall).VeracryptData"
, SingleConstructor "CIFSData" "CIFSData" "(./dhall/rofi-dev.dhall).CIFSData.Type" , SingleConstructor "CIFSData" "CIFSData" "(./dhall/rofi-dev.dhall).CIFSData"
, SingleConstructor "CIFSOpts" "CIFSOpts" "(./dhall/rofi-dev.dhall).CIFSOpts.Type" , SingleConstructor "CIFSOpts" "CIFSOpts" "(./dhall/rofi-dev.dhall).CIFSOpts"
, SingleConstructor "SSHFSData" "SSHFSData" "(./dhall/rofi-dev.dhall).SSHFSData.Type" , SingleConstructor "SSHFSData" "SSHFSData" "(./dhall/rofi-dev.dhall).SSHFSData"
] ]
main :: IO () main :: IO ()
@ -176,12 +176,12 @@ mountByAlias unmountFlag alias = do
mkGroup :: NE.NonEmpty (Header, ProtoAction) -> RofiGroup MountConf mkGroup :: NE.NonEmpty (Header, ProtoAction) -> RofiGroup MountConf
mkGroup as = titledGroup h $ toRofiActions $ NE.toList $ alignEntries $ snd <$> as mkGroup as = titledGroup h $ toRofiActions $ NE.toList $ alignEntries $ snd <$> as
where where
h = T.pack $ show $ fst $ NE.head as h = (T.pack $ show $ fst $ NE.head as)
alignSep :: T.Text alignSep :: T.Text
alignSep = " | " alignSep = " | "
alignEntries :: NE.NonEmpty ProtoAction -> NE.NonEmpty (T.Text, MIO ()) alignEntries :: NE.NonEmpty (ProtoAction) -> NE.NonEmpty (T.Text, MIO ())
alignEntries ps = NE.zip (align es) as alignEntries ps = NE.zip (align es) as
where where
(es, as) = NE.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps (es, as) = NE.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
@ -190,10 +190,10 @@ alignEntries ps = NE.zip (align es) as
. NE.transpose . NE.transpose
. fmap1 padAll . fmap1 padAll
. NE.transpose . NE.transpose
fmap1 f (x :| xs) = f x :| xs fmap1 f (x :| xs) = (f x) :| xs
padAll xs = let m = maxNE $ fmap T.length xs in fmap (rpad m ' ') xs padAll xs = let m = maxNE $ fmap T.length xs in fmap (rpad m ' ') xs
maxNE (x :| []) = x maxNE (x :| []) = x
maxNE (x :| (y : ys)) = maxNE $ max x y :| ys maxNE (x :| (y : ys)) = maxNE $ (max x y) :| ys
rpad :: Int -> Char -> T.Text -> T.Text rpad :: Int -> Char -> T.Text -> T.Text
rpad n c s = T.append s $ T.replicate (n - T.length s) $ T.singleton c rpad n c s = T.append s $ T.replicate (n - T.length s) $ T.singleton c
@ -270,7 +270,7 @@ class Mountable a where
class Mountable a => Actionable a where class Mountable a => Actionable a where
-- | Return a string to go in the Rofi menu for the given type -- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> NE.NonEmpty T.Text fmtEntry :: a -> NE.NonEmpty T.Text
fmtEntry d = getLabel d :| [] fmtEntry d = (getLabel d :| [])
groupHeader :: a -> Header groupHeader :: a -> Header
@ -283,7 +283,7 @@ class Mountable a => Actionable a where
let h = groupHeader dev let h = groupHeader dev
let action = when i $ mountMaybe dev $ mountedState m let action = when i $ mountMaybe dev $ mountedState m
let entry = case fmtEntry dev of let entry = case fmtEntry dev of
(e :| es) -> T.append (mountedPrefix m i) e :| es (e :| es) -> (T.append (mountedPrefix m i) e) :| es
return (h, ProtoAction entry action) return (h, ProtoAction entry action)
where where
mountedPrefix _ False = "! " mountedPrefix _ False = "! "
@ -346,7 +346,7 @@ instance Mountable a => Mountable (Tree a) where
getLabel (Tree p _) = getLabel p getLabel (Tree p _) = getLabel p
instance Actionable (Tree DeviceConfig) where instance Actionable (Tree DeviceConfig) where
fmtEntry (Tree p@DeviceConfig {deviceData = d} _) = getLabel p :| [target d] fmtEntry (Tree p@DeviceConfig {deviceData = d} _) = (getLabel p :| [target d])
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
@ -462,7 +462,6 @@ fromCIFSOpts o = T.intercalate "," $ mapMaybe concatMaybe fs
fs = fs =
[ ("username", cifsoptsUsername) [ ("username", cifsoptsUsername)
, ("workgroup", cifsoptsWorkgroup) , ("workgroup", cifsoptsWorkgroup)
, ("domain", cifsoptsDomain)
, ("uid", fmap (T.pack . show) . cifsoptsUID) , ("uid", fmap (T.pack . show) . cifsoptsUID)
, ("gid", fmap (T.pack . show) . cifsoptsGID) , ("gid", fmap (T.pack . show) . cifsoptsGID)
, ("iocharset", cifsoptsIocharset) , ("iocharset", cifsoptsIocharset)
@ -552,7 +551,7 @@ runPromptLoop n pwd = do
configToPwd :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => PasswordConfig -> PasswordGetter m configToPwd :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => PasswordConfig -> PasswordGetter m
configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) = configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) =
runPromptLoop n $ runBitwarden k runPromptLoop n $ runBitwarden k
configToPwd (PwdLS s) = runSecret $ M.fromList $ (\(SecretMap k v) -> (k, v)) <$> secretAttributes s configToPwd (PwdLS s) = runSecret $ M.fromList $ fmap (\(SecretMap k v) -> (k, v)) $ secretAttributes s
configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
withPasswordGetter withPasswordGetter
@ -594,7 +593,7 @@ instance Mountable Removable where
getLabel Removable {removableLabel = l} = l getLabel Removable {removableLabel = l} = l
instance Actionable Removable where instance Actionable Removable where
fmtEntry Removable {removablePath = d, removableLabel = l} = l :| [d] fmtEntry Removable {removablePath = d, removableLabel = l} = (l :| [d])
groupHeader _ = RemovableHeader groupHeader _ = RemovableHeader
@ -690,7 +689,7 @@ mtpExeInstalled :: MonadIO m => m Bool
mtpExeInstalled = isJust <$> findExecutable mtpExe mtpExeInstalled = isJust <$> findExecutable mtpExe
instance Actionable MTPFS where instance Actionable MTPFS where
fmtEntry d = getLabel d :| [] fmtEntry d = (getLabel d :| [])
groupHeader _ = MTPFSHeader groupHeader _ = MTPFSHeader
@ -733,16 +732,9 @@ runMountSudoMaybe' useSudo cmd args environ =
-- runSudoMount rootpass cmd args stdin = runSudoMount' rootpass cmd args stdin [] -- runSudoMount rootpass cmd args stdin = runSudoMount' rootpass cmd args stdin []
runSudoMount' :: MonadIO m => T.Text -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> m MountResult runSudoMount' :: MonadIO m => T.Text -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> m MountResult
runSudoMount' rootpass cmd args environ = do runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass
-- This needs Default timestamp_type=global in sudoers to have any effect
-- since these are all separate shells
isCached <- isJust <$> readCmdSuccess "sudo" ["-n", "true"] ""
if isCached then run else do
cacheSuccess <- isJust <$> readCmdSuccess "sudo" ["-S", "true"] rootpass
if cacheSuccess then run else return $ MountError "Could not cache password"
where where
run = runMount "sudo" args' "" args' = ["-S"] ++ environ' ++ [cmd] ++ args
args' = ["-n"] ++ environ' ++ [cmd] ++ args
environ' = fmap (\(k, v) -> T.concat [k, "=", v]) environ environ' = fmap (\(k, v) -> T.concat [k, "=", v]) environ
eitherToMountResult :: Either (Int, T.Text, T.Text) T.Text -> MountResult eitherToMountResult :: Either (Int, T.Text, T.Text) T.Text -> MountResult

View File

@ -1,96 +1,52 @@
let MountConfig = { mpPath : Text, mpLabel : Optional Text } let MountConfig = { mpPath : Text, mpLabel : Optional Text }
let BitwardenConfig = let BitwardenConfig = { bwKey : Text, bwTries : Natural }
{ Type = { bwKey : Text, bwTries : Natural }, default.bwTries = 3 }
let SecretMap = { sKey : Text, sVal : Text } let SecretMap = { sKey : Text, sVal : Text }
let SecretConfig = { secretAttributes : List SecretMap } let SecretConfig = { secretAttributes : List SecretMap }
let PromptConfig = { Type = { promptTries : Natural }, default.promptTries = 3 } let PromptConfig = { promptTries : Natural }
let PasswordConfig = let PasswordConfig =
< PwdBW : BitwardenConfig.Type < PwdBW : BitwardenConfig | PwdLS : SecretConfig | PwdPr : PromptConfig >
| PwdLS : SecretConfig
| PwdPr : PromptConfig.Type
>
let SSHFSData = let SSHFSData = { sshfsRemote : Text, sshfsPassword : Optional PasswordConfig }
{ Type = { sshfsRemote : Text, sshfsPassword : Optional PasswordConfig }
, default.sshfsPassword = None PasswordConfig
}
let CIFSOpts = let CIFSOpts =
{ Type =
{ cifsoptsUsername : Optional Text { cifsoptsUsername : Optional Text
, cifsoptsWorkgroup : Optional Text , cifsoptsWorkgroup : Optional Text
, cifsoptsDomain : Optional Text
, cifsoptsUID : Optional Natural , cifsoptsUID : Optional Natural
, cifsoptsGID : Optional Natural , cifsoptsGID : Optional Natural
, cifsoptsIocharset : Optional Text , cifsoptsIocharset : Optional Text
} }
, default =
{ cifsoptsUsername = None Text
, cifsoptsWorkgroup = None Text
, cifsoptsDomain = None Text
, cifsoptsUID = None Natural
, cifsoptsGID = None Natural
, cifsoptsIocharset = None Text
}
}
let CIFSData = let CIFSData =
{ Type =
{ cifsRemote : Text { cifsRemote : Text
, cifsSudo : Bool , cifsSudo : Bool
, cifsPassword : Optional PasswordConfig , cifsPassword : Optional PasswordConfig
, cifsOpts : Optional CIFSOpts.Type , cifsOpts : Optional CIFSOpts
}
, default =
{ cifsSudo = False
, cifsPassword = None PasswordConfig
, cifsOpts = Some CIFSOpts::{=}
}
} }
let VeracryptData = let VeracryptData = { vcVolume : Text, vcPassword : Optional PasswordConfig }
{ Type =
{ vcVolume : Text
, vcPassword
{- TODO this shouldn't be optional -}
: Optional PasswordConfig
}
, default.vcPassword = None PasswordConfig
}
let DataConfig = let DataConfig =
< VeracryptConfig : VeracryptData.Type < VeracryptConfig : VeracryptData
| SSHFSConfig : SSHFSData.Type | SSHFSConfig : SSHFSData
| CIFSConfig : CIFSData.Type | CIFSConfig : CIFSData
> >
let DeviceConfig = { deviceMount : MountConfig, deviceData : DataConfig } let DeviceConfig = { deviceMount : MountConfig, deviceData : DataConfig }
let TreeConfig = let TreeConfig = { tcParent : DeviceConfig, tcChildren : List Text }
{ Type = { tcParent : DeviceConfig, tcChildren : List Text }
, default.tcChildren = [] : List Text
}
let TreeMap = { tKey : Text, tVal : TreeConfig.Type } let TreeMap = { tKey : Text, tVal : TreeConfig }
let StaticConfig = let StaticConfig =
{ Type =
{ scTmpPath : Optional Text { scTmpPath : Optional Text
, scVerbose : Optional Bool , scVerbose : Optional Bool
, scDevices : List TreeMap , scDevices : List TreeMap
} }
, default =
{ scTmpPath =
{- defaults to /tmp/media/{username} -}
None Text
, scVerbose = Some False
}
}
in { StaticConfig in { StaticConfig
, TreeConfig , TreeConfig

View File

@ -69,8 +69,8 @@ hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey c] -> [T.Text] hotkeyArgs :: [Hotkey c] -> [T.Text]
hotkeyArgs hks = hotkeyArgs hks =
hotkeyMsg hks (hotkeyMsg hks)
++ concatMap (uncurry hotkeyBinding) (take 19 $ zip [1 ..] hks) ++ (concatMap (uncurry hotkeyBinding) $ take 19 $ zip [1 ..] hks)
data RofiMenu c = RofiMenu data RofiMenu c = RofiMenu
{ groups :: ![RofiGroup c] { groups :: ![RofiGroup c]
@ -129,7 +129,7 @@ selectAction rm = do
-- keybindings are labeled 1-19 and thus need to be explicitly -- keybindings are labeled 1-19 and thus need to be explicitly
-- indexed, and the program itself tells the world which key was -- indexed, and the program itself tells the world which key was
-- pressed via return code (any possible integer) -- pressed via return code (any possible integer)
(V.fromList (hotkeys rm) V.!? (n - 10)) ((V.fromList $ hotkeys rm) V.!? (n - 10))
runRofi :: (MonadIO m, HasRofiConf c) => c -> RofiMenu c -> m () runRofi :: (MonadIO m, HasRofiConf c) => c -> RofiMenu c -> m ()
runRofi c = runRIO c . selectAction runRofi c = runRIO c . selectAction
@ -171,7 +171,7 @@ readCmdEither'
-> m (Either (Int, T.Text, T.Text) T.Text) -> m (Either (Int, T.Text, T.Text) T.Text)
readCmdEither' cmd args input environ = readCmdEither' cmd args input environ =
resultToEither resultToEither
<$> liftIO (readCreateProcessWithExitCode p (T.unpack input)) <$> (liftIO $ readCreateProcessWithExitCode p (T.unpack input))
where where
e = case environ of e = case environ of
[] -> Nothing [] -> Nothing

View File

@ -16,8 +16,8 @@ notify icon summary body =
liftIO $ liftIO $
void $ void $
spawnProcess "notify-send" $ spawnProcess "notify-send" $
maybe args ((\b -> args ++ [b]) . T.unpack) maybe args (\b -> args ++ [b]) $
body fmap T.unpack body
where where
args = ["-i", show icon, T.unpack summary] args = ["-i", show icon, T.unpack summary]