diff --git a/app/rofi-dev.hs b/app/rofi-dev.hs index 7a0df19..fafdae8 100644 --- a/app/rofi-dev.hs +++ b/app/rofi-dev.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -24,6 +25,7 @@ import Data.List.Split (splitOn) import qualified Data.Map as M import qualified Data.Map.Ordered as O import Data.Maybe +import qualified Data.Text as T import qualified Data.Vector as V import Data.Yaml @@ -48,18 +50,37 @@ main = getArgs >>= parse parse :: [String] -> IO () parse args = case getOpt Permute options args of - (o, n, []) -> initMountConf n >>= \i -> runMounts $ foldl (flip id) i o + -- (o, n, []) -> initMountConf n >>= \i -> runMounts $ foldl (flip id) i o + (o, n, []) -> runMounts $ foldl (flip id) (defaultOpts n) o (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options where h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]" + defaultOpts r = Opts + { optsConfig = Nothing + , optsAlias = Nothing + , optsUnmount = False + , optsRofiArgs = r + } -options :: [OptDescr (MountConf -> MountConf)] +options :: [OptDescr (Opts -> Opts)] options = [ Option ['c'] ["config"] - (ReqArg (\s m -> m { mConfig = Just s } ) "CONF") + (ReqArg (\s m -> m { optsConfig = Just s } ) "CONF") "The path to the config file" + , Option ['m'] ["mount"] + (ReqArg (\s m -> m { optsAlias = Just s } ) "ALIAS") + "Mount the device specified by ALIAS directly" + , Option ['u'] ["unmount"] (NoArg (\m -> m { optsUnmount = True } )) + "Unmount the device specified by ALIAS instead of mounting it." ] +data Opts = Opts + { optsConfig :: Maybe FilePath + , optsAlias :: Maybe String + , optsUnmount :: Bool + , optsRofiArgs :: [String] + } deriving Show + -------------------------------------------------------------------------------- -- | Static configuration -- @@ -69,6 +90,9 @@ options = defaultTries :: Integer defaultTries = 2 +(.:&) :: FromJSON a => Object -> T.Text -> Parser (V.Vector a) +(.:&) o t = o .:? t .!= V.empty + data MountConfig = MountConfig { _mountMountPoint :: FilePath , _mountLabel :: Maybe String @@ -79,6 +103,18 @@ instance FromJSON MountConfig where <$> o .: "mountpoint" <*> o .:? "label" +data DependsConfig = DependsConfig + { _dependsVeracrypt :: V.Vector String + , _dependsSSHFS :: V.Vector String + , _dependsCIFS :: V.Vector String + } deriving Show + +instance FromJSON DependsConfig where + parseJSON = withObject "depends" $ \o -> DependsConfig + <$> o .:& "veracrypt" + <*> o .:& "sshfs" + <*> o .:& "cifs" + data BitwardenConfig = BitwardenConfig { _bitwardenKey :: String , _bitwardenTries :: Integer } @@ -121,6 +157,7 @@ instance FromJSON PasswordConfig where data VeracryptConfig = VeracryptConfig { _veracryptMount :: MountConfig , _veracryptVolume :: String + , _veracryptDepends :: Maybe DependsConfig , _veracryptPassword :: Maybe PasswordConfig } deriving Show @@ -128,21 +165,25 @@ instance FromJSON VeracryptConfig where parseJSON = withObject "veracrypt" $ \o -> VeracryptConfig <$> o .: "mount" <*> o .: "volume" + <*> o .:? "depends" <*> o .:? "password" data SSHFSConfig = SSHFSConfig { _sshfsMount :: MountConfig , _sshfsRemote :: String + , _sshfsDepends :: Maybe DependsConfig } deriving Show instance FromJSON SSHFSConfig where parseJSON = withObject "sshfs" $ \o -> SSHFSConfig <$> o .: "mount" <*> o .: "remote" + <*> o .:? "depends" data CIFSConfig = CIFSConfig { _cifsMount :: MountConfig , _cifsRemote :: String + , _cifsDepends :: Maybe DependsConfig , _cifsPassword :: Maybe PasswordConfig } deriving Show @@ -150,12 +191,49 @@ instance FromJSON CIFSConfig where parseJSON = withObject "cifs" $ \o -> CIFSConfig <$> o .: "mount" <*> o .: "remote" - <*> o .: "password" + <*> o .:? "depends" + <*> o .:? "password" + +-- data DeviceConfig = VeracryptConfig +-- { _veracryptMount :: MountConfig +-- , _veracryptVolume :: String +-- , _veracryptDepends :: Maybe DependsConfig +-- , _veracryptPassword :: Maybe PasswordConfig +-- } | SSHFSConfig +-- { _sshfsMount :: MountConfig +-- , _sshfsRemote :: String +-- , _sshfsDepends :: Maybe DependsConfig +-- } | CIFSConfig +-- { _cifsMount :: MountConfig +-- , _cifsRemote :: String +-- , _cifsDepends :: Maybe DependsConfig +-- , _cifsPassword :: Maybe PasswordConfig +-- } deriving Show + +-- instance FromJSON DeviceConfig where +-- parseJSON = withObject "devices" $ \o -> do +-- devType <- o .: "type" +-- case devType of +-- "cifs" -> CIFSConfig +-- <$> o .: "mount" +-- <*> o .: "remote" +-- <*> o .:? "depends" +-- <*> o .:? "password" +-- "sshfs" -> SSHFSConfig +-- <$> o .: "mount" +-- <*> o .: "remote" +-- <*> o .:? "depends" +-- "veracrypt" -> VeracryptConfig +-- <$> o .: "mount" +-- <*> o .: "volume" +-- <*> o .:? "depends" +-- <*> o .:? "password" +-- _ -> fail "unknown device type" data DevicesConfig = DevicesConfig - { _veracryptConfigs :: V.Vector VeracryptConfig - , _sshfsConfigs :: V.Vector SSHFSConfig - , _cifsConfigs :: V.Vector CIFSConfig + { _veracryptConfigs :: M.Map String VeracryptConfig + , _sshfsConfigs :: M.Map String SSHFSConfig + , _cifsConfigs :: M.Map String CIFSConfig } deriving Show instance FromJSON DevicesConfig where @@ -165,8 +243,9 @@ instance FromJSON DevicesConfig where <*> o .: "cifs" data StaticConfig = StaticConfig - { _tmpMountDir :: Maybe String - , _devicesConfig :: Maybe DevicesConfig + { _staticconfigTmpPath :: Maybe String + , _staticconfigDevices :: Maybe DevicesConfig + -- , _staticconfigDevices :: M.Map String DeviceConfig } deriving Show instance FromJSON StaticConfig where @@ -182,13 +261,15 @@ instance FromJSON StaticConfig where -- from the parse tree. class Mountable m => StaticDevice m a where - -- | Mount the given type (or dismount if False is passed) - fromConfig :: V.Vector a -> RofiIO MountConf [m] - fromConfig s = do - v <- asks mountDir - return $ configToDev v <$> V.toList s + fromConfig :: DevicesConfig -> (DevicesConfig -> M.Map String a) -> RofiIO MountConf [m] + fromConfig s f = fromConfig' s (M.elems . f) - configToDev :: FilePath -> a -> m + fromConfig' :: DevicesConfig -> (DevicesConfig -> [a]) -> RofiIO MountConf [m] + fromConfig' s f = do + v <- asks mountconfVolatilePath + mapM (configToDev v s) $ f s + + configToDev :: FilePath -> DevicesConfig -> a -> RofiIO MountConf m -------------------------------------------------------------------------------- -- | Global config used in the reader monad stack @@ -201,24 +282,13 @@ class Mountable m => StaticDevice m a where -- - any arguments to be passed to the rofi command data MountConf = MountConf - { mountDir :: FilePath - , rofiArgs :: [String] - , mConfig :: Maybe FilePath - , devConfig :: Maybe DevicesConfig + { mountconfVolatilePath :: FilePath + , mountconfRofiArgs :: [String] + , mountconfStaticDevs :: Maybe DevicesConfig } instance RofiConf MountConf where - defArgs MountConf { rofiArgs = a } = a - -initMountConf :: [String] -> IO MountConf -initMountConf a = conf <$> getEffectiveUserName - where - conf u = MountConf - { mountDir = "/tmp/media" u - , rofiArgs = a - , mConfig = Nothing - , devConfig = Nothing - } + defArgs MountConf { mountconfRofiArgs = a } = a -------------------------------------------------------------------------------- -- | Password-getting functions @@ -268,19 +338,27 @@ configToPwd PasswordConfig{ _passwordBitwarden = b -- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like -- pretty things, so ensure the entries are aligned properly as well -runMounts :: MountConf -> IO () -runMounts c = do - c' <- maybe (return c) parseConfig (mConfig c) - runRofiIO c' $ runPrompt =<< getGroups - where - parseConfig m = do - res <- decodeFileEither m - case res of - Left e -> print e >> return c - Right StaticConfig { _tmpMountDir = Just v, _devicesConfig = dc } -> - return $ c { mountDir = v, devConfig = dc } - Right StaticConfig { _devicesConfig = dc } -> - return $ c { devConfig = dc } +runMounts :: Opts -> IO () +runMounts opts = do + static <- join <$> traverse parseStaticConfig (optsConfig opts) + defaultTmpPath <- ("/tmp/media" ) <$> getEffectiveUserName + let tmpPath = fromMaybe defaultTmpPath (_staticconfigTmpPath =<< static) + let staticDevs = _staticconfigDevices =<< static + let mountconf = MountConf + { mountconfVolatilePath = tmpPath + , mountconfRofiArgs = optsRofiArgs opts + , mountconfStaticDevs = staticDevs + } + let byAlias = mountByAlias $ optsUnmount opts + let byPrompt = runPrompt =<< getGroups + runRofiIO mountconf $ maybe byPrompt byAlias $ optsAlias opts + +parseStaticConfig :: FilePath -> IO (Maybe StaticConfig) +parseStaticConfig p = do + res <- decodeFileEither p + case res of + Left e -> print e >> return Nothing + Right c -> return $ Just c runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c () runPrompt gs = selectAction $ emptyMenu @@ -291,14 +369,7 @@ runPrompt gs = selectAction $ emptyMenu getGroups :: RofiIO MountConf [RofiGroup MountConf] getGroups = do sysd <- io getSystemdDevices - devConf <- asks devConfig - (cifsDevs, sshfsDevs, vcDevs) <- maybe - (return ( [] :: [CIFS], [] :: [SSHFS], [] :: [VeraCrypt])) - (\c -> liftM3 (,,) - (fromConfig $ _cifsConfigs c) - (fromConfig $ _sshfsConfigs c) - (fromConfig $ _veracryptConfigs c)) - devConf + (cifsDevs, sshfsDevs, vcDevs) <- getStaticDevices sequence [ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) sshfsDevs , mkGroup "CIFS Devices" cifsDevs @@ -309,6 +380,34 @@ getGroups = do where filterSysd t = filter (\s -> sysdType s == t) +mountByAlias :: Bool -> String -> RofiIO MountConf () +mountByAlias unmountFlag alias = do + static <- asks mountconfStaticDevs + forM_ static $ \static' -> do + volatilePath <- asks mountconfVolatilePath + c <- toDev volatilePath static' _cifsConfigs alias + s <- toDev volatilePath static' _sshfsConfigs alias + v <- toDev volatilePath static' _veracryptConfigs alias + mountIfJust (c :: Maybe CIFS) + $ mountIfJust (s :: Maybe SSHFS) + $ mountIfJust (v :: Maybe VeraCrypt) (return ()) + where + toDev v s f = mapM (configToDev v s) . aliasToDevice s f + mountIfJust a b = if isNothing a then b else forM_ a $ flip mount unmountFlag + +aliasToDevice :: DevicesConfig -> (DevicesConfig -> M.Map String a) -> String -> Maybe a +aliasToDevice d f = flip M.lookup (f d) + +getStaticDevices :: RofiIO MountConf ([CIFS], [SSHFS], [VeraCrypt]) +getStaticDevices = do + static <- asks mountconfStaticDevs + maybe (return ( [] :: [CIFS], [] :: [SSHFS], [] :: [VeraCrypt])) + (\c -> liftM3 (,,) + (fromConfig c _cifsConfigs) + (fromConfig c _sshfsConfigs) + (fromConfig c _veracryptConfigs)) + static + mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf) mkGroup header devs = sortGroup header <$> mapM mkAction devs @@ -391,10 +490,14 @@ getRemovableDevices = fromLines toDev . lines -- This wraps the Removable device (since it is removable) and also adds its -- own mount options and passwords for authentication. -data CIFS = CIFS Removable FilePath (Maybe PasswordGetter) +data CIFS = CIFS Removable FilePath (Maybe PasswordGetter) Dependency + +instance Show CIFS where + show (CIFS r f _ d) = unwords [show r, show f, "", show d] instance Mountable CIFS where - mount (CIFS Removable{ label = l } m getPwd) False = + mount (CIFS Removable{ label = l } m getPwd deps) False = do + mountDependencies deps bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) @@ -406,20 +509,22 @@ instance Mountable CIFS where Nothing -> readCmdEither "mount" [m] "" notifyMounted (isRight res) False l - mount (CIFS Removable{ label = l } m _) True = umountNotify l m + mount (CIFS Removable{ label = l } m _ _) True = umountNotify l m allInstalled _ = io $ isJust <$> findExecutable "mount.cifs" - isMounted (CIFS _ dir _) = io $ isDirMounted dir + isMounted (CIFS _ dir _ _) = io $ isDirMounted dir - fmtEntry (CIFS r _ _) = fmtEntry r + fmtEntry (CIFS r _ _ _) = fmtEntry r instance StaticDevice CIFS CIFSConfig where - configToDev v CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m } - , _cifsRemote = t - , _cifsPassword = p } = + configToDev v s CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m } + , _cifsRemote = t + , _cifsDepends = d + , _cifsPassword = p } = do let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m } - in CIFS r (appendRoot v m) $ configToPwd <$> p + d' <- maybe (return initDependencies) (getDependencies s) d + return $ CIFS r (appendRoot v m) (configToPwd <$> p) d' where smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a @@ -431,37 +536,44 @@ instance StaticDevice CIFS CIFSConfig where -- config that specifies the port, hostname, user, and identity file, these -- need to be passed as mount options. -data SSHFS = SSHFS Removable FilePath +data SSHFS = SSHFS Removable FilePath Dependency deriving Show instance Mountable SSHFS where - mount (SSHFS Removable{ deviceSpec = d, label = l } m) False = do + mount (SSHFS Removable{ deviceSpec = d, label = l } m deps) False = do + mountDependencies deps bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) (io $ runMountNotify "sshfs" [d, m] l False) - mount (SSHFS Removable{ label = l } m) True = umountNotify l m + mount (SSHFS Removable{ label = l } m _) True = umountNotify l m allInstalled _ = fmap isJust $ io $ findExecutable "sshfs" - isMounted (SSHFS _ dir) = io $ isDirMounted dir + isMounted (SSHFS _ dir _) = io $ isDirMounted dir - fmtEntry (SSHFS r _) = fmtEntry r + fmtEntry (SSHFS r _ _) = fmtEntry r instance StaticDevice SSHFS SSHFSConfig where - configToDev v SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m } - , _sshfsRemote = t } = + configToDev v s SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m } + , _sshfsDepends = d + , _sshfsRemote = t } = do let r = Removable { deviceSpec = t, label = takeFileName m } - in SSHFS r (appendRoot v m) + d' <- maybe (return initDependencies) (getDependencies s) d + return $ SSHFS r (appendRoot v m) d' -------------------------------------------------------------------------------- -- | VeraCrypt Devices -- -data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) +data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) Dependency + +instance Show VeraCrypt where + show (VeraCrypt r f _ d) = unwords [show r, show f, show d] instance Mountable VeraCrypt where - mount (VeraCrypt Removable{ deviceSpec = s, label = l } m getPwd) False = + mount (VeraCrypt Removable{ deviceSpec = s, label = l } m getPwd deps) False = do + mountDependencies deps bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) mountMaybe where mountMaybe = io $ maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) getPwd @@ -471,15 +583,15 @@ instance Mountable VeraCrypt where notifyFail = notify "dialog-error-symbolic" $ printf "Failed to get volume password for %s" l - mount (VeraCrypt Removable{ label = l } m _) True = io $ do + mount (VeraCrypt Removable{ label = l } m _ _) True = io $ do res <- runVeraCrypt "" ["-d", m] notifyMounted (isRight res) True l allInstalled _ = io $ isJust <$> findExecutable "veracrypt" - isMounted (VeraCrypt _ dir _) = io $ isDirMounted dir + isMounted (VeraCrypt _ dir _ _) = io $ isDirMounted dir - fmtEntry (VeraCrypt r _ _) = fmtEntry r + fmtEntry (VeraCrypt r _ _ _) = fmtEntry r -- NOTE: the user is assumed to have added themselves to the sudoers file so -- that this command will work @@ -490,11 +602,56 @@ runVeraCrypt stdin args = do defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"] instance StaticDevice VeraCrypt VeracryptConfig where - configToDev v VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m } - , _veracryptVolume = t - , _veracryptPassword = p } = + configToDev v s VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m } + , _veracryptVolume = t + , _veracryptDepends = d + , _veracryptPassword = p } = do let r = Removable { deviceSpec = t, label = takeFileName m } - in VeraCrypt r (appendRoot v m) $ configToPwd <$> p + d' <- maybe (return initDependencies) (getDependencies s) d + return $ VeraCrypt r (appendRoot v m) (configToPwd <$> p) d' + +-------------------------------------------------------------------------------- +-- | Dependencies +-- +-- Define a data structure that allows one device to depend on another. Since +-- each device is different and has a different typeclass instance, need to +-- include slots for all possible devices. For now only deal with static +-- devices. + +data Dependency = Dependency + { dependencySSHFS :: [SSHFS] + , dependencyCIFS :: [CIFS] + , dependencyVeracrypt :: [VeraCrypt] + } deriving Show + +initDependencies :: Dependency +initDependencies = Dependency [] [] [] + +getDependencies :: DevicesConfig -> DependsConfig -> RofiIO MountConf Dependency +getDependencies devConf DependsConfig { _dependsCIFS = c + , _dependsSSHFS = s + , _dependsVeracrypt = v} = do + c' <- getDepConfigs c _cifsConfigs + s' <- getDepConfigs s _sshfsConfigs + v' <- getDepConfigs v _veracryptConfigs + return Dependency + { dependencyCIFS = c' + , dependencySSHFS = s' + , dependencyVeracrypt = v' + } + where + getDepConfigs aliases getConfig = fromConfig' devConf + $ M.elems . M.filterWithKey (\k _ -> k `elem` V.toList aliases) . getConfig + +mountDependencies :: Dependency -> RofiIO MountConf () +mountDependencies Dependency { dependencyCIFS = c + , dependencySSHFS = s + , dependencyVeracrypt = v + } = + mountAll c >> mountAll s >> mountAll v + where + mountAll :: Mountable a => [a] -> RofiIO MountConf () + mountAll = mapM_ (\d -> isMounted d >>= (\r -> unless r $ mount d False)) -------------------------------------------------------------------------------- -- | MTP devices @@ -533,7 +690,7 @@ instance Mountable MTPFS where -- | Return list of all available MTP devices getMTPDevices :: RofiIO MountConf [MTPFS] getMTPDevices = do - dir <- asks mountDir + dir <- asks mountconfVolatilePath res <- io $ readProcess "jmtpfs" ["-l"] "" return $ fromLines (toDev dir) $ toDevList res where @@ -669,7 +826,7 @@ mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp rmDirMaybe :: FilePath -> RofiIO MountConf () rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp - $ asks mountDir >>= io . rmUntil fp + $ asks mountconfVolatilePath >>= io . rmUntil fp where rmUntil cur target = unless (target == cur) $ do removePathForcibly cur @@ -677,7 +834,7 @@ rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp whenInMountDir :: FilePath -> RofiIO MountConf () -> RofiIO MountConf () whenInMountDir fp f = do - mDir <- asks mountDir + mDir <- asks mountconfVolatilePath when (mDir `isPrefixOf` fp) f unlessMountpoint :: FilePath -> RofiIO MountConf () -> RofiIO MountConf () diff --git a/package.yaml b/package.yaml index fbbb876..11af86c 100644 --- a/package.yaml +++ b/package.yaml @@ -33,6 +33,7 @@ dependencies: - split >= 0.2.3.3 - containers >= 0.6.0.1 - filepath >= 1.4.2.1 +- text >= 1.2.3.1 - unliftio >= 0.2.12 - unliftio-core >= 0.1.2.0 - X11 >= 1.9.1