ENH generalize RofiIO monad

app/rofi-bitwarden.hs

@@ -61,7 +61,7 @@ checkExe cmd = do
 --
 -- The session ID will be valid only as long as TIMEOUT
 
-newtype BWConf = BWConf
+newtype BWServerConf = BWServerConf
     { timeout :: UnixDiffTime
     }
 
@@ -75,15 +75,15 @@ type Session = MVar (Maybe CurrentSession)
 runDaemon :: Int -> IO ()
 runDaemon t = do
   ses <- newMVar Nothing
-  let c = BWConf { timeout = UnixDiffTime (fromIntegral t) 0 }
+  let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 }
   startService c ses
   forever $ threadDelay 1000000
 
 lockSession :: Session -> IO ()
 lockSession ses = void $ swapMVar ses Nothing
 
-getSession :: BWConf -> Session -> IO String
+getSession :: BWServerConf -> Session -> IO String
-getSession BWConf { timeout = t } ses = do
+getSession BWServerConf { timeout = t } ses = do
   ut <- getUnixTime
   modifyMVar ses $ \s -> case s of
     Just CurrentSession { timestamp = ts, hash = h } ->
@@ -98,11 +98,6 @@ getSession BWConf { timeout = t } ses = do
       ut <- getUnixTime
       return CurrentSession { timestamp = ut, hash = h }
 
-readPassword :: IO (Maybe String)
-readPassword = readCmdSuccess "rofi" args ""
-  where
-    args = dmenuArgs ++ ["-p", "Password", "-password"]
-
 readSession :: String -> IO (Maybe String)
 readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
 
@@ -122,10 +117,15 @@ readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
 --     - password (if applicable) -> copy to clipboard
 --     - anything else (notes and such) -> copy to clipboard
 
+newtype BWClientConf = BWClientConf [String]
+
+instance RofiConf BWClientConf where
+  defArgs (BWClientConf a) = a
+
 runClient :: [String] -> IO ()
 runClient a = do
-  let c = RofiConf { defArgs = a }
+  let c = BWClientConf a
-  runRofiPrompt c $ selectAction $ emptyMenu
+  runRofiIO c $ selectAction $ emptyMenu
     { groups = [untitledGroup $ toRofiActions ras]
     , prompt = Just "Action"
     }
@@ -134,12 +134,12 @@ runClient a = do
           , ("Lock Session", io callLockSession)
           ]
 
-browseLogins :: RofiPrompt ()
+browseLogins :: RofiConf c => RofiIO c ()
 browseLogins = do
   session <- io callGetSession
   forM_ session $ getItems >=> selectItem
 
-getItems :: String -> RofiPrompt [Item]
+getItems :: RofiConf c => String -> RofiIO c [Item]
 getItems session = do
   items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
   return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
@@ -170,16 +170,16 @@ instance FromJSON Login
 
 -- TODO make menu buttons here to go back and to copy without leaving
 -- the current menu
-selectItem :: [Item] -> RofiPrompt ()
+selectItem :: RofiConf c => [Item] -> RofiIO c ()
 selectItem items = selectAction $ emptyMenu
   { groups = [untitledGroup $ itemsToRofiActions items]
   , prompt = Just "Login"
   }
 
-itemsToRofiActions :: [Item] -> RofiActions
+itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
 itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
 
-selectCopy :: Login -> RofiPrompt ()
+selectCopy :: RofiConf c => Login -> RofiIO c ()
 selectCopy l = selectAction $ emptyMenu
   { groups = [untitledGroup $ loginToRofiActions l copy]
   , prompt = Just "Copy"
@@ -203,7 +203,7 @@ selectCopy l = selectAction $ emptyMenu
       , keyActions = loginToRofiActions l (const browseLogins)
       }
 
-loginToRofiActions :: Login -> (String -> RofiPrompt ()) -> RofiActions
+loginToRofiActions :: RofiConf c => Login -> (String -> RofiIO c ()) -> RofiActions c
 loginToRofiActions Login { username = u, password = p } a =
   toRofiActions $ catMaybes [user, pwd]
   where
@@ -231,7 +231,7 @@ memGetSession = "GetSession"
 memLockSession :: MemberName
 memLockSession = "LockSession"
 
-startService :: BWConf -> Session -> IO ()
+startService :: BWServerConf -> Session -> IO ()
 startService c ses = do
   client <- connectSession
   let flags = [nameAllowReplacement, nameReplaceExisting]

app/rofi-devices.hs

@@ -1,63 +1,145 @@
-{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 
 module Main (main) where
 
-import           Control.Exception
 import           Control.Monad
+import           Control.Monad.Reader
 
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.Char
-import           Data.Csv                   hiding (lookup)
 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           Data.Maybe
-import           Data.Vector                (Vector, toList)
-
-import           GHC.Generics               (Generic)
 
 import           Rofi.Command
 
 import           Text.Printf
 import           Text.Regex.TDFA
 
+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
+
 main :: IO ()
 main = check >> getArgs >>= parse
 
+type Password = IO (Maybe String)
+
+data MountConf = MountConf
+    { credentials :: M.Map String Password
+    , mountDir    :: FilePath
+    , rofiArgs    :: [String]
+    }
+
+instance RofiConf MountConf where
+  defArgs MountConf { rofiArgs = a } = a
+
+
+type DevicePasswords = M.Map String Password
+
+initMountConf :: [String] -> IO MountConf
+initMountConf a = conf <$> getEffectiveUserName
+  where
+    conf u = MountConf
+      { credentials = M.empty
+      , mountDir = "/media" </> u
+      , rofiArgs = a
+      }
+
+options :: [OptDescr (MountConf -> MountConf)]
+options =
+  -- TODO clean up massive text blocks here with textwrap
+  [ Option ['s'] ["secret"]
+    (ReqArg (\s m -> m { credentials = addGetSecret (credentials m) s } ) "SECRET")
+    ("Use libsecret to retrieve password for DIR using ATTR/VAL pairs.\n" ++
+     "The pairs will be supplied to a 'secret-tool lookup' call.\n" ++
+     "Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'")
+  , Option ['d'] ["directory"]
+    (ReqArg (\s m -> m { mountDir = s } ) "DIR")
+    ("The directory in which new mountpoints will be created. This is\n" ++
+     "assumed to be writable to the current user, and will be used for\n" ++
+     "fuse entries as well as user mounts in fstab. For the latter, it is\n" ++
+     "assumed that all user mounts contain this directory if a mountpoint\n" ++
+     "does not already exist for them. If not diven this will default to\n" ++
+     "'/media/USER'.")
+  , Option ['p'] ["password"]
+    (ReqArg (\s m -> m { credentials = addGetPrompt (credentials m) s } ) "DIR")
+    "Prompt for password when mounting DIR."
+  ]
+
 parse :: [String] -> IO ()
-parse = runMounts
+parse args = case getOpt Permute options args of
+  (o, n, [])   -> do
+    i <- initMountConf n
+    runMounts $ foldl (flip id) i o
+  -- TODO make this a real error
+  (_, _, errs) -> putStrLn $ concat errs ++ usageInfo "header" options
+
+addGetSecret :: DevicePasswords -> String -> DevicePasswords
+addGetSecret pwds c = case splitPrefix c of
+  (dir, ":", r) -> addPasswordGetter pwds dir $ runGetSecret
+    $ mapMaybe (toCell . splitEq) $ splitBy ',' r
+  _             -> pwds
+  where
+    splitPrefix s = s =~ (":" :: String) :: (String, String, String)
+    splitEq e = e =~ ("=" :: String) :: (String, String, String)
+    toCell (k, "=", v) = Just (k, v)
+    toCell _           = Nothing
+
+runGetSecret :: [(String, String)] -> Password
+runGetSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
+  where
+    kvs' = concatMap (\(k, v) -> [k, v]) kvs
+
+addGetPrompt :: DevicePasswords -> String -> DevicePasswords
+addGetPrompt pwds dir = addPasswordGetter pwds dir readPassword
+
+addPasswordGetter :: DevicePasswords -> String -> IO (Maybe String) -> DevicePasswords
+addPasswordGetter pwds key f = M.insert key f pwds
+
+-- runGetBwPwd :: [(String, String)] -> IO (Maybe String)
+-- runGetBwPwd = undefined
+
+-- getPassword :: Credentials -> IO (Maybe String)
+-- getPassword NoCredentials = return Nothing
+-- getPassword (Secret kvs) = do
+--   let kvs' = concat [[a, b] | (a, b) <- M.toList kvs]
+--   readCmdSuccess "secret-tool" ("lookup":kvs') ""
 
 -- TODO
 check :: IO ()
 check = return ()
 
-runMounts :: [String] -> IO ()
+runMounts :: MountConf -> IO ()
-runMounts a = do
+runMounts c = runRofiIO c $ runPrompt =<< getGroups
-  let c = RofiConf { defArgs = a }
-  runRofiPrompt c runPrompt
 
-runPrompt :: RofiPrompt ()
+runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
-runPrompt = do
+runPrompt gs = selectAction $ emptyMenu
-  net <- titledGroup "Network Devices" <$> io getNetActions
+               { groups = gs
-  rmv <- titledGroup "Removable Devices" <$> io getRemovableActions
-  mtp <- titledGroup "MTP Devices" <$> io getMTPActions
-  selectAction $ emptyMenu
-        { groups = [net, rmv, mtp]
                , prompt = Just "Select Device"
                }
 
-getNetActions :: IO RofiActions
+getGroups :: RofiIO MountConf [RofiGroup MountConf]
-getNetActions = alignEntries . toRofiActions . catMaybes
+getGroups = do
-  <$> (mapM csvToAction =<< getCSV)
+  fstab <- readFSTab
+  sequence
+    [ mkGroup "SSHFS Devices" $ sshfsDevices fstab
+    , mkGroup "CIFS Devices" $ cifsDevices fstab
+    , mkGroup "Removable Devices" =<< getRemovableDevices
+    , mkGroup "MTP Devices" =<< getMTPDevices
+    ]
+
+mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf)
+mkGroup header devs = titledGroup header . alignEntries . toRofiActions
+    <$> mapM mkAction devs
 
 alignSep :: String
 alignSep = " | "
@@ -65,7 +147,7 @@ alignSep = " | "
 alignSepPre :: String
 alignSepPre = "@@@"
 
-alignEntries :: RofiActions -> RofiActions
+alignEntries :: RofiActions c -> RofiActions c
 alignEntries = O.fromList . withKeys . O.assocs
   where
     withKeys as = let (ks, vs) = unzip as in zip (align ks) vs
@@ -83,24 +165,24 @@ alignEntries = O.fromList . withKeys . O.assocs
 -- | Class and methods for type representing mountable devices
 class Mountable a where
   -- | Mount the given type (or dismount if False is passed)
-  mount :: a -> Bool -> IO ()
+  mount :: a -> Bool -> RofiIO MountConf ()
 
   -- | Check if the mounting utilities are present
-  allInstalled :: a -> IO Bool
+  allInstalled :: a -> RofiIO MountConf Bool
 
   -- | Return a string to go in the Rofi menu for the given type
   fmtEntry :: a -> String
 
   -- | Determine if the given type is mounted or not
-  isMounted :: a -> IO Bool
+  isMounted :: a -> RofiIO MountConf Bool
 
   -- | 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 -> IO (String, RofiPrompt ())
+  mkAction :: a -> RofiIO MountConf (String, RofiIO MountConf ())
   mkAction dev = do
     m <- isMounted dev
     i <- allInstalled dev
-    let a = when i $ io $ mount dev m
+    let a = when i $ mount dev m
     let s = mountedPrefix m i ++ fmtEntry dev
     return (s, a)
     where
@@ -121,99 +203,62 @@ parseMountOptions s = M.fromList $ toCell . splitEq <$> splitBy ',' s
     toCell (k, "=", v) = (k, Just v)
     toCell (k, _, _)   = (k, Nothing)
 
--- | Given a mount options map, return a string of comma separated items
+-- -- | Given a mount options map, return a string of comma separated items
-fmtMountOptions :: MountOptions -> String
+-- fmtMountOptions :: MountOptions -> String
-fmtMountOptions = intercalate "," . fmap fromCell . M.toList
+-- fmtMountOptions = intercalate "," . fmap fromCell . M.toList
-  where
+--   where
-    fromCell (k, Just v)  = k ++ "=" ++ v
+--     fromCell (k, Just v)  = k ++ "=" ++ v
-    fromCell (k, Nothing) = k
+--     fromCell (k, Nothing) = k
-
--- | Various credentials to be used with a given mountable type.
--- Secret: represents a lookup using 'secret-tool' where the map represents
--- the attribute/value pairs to pass.
--- NoCredentials: self explanatory
-data Credentials = Secret (M.Map String String)
-    | NoCredentials
-    deriving (Eq, Show)
-
--- | Given a string, return a credentials type. The type of credentials is
--- determined by the prefix (which is followed by a colon) and is followed by
--- a comma-separated list of 'key=val' pairs
-parseCredentials :: String -> Credentials
-parseCredentials c = case splitPrefix c of
-  ("secret", ":", r) -> Secret $ M.fromList $ mapMaybe (toCell . splitEq) $ splitBy ',' r
-  -- TODO fetch from bitwarden
-  -- add more here...
-  _                  -> NoCredentials
-  where
-    splitPrefix s = s =~ (":" :: String) :: (String, String, String)
-    splitEq e = e =~ ("=" :: String) :: (String, String, String)
-    toCell (k, "=", v) = Just (k, v)
-    toCell _           = Nothing
 
 --------------------------------------------------------------------------------
 -- | Removable devices
 --
 -- A device which can be removed (which is all the devices we care about)
--- This can be minimally described by a device PATH and LABEL. If MOUNTPOINT is
+-- This can be minimally described by a device DEVICESPEC and LABEL.
--- Nothing, this represents the device being mounted at a default location.
 
 data Removable = Removable
-    { path       :: String
+    { deviceSpec :: String
     , label      :: String
-    , mountpoint :: Maybe String
     }
     deriving (Eq, Show)
 
 instance Mountable Removable where
   -- | (Un)mount the device using udiskctl
-  mount Removable { path = p, label = l } m = do
+  mount Removable { deviceSpec = d, label = l } m = io $ do
-    res <- readCmdEither "udisksctl" [cmd, "-b", p] ""
+    res <- readCmdEither "udisksctl" [cmd, "-b", d] ""
     notifyMounted (isRight res) m l
       where
         cmd = if m then "unmount" else "mount"
 
   -- | Need udisksctl to mount and umount
-  allInstalled _ = isJust <$> findExecutable "udisksctl"
+  allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"
 
   -- | Check if the device is mounted using /proc/mount
-  isMounted Removable { path = p, mountpoint = m } = do
+  isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs
-    cur <- curMountpoints
-    return $ case m of
-      Just m' -> (p, m') `elem` cur
-      Nothing -> p `elem` fmap fst cur
 
   -- | Format the Rofi entry like 'LABEL - PATH' and add a star in the front
   -- if the device is mounted
-  fmtEntry Removable { path = p, label = l } = l ++ alignSepPre ++ p
+  fmtEntry Removable { deviceSpec = d, label = l } = l ++ alignSepPre ++ d
-
 
 -- | 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
 -- label shown on the prompt will be 'SIZE Volume' where size is the size of
 -- the device
-getRemovableDevices :: IO [Removable]
+getRemovableDevices :: RofiConf c => RofiIO c [Removable]
 getRemovableDevices = mapMaybe toDev
   . lines
   . stripWS
-  <$> readProcess "lsblk" ["-n", "-r", "-o", columns] ""
+  <$> 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
-      [_, "1", p, "", s] -> mk p $ s ++ " Volume"
+      [_, "1", d, "", s] -> mk d $ s ++ " Volume"
-      [_, "1", p, l, _]  -> mk p l
+      [_, "1", d, l, _]  -> mk d l
       _                  -> Nothing
-    mk p l = Just $ Removable { path = p
+    mk d l = Just $ Removable { deviceSpec = d, label = l }
-                              , label = l
-                              , mountpoint = Nothing
-                              }
-
-getRemovableActions :: IO RofiActions
-getRemovableActions = alignEntries . toRofiActions
-  <$> (mapM mkAction =<< getRemovableDevices)
 
 --------------------------------------------------------------------------------
 -- | CIFS Devices
@@ -221,34 +266,46 @@ getRemovableActions = alignEntries . toRofiActions
 -- This wraps the Removable device (since it is removable) and also adds its
 -- own mount options and credentials for authentication.
 
-data CIFS = CIFS Removable MountOptions Credentials
+data CIFS = CIFS Removable FilePath (Maybe Password)
 
 instance Mountable CIFS where
-  -- | Mount using udevil
+  mount (CIFS Removable{ label = l } m getPwd) False =
-  mount (CIFS Removable{..} opts creds) False = do
+    bracketOnError_
-    pwd <- getPassword creds
+      (mkDirMaybe m)
-    let opts' = fmtOpts $ addPwd pwd opts
+      (rmDirMaybe m)
-    res <- readCmdEither "udevil" (["mount"] ++ opts' ++ ["-t", "cifs", path]) ""
+      $ io $ do
-    notifyMounted (isRight res) False label
+      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
+
+-- TODO this smells like something that should be in a typeclass
+fstabToCIFS :: FSTabEntry -> RofiIO MountConf CIFS
+fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
+  -- This is a hack. If the options specify "guest" don't require a
+  -- password. Else try to find a means to get the password from the
+  -- command line options provided for the this mountpoint. If nothing is
+  -- found, create a dummy function that returns "" as the password, which
+  -- will be passed to the env variable PASSWD when mounting this cifs
+  -- directory and cause it to fail. Setting the env variable is necessary
+  -- the cifs mount call will prompt for a password and hang otherwise.
+  pwd <- if M.member "guest" o
+         then return Nothing
+         else Just . M.findWithDefault (return $ Just "") d <$> asks credentials
+  let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
+  return $ CIFS r d pwd
   where
-      addPwd (Just pwd) o = M.insert "password" (Just pwd) o
+    smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
-      addPwd Nothing o    = o
-      fmtOpts o = if null o then [] else ["-o", fmtMountOptions o]
-
-  -- | Unmount using udevil
-  mount (CIFS Removable{..} _ _) True = do
-    res <- readCmdEither "udevil" ["unmount", path] ""
-    notifyMounted (isRight res) True label
-
-  -- | Need udevil and mount.cifs
-  allInstalled _ = all isJust <$> mapM findExecutable ["udevil", "mount.cifs"]
-
-  -- | Return True if mounted. Only checks the removable type wrapped within
-  isMounted (CIFS r _ _) = isMounted r
-
-  -- | Format the Rofi entry like 'LABEL - (CIFS) - PATH' and prefix with a star
-  -- if mounted
-  fmtEntry (CIFS r _ _) = fmtNetEntry r "CIFS"
 
 --------------------------------------------------------------------------------
 -- | SSHFS Devices
@@ -258,42 +315,29 @@ instance Mountable CIFS where
 -- config that specifies the port, hostname, user, and identity file, these
 -- need to be passed as mount options.
 
-data SSHFS = SSHFS Removable MountOptions
+data SSHFS = SSHFS Removable FilePath
 
 instance Mountable SSHFS where
-  -- | Mount using sshfs
+  mount (SSHFS Removable{ label = l } m) False =
-  mount (SSHFS Removable{..} opts) False =
+    bracketOnError_
-    case mountpoint of
+      (mkDirMaybe m)
-      Just m  -> cmd m
+      (rmDirMaybe m)
-      -- TODO only destroy mountpoint if it is not already another mountpoint
+      $ io $ do
-      Nothing -> bracketOnError (makeFuseMount label)
+      res <- readCmdEither "mount" [m] ""
-        (const $ destroyFuseMount label) (const $ cmd $ fmtFusePath label)
+      notifyMounted (isRight res) False l
+
+  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
+
+fstabToSSHFS :: FSTabEntry -> RofiIO MountConf SSHFS
+fstabToSSHFS FSTabEntry{ fstabSpec = s, fstabDir = d } = return $ SSHFS r d
   where
-      -- TODO add auto-dismount to options
+    r = Removable { deviceSpec = s, label = takeFileName d }
-      opts' = if null opts then [] else ["-o", fmtMountOptions opts]
-      cmd m' = do
-        res <- readCmdEither "sshfs" ([path, m'] ++ opts') ""
-        notifyMounted (isRight res) False label
-
-  -- | Umount using fusermount
-  mount (SSHFS r _) True = fuseUnmount r
-
-  -- | Need sshfs (assume fuse is also installed)
-  allInstalled _ = isJust <$> findExecutable "sshfs"
-
-  -- | Return True if mounted. Only checks the removable type wrapped within
-  isMounted (SSHFS r _) = isMounted r
-
-  -- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH' and prefix with a
-  -- star if mounted
-  fmtEntry (SSHFS r _) = fmtNetEntry r "SSHFS"
-
--- | Given a removable device, type string, and boolean for if the device is
--- mounted, return a string like 'LABEL - (TYPESTRING) - PATH' and prefix with a
--- star if mounted
-fmtNetEntry :: Removable -> String -> String
-fmtNetEntry Removable { label = l, path = p } t =
-  intercalate alignSepPre [l, t, p]
 
 --------------------------------------------------------------------------------
 -- | MTP devices
@@ -301,47 +345,47 @@ fmtNetEntry Removable { label = l, path = p } t =
 data MTPFS = MTPFS
     { bus         :: String
     , device      :: String
-    , mountpointMTP :: String
+    , mountpoint  :: FilePath
     , description :: String
     }
     deriving (Eq, Show)
 
 instance Mountable MTPFS where
-  -- | Mount using sshfs
   mount MTPFS {..} False = do
     -- TODO add autodismount to options
     let dev = "-device=" ++ bus ++ "," ++ device
-    bracketOnError (createDirectoryIfMissing False mountpointMTP)
+    bracketOnError_
-      (const $ removePathForcibly mountpointMTP) $ \_ -> do
+      (mkDirMaybe mountpoint)
-      res <- readCmdEither "jmtpfs" [dev, mountpointMTP] ""
+      (rmDirMaybe mountpoint)
+      $ io $ do
+      res <- readCmdEither "jmtpfs" [dev, mountpoint] ""
       notifyMounted (isRight res) False description
 
-  -- | Umount using fusermount
+  mount MTPFS { mountpoint = m, description = d } True = umountNotify d m
-  mount MTPFS { mountpointMTP = m, description = d } True =
-    finally (fuseUnmount' d m) $ removePathForcibly m
 
-  -- | Need jmtpfs (assume fuse is also installed)
+  -- | return True always since the list won't even show without jmtpfs
-  allInstalled _ = isJust <$> findExecutable "jmtpfs"
+  allInstalled _ = return True
 
-  -- | Return True if mounted. Only checks the mountpoint path
+  isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir
-  isMounted MTPFS { mountpointMTP = m } = elem m . fmap snd <$> curMountpoints
 
-  -- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH'
   fmtEntry MTPFS { description = d } = d
 
-getMTPDevices :: IO [MTPFS]
+getMTPDevices :: RofiIO MountConf [MTPFS]
-getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] ""
+getMTPDevices = do
+  dir <- asks mountDir
+  res <- io $ readProcess "jmtpfs" ["-l"] ""
+  return $ mapMaybe (toDev dir) $ toDevList res
   where
     toDevList = reverse
       . takeWhile (not . isPrefixOf "Available devices")
       . reverse
       . lines
-    toDev s = case splitOn ", " s of
+    toDev dir s = case splitOn ", " s of
       [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
         in Just $ MTPFS
            { bus = busNum
            , device = devNum
-           , mountpointMTP = fuseMount ++ canonicalize d
+           , mountpoint = dir </> canonicalize d
            , description = d
            }
       _ -> Nothing
@@ -351,108 +395,91 @@ getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] ""
       | c == ' ' = Just '-'
       | otherwise = Just c
 
-getMTPActions :: IO RofiActions
-getMTPActions = toRofiActions <$> (mapM mkAction =<< getMTPDevices)
-
 -- TODO add truecrypt volumes (see tcplay, will need root)
 --------------------------------------------------------------------------------
--- | Csv device parsing
+-- | Fstab devices
---
--- These devices are stored in a CSV file which needs to be parsed into the
--- appropriate devices types
 
--- | Represents one parsable line in the network device config .tsv file
+data FSTab = FSTab
-data CsvDev = CsvDev
+    { sshfsDevices :: [SSHFS]
-    { csvLabel        :: String
+    , cifsDevices  :: [CIFS]
-    , csvType         :: String
-    , csvPath         :: String
-    , csvMountpoint   :: Maybe String
-    , csvMountOptions :: Maybe String
-    , csvCredentials  :: Maybe String
     }
-    deriving (Generic, Show)
 
-instance FromRecord CsvDev
+data FSTabEntry = FSTabEntry
+    { fstabSpec    :: String
+    , fstabDir     :: FilePath
+    , fstabType    :: String
+    , fstabOptions :: MountOptions
+    }
 
--- | Return a list of all Csv lines from the network config file
+readFSTab :: RofiIO MountConf FSTab
-getCSV :: IO [CsvDev]
+readFSTab = do
-getCSV = do
+  let i = FSTab { sshfsDevices = [], cifsDevices = [] }
-  xdgConf <- getEnv "XDG_CONFIG_HOME"
+  fstab <- io $ readFile "/etc/fstab"
-  -- TODO this shouldn't be hardcoded
+  foldM addFstabDevice i $ mapMaybe toEntry $ lines fstab
-  contents <- B.readFile $ xdgConf ++ "/rofi/devices.tsv"
-  let opts = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') }
-  case decodeWith opts HasHeader contents of
-    Left s  -> putStrLn s >> return []
-    Right v -> return $ toList (v :: Vector CsvDev)
-
--- TODO split this into each device type so they can be separated in the prompt
--- | Given a parsed csv line from the network config file, return a
--- (ENTRY, ACTION) where ENTRY is a string to appear on the Rofi prompt and
--- ACTION is an action to perform on the device in the csv line when selected
-csvToAction :: CsvDev -> IO (Maybe (String, RofiPrompt ()))
-csvToAction CsvDev {..}
-  | csvType == "cifs" = Just <$> mkAction (CIFS r' opts creds)
-  | csvType == "sshfs" = Just <$> mkAction (SSHFS r opts)
-  | otherwise = return Nothing
   where
-    r = Removable { label = csvLabel
+    toEntry line = case words $ stripWS line of
-                  , path = csvPath
+      (('#':_):_)                     -> Nothing
-                  , mountpoint = csvMountpoint
+      [spec, dir, fsType, opts, _, _] -> Just $ FSTabEntry
+                                         { fstabSpec = spec
+                                         , fstabDir = dir
+                                         , fstabType = fsType
+                                         , fstabOptions = parseMountOptions opts
                                          }
-    opts = maybe M.empty parseMountOptions csvMountOptions
+      _                               -> Nothing
-    creds = maybe NoCredentials parseCredentials csvCredentials
+
-    -- CIFS prefixes the path with two slashes
+addFstabDevice :: FSTab -> FSTabEntry -> RofiIO MountConf FSTab
-    r' = r { path = smartSlashPrefix csvPath }
+addFstabDevice f@FSTab{..} e@FSTabEntry{..}
-    smartSlashPrefix s = if "//" `isPrefixOf` s then s else "//" ++ s
+  | M.notMember "users" fstabOptions = return f
+  | fstabType == "cifs" =
+    (\d -> f { cifsDevices = cifsDevices ++ [d] }) <$> fstabToCIFS e
+  | fstabType == "fuse.sshfs" =
+    (\d -> f { sshfsDevices = sshfsDevices ++ [d] }) <$> fstabToSSHFS e
+  | otherwise = return f
 
 --------------------------------------------------------------------------------
 -- | Low-level mount functions
 
--- | Return a list of mountpoints like (PATH, MOUNTPOINT) from /proc/mount
+-- ASSUME these will never fail because the format of this file is fixed
-curMountpoints :: IO [(String, String)]
-curMountpoints = do
-  m <- readFile "/proc/mounts"
-  -- ASSUME this will never fail because the format of this file is fixed
-  return $ (\(path:mntpnt:_) -> (path, mntpnt)) . words <$> lines m
 
--- | Given a path, return its mountpoint if it exists
+curMountField :: Int -> IO [String]
-lookupMountpoint :: String -> IO (Maybe String)
+curMountField i = fmap ((!! i) . words) . lines <$> readFile "/proc/mounts"
-lookupMountpoint path = lookup path <$> curMountpoints
 
--- | Given a removable device, unmount it using fuse
+curDeviceSpecs :: IO [String]
-fuseUnmount :: Removable -> IO ()
+curDeviceSpecs = curMountField 0
-fuseUnmount Removable { path = p, mountpoint = m, label = l } =
+
-  maybe umountDef umount m
+curMountpoints :: IO [String]
+curMountpoints = curMountField 1
+
+mkDirMaybe :: FilePath -> RofiIO MountConf ()
+mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
+
+rmDirMaybe :: FilePath -> RofiIO MountConf ()
+rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
+  $ asks mountDir >>= io . rmUntil fp
   where
-    umount = fuseUnmount' l
+    rmUntil cur target = unless (target == cur) $ do
-    umountDef = lookupMountpoint p >>=
+      removePathForcibly cur
-      mapM_ (liftM2 finally umount removePathForcibly)
+      rmUntil (takeDirectory cur) target
 
-fuseUnmount' :: String -> String -> IO ()
+whenInMountDir :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
-fuseUnmount' label path = do
+whenInMountDir fp f = do
-  res <- readCmdEither "fusermount" ["-u", path] ""
+  mDir <- asks mountDir
+  when (mDir `isPrefixOf` fp) f
+
+unlessMountpoint :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
+unlessMountpoint fp f = do
+  mounted <- io $ isDirMounted fp
+  unless mounted f
+
+umountNotify :: String -> FilePath -> RofiIO MountConf ()
+umountNotify label dir = finally cmd $ rmDirMaybe dir
+  where
+    cmd = io $ do
+      res <- readCmdEither "umount" [dir] ""
       notifyMounted (isRight res) True label
 
--- | Given credentials, return a password
+isDirMounted :: FilePath -> IO Bool
-getPassword :: Credentials -> IO (Maybe String)
+isDirMounted fp = elem fp <$> curMountpoints
-getPassword NoCredentials = return Nothing
-getPassword (Secret kvs) = do
-  let kvs' = concat [[a, b] | (a, b) <- M.toList kvs]
-  readCmdSuccess "secret-tool" ("lookup":kvs') ""
-
--- TODO this shouldn't be hardcoded
-fuseMount :: FilePath
-fuseMount = "/media/ndwar-fuse/"
-
--- TODO what if there is no trailing slash?
-fmtFusePath :: String -> String
-fmtFusePath label = fuseMount ++ label
-
-makeFuseMount :: String -> IO ()
-makeFuseMount label = createDirectoryIfMissing False $ fmtFusePath label
-
-destroyFuseMount :: String -> IO ()
-destroyFuseMount label = removePathForcibly $ fmtFusePath label
 
 --------------------------------------------------------------------------------
 -- | Other functions

lib/Rofi/Command.hs

@@ -5,23 +5,27 @@ module Rofi.Command
   , RofiMenu(..)
   , RofiAction
   , RofiActions
-  , RofiPrompt
+  , RofiIO
+  , RofiGroup
   , Hotkey(..)
   , io
   , emptyMenu
-  , runRofiPrompt
+  , runRofiIO
   , toRofiActions
   , rofiActionKeys
   , untitledGroup
   , titledGroup
   , selectAction
+  , readPassword
   , readCmdSuccess
   , readCmdEither
+  , readCmdEither'
   , dmenuArgs
   , joinNewline
   , stripWS
   ) where
 
+import           Control.Monad.IO.Unlift
 import           Control.Monad.Reader
 
 import           Data.Char
@@ -32,99 +36,97 @@ import           Data.Maybe
 import           System.Exit
 import           System.Process
 
-newtype RofiConf = RofiConf
+class RofiConf c where
-    { defArgs :: [String]
+  defArgs :: c -> [String]
-    }
-  deriving (Eq, Show)
 
-type RofiAction = (String, RofiPrompt ())
+type RofiAction c = (String, RofiIO c ())
 
-type RofiActions = M.OMap String (RofiPrompt ())
+type RofiActions c = M.OMap String (RofiIO c ())
 
-data RofiGroup = RofiGroup
+data RofiGroup c = RofiGroup
-    { actions :: RofiActions
+    { actions :: RofiActions c
     , title   :: Maybe String
     }
 
-untitledGroup :: RofiActions -> RofiGroup
+untitledGroup :: RofiActions c -> RofiGroup c
 untitledGroup a = RofiGroup { actions = a, title = Nothing }
 
-titledGroup :: String -> RofiActions -> RofiGroup
+titledGroup :: String -> RofiActions c -> RofiGroup c
 titledGroup t a = (untitledGroup a) { title = Just t }
 
-data Hotkey = Hotkey
+data Hotkey c = Hotkey
     { keyCombo       :: String
     -- only 1-10 are valid
     , keyIndex       :: Int
     , keyDescription :: String
-    , keyActions     :: RofiActions
+    , keyActions     :: RofiActions c
     }
 
-hotkeyBinding :: Hotkey -> [String]
+hotkeyBinding :: Hotkey c -> [String]
 hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
   where
     k = "-kb-custom-" ++ show e
 
-hotkeyMsg1 :: Hotkey -> String
+hotkeyMsg1 :: Hotkey c -> String
 hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
   c ++ ": <i>" ++ d ++ "</i>"
 
-hotkeyMsg :: [Hotkey] -> [String]
+hotkeyMsg :: [Hotkey c] -> [String]
 hotkeyMsg [] = []
 hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
 
-hotkeyArgs :: [Hotkey] -> [String]
+hotkeyArgs :: [Hotkey c] -> [String]
 hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
 
-data RofiMenu = RofiMenu
+data RofiMenu c = RofiMenu
-    { groups  :: [RofiGroup]
+    { groups  :: [RofiGroup c]
     , prompt  :: Maybe String
-    , hotkeys :: [Hotkey]
+    , hotkeys :: [Hotkey c]
     }
 
-emptyMenu :: RofiMenu
+emptyMenu :: RofiMenu c
 emptyMenu = RofiMenu
   { groups = []
   , prompt = Nothing
   , hotkeys = []
   }
 
-newtype RofiPrompt a = RofiPrompt (ReaderT RofiConf IO a)
+newtype RofiIO c a = RofiIO (ReaderT c IO a)
-    deriving (Functor, Monad, MonadIO, MonadReader RofiConf)
+    deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO)
 
-instance Applicative RofiPrompt where
+instance Applicative (RofiIO c) where
   pure = return
   (<*>) = ap
 
-io :: IO a -> RofiPrompt a
+io :: MonadIO m => IO a -> m a
 io = liftIO
 
-runRofiPrompt :: RofiConf -> RofiPrompt a -> IO a
+runRofiIO :: c -> RofiIO c a -> IO a
-runRofiPrompt c (RofiPrompt a) = runReaderT a c
+runRofiIO c (RofiIO r) = runReaderT r c
 
-toRofiActions :: [(String, RofiPrompt ())] -> RofiActions
+toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
 toRofiActions = M.fromList
 
-rofiActionKeys :: RofiActions -> String
+rofiActionKeys :: RofiActions c -> String
 rofiActionKeys = joinNewline . map fst . M.assocs
 
-lookupRofiAction :: String -> RofiActions -> RofiPrompt ()
+lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
 lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
 
-groupEntries :: RofiGroup -> String
+groupEntries :: RofiGroup c -> String
 groupEntries RofiGroup { actions = a, title = t }
   | null a = ""
   | otherwise = title' ++ rofiActionKeys a
   where
     title' = maybe "" (++ "\n") t
 
-menuActions :: RofiMenu -> RofiActions
+menuActions :: RofiMenu c -> RofiActions c
 menuActions = foldr1 (M.<>|) . fmap actions . groups
 
-menuEntries :: RofiMenu -> String
+menuEntries :: RofiMenu c -> String
 menuEntries = intercalate "\n\n" . fmap groupEntries . groups
 
-selectAction :: RofiMenu -> RofiPrompt ()
+selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
 selectAction rm = do
   let p = maybeOption "-p" $ prompt rm
   let hArgs = hotkeyArgs $ hotkeys rm
@@ -141,7 +143,9 @@ maybeOption switch = maybe [] (\o -> [switch, o])
 dmenuArgs :: [String]
 dmenuArgs = ["-dmenu"]
 
-readRofi :: [String] -> String -> RofiPrompt (Either (Int, String, String) String)
+readRofi :: RofiConf c => [String]
+  -> String
+  -> RofiIO c (Either (Int, String, String) String)
 readRofi uargs input = do
   dargs <- asks defArgs
   io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
@@ -150,15 +154,35 @@ readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
 readCmdSuccess cmd args input = either (const Nothing) Just
   <$> readCmdEither cmd args input
 
-readCmdEither :: String -> [String] -> String -> IO (Either (Int, String, String) String)
+readCmdEither :: String
-readCmdEither cmd args input = do
+  -> [String]
-  (ec, out, err) <- readProcessWithExitCode cmd args input
+  -> String
-  return $ case ec of
+  -> IO (Either (Int, String, String) String)
-    ExitSuccess   -> Right $ stripWS out
+readCmdEither cmd args input = resultToEither
-    ExitFailure n -> Left (n, stripWS out, stripWS err)
+  <$> readProcessWithExitCode cmd args input
+
+readCmdEither' :: String
+  -> [String]
+  -> String
+  -> [(String, String)]
+  -> IO (Either (Int, String, String) String)
+readCmdEither' cmd args input environ = resultToEither
+  <$> readCreateProcessWithExitCode p input
+  where
+    p = (proc cmd args) { env = Just environ }
+
+resultToEither :: (ExitCode, String, String)
+  -> Either (Int, String, String) String
+resultToEither (ExitSuccess, out, _)     = Right $ stripWS out
+resultToEither (ExitFailure n, out, err) = Left (n, stripWS out, stripWS err)
 
 stripWS :: String -> String
 stripWS = reverse . dropWhile isSpace . reverse
 
 joinNewline :: [String] -> String
 joinNewline = intercalate "\n"
+
+readPassword :: IO (Maybe String)
+readPassword = readCmdSuccess "rofi" args ""
+  where
+    args = dmenuArgs ++ ["-p", "Password", "-password"]

package.yaml

@@ -23,16 +23,21 @@ dependencies:
 - process >= 1.6.5.0
 - aeson >= 1.4.5.0
 - unix-time >= 0.4.7
+- unix >= 2.7.2.2
 - dbus >= 1.2.7
 - ordered-containers >= 0.2.2
 - Clipboard >= 2.3.2.0
 - mtl >= 2.2.2
 - directory >= 1.3.3.0
-- cassava >= 0.5.2.0
 - bytestring >= 0.10.8.2
-- vector >= 0.12.0.3
 - regex-tdfa >= 1.2.3.2
-- split >= 0.2.3.4
+- split >= 0.2.3.3
+- containers >= 0.6.0.1
+- filepath >= 1.4.2.1
+- unliftio >= 0.2.12
+- unliftio-core >= 0.1.2.0
+# - cassava >= 0.5.2.0
+# - vector >= 0.12.0.3
 
 library:
   source-dirs: lib/