REF clean up code a bit
This commit is contained in:
parent
047d68a6d8
commit
79d8b0194a
174
app/rofi-dev.hs
174
app/rofi-dev.hs
|
@ -1,6 +1,3 @@
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
@ -29,8 +26,6 @@ import qualified Data.Text as T
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import Data.Yaml
|
import Data.Yaml
|
||||||
|
|
||||||
import GHC.Generics()
|
|
||||||
|
|
||||||
import Rofi.Command
|
import Rofi.Command
|
||||||
|
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
@ -50,7 +45,6 @@ main = getArgs >>= parse
|
||||||
|
|
||||||
parse :: [String] -> IO ()
|
parse :: [String] -> IO ()
|
||||||
parse args = case getOpt Permute options args of
|
parse args = case getOpt Permute options args of
|
||||||
-- (o, n, []) -> initMountConf n >>= \i -> runMounts $ foldl (flip id) i o
|
|
||||||
(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
|
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
|
||||||
where
|
where
|
||||||
|
@ -176,7 +170,9 @@ instance FromJSON DeviceConfig where
|
||||||
<*> o .: "volume"
|
<*> o .: "volume"
|
||||||
<*> o .:& "depends"
|
<*> o .:& "depends"
|
||||||
<*> o .:? "password"
|
<*> o .:? "password"
|
||||||
_ -> fail "unknown device type"
|
-- TODO make this skip adding an entry to the map rather than skipping the
|
||||||
|
-- map entirely
|
||||||
|
_ -> fail $ "unknown device type: " ++ devType
|
||||||
|
|
||||||
data StaticConfig = StaticConfig
|
data StaticConfig = StaticConfig
|
||||||
{ _staticconfigTmpPath :: Maybe String
|
{ _staticconfigTmpPath :: Maybe String
|
||||||
|
@ -188,26 +184,6 @@ instance FromJSON StaticConfig where
|
||||||
<$> o .:? "mountdir"
|
<$> o .:? "mountdir"
|
||||||
<*> o .: "devices"
|
<*> o .: "devices"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Static Devices typeclass
|
|
||||||
--
|
|
||||||
-- A class to represent devices defined in the static configuration (eg the YAML
|
|
||||||
-- file). Its methods define the machinery to extract specific devies types
|
|
||||||
-- from the parse tree.
|
|
||||||
|
|
||||||
fromConfig :: M.Map String DeviceConfig -> RofiIO MountConf [DevTriple]
|
|
||||||
fromConfig st = do
|
|
||||||
p <- asks mountconfVolatilePath
|
|
||||||
mapM (configToDev p st) $ M.elems st
|
|
||||||
|
|
||||||
foldTriples :: [Triple a b c] -> ([a], [b], [c])
|
|
||||||
foldTriples = foldl stackTriples ([], [], [])
|
|
||||||
|
|
||||||
stackTriples :: ([a], [b], [c]) -> Triple a b c -> ([a], [b], [c])
|
|
||||||
stackTriples (c, v, s) (First x) = (x:c, v, s)
|
|
||||||
stackTriples (c, v, s) (Second x) = (c, x:v, s)
|
|
||||||
stackTriples (c, v, s) (Third x) = (c, v, x:s)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Global config used in the reader monad stack
|
-- | Global config used in the reader monad stack
|
||||||
--
|
--
|
||||||
|
@ -306,7 +282,7 @@ runPrompt gs = selectAction $ emptyMenu
|
||||||
getGroups :: RofiIO MountConf [RofiGroup MountConf]
|
getGroups :: RofiIO MountConf [RofiGroup MountConf]
|
||||||
getGroups = do
|
getGroups = do
|
||||||
sysd <- io getSystemdDevices
|
sysd <- io getSystemdDevices
|
||||||
(cifsDevs, sshfsDevs, vcDevs) <- foldTriples
|
(cifsDevs, sshfsDevs, vcDevs) <- groupTriples
|
||||||
<$> (fromConfig =<< asks mountconfStaticDevs)
|
<$> (fromConfig =<< asks mountconfStaticDevs)
|
||||||
sequence
|
sequence
|
||||||
[ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) sshfsDevs
|
[ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) sshfsDevs
|
||||||
|
@ -414,7 +390,7 @@ getRemovableDevices = fromLines toDev . lines
|
||||||
-- This wraps the Removable device (since it is removable) and also adds its
|
-- This wraps the Removable device (since it is removable) and also adds its
|
||||||
-- own mount options and passwords for authentication.
|
-- own mount options and passwords for authentication.
|
||||||
|
|
||||||
data CIFS = CIFS Removable FilePath (Maybe PasswordGetter) Dependency
|
data CIFS = CIFS Removable FilePath (Maybe PasswordGetter) Dependencies
|
||||||
|
|
||||||
instance Show CIFS where
|
instance Show CIFS where
|
||||||
show (CIFS r f _ d) = unwords [show r, show f, "<Pwd>", show d]
|
show (CIFS r f _ d) = unwords [show r, show f, "<Pwd>", show d]
|
||||||
|
@ -449,7 +425,7 @@ instance Mountable CIFS where
|
||||||
-- config that specifies the port, hostname, user, and identity file, these
|
-- config that specifies the port, hostname, user, and identity file, these
|
||||||
-- need to be passed as mount options.
|
-- need to be passed as mount options.
|
||||||
|
|
||||||
data SSHFS = SSHFS Removable FilePath Dependency deriving Show
|
data SSHFS = SSHFS Removable FilePath Dependencies deriving Show
|
||||||
|
|
||||||
instance Mountable SSHFS where
|
instance Mountable SSHFS where
|
||||||
mount (SSHFS Removable{ deviceSpec = d, label = l } m deps) False = do
|
mount (SSHFS Removable{ deviceSpec = d, label = l } m deps) False = do
|
||||||
|
@ -471,7 +447,7 @@ instance Mountable SSHFS where
|
||||||
-- | VeraCrypt Devices
|
-- | VeraCrypt Devices
|
||||||
--
|
--
|
||||||
|
|
||||||
data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) Dependency
|
data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) Dependencies
|
||||||
|
|
||||||
instance Show VeraCrypt where
|
instance Show VeraCrypt where
|
||||||
show (VeraCrypt r f _ d) = unwords [show r, show f, show d]
|
show (VeraCrypt r f _ d) = unwords [show r, show f, show d]
|
||||||
|
@ -506,69 +482,6 @@ runVeraCrypt stdin args = do
|
||||||
where
|
where
|
||||||
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
|
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
|
||||||
|
|
||||||
data Triple a b c = First a | Second b | Third c deriving Show
|
|
||||||
|
|
||||||
type DevTriple = Triple CIFS SSHFS VeraCrypt
|
|
||||||
|
|
||||||
-- TODO abstract parts of this away in new typeclass for static devices
|
|
||||||
configToDev :: FilePath -> M.Map String DeviceConfig -> DeviceConfig
|
|
||||||
-> RofiIO MountConf DevTriple
|
|
||||||
configToDev v s CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m }
|
|
||||||
, _cifsRemote = t
|
|
||||||
, _cifsDepends = d
|
|
||||||
, _cifsPassword = p } = do
|
|
||||||
-- stuff like this is totally refactorable
|
|
||||||
let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
|
|
||||||
d' <- getDependencies s $ V.toList d
|
|
||||||
return $ First $ CIFS r (appendRoot v m) (configToPwd <$> p) d'
|
|
||||||
where
|
|
||||||
smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
|
|
||||||
configToDev v s SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m }
|
|
||||||
, _sshfsDepends = d
|
|
||||||
, _sshfsRemote = t } = do
|
|
||||||
let r = Removable { deviceSpec = t, label = takeFileName m }
|
|
||||||
d' <- getDependencies s $ V.toList d
|
|
||||||
return $ Second $ SSHFS r (appendRoot v m) d'
|
|
||||||
configToDev v s VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m }
|
|
||||||
, _veracryptVolume = t
|
|
||||||
, _veracryptDepends = d
|
|
||||||
, _veracryptPassword = p } = do
|
|
||||||
let r = Removable { deviceSpec = t, label = takeFileName m }
|
|
||||||
d' <- getDependencies s $ V.toList d
|
|
||||||
return $ Third $ 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
|
|
||||||
|
|
||||||
getDependencies :: M.Map String DeviceConfig -> [String] -> RofiIO MountConf Dependency
|
|
||||||
getDependencies devMap aliases = do
|
|
||||||
(c, s, v) <- fmap foldTriples
|
|
||||||
$ fromConfig $ M.filterWithKey (\k _ -> k `elem` aliases) devMap
|
|
||||||
return Dependency { dependencyCIFS = c
|
|
||||||
, dependencySSHFS = s
|
|
||||||
, dependencyVeracrypt = v}
|
|
||||||
|
|
||||||
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
|
-- | MTP devices
|
||||||
--
|
--
|
||||||
|
@ -680,6 +593,79 @@ getSystemdDevices = do
|
||||||
toDev _ = Nothing
|
toDev _ = Nothing
|
||||||
splitInstance p = fmap (takeWhile (not . (==) '.')) . stripPrefix p
|
splitInstance p = fmap (takeWhile (not . (==) '.')) . stripPrefix p
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Static Device Wrapper
|
||||||
|
--
|
||||||
|
-- In order to make a consistent interface for the static device types, create
|
||||||
|
-- a wrapper type to encapsulate them.
|
||||||
|
|
||||||
|
-- | a sum-type wrapper for three different types, obviously this will change
|
||||||
|
-- if/when I add more static devices and their types
|
||||||
|
data Triple a b c = First a | Second b | Third c deriving Show
|
||||||
|
|
||||||
|
-- | Specific wrapper for static devices
|
||||||
|
type StaticDeviceTriple = Triple CIFS SSHFS VeraCrypt
|
||||||
|
|
||||||
|
fromConfig :: M.Map String DeviceConfig -> RofiIO MountConf [StaticDeviceTriple]
|
||||||
|
fromConfig st = do
|
||||||
|
p <- asks mountconfVolatilePath
|
||||||
|
mapM (configToDev p st) $ M.elems st
|
||||||
|
|
||||||
|
-- TODO abstract parts of this away in new typeclass for static devices
|
||||||
|
configToDev :: FilePath -> M.Map String DeviceConfig -> DeviceConfig
|
||||||
|
-> RofiIO MountConf StaticDeviceTriple
|
||||||
|
configToDev v s CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m }
|
||||||
|
, _cifsRemote = t
|
||||||
|
, _cifsDepends = d
|
||||||
|
, _cifsPassword = p } = do
|
||||||
|
-- stuff like this is totally refactorable
|
||||||
|
let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
|
||||||
|
d' <- getDependencies s $ V.toList d
|
||||||
|
return $ First $ CIFS r (appendRoot v m) (configToPwd <$> p) d'
|
||||||
|
where
|
||||||
|
smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
|
||||||
|
configToDev v s SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m }
|
||||||
|
, _sshfsDepends = d
|
||||||
|
, _sshfsRemote = t } = do
|
||||||
|
let r = Removable { deviceSpec = t, label = takeFileName m }
|
||||||
|
d' <- getDependencies s $ V.toList d
|
||||||
|
return $ Second $ SSHFS r (appendRoot v m) d'
|
||||||
|
configToDev v s VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m }
|
||||||
|
, _veracryptVolume = t
|
||||||
|
, _veracryptDepends = d
|
||||||
|
, _veracryptPassword = p } = do
|
||||||
|
let r = Removable { deviceSpec = t, label = takeFileName m }
|
||||||
|
d' <- getDependencies s $ V.toList d
|
||||||
|
return $ Third $ VeraCrypt r (appendRoot v m) (configToPwd <$> p) d'
|
||||||
|
|
||||||
|
groupTriples :: [Triple a b c] -> ([a], [b], [c])
|
||||||
|
groupTriples = foldl stackTriples ([], [], [])
|
||||||
|
|
||||||
|
stackTriples :: ([a], [b], [c]) -> Triple a b c -> ([a], [b], [c])
|
||||||
|
stackTriples (c, v, s) (First x) = (x:c, v, s)
|
||||||
|
stackTriples (c, v, s) (Second x) = (c, x:v, s)
|
||||||
|
stackTriples (c, v, s) (Third x) = (c, v, x:s)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Static Dependencies
|
||||||
|
--
|
||||||
|
-- Define a data structure that allows one device to depend on another.
|
||||||
|
|
||||||
|
newtype Dependencies = Dependencies [StaticDeviceTriple] deriving Show
|
||||||
|
|
||||||
|
getDependencies :: M.Map String DeviceConfig -> [String] -> RofiIO MountConf Dependencies
|
||||||
|
getDependencies devMap aliases = fmap Dependencies
|
||||||
|
$ fromConfig $ M.filterWithKey (\k _ -> k `elem` aliases) devMap
|
||||||
|
|
||||||
|
mountDependencies :: Dependencies -> RofiIO MountConf ()
|
||||||
|
mountDependencies (Dependencies d) = mapM_ mount' d
|
||||||
|
where
|
||||||
|
-- this looks stupid but all these mount calls are technically different
|
||||||
|
-- functions because class instances
|
||||||
|
mount' (First m) = mount m False
|
||||||
|
mount' (Second m) = mount m False
|
||||||
|
mount' (Third m) = mount m False
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Mountable typeclass
|
-- | Mountable typeclass
|
||||||
--
|
--
|
||||||
|
|
Loading…
Reference in New Issue