ADD systemd mount unit thing support

app/rofi-dev.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE ViewPatterns   #-}
 
 --------------------------------------------------------------------------------
 -- | rofi-dev - a rofi prompt for mountable devices
@@ -33,6 +34,7 @@ import           Text.Wrap
 import           System.Console.GetOpt
 import           System.Directory
 import           System.Environment
+import           System.Exit (ExitCode(..))
 import           System.FilePath.Posix
 import           System.Posix.User     (getEffectiveUserName)
 import           System.Process
@@ -170,17 +172,29 @@ runPrompt gs = selectAction $ emptyMenu
 getGroups :: RofiIO MountConf [RofiGroup MountConf]
 getGroups = do
   fstab <- readFSTab
+  sysd <- io getSystemdDevices
   sequence
-    [ mkGroup "SSHFS Devices" $ sshfsDevices fstab
+    [ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) $ sshfsDevices fstab
     , mkGroup "CIFS Devices" $ cifsDevices fstab
-    , mkGroup "Veracrypt Devices" =<< getVeracryptDevices
+    , mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) =<< getVeracryptDevices
     , mkGroup "Removable Devices"  =<< getRemovableDevices
     , mkGroup "MTP Devices" =<< getMTPDevices
     ]
+  where
+    filterSysd t = filter (\s -> sysdType s == t)
 
 mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf)
-mkGroup header devs = titledGroup header . alignEntries . toRofiActions
-    <$> mapM mkAction devs
+mkGroup header devs = sortGroup header <$> mapM mkAction devs
+
+mkGroup2 :: (Mountable d, Mountable e) => String
+  -> [d] -> [e] -> RofiIO MountConf (RofiGroup MountConf)
+mkGroup2 header devs1 devs2 = do
+  r1 <- mapM mkAction devs1
+  r2 <- mapM mkAction devs2
+  return $ sortGroup header (r1 ++ r2)
+
+sortGroup :: String -> [(String, RofiIO MountConf ())] -> RofiGroup MountConf
+sortGroup header = titledGroup header . alignEntries . toRofiActions
 
 alignSep :: String
 alignSep = " | "
@@ -424,6 +438,57 @@ getMTPDevices = do
       | c == ' ' = Just '-'
       | otherwise = Just c
 
+--------------------------------------------------------------------------------
+-- | Systemd typeclass
+
+data SystemdMountType = SystemdVeracrypt | SystemdSSHFS deriving (Eq, Show)
+  
+data Systemd = Systemd
+    { sysdType     :: SystemdMountType
+    , sysdInstance :: String
+    }
+    deriving (Eq, Show)
+
+instance Mountable Systemd where
+  mount s@Systemd { sysdInstance = i } m = let
+    unit = fmtSysdInstanceName s
+    op = if m then "stop" else "start" in
+    io $ runMountNotify "systemctl" ["--user", op, unit] i m
+
+  allInstalled Systemd { sysdType = SystemdVeracrypt } =
+    io $ isJust <$> findExecutable "veracrypt"
+
+  allInstalled Systemd { sysdType = SystemdSSHFS } =
+    io $ isJust <$> findExecutable "sshfs"
+
+  isMounted s = let
+    unit = fmtSysdInstanceName s
+    args = ["--user", "is-active", "--quiet", unit] in
+    io $ (\(ec, _, _) -> ec == ExitSuccess)
+    <$> readProcessWithExitCode "systemctl" args ""
+
+  fmtEntry Systemd { sysdInstance = i } = i ++ alignSepPre ++ "Systemd"
+
+fmtSysdInstanceName :: Systemd -> String
+fmtSysdInstanceName Systemd { sysdType = SystemdVeracrypt, sysdInstance = i } =
+  "mount-veracrypt@" ++ i ++ ".service"
+fmtSysdInstanceName Systemd { sysdType = SystemdSSHFS, sysdInstance = i } =
+  "mount-sshfs@" ++ i ++ ".service"
+
+getSystemdDevices :: IO [Systemd]
+getSystemdDevices = do
+  systemdHome <- io $ getXdgDirectory XdgConfig "systemd/user"
+  io $ mapMaybe toDev
+    <$> (filterM (doesDirectoryExist . (systemdHome </>))
+    =<< listDirectory systemdHome)
+  where
+    toDev (splitInstance "mount-veracrypt@" -> Just s) =
+      Just $ Systemd { sysdType = SystemdVeracrypt , sysdInstance = s }
+    toDev (splitInstance "mount-sshfs@" -> Just s) =
+      Just $ Systemd { sysdType = SystemdSSHFS , sysdInstance = s }
+    toDev _ = Nothing
+    splitInstance p = fmap (takeWhile (not . (==) '.')) . stripPrefix p
+
 --------------------------------------------------------------------------------
 -- | Mountable typeclass
 --