ADD cifs domain option

app/rofi-dev.hs

@@ -37,17 +37,17 @@ makeHaskellTypesWith
   , 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 "StaticConfig" "StaticConfig" "(./dhall/rofi-dev.dhall).StaticConfig.Type"
+  , SingleConstructor "PromptConfig" "PromptConfig" "(./dhall/rofi-dev.dhall).PromptConfig.Type"
+  , SingleConstructor "TreeConfig" "TreeConfig" "(./dhall/rofi-dev.dhall).TreeConfig.Type"
   , 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"
+  , SingleConstructor "BitwardenConfig" "BitwardenConfig" "(./dhall/rofi-dev.dhall).BitwardenConfig.Type"
+  , SingleConstructor "VeracryptData" "VeracryptData" "(./dhall/rofi-dev.dhall).VeracryptData.Type"
+  , SingleConstructor "CIFSData" "CIFSData" "(./dhall/rofi-dev.dhall).CIFSData.Type"
+  , SingleConstructor "CIFSOpts" "CIFSOpts" "(./dhall/rofi-dev.dhall).CIFSOpts.Type"
+  , SingleConstructor "SSHFSData" "SSHFSData" "(./dhall/rofi-dev.dhall).SSHFSData.Type"
   ]
 
 main :: IO ()
@@ -176,12 +176,12 @@ mountByAlias unmountFlag alias = do
 mkGroup :: NE.NonEmpty (Header, ProtoAction) -> RofiGroup MountConf
 mkGroup as = titledGroup h $ toRofiActions $ NE.toList $ alignEntries $ snd <$> as
   where
-    h = (T.pack $ show $ fst $ NE.head as)
+    h = T.pack $ show $ fst $ NE.head as
 
 alignSep :: T.Text
 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
   where
     (es, as) = NE.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
@@ -190,10 +190,10 @@ alignEntries ps = NE.zip (align es) as
         . NE.transpose
         . fmap1 padAll
         . 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
     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 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
   -- | Return a string to go in the Rofi menu for the given type
   fmtEntry :: a -> NE.NonEmpty T.Text
-  fmtEntry d = (getLabel d :| [])
+  fmtEntry d = getLabel d :| []
 
   groupHeader :: a -> Header
 
@@ -283,7 +283,7 @@ class Mountable a => Actionable a where
     let h = groupHeader dev
     let action = when i $ mountMaybe dev $ mountedState m
     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)
     where
       mountedPrefix _ False = "! "
@@ -346,7 +346,7 @@ instance Mountable a => Mountable (Tree a) where
   getLabel (Tree p _) = getLabel p
 
 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
       target (CIFSConfig (CIFSData {cifsRemote = r})) = r
       target (SSHFSConfig (SSHFSData {sshfsRemote = r})) = r
@@ -462,6 +462,7 @@ fromCIFSOpts o = T.intercalate "," $ mapMaybe concatMaybe fs
     fs =
       [ ("username", cifsoptsUsername)
       , ("workgroup", cifsoptsWorkgroup)
+      , ("domain", cifsoptsDomain)
       , ("uid", fmap (T.pack . show) . cifsoptsUID)
       , ("gid", fmap (T.pack . show) . cifsoptsGID)
       , ("iocharset", cifsoptsIocharset)
@@ -551,7 +552,7 @@ runPromptLoop n pwd = do
 configToPwd :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => PasswordConfig -> PasswordGetter m
 configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) =
   runPromptLoop n $ runBitwarden k
-configToPwd (PwdLS s) = runSecret $ M.fromList $ fmap (\(SecretMap k v) -> (k, v)) $ secretAttributes s
+configToPwd (PwdLS s) = runSecret $ M.fromList $ (\(SecretMap k v) -> (k, v)) <$> secretAttributes s
 configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
 
 withPasswordGetter
@@ -593,7 +594,7 @@ instance Mountable Removable where
   getLabel Removable {removableLabel = l} = l
 
 instance Actionable Removable where
-  fmtEntry Removable {removablePath = d, removableLabel = l} = (l :| [d])
+  fmtEntry Removable {removablePath = d, removableLabel = l} = l :| [d]
 
   groupHeader _ = RemovableHeader
 
@@ -689,7 +690,7 @@ mtpExeInstalled :: MonadIO m => m Bool
 mtpExeInstalled = isJust <$> findExecutable mtpExe
 
 instance Actionable MTPFS where
-  fmtEntry d = (getLabel d :| [])
+  fmtEntry d = getLabel d :| []
 
   groupHeader _ = MTPFSHeader
 
@@ -732,9 +733,16 @@ runMountSudoMaybe' useSudo cmd args environ =
 -- 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' rootpass cmd args environ = runMount "sudo" args' rootpass
+runSudoMount' rootpass cmd args environ = do
+  -- 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
-    args' = ["-S"] ++ environ' ++ [cmd] ++ args
+    run = runMount "sudo" args' ""
+    args' = ["-n"] ++ environ' ++ [cmd] ++ args
     environ' = fmap (\(k, v) -> T.concat [k, "=", v]) environ
 
 eitherToMountResult :: Either (Int, T.Text, T.Text) T.Text -> MountResult

dhall/rofi-dev.dhall

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

lib/Rofi/Command.hs

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

lib/Rofi/IO.hs

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