diff --git a/app/rofi-dev.hs b/app/rofi-dev.hs index 2b33815..0aefe62 100644 --- a/app/rofi-dev.hs +++ b/app/rofi-dev.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | rofi-dev - a rofi prompt for mountable devices +-- rofi-dev - a rofi prompt for mountable devices -- -- Like all "mount helpers" this is basically a wrapper for low-level utilities -- the mount things from the command line. It also creates/destroys mountpoint @@ -13,73 +13,75 @@ module Main (main) where -import Bitwarden.Internal - -import Control.Lens -import Control.Monad -import Control.Monad.Reader - -import Data.List -import Data.List.Split (splitOn) -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Text as T -import Data.Typeable -import qualified Data.Vector as V - -import Dhall hiding (maybe, sequence, void) -import qualified Dhall.Map as DM - -import Rofi.Command - -import Text.Printf - -import System.Console.GetOpt -import System.Directory -import System.Environment -import System.FilePath.Posix -import System.Posix.User (getEffectiveUserName) -import System.Process - -import UnliftIO.Exception +import Bitwarden.Internal +import Control.Lens +import Control.Monad +import Control.Monad.Reader +import Data.List +import Data.List.Split (splitOn) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Data.Typeable +import qualified Data.Vector as V +import Dhall hiding (maybe, sequence, void) +import qualified Dhall.Map as DM +import Rofi.Command +import System.Console.GetOpt +import System.Directory +import System.Environment +import System.FilePath.Posix +import System.Posix.User (getEffectiveUserName) +import System.Process +import Text.Printf +import UnliftIO.Exception main :: IO () main = getArgs >>= parse parse :: [String] -> IO () parse args = case getOpt Permute options args of - (o, n, []) -> runMounts $ foldl (flip id) (defaultOpts n) 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 - } + defaultOpts r = + Opts + { optsConfig = Nothing + , optsAlias = Nothing + , optsUnmount = False + , optsRofiArgs = r + } options :: [OptDescr (Opts -> Opts)] options = - [ Option ['c'] ["config"] - (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." + [ Option + ['c'] + ["config"] + (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 + { optsConfig :: Maybe FilePath + , optsAlias :: Maybe String + , optsUnmount :: Bool , optsRofiArgs :: [String] - } deriving Show + } + deriving (Show) -------------------------------------------------------------------------------- --- | Main prompt +-- Main prompt -- -- This command will have one Rofi prompt and will display all available -- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like @@ -92,12 +94,13 @@ runMounts opts = do let tmpPath = fromMaybe defaultTmpPath $ scTmpPath =<< static let staticDevs = maybe M.empty scDevices static let verbose = fromMaybe False $ scVerbose =<< static - let mountconf = MountConf - { mountconfVolatilePath = tmpPath - , mountconfRofiArgs = optsRofiArgs opts - , mountconfStaticDevs = staticDevs - , mountconfVerbose = verbose - } + let mountconf = + MountConf + { mountconfVolatilePath = tmpPath + , mountconfRofiArgs = optsRofiArgs opts + , mountconfStaticDevs = staticDevs + , mountconfVerbose = verbose + } let byAlias = mountByAlias $ optsUnmount opts let byPrompt = runPrompt =<< getGroups runRofiIO mountconf $ maybe byPrompt byAlias $ optsAlias opts @@ -106,40 +109,64 @@ parseStaticConfig :: FilePath -> IO (Maybe StaticConfig) parseStaticConfig p = do res <- try $ inputFileWithSettings es auto p case res of - Left e -> print (e :: SomeException) >> return Nothing + Left e -> print (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, maximum $ expected a)) - $ listToMaybe $ snd $ splitTyConApp $ typeOf a + 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, maximum $ expected a)) $ + listToMaybe $ + snd $ + splitTyConApp $ + typeOf a runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c () -runPrompt gs = selectAction $ emptyMenu - { groups = gs - , prompt = Just "Select Device" - } +runPrompt gs = + selectAction $ + emptyMenu + { groups = gs + , prompt = Just "Select Device" + } getGroups :: RofiMountIO [RofiGroup MountConf] getGroups = do actions <- sequence [getStaticActions, getRemovableActions, getMTPActions] - return $ mapMaybe mkGroup - $ groupBy (\(hx, _) (hy, _) -> hx == hy) - $ sortBy (\(hx, _) (hy, _) -> compare hx hy) - $ concat actions + return $ + (++ [metaActions]) $ + mapMaybe mkGroup $ + groupBy (\(hx, _) (hy, _) -> hx == hy) $ + sortBy (\(hx, _) (hy, _) -> compare hx hy) $ + concat actions + where + metaActions = + titledGroup "Meta Actions" $ + toRofiActions [(" Dismount All", dismountAll)] + +dismountAll :: RofiMountIO () +dismountAll = do + umount =<< asks (configToTree' . mountconfStaticDevs) + umount =<< getRemovableDevices + umount =<< getMTPDevices + return () + where + umount :: Mountable a => [a] -> RofiMountIO () + umount = mapM_ (`mountMaybe` True) mountByAlias :: Bool -> String -> RofiMountIO () mountByAlias unmountFlag alias = do @@ -148,8 +175,9 @@ mountByAlias unmountFlag alias = do mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf) mkGroup [] = Nothing -mkGroup as = let ((h, _):_) = as in - Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as +mkGroup as = + let ((h, _) : _) = as + in Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as alignSep :: String alignSep = " | " @@ -158,31 +186,33 @@ alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())] alignEntries ps = zip (align es) as where (es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps - align = fmap (intercalate alignSep) - . transpose - . mapToLast pad - . transpose + align = + fmap (intercalate alignSep) + . transpose + . mapToLast pad + . transpose pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs getMax = maximum . fmap length - mapToLast _ [] = [] - mapToLast _ [x] = [x] - mapToLast f (x:xs) = f x : mapToLast f xs + mapToLast _ [] = [] + mapToLast _ [x] = [x] + mapToLast f (x : xs) = f x : mapToLast f xs -------------------------------------------------------------------------------- --- | Global config used in the reader monad stack +-- Global config used in the reader monad stack data MountConf = MountConf { mountconfVolatilePath :: FilePath - , mountconfRofiArgs :: [String] - , mountconfStaticDevs :: M.Map String TreeConfig - , mountconfVerbose :: Bool - } deriving Show + , mountconfRofiArgs :: [String] + , mountconfStaticDevs :: M.Map String TreeConfig + , mountconfVerbose :: Bool + } + deriving (Show) instance RofiConf MountConf where - defArgs MountConf { mountconfRofiArgs = a } = a + defArgs MountConf {mountconfRofiArgs = a} = a -------------------------------------------------------------------------------- --- | Mountable typeclass +-- Mountable typeclass -- -- Class to provide common interface for anything that can be mounted. @@ -190,7 +220,7 @@ data MountState = Unmounted | Mounted | Partial deriving (Show, Eq) mountedState :: MountState -> Bool mountedState Mounted = True -mountedState _ = False +mountedState _ = False class Mountable a where -- | Mount the given type (or dismount if False is passed) @@ -219,7 +249,7 @@ class Mountable a where mountState :: a -> RofiMountIO MountState -------------------------------------------------------------------------------- --- | Actionable typeclass +-- Actionable typeclass -- -- Class to provide common interface for anything that can be presented in the -- Rofi menu as an action. Note that this must be separate from the Mountable @@ -243,22 +273,26 @@ 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) -> (mountedPrefix m i ++ e):es - _ -> [] + (e : es) -> (mountedPrefix m i ++ e) : es + _ -> [] return (h, ProtoAction entry action) where - mountedPrefix _ False = "! " + mountedPrefix _ False = "! " mountedPrefix Unmounted True = " " - mountedPrefix Mounted True = "* " - mountedPrefix Partial True = "- " + mountedPrefix Mounted True = "* " + mountedPrefix Partial True = "- " -mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])] +mountableToAction + :: Actionable a + => RofiMountIO [a] + -> RofiMountIO [(Header, ProtoAction [String])] mountableToAction ms = mapM mkAction =<< ms type RofiMountIO a = RofiIO MountConf a -- headers appear in the order listed here (per Enum) -data Header = CIFSHeader +data Header + = CIFSHeader | SSHFSHeader | VeracryptHeader | RemovableHeader @@ -267,11 +301,11 @@ data Header = CIFSHeader instance Show Header where show h = case h of - CIFSHeader -> suffix "CIFS" - SSHFSHeader -> suffix "SSHFS" + CIFSHeader -> suffix "CIFS" + SSHFSHeader -> suffix "SSHFS" VeracryptHeader -> suffix "Veracrypt" RemovableHeader -> suffix "Removable" - MTPFSHeader -> suffix "MTPFS" + MTPFSHeader -> suffix "MTPFS" where suffix = (++ " Devices") @@ -281,80 +315,91 @@ instance Ord Header where data ProtoAction a = ProtoAction a (RofiMountIO ()) -------------------------------------------------------------------------------- --- | Static device configuration (dhall) +-- Static device configuration (dhall) data MountConfig = MountConfig - { mpPath :: FilePath + { mpPath :: FilePath , mpLabel :: Maybe String - } deriving (Show, Generic, FromDhall) + } + deriving (Show, Generic, FromDhall) data BitwardenConfig = BitwardenConfig - { bwKey :: String - , bwTries :: Integer } + { bwKey :: String + , bwTries :: Integer + } deriving (Show, Generic, FromDhall) newtype SecretConfig = SecretConfig - { secretAttributes :: M.Map String String } + {secretAttributes :: M.Map String String} deriving (Show, Generic, FromDhall) newtype PromptConfig = PromptConfig - { promptTries :: Integer } + {promptTries :: Integer} deriving (Show, Generic, FromDhall) -data PasswordConfig = PwdBW BitwardenConfig +data PasswordConfig + = PwdBW BitwardenConfig | PwdLS SecretConfig | PwdPr PromptConfig deriving (Show, Generic, FromDhall) data CIFSOpts = CIFSOpts - { cifsoptsUsername :: Maybe String + { cifsoptsUsername :: Maybe String , cifsoptsWorkgroup :: Maybe String - , cifsoptsUID :: Maybe Integer - , cifsoptsGID :: Maybe Integer + , cifsoptsUID :: Maybe Integer + , cifsoptsGID :: Maybe Integer , cifsoptsIocharset :: Maybe String - } deriving (Show, Generic, FromDhall) + } + deriving (Show, Generic, FromDhall) -data DataConfig = VeracryptConfig VeracryptData +data DataConfig + = VeracryptConfig VeracryptData | SSHFSConfig SSHFSData | CIFSConfig CIFSData deriving (Show, Generic, FromDhall) data VeracryptData = VeracryptData - { vcVolume :: String + { vcVolume :: String , vcPassword :: Maybe PasswordConfig - } deriving (Show, Generic, FromDhall) + } + deriving (Show, Generic, FromDhall) data SSHFSData = SSHFSData - { sshfsRemote :: String + { sshfsRemote :: String , sshfsPassword :: Maybe PasswordConfig - } deriving (Show, Generic, FromDhall) + } + deriving (Show, Generic, FromDhall) data CIFSData = CIFSData - { cifsRemote :: String - , cifsSudo :: Bool + { cifsRemote :: String + , cifsSudo :: Bool , cifsPassword :: Maybe PasswordConfig - , cifsOpts :: Maybe CIFSOpts - } deriving (Show, Generic, FromDhall) + , cifsOpts :: Maybe CIFSOpts + } + deriving (Show, Generic, FromDhall) data DeviceConfig = DeviceConfig { deviceMount :: MountConfig - , deviceData :: DataConfig - } deriving (Show, Generic, FromDhall) + , deviceData :: DataConfig + } + deriving (Show, Generic, FromDhall) data TreeConfig = TreeConfig - { tcParent :: DeviceConfig + { tcParent :: DeviceConfig , tcChildren :: V.Vector String - } deriving (Show, Generic, FromDhall) + } + deriving (Show, Generic, FromDhall) data StaticConfig = StaticConfig { scTmpPath :: Maybe String , scVerbose :: Maybe Bool , scDevices :: M.Map String TreeConfig - } deriving (Show, Generic, FromDhall) + } + deriving (Show, Generic, FromDhall) -------------------------------------------------------------------------------- --- | Static devices trees --- +-- Static devices trees + -- Static devices as defined in the config file may declare dependencies on -- other static devices, and thus are best represented as a tree. Note that the -- tree is both Actionable and Mountable, where each node in the tree is only @@ -367,7 +412,7 @@ type StaticConfigTree = Tree DeviceConfig instance Mountable a => Mountable (Tree a) where mount (Tree p cs) False = mapM_ (`mountMaybe` False) cs >> mount p False - mount (Tree p _) True = mount p True + mount (Tree p _) True = mount p True mountState (Tree p _) = mountState p @@ -378,29 +423,29 @@ 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 - target (VeracryptConfig (VeracryptData { vcVolume = v })) = v + target (CIFSConfig (CIFSData {cifsRemote = r})) = r + target (SSHFSConfig (SSHFSData {sshfsRemote = r})) = r + target (VeracryptConfig (VeracryptData {vcVolume = v})) = v - groupHeader (Tree DeviceConfig{ deviceData = d } _) = + groupHeader (Tree DeviceConfig {deviceData = d} _) = case d of - CIFSConfig{} -> CIFSHeader - SSHFSConfig{} -> SSHFSHeader - VeracryptConfig{} -> VeracryptHeader + CIFSConfig {} -> CIFSHeader + SSHFSConfig {} -> SSHFSHeader + VeracryptConfig {} -> VeracryptHeader configToTree' :: M.Map String TreeConfig -> [StaticConfigTree] configToTree' devMap = configToTree devMap <$> M.elems devMap configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree -configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } = +configToTree devMap TreeConfig {tcParent = p, tcChildren = c} = Tree p $ fmap go V.toList c where go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds -------------------------------------------------------------------------------- --- | Static devices +-- Static devices -- -- This is complex because there may be multiple classes of static devices -- in the config file, and each device may depend on another device that is @@ -410,51 +455,57 @@ configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } = -- outside of these needs to be aware of these different classes. instance Mountable DeviceConfig where - mount DeviceConfig{ deviceMount = m, deviceData = devData} False = do + mount DeviceConfig {deviceMount = m, deviceData = devData} False = do m' <- getAbsMountpoint m - withTmpMountDir m' - $ io - $ case devData of - SSHFSConfig (SSHFSData { sshfsRemote = r, sshfsPassword = p }) -> + withTmpMountDir m' $ + io $ + case devData of + SSHFSConfig (SSHFSData {sshfsRemote = r, sshfsPassword = p}) -> mountSSHFS m' p r - CIFSConfig (CIFSData - { cifsRemote = r - , cifsSudo = s - , cifsPassword = p - , cifsOpts = o - }) -> - mountCIFS s r m' o p - VeracryptConfig (VeracryptData - { vcPassword = p - , vcVolume = v - }) -> - mountVeracrypt m' p v - - mount DeviceConfig{ deviceMount = m, deviceData = d } True = do + CIFSConfig + ( CIFSData + { cifsRemote = r + , cifsSudo = s + , cifsPassword = p + , cifsOpts = o + } + ) -> + mountCIFS s r m' o p + VeracryptConfig + ( VeracryptData + { vcPassword = p + , vcVolume = v + } + ) -> + mountVeracrypt m' p v + mount DeviceConfig {deviceMount = m, deviceData = d} True = do m' <- getAbsMountpoint m runAndRemoveDir m' $ io $ case d of - CIFSConfig (CIFSData { cifsSudo = s }) -> runMountSudoMaybe s "umount" [m'] - VeracryptConfig _ -> runVeraCrypt ["-d", m'] "" - _ -> runMount "umount" [m'] "" + CIFSConfig (CIFSData {cifsSudo = s}) -> runMountSudoMaybe s "umount" [m'] + VeracryptConfig _ -> runVeraCrypt ["-d", m'] "" + _ -> runMount "umount" [m'] "" - allInstalled DeviceConfig{ deviceData = devData } = io $ isJust - <$> findExecutable (exe devData) + allInstalled DeviceConfig {deviceData = devData} = + io $ + isJust + <$> findExecutable (exe devData) where - exe SSHFSConfig{} = "sshfs" - exe CIFSConfig{} = "mount.cifs" - exe VeracryptConfig{} = "veracrypt" + exe SSHFSConfig {} = "sshfs" + exe CIFSConfig {} = "mount.cifs" + exe VeracryptConfig {} = "veracrypt" - mountState DeviceConfig{ deviceMount = m, deviceData = d } = do - -- mountState DeviceConfig{ deviceMount = m } = do + mountState DeviceConfig {deviceMount = m, deviceData = d} = do + -- mountState DeviceConfig{ deviceMount = m } = do case d of - VeracryptConfig{} -> veracryptMountState m - _ -> do + VeracryptConfig {} -> veracryptMountState m + _ -> do b <- (io . isDirMounted) =<< getAbsMountpoint m return $ if b then Mounted else Unmounted - getLabel DeviceConfig - { deviceMount = MountConfig { mpPath = p, mpLabel = l } - } = fromMaybe (takeFileName p) l + getLabel + DeviceConfig + { deviceMount = MountConfig {mpPath = p, mpLabel = l} + } = fromMaybe (takeFileName p) l mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult mountSSHFS mountpoint pwdConfig remote = @@ -462,8 +513,13 @@ mountSSHFS mountpoint pwdConfig remote = where run other = runMount "sshfs" (other ++ [remote, mountpoint]) -mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOpts - -> Maybe PasswordConfig -> IO MountResult +mountCIFS + :: Bool + -> String + -> FilePath + -> Maybe CIFSOpts + -> Maybe PasswordConfig + -> IO MountResult mountCIFS useSudo remote mountpoint opts pwdConfig = withPasswordGetter pwdConfig runPwd run where @@ -474,18 +530,19 @@ mountCIFS useSudo remote mountpoint opts pwdConfig = fromCIFSOpts :: CIFSOpts -> String fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs where - fs = [ ("username", cifsoptsUsername) - , ("workgroup", cifsoptsWorkgroup) - , ("uid", fmap show . cifsoptsUID) - , ("gid", fmap show . cifsoptsGID) - , ("iocharset", cifsoptsIocharset) - ] + fs = + [ ("username", cifsoptsUsername) + , ("workgroup", cifsoptsWorkgroup) + , ("uid", fmap show . cifsoptsUID) + , ("gid", fmap show . cifsoptsGID) + , ("iocharset", cifsoptsIocharset) + ] concatMaybe (k, f) = (\v -> k ++ "=" ++ v) <$> f o mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult mountVeracrypt mountpoint pwdConfig volume = - withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) - $ runVeraCrypt args "" + withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) $ + runVeraCrypt args "" where args = [volume, mountpoint] @@ -502,43 +559,44 @@ veracryptMountState mc = do primary <- io $ lookupSpec mp aux <- io $ fmap join $ mapM lookupSpec $ auxPath =<< primary return $ case (primary, aux) of - (Just _, Just _) -> Mounted + (Just _, Just _) -> Mounted (Nothing, Nothing) -> Unmounted - _ -> Partial + _ -> Partial where -- TODO don't hardcode the tmp directory auxPath = fmap (\i -> "/tmp/.veracrypt_aux_mnt" ++ [i]) . vcIndex vcIndex spec = case reverse spec of -- TODO what if I have more than one digit? - (i:_) -> if i `elem` ['0'..'9'] then Just i else Nothing - _ -> Nothing + (i : _) -> if i `elem` ['0' .. '9'] then Just i else Nothing + _ -> Nothing getAbsMountpoint :: MountConfig -> RofiMountIO FilePath -getAbsMountpoint MountConfig{ mpPath = m } = +getAbsMountpoint MountConfig {mpPath = m} = asks $ flip appendRoot m . mountconfVolatilePath getStaticActions :: RofiMountIO [(Header, ProtoAction [String])] getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs -------------------------------------------------------------------------------- --- | Password-getting functions for static devices +-- Password-getting functions for static devices type PasswordGetter = IO (Maybe String) runSecret :: M.Map String String -> PasswordGetter -runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') "" +runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') "" where kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs runBitwarden :: String -> PasswordGetter -runBitwarden pname = ((password . login) <=< find (\i -> name i == pname)) - <$> getItems +runBitwarden pname = + ((password . login) <=< find (\i -> name i == pname)) + <$> getItems runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter runPromptLoop n pwd = do res <- pwd - if isNothing res then - if n <= 0 then return Nothing else runPromptLoop (n-1) pwd + if isNothing res + then if n <= 0 then return Nothing else runPromptLoop (n - 1) pwd else return res -- configToPwd :: PasswordConfig -> PasswordGetter @@ -557,47 +615,50 @@ runPromptLoop n pwd = do -- runMaybe x y = (\r -> if isNothing r then y else return r) =<< x configToPwd :: PasswordConfig -> PasswordGetter -configToPwd (PwdBW (BitwardenConfig { bwKey = k, bwTries = n })) = +configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) = runPromptLoop n $ runBitwarden k configToPwd (PwdLS s) = runSecret $ secretAttributes s configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p -withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult) - -> IO MountResult -> IO MountResult +withPasswordGetter + :: Maybe PasswordConfig + -> (String -> IO MountResult) + -> IO MountResult + -> IO MountResult withPasswordGetter (Just pwdConfig) runPwd _ = maybe (return $ MountError "Password could not be obtained") runPwd - =<< configToPwd pwdConfig + =<< configToPwd pwdConfig withPasswordGetter Nothing _ run = run -------------------------------------------------------------------------------- --- | Removable devices +-- Removable devices -- -- A device which can be removed (such as a flash drive). These are distinct -- from any device in the static configuration in that they only have device -- addresses (eg in /dev) and labels. data Removable = Removable - { removablePath :: String - , removableLabel :: String - } - deriving (Eq, Show) + { removablePath :: String + , removableLabel :: String + } + deriving (Eq, Show) instance Mountable Removable where - mount Removable { removablePath = d } m = + mount Removable {removablePath = d} m = io $ runMount "udisksctl" [c, "-b", d] "" where c = if m then "unmount" else "mount" allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl" - mountState Removable { removablePath = d } = do + mountState Removable {removablePath = d} = do s <- elem d <$> io curDeviceSpecs return $ if s then Mounted else Unmounted - getLabel Removable { removableLabel = l } = l + 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 @@ -607,48 +668,48 @@ instance Actionable Removable where -- label shown on the prompt will be 'SIZE Volume' where size is the size of -- the device getRemovableDevices :: RofiConf c => RofiIO c [Removable] -getRemovableDevices = fromLines toDev . lines - <$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "") +getRemovableDevices = + fromLines toDev . lines + <$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "") where columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE" -- can't use 'words' here since it will drop spaces in the front toDev line = case splitBy ' ' line of - ("":_) -> Nothing + ("" : _) -> Nothing [_, "1", d, "", s] -> mk d $ s ++ " Volume" - [_, "1", d, l, _] -> mk d l - _ -> Nothing - mk d l = Just $ Removable { removablePath = d, removableLabel = l } + [_, "1", d, l, _] -> mk d l + _ -> Nothing + mk d l = Just $ Removable {removablePath = d, removableLabel = l} getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])] getRemovableActions = mountableToAction getRemovableDevices -------------------------------------------------------------------------------- --- | MTP devices +-- MTP devices mtpExe :: String mtpExe = "jmtpfs" data MTPFS = MTPFS - { mtpfsBus :: String - , mtpfsDevice :: String - , mtpfsMountpoint :: FilePath - , mtpfsDescription :: String - } - deriving (Eq, Show) + { mtpfsBus :: String + , mtpfsDevice :: String + , mtpfsMountpoint :: FilePath + , mtpfsDescription :: String + } + deriving (Eq, Show) instance Mountable MTPFS where - mount MTPFS { mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m } False = do + mount MTPFS {mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m} False = do -- TODO add autodismount to options let dev = "-device=" ++ b ++ "," ++ n withTmpMountDir m $ io $ runMount mtpExe [dev, m] "" - - mount MTPFS { mtpfsMountpoint = m } True = + mount MTPFS {mtpfsMountpoint = m} True = runAndRemoveDir m $ io $ runMount "umount" [m] "" - -- | return True always since the list won't even show without jmtpfs + -- \| return True always since the list won't even show without jmtpfs allInstalled _ = return True - mountState MTPFS { mtpfsMountpoint = m } = do + mountState MTPFS {mtpfsMountpoint = m} = do s <- io $ isDirMounted m return $ if s then Mounted else Unmounted @@ -664,18 +725,21 @@ getMTPDevices = do dir <- asks mountconfVolatilePath res <- io $ readProcess mtpExe ["-l"] "" return $ fromLines (toDev dir) $ toDevList res - toDevList = reverse - . takeWhile (not . isPrefixOf "Available devices") - . reverse - . lines + toDevList = + reverse + . takeWhile (not . isPrefixOf "Available devices") + . reverse + . lines toDev dir s = case splitOn ", " s of - [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc] - in Just $ MTPFS - { mtpfsBus = busNum - , mtpfsDevice = devNum - , mtpfsMountpoint = dir canonicalize d - , mtpfsDescription = d - } + [busNum, devNum, _, _, desc, vendor] -> + let d = unwords [vendor, desc] + in Just $ + MTPFS + { mtpfsBus = busNum + , mtpfsDevice = devNum + , mtpfsMountpoint = dir canonicalize d + , mtpfsDescription = d + } _ -> Nothing canonicalize = mapMaybe repl repl c @@ -695,13 +759,13 @@ instance Actionable MTPFS where groupHeader _ = MTPFSHeader -------------------------------------------------------------------------------- --- | Notifications +-- Notifications data NotifyIcon = IconError | IconInfo instance Show NotifyIcon where show IconError = "dialog-error-symbolic" - show IconInfo = "dialog-information-symbolic" + show IconInfo = "dialog-information-symbolic" notifyMountResult :: Bool -> String -> MountResult -> IO () notifyMountResult mounted label result = case result of @@ -711,13 +775,15 @@ notifyMountResult mounted label result = case result of verb = if mounted then "unmount" else "mount" :: String notify :: NotifyIcon -> String -> Maybe String -> IO () -notify icon summary body = void $ spawnProcess "notify-send" - $ maybe args (\b -> args ++ [b]) body +notify icon summary body = + void $ + spawnProcess "notify-send" $ + maybe args (\b -> args ++ [b]) body where args = ["-i", show icon, summary] -------------------------------------------------------------------------------- --- | Mount commands +-- Mount commands data MountResult = MountSuccess | MountError String deriving (Show, Eq) @@ -725,18 +791,20 @@ runMount :: String -> [String] -> String -> IO MountResult runMount cmd args stdin = eitherToMountResult <$> readCmdEither cmd args stdin runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult -runMount' cmd args stdin environ = eitherToMountResult - <$> readCmdEither' cmd args stdin environ +runMount' cmd args stdin environ = + eitherToMountResult + <$> readCmdEither' cmd args stdin environ runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult runMountSudoMaybe useSudo cmd args = runMountSudoMaybe' useSudo cmd args [] runMountSudoMaybe' :: Bool -> String -> [String] -> [(String, String)] -> IO MountResult -runMountSudoMaybe' useSudo cmd args environ = maybe - (runMount' cmd args "" environ) - (\r -> runSudoMount' r cmd args environ) - =<< if useSudo then readPassword' "Sudo Password" else return Nothing +runMountSudoMaybe' useSudo cmd args environ = + maybe + (runMount' cmd args "" environ) + (\r -> runSudoMount' r cmd args environ) + =<< if useSudo then readPassword' "Sudo Password" else return Nothing -- TODO untested -- runSudoMount :: String -> String -> [String] -> String -> IO MountResult @@ -749,11 +817,11 @@ runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass environ' = fmap (\(k, v) -> k ++ "=" ++ v) environ eitherToMountResult :: Either (Int, String, String) String -> MountResult -eitherToMountResult (Right _) = MountSuccess +eitherToMountResult (Right _) = MountSuccess eitherToMountResult (Left (_, _, e)) = MountError e -------------------------------------------------------------------------------- --- | Low-level mount functions +-- Low-level mount functions mountMap :: IO (M.Map FilePath String) mountMap = do @@ -762,7 +830,7 @@ mountMap = do parseFile = M.fromList . mapMaybe (parseLine . words) . lines -- none of these should fail since this file format will never change parseLine [spec, mountpoint, _, _, _, _] = Just (mountpoint, spec) - parseLine _ = Nothing + parseLine _ = Nothing curDeviceSpecs :: IO [String] curDeviceSpecs = M.elems <$> mountMap @@ -789,8 +857,9 @@ rmDirOnMountError d f = do -- | Run a mount command and create the mountpoint if it does not exist, and -- remove the mountpoint if a mount error occurs withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult -withTmpMountDir m = rmDirOnMountError m - . bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) +withTmpMountDir m = + rmDirOnMountError m + . bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) -- | Run an unmount command and remove the mountpoint if no errors occur runAndRemoveDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult @@ -803,8 +872,10 @@ mkDirMaybe :: FilePath -> RofiMountIO () mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp rmDirMaybe :: FilePath -> RofiMountIO () -rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp - $ asks mountconfVolatilePath >>= io . rmUntil fp +rmDirMaybe fp = + whenInMountDir fp $ + unlessMountpoint fp $ + asks mountconfVolatilePath >>= io . rmUntil fp where rmUntil cur target = unless (target == cur) $ do removePathForcibly cur @@ -824,7 +895,7 @@ isDirMounted :: FilePath -> IO Bool isDirMounted fp = elem fp <$> curMountpoints -------------------------------------------------------------------------------- --- | Other functions +-- Other functions fromLines :: (String -> Maybe a) -> [String] -> [a] fromLines f = mapMaybe (f . stripWS) @@ -834,8 +905,9 @@ splitBy :: Char -> String -> [String] splitBy delimiter = foldr f [[]] where f _ [] = [] - f c l@(x:xs) | c == delimiter = []:l - | otherwise = (c:x):xs + f c l@(x : xs) + | c == delimiter = [] : l + | otherwise = (c : x) : xs appendRoot :: FilePath -> FilePath -> FilePath appendRoot root path = if isRelative path then root path else path