WIP use trees for staic config

app/rofi-dev.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 --------------------------------------------------------------------------------
 -- | rofi-dev - a rofi prompt for mountable devices
@@ -19,7 +20,7 @@ import           Data.Either
 import           Data.List
 import           Data.List.Split       (splitOn)
 import qualified Data.Map              as M
-import qualified Data.Map.Ordered      as O
+-- import qualified Data.Map.Ordered      as O
 import           Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Vector as V
@@ -134,47 +135,54 @@ instance FromJSON PasswordConfig where
     <*> o .:? "libsecret"
     <*> o .:? "prompt"
 
-data DeviceConfig = VeracryptConfig
+data DataConfig = VeracryptConfig
-  { _veracryptMount :: MountConfig
+  { _veracryptVolume :: String
-  , _veracryptVolume :: String
-  , _veracryptDepends :: V.Vector String
   , _veracryptPassword :: Maybe PasswordConfig
   } | SSHFSConfig
-  { _sshfsMount :: MountConfig
+  { _sshfsRemote :: String
-  , _sshfsRemote :: String
-  , _sshfsDepends :: V.Vector String
   } | CIFSConfig
-  { _cifsMount :: MountConfig
+  { _cifsRemote :: String
-  , _cifsRemote :: String
-  , _cifsDepends :: V.Vector String
   , _cifsPassword :: Maybe PasswordConfig
   } deriving Show
 
-instance FromJSON DeviceConfig where
+data DeviceConfig = DeviceConfig
+  { _deviceMount :: MountConfig
+  , _deviceData :: DataConfig
+  } deriving Show
+
+data TreeConfig = TreeConfig
+  { _treeParent :: DeviceConfig
+  , _treeChildren :: V.Vector String
+  } deriving Show
+
+instance FromJSON TreeConfig where
   parseJSON = withObject "devices" $ \o -> do
     devType <- o .: "type"
-    case (devType :: String) of
+    deps <- o .:& "depends"
+    mountconf <- o .: "mount"
+    devData <- case (devType :: String) of
                  "cifs"      -> CIFSConfig
-        <$> o .: "mount"
+                   <$> o .: "remote"
-        <*> o .: "remote"
-        <*> o .:& "depends"
                    <*> o .:? "password"
                  "sshfs"     -> SSHFSConfig
-        <$> o .: "mount"
+                   <$> o .: "remote"
-        <*> o .: "remote"
-        <*> o .:& "depends"
                  "veracrypt" -> VeracryptConfig
-        <$> o .: "mount"
+                   <$> o .: "volume"
-        <*> o .: "volume"
-        <*> o .:& "depends"
                    <*> o .:? "password"
-      -- TODO make this skip adding an entry to the map rather than skipping the
+                 -- TODO make this skip adding an entry to the map rather than
-      -- map entirely
+                 -- skipping the map entirely
                  _           -> fail $ "unknown device type: " ++ devType
+    return $ TreeConfig
+      { _treeParent = DeviceConfig
+                      { _deviceMount = mountconf
+                      , _deviceData = devData
+                      }
+      , _treeChildren = deps
+      }
 
 data StaticConfig = StaticConfig
   { _staticconfigTmpPath :: Maybe String
-  , _staticconfigDevices :: M.Map String DeviceConfig
+  , _staticconfigDevices :: M.Map String TreeConfig
   } deriving Show
 
 instance FromJSON StaticConfig where
@@ -195,7 +203,7 @@ instance FromJSON StaticConfig where
 data MountConf = MountConf
     { mountconfVolatilePath :: FilePath
     , mountconfRofiArgs     :: [String]
-    , mountconfStaticDevs   :: M.Map String DeviceConfig
+    , mountconfStaticDevs   :: M.Map String TreeConfig
     }
 
 instance RofiConf MountConf where
@@ -279,56 +287,46 @@ runPrompt gs = selectAction $ emptyMenu
 
 getGroups :: RofiIO MountConf [RofiGroup MountConf]
 getGroups = do
-  (cifsDevs, sshfsDevs, vcDevs) <- groupTriples
+  staticDevs <- asks mountconfStaticDevs
-    <$> (fromConfig =<< asks mountconfStaticDevs)
+  staticActions <- mapM mkAction $ configToTree' staticDevs
-  sequence
+  removableActions <- mapM mkAction =<< getRemovableDevices
-    [ mkGroup "SSHFS Devices" sshfsDevs
+  mtpActions <- mapM mkAction =<< getMTPDevices
-    , mkGroup "CIFS Devices" cifsDevs
+  return $ mapMaybe mkGroup
-    , mkGroup "Veracrypt Devices" vcDevs
+    $ groupBy (\(hx, _, _) (hy, _, _) -> hx == hy)
-    , mkGroup "Removable Devices"  =<< getRemovableDevices
+    $ sortBy (\(hx, _, _) (hy, _, _) -> compare hx hy)
-    , mkGroup "MTP Devices" =<< getMTPDevices
+    $ staticActions ++ removableActions ++ mtpActions
-    ]
 
 mountByAlias :: Bool -> String -> RofiIO MountConf ()
 mountByAlias unmountFlag alias = do
   static <- asks mountconfStaticDevs
-  volatilePath <- asks mountconfVolatilePath
+  mapM_ (`mount` unmountFlag) $ configToTree static <$> M.lookup alias static
-  forM_(M.lookup alias static) $ \d -> do
-    res <- configToDev volatilePath static d
-    case res of
-      First d'  -> mount' d'
-      Second d' -> mount' d'
-      Third d'  -> mount' d'
-  where
-    mount' :: Mountable a => a -> RofiIO MountConf ()
-    mount' = flip mount unmountFlag
 
-mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf)
+mkGroup :: [(Header, String, RofiIO MountConf ())] -> Maybe (RofiGroup MountConf)
-mkGroup header devs = sortGroup header <$> mapM mkAction devs
+mkGroup [] = Nothing
+mkGroup as = let ((Header title _, _, _):_) = as in
+  -- Just $ titledGroup title $ alignEntries $ toRofiActions $ fmap (\(_, e, a) -> (e, a)) as
+  Just $ titledGroup title $ toRofiActions $ fmap (\(_, e, a) -> (e, a)) as
 
-sortGroup :: String -> [(String, RofiIO MountConf ())] -> RofiGroup MountConf
+-- alignSep :: String
-sortGroup header = titledGroup header . alignEntries . toRofiActions
+-- alignSep = " | "
-
-alignSep :: String
-alignSep = " | "
 
 alignSepPre :: String
 alignSepPre = "@@@"
 
-alignEntries :: RofiActions c -> RofiActions c
+-- alignEntries :: RofiActions c -> RofiActions c
-alignEntries = O.fromList . withKeys . O.assocs
+-- alignEntries = O.fromList . withKeys . O.assocs
-  where
+--   where
-    withKeys as = let (ks, vs) = unzip as in zip (align ks) vs
+--     withKeys as = let (ks, vs) = unzip as in zip (align ks) vs
-    align = fmap (intercalate alignSep)
+--     align = fmap (intercalate alignSep)
-      . transpose
+--       . transpose
-      . mapToLast pad
+--       . mapToLast pad
-      . transpose
+--       . transpose
-      . fmap (splitOn alignSepPre)
+--       . fmap (splitOn alignSepPre)
-    pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs
+--     pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs
-    getMax = maximum . fmap length
+--     getMax = maximum . fmap length
-    mapToLast _ []     = []
+--     mapToLast _ []     = []
-    mapToLast _ [x]    = [x]
+--     mapToLast _ [x]    = [x]
-    mapToLast f (x:xs) = f x : mapToLast f xs
+--     mapToLast f (x:xs) = f x : mapToLast f xs
 
 --------------------------------------------------------------------------------
 -- | Removable devices
@@ -352,8 +350,13 @@ instance Mountable Removable where
 
   isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs
 
+  getLabel Removable { label = l } = l
+
+instance Actionable Removable where
   fmtEntry Removable { deviceSpec = d, label = l } = l ++ alignSepPre ++ d
 
+  groupHeader _ = Header "Removable Devices" 3
+
 -- | Return list of possible rofi actions for removable devices
 -- A 'removable device' is defined as a hotplugged device with a filesystem as
 -- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the
@@ -372,96 +375,10 @@ getRemovableDevices = fromLines toDev . lines
       _                  -> Nothing
     mk d l = Just $ Removable { deviceSpec = d, label = l }
 
---------------------------------------------------------------------------------
--- | CIFS Devices
---
--- 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) Dependencies
-
-instance Show CIFS where
-  show (CIFS r f _ d) = unwords [show r, show f, "<Pwd>", show d]
-
-instance Mountable CIFS where
-  mount (CIFS Removable{ label = l } m getPwd deps) False = do
-    mountDependencies deps
-    bracketOnError_
-      (mkDirMaybe m)
-      (rmDirMaybe m)
-      $ io $ do
-      res <- case getPwd of
-        Just pwd -> do
-          p <- maybe [] (\p -> [("PASSWD", p)]) <$> pwd
-          readCmdEither' "mount" [m] "" p
-        Nothing -> readCmdEither "mount" [m] ""
-      notifyMounted (isRight res) False l
-
-  mount (CIFS Removable{ label = l } m _ _) True = umountNotify l m
-
-  allInstalled _ = io $ isJust <$> findExecutable "mount.cifs"
-
-  isMounted (CIFS _ dir _ _) = io $ isDirMounted dir
-
-  fmtEntry (CIFS r _ _ _) = fmtEntry r
-
---------------------------------------------------------------------------------
--- | SSHFS Devices
---
--- This wraps the Removable device (since it is removable) and also adds its
--- own mount options. If the path does not point to an aliased entry in the ssh
--- config that specifies the port, hostname, user, and identity file, these
--- need to be passed as mount options.
-
-data SSHFS = SSHFS Removable FilePath Dependencies deriving Show
-
-instance Mountable SSHFS where
-  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
-
-  allInstalled _ = fmap isJust $ io $ findExecutable "sshfs"
-
-  isMounted (SSHFS _ dir _) = io $ isDirMounted dir
-
-  fmtEntry (SSHFS r _ _) = fmtEntry r
-
 --------------------------------------------------------------------------------
 -- | VeraCrypt Devices
 --
 
-data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) Dependencies
-
-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 deps) False = do
-    mountDependencies deps
-    bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) mountMaybe
-    where
-      mountMaybe = io $ maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) getPwd
-      runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"])
-      runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False l)
-        =<< runVeraCrypt stdin ([s, m] ++ args)
-      notifyFail = notify "dialog-error-symbolic" $
-        printf "Failed to get volume password for %s" l
-
-  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
-
-  fmtEntry (VeraCrypt r _ _ _) = fmtEntry r
-
 -- NOTE: the user is assumed to have added themselves to the sudoers file so
 -- that this command will work
 runVeraCrypt :: String -> [String] -> IO (Either (Int, String, String) String)
@@ -502,8 +419,13 @@ instance Mountable MTPFS where
 
   isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir
 
+  getLabel = fmtEntry
+
+instance Actionable MTPFS where
   fmtEntry MTPFS { description = d } = d
 
+  groupHeader _ = Header "MTP Devices" 5
+
 -- | Return list of all available MTP devices
 getMTPDevices :: RofiIO MountConf [MTPFS]
 getMTPDevices = do
@@ -536,72 +458,88 @@ getMTPDevices = do
 -- 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
+data Tree a = Tree a [Tree a] deriving (Eq, Show)
--- 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 StaticConfigTree = Tree DeviceConfig
-type StaticDeviceTriple = Triple CIFS SSHFS VeraCrypt
 
-fromConfig :: M.Map String DeviceConfig -> RofiIO MountConf [StaticDeviceTriple]
+instance Actionable (Tree DeviceConfig) where
-fromConfig st = do
+  fmtEntry (Tree p _) = getLabel p
-  p <- asks mountconfVolatilePath
-  mapM (configToDev p st) $ M.elems st
 
--- TODO abstract parts of this away in new typeclass for static devices
+  groupHeader (Tree DeviceConfig{ _deviceData = d } _) =
-configToDev :: FilePath -> M.Map String DeviceConfig -> DeviceConfig
+    case d of
-  -> RofiIO MountConf StaticDeviceTriple
+      CIFSConfig{} -> Header "CIFS Devices" 0
-configToDev v s CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m }
+      SSHFSConfig{} -> Header "SSHFS Devices" 1
-                           , _cifsRemote = t
+      VeracryptConfig{} -> Header "Veracrypt Devices" 2
-                           , _cifsDepends = d
+
-                           , _cifsPassword = p } = do
+configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
-  -- stuff like this is totally refactorable
+configToTree' devMap = configToTree devMap <$> M.elems devMap
-  let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
+
-  d' <- getDependencies s $ V.toList d
+configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
-  return $ First $ CIFS r (appendRoot v m) (configToPwd <$> p) d'
+configToTree devMap TreeConfig{ _treeParent = p, _treeChildren = c } =
+  Tree p $ fmap go V.toList c
   where
-    smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
+    go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
-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])
+instance Mountable a => Mountable (Tree a) where
-groupTriples = foldl stackTriples ([], [], [])
+  mount (Tree p cs) False = mapM_ (`mount` False) cs >> mount p False
+  mount (Tree p _) True = mount p True
 
-stackTriples :: ([a], [b], [c]) -> Triple a b c -> ([a], [b], [c])
+  isMounted (Tree p _) = isMounted p
-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)
 
---------------------------------------------------------------------------------
+  allInstalled (Tree p cs) = do
--- | Static Dependencies
+    res <- and <$> mapM allInstalled cs
---
+    if res then allInstalled p else return res
--- Define a data structure that allows one device to depend on another.
 
-newtype Dependencies = Dependencies [StaticDeviceTriple] deriving Show
+  getLabel (Tree p _) = getLabel p
 
-getDependencies :: M.Map String DeviceConfig -> [String] -> RofiIO MountConf Dependencies
+instance Mountable DeviceConfig where
-getDependencies devMap aliases = fmap Dependencies
+  mount c@DeviceConfig{ _deviceMount = MountConfig { _mountMountPoint = m }
-  $ fromConfig $ M.filterWithKey (\k _ -> k `elem` aliases) devMap
+                      , _deviceData = devData
-
+                      } False = do
-mountDependencies :: Dependencies -> RofiIO MountConf ()
+    mountRoot <- asks mountconfVolatilePath
-mountDependencies (Dependencies d) = mapM_ mount' d
+    let m' = appendRoot mountRoot m
+    bracketOnError_ (mkDirMaybe m') (rmDirMaybe m') $ mount' m'
     where
-    -- this looks stupid but all these mount calls are technically different
+      mount' mountpoint = io $ case devData of
-    -- functions because class instances
+        SSHFSConfig{ _sshfsRemote = r } ->
-    mount' (First m) = mount m False
+          runMountNotify "sshfs" [r, mountpoint] (getLabel c) False
-    mount' (Second m) = mount m False
+        CIFSConfig{ _cifsPassword = p } -> do
-    mount' (Third m) = mount m False
+          res <- case p of
+            Just pwd -> do
+              pwd' <- maybe [] (\p' -> [("PASSWD", p')]) <$> configToPwd pwd
+              readCmdEither' "mount" [mountpoint] "" pwd'
+            Nothing -> readCmdEither "mount" [mountpoint] ""
+          notifyMounted (isRight res) False (getLabel c)
+        VeracryptConfig{ _veracryptPassword = getPwd, _veracryptVolume = v } ->
+          maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) (configToPwd <$> getPwd)
+          where
+            l = getLabel c
+            runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"])
+            runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False l)
+              =<< runVeraCrypt stdin ([v, mountpoint] ++ args)
+            notifyFail = notify "dialog-error-symbolic" $
+              printf "Failed to get volume password for %s" l
+
+  mount c@DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = m }
+                      , _deviceData = VeracryptConfig{}
+                      } True = io $ do
+    res <- runVeraCrypt "" ["-d", m]
+    notifyMounted (isRight res) True (getLabel c)
+  
+  mount c@DeviceConfig{ _deviceMount = MountConfig { _mountMountPoint = m }} True =
+    umountNotify (getLabel c) m
+
+  allInstalled DeviceConfig{ _deviceData = devData } = io $ isJust
+    <$> findExecutable (exe devData)
+    where
+      exe SSHFSConfig{} = "sshfs"
+      exe CIFSConfig{} = "mount.cifs"
+      exe VeracryptConfig{} = "veracrypt"
+
+  isMounted DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = m }} = io $ isDirMounted m
+
+  getLabel DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = p, _mountLabel = l }} =
+    fromMaybe (takeBaseName p) l
 
 --------------------------------------------------------------------------------
 -- | Mountable typeclass
@@ -616,24 +554,44 @@ class Mountable a where
   -- | Mount the given type (or dismount if False is passed)
   mount :: a -> Bool -> RofiIO MountConf ()
 
+  mountMaybe :: a -> Bool -> RofiIO MountConf ()
+  mountMaybe dev mountFlag = do
+    mounted <- isMounted dev
+    if mountFlag == mounted then mount dev mountFlag
+      else io $ notify "dialog-information-symbolic"
+           $ getLabel dev ++ " already mounted"
+
   -- | Check if the mounting utilities are present
   allInstalled :: a -> RofiIO MountConf Bool
 
-  -- | Return a string to go in the Rofi menu for the given type
+  -- | Return a string representing the label of the device
-  fmtEntry :: a -> String
+  getLabel :: a -> String
 
   -- | Determine if the given type is mounted or not
   isMounted :: a -> RofiIO MountConf Bool
 
+data Header = Header String Integer deriving (Show, Eq)
+
+instance Ord Header where
+  compare (Header _ x) (Header _ y) = compare x y
+
+class Mountable a => Actionable a where
+  -- | Return a string to go in the Rofi menu for the given type
+  fmtEntry :: a -> String
+  fmtEntry = getLabel
+
+  groupHeader :: a -> Header
+
   -- | Given a mountable type, return a rofi action (string to go in the
   -- Rofi prompt and an action to perform when it is selected)
-  mkAction :: a -> RofiIO MountConf (String, RofiIO MountConf ())
+  mkAction :: a -> RofiIO MountConf (Header, String, RofiIO MountConf ())
   mkAction dev = do
     m <- isMounted dev
     i <- allInstalled dev
-    let a = when i $ mount dev m
+    let h = groupHeader dev
+    let a = when i $ mountMaybe dev m
     let s = mountedPrefix m i ++ fmtEntry dev
-    return (s, a)
+    return (h, s, a)
     where
       mountedPrefix False True = "  "
       mountedPrefix True True  = "* "