From cd3ee141b02454fe3cf7c9b4027e624c26c415dd Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Thu, 18 Mar 2021 00:41:04 -0400
Subject: [PATCH] ENH use yaml file for static config

---
 app/rofi-dev.hs | 388 +++++++++++++++++++++++++++---------------------
 package.yaml    |   5 +-
 2 files changed, 220 insertions(+), 173 deletions(-)

diff --git a/app/rofi-dev.hs b/app/rofi-dev.hs
index 129020e..7a0df19 100644
--- a/app/rofi-dev.hs
+++ b/app/rofi-dev.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
@@ -23,13 +24,14 @@ import           Data.List.Split       (splitOn)
 import qualified Data.Map              as M
 import qualified Data.Map.Ordered      as O
 import           Data.Maybe
-import           Data.Text             (unpack)
+import qualified Data.Vector as V
+import           Data.Yaml
+
+import           GHC.Generics()
 
 import           Rofi.Command
 
 import           Text.Printf
-import           Text.Regex.TDFA
-import           Text.Wrap
 
 import           System.Console.GetOpt
 import           System.Directory
@@ -53,39 +55,144 @@ parse args = case getOpt Permute options args of
 
 options :: [OptDescr (MountConf -> MountConf)]
 options =
-  [ Option ['s'] ["secret"]
-    (ReqArg (\s m -> m { passwords = addSecret (passwords m) s } ) "SECRET")
-    $ wrap "Use libsecret to retrieve password for DIR using ATTR/VAL pairs. \
-           \The pairs will be supplied to a 'secret-tool lookup' call. \
-           \ Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'"
-  , Option ['b'] ["bitwarden"]
-    (ReqArg (\s m -> m { passwords = addBitwarden (passwords m) s } ) "BW")
-    $ wrap "Use the Bitwarden CLI to retrieve a password for DIR. \
-           \The argument is formatted like 'DIR:NAME' where NAME is the \
-           \name of the Bitwarden entry to find."
-  , Option ['p'] ["password"]
-    (ReqArg (\s m -> m { passwords = addPwdPrompt (passwords m) s } ) "DIR")
-    "Prompt for password when mounting DIR."
-  , Option ['d'] ["directory"]
-    (ReqArg (\s m -> m { mountDir = s } ) "DIR")
-    $ wrap "The DIR in which new mountpoints will be created. This is assumed \
-           \to be writable to the current user, and will be used for fuse \
-           \entries as well as user mounts in fstab. For the latter, it is \
-           \assumed that all user mounts contain this directory if a \
-           \mountpoint does not already exist for them. If not given this will \
-           \default to '/tmp/media/USER'."
-  , Option ['v'] ["veracrypt"]
-    (ReqArg (\s m -> m { vcMounts = addVeracryptMount (vcMounts m) s } ) "VC")
-    $ wrap "A veracrypt mount specification formatted like DIR:VOL where \
-           \DIR is the mountpoint and VOL is the path to the encrypted \
-           \volume. To specify a password, use the -p, -b- or -s options."
+  [ Option ['c'] ["config"]
+    (ReqArg (\s m -> m { mConfig = Just s } ) "CONF")
+    "The path to the config file"
   ]
-  where
-    wrap = unpack . wrapText defaultWrapSettings 40
 
 --------------------------------------------------------------------------------
 -- | Static configuration
 --
+-- This is defined in a YAML file which describes how to mount each device. Here
+-- I define a parser for said YAML file
+
+defaultTries :: Integer
+defaultTries = 2
+
+data MountConfig = MountConfig
+  { _mountMountPoint :: FilePath
+  , _mountLabel :: Maybe String
+  } deriving Show
+
+instance FromJSON MountConfig where
+  parseJSON = withObject "devices" $ \o -> MountConfig
+    <$> o .: "mountpoint"
+    <*> o .:? "label"
+
+data BitwardenConfig = BitwardenConfig
+  { _bitwardenKey :: String
+  , _bitwardenTries :: Integer }
+  deriving Show
+
+instance FromJSON BitwardenConfig where
+  parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
+    <$> o .: "key"
+    <*> o .:? "tries" .!= defaultTries
+
+newtype LibSecretConfig = LibSecretConfig
+  { _libsecretAttributes :: M.Map String String }
+  deriving Show
+
+instance FromJSON LibSecretConfig where
+  parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
+    <$> o .: "attributes"
+
+newtype PromptConfig = PromptConfig
+  { _promptTries :: Integer }
+  deriving Show
+
+instance FromJSON PromptConfig where
+  parseJSON = withObject "libsecret" $ \o -> PromptConfig
+    <$> o .: "tries" .!= defaultTries
+
+data PasswordConfig = PasswordConfig
+  { _passwordBitwarden :: Maybe BitwardenConfig
+  , _passwordLibSecret :: Maybe LibSecretConfig
+  , _passwordPrompt :: Maybe PromptConfig
+  }
+  deriving Show
+
+instance FromJSON PasswordConfig where
+  parseJSON = withObject "password" $ \o -> PasswordConfig
+    <$> o .:? "bitwarden"
+    <*> o .:? "libsecret"
+    <*> o .:? "prompt"
+                       
+data VeracryptConfig = VeracryptConfig
+  { _veracryptMount :: MountConfig
+  , _veracryptVolume :: String
+  , _veracryptPassword :: Maybe PasswordConfig
+  } deriving Show
+
+instance FromJSON VeracryptConfig where
+  parseJSON = withObject "veracrypt" $ \o -> VeracryptConfig
+    <$> o .: "mount"
+    <*> o .: "volume"
+    <*> o .:? "password"
+
+data SSHFSConfig = SSHFSConfig
+  { _sshfsMount :: MountConfig
+  , _sshfsRemote :: String
+  } deriving Show
+
+instance FromJSON SSHFSConfig where
+  parseJSON = withObject "sshfs" $ \o -> SSHFSConfig
+    <$> o .: "mount"
+    <*> o .: "remote"
+
+data CIFSConfig = CIFSConfig
+  { _cifsMount :: MountConfig
+  , _cifsRemote :: String
+  , _cifsPassword :: Maybe PasswordConfig
+  } deriving Show
+
+instance FromJSON CIFSConfig where
+  parseJSON = withObject "cifs" $ \o -> CIFSConfig
+    <$> o .: "mount"
+    <*> o .: "remote"
+    <*> o .: "password"
+
+data DevicesConfig = DevicesConfig
+  { _veracryptConfigs :: V.Vector VeracryptConfig
+  , _sshfsConfigs :: V.Vector SSHFSConfig
+  , _cifsConfigs :: V.Vector CIFSConfig
+  } deriving Show
+
+instance FromJSON DevicesConfig where
+  parseJSON = withObject "devices" $ \o -> DevicesConfig
+    <$> o .: "veracrypt"
+    <*> o .: "sshfs"
+    <*> o .: "cifs"
+
+data StaticConfig = StaticConfig
+  { _tmpMountDir :: Maybe String
+  , _devicesConfig :: Maybe DevicesConfig
+  } deriving Show
+
+instance FromJSON StaticConfig where
+  parseJSON = withObject "devices" $ \o -> StaticConfig
+    <$> o .:? "mountdir"
+    <*> 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.
+
+class Mountable m => StaticDevice m a where
+  -- | Mount the given type (or dismount if False is passed)
+  fromConfig :: V.Vector a -> RofiIO MountConf [m]
+  fromConfig s = do
+    v <- asks mountDir
+    return $ configToDev v <$> V.toList s
+
+  configToDev :: FilePath -> a -> m
+
+--------------------------------------------------------------------------------
+-- | Global config used in the reader monad stack
+--
 -- This is defined by the mount options on the command line, and holds:
 -- - a map between mountpoints and a means to get passwords when mounting those
 --   mountpoints
@@ -93,23 +200,11 @@ options =
 --   to '/tmp/media/USER'
 -- - any arguments to be passed to the rofi command
 
-type PasswordGetter = IO (Maybe String)
-
-type MountpointPasswords = M.Map String PasswordGetter
-
-type VeracryptMount = (FilePath, FilePath)
-
-addVeracryptMount :: [VeracryptMount] -> String -> [VeracryptMount]
-addVeracryptMount l s = case splitPrefix s of
-  (dir, ":", vol) -> (dir, vol):l
-  _               -> l
-
--- TODO check if mountdir exists or puke
 data MountConf = MountConf
-    { passwords :: MountpointPasswords
-    , mountDir  :: FilePath
+    { mountDir  :: FilePath
     , rofiArgs  :: [String]
-    , vcMounts  :: [VeracryptMount]
+    , mConfig   :: Maybe FilePath
+    , devConfig :: Maybe DevicesConfig
     }
 
 instance RofiConf MountConf where
@@ -119,39 +214,52 @@ initMountConf :: [String] -> IO MountConf
 initMountConf a = conf <$> getEffectiveUserName
   where
     conf u = MountConf
-      { passwords = M.empty
-      , mountDir = "/tmp/media" </> u
+      { mountDir = "/tmp/media" </> u
       , rofiArgs = a
-      , vcMounts = []
+      , mConfig = Nothing
+      , devConfig = Nothing
       }
 
 --------------------------------------------------------------------------------
 -- | Password-getting functions
 
-addSecret :: MountpointPasswords -> String -> MountpointPasswords
-addSecret pwds c = case splitPrefix c of
-  (dir, ":", r) -> M.insert dir (runSecret $ fromCommaSepString' r) pwds
-  _             -> pwds
+type PasswordGetter = IO (Maybe String)
 
 runSecret :: [(String, String)] -> PasswordGetter
 runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
   where
     kvs' = concatMap (\(k, v) -> [k, v]) kvs
 
-addBitwarden :: MountpointPasswords -> String -> MountpointPasswords
-addBitwarden pwds c = case splitPrefix c of
-  (dir, ":", name) -> M.insert dir (runBitwarden name) pwds
-  _                -> pwds
-
 runBitwarden :: String -> PasswordGetter
 runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
   <$> getItems
 
-addPwdPrompt :: MountpointPasswords -> String -> MountpointPasswords
-addPwdPrompt pwds dir = M.insert dir readPassword pwds
+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
+    else return res
 
-splitPrefix :: String -> (String, String, String)
-splitPrefix s = s =~ (":" :: String)
+configToPwd :: PasswordConfig -> PasswordGetter
+configToPwd PasswordConfig{ _passwordBitwarden = b
+                          , _passwordLibSecret = s
+                          , _passwordPrompt = p
+                          } =
+    getBW b `runMaybe` getLS s `runMaybe` getPrompt p
+  where
+    getBW (Just BitwardenConfig{ _bitwardenKey = k, _bitwardenTries = n }) =
+      runPromptLoop n $ runBitwarden k
+    getBW _ = return Nothing
+    getLS (Just LibSecretConfig{ _libsecretAttributes = a }) =
+      runSecret $ M.toList a
+    getLS _ = return Nothing
+    getPrompt (Just PromptConfig{ _promptTries = n }) =
+      runPromptLoop n readPassword
+    getPrompt _ = return Nothing
+    runMaybe x y = do
+      res <- x
+      if isNothing res then y else return res
 
 --------------------------------------------------------------------------------
 -- | Main prompt
@@ -161,7 +269,18 @@ splitPrefix s = s =~ (":" :: String)
 -- pretty things, so ensure the entries are aligned properly as well
 
 runMounts :: MountConf -> IO ()
-runMounts c = runRofiIO c $ runPrompt =<< getGroups
+runMounts c = do
+  c' <- maybe (return c) parseConfig (mConfig c)
+  runRofiIO c' $ runPrompt =<< getGroups
+  where
+    parseConfig m = do
+      res <- decodeFileEither m
+      case res of
+        Left e -> print e >> return c
+        Right StaticConfig { _tmpMountDir = Just v, _devicesConfig = dc } ->
+          return $ c { mountDir = v, devConfig = dc }
+        Right StaticConfig { _devicesConfig = dc } ->
+          return $ c { devConfig = dc }
 
 runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
 runPrompt gs = selectAction $ emptyMenu
@@ -171,12 +290,19 @@ runPrompt gs = selectAction $ emptyMenu
 
 getGroups :: RofiIO MountConf [RofiGroup MountConf]
 getGroups = do
-  fstab <- readFSTab
   sysd <- io getSystemdDevices
+  devConf <- asks devConfig
+  (cifsDevs, sshfsDevs, vcDevs) <- maybe
+    (return ( [] :: [CIFS], [] :: [SSHFS], [] :: [VeraCrypt]))
+    (\c -> liftM3 (,,)
+           (fromConfig $ _cifsConfigs c)
+           (fromConfig $ _sshfsConfigs c)
+           (fromConfig $ _veracryptConfigs c))
+    devConf
   sequence
-    [ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) $ sshfsDevices fstab
-    , mkGroup "CIFS Devices" $ cifsDevices fstab
-    , mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) =<< getVeracryptDevices
+    [ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) sshfsDevs
+    , mkGroup "CIFS Devices" cifsDevs
+    , mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) vcDevs
     , mkGroup "Removable Devices"  =<< getRemovableDevices
     , mkGroup "MTP Devices" =<< getMTPDevices
     ]
@@ -288,22 +414,14 @@ instance Mountable CIFS where
 
   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
-  -- 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, prompt for a password. In any case,
-  -- the output will be passed to env variable PASSWD when mounting this cifs
-  -- directory and cause it to fail. Setting the env variable is necessary as
-  -- the cifs mount call will prompt for a password and hang otherwise.
-  pwd <- if M.member "guest" o
-         then return Nothing
-         else asks $ Just . M.findWithDefault readPassword d . passwords
-  let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
-  return $ CIFS r d pwd
-  where
-    smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
+instance StaticDevice CIFS CIFSConfig where
+  configToDev v CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m }
+                           , _cifsRemote = t
+                           , _cifsPassword = p } =
+    let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
+    in CIFS r (appendRoot v m) $ configToPwd <$> p
+    where
+      smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
 
 --------------------------------------------------------------------------------
 -- | SSHFS Devices
@@ -316,11 +434,11 @@ fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
 data SSHFS = SSHFS Removable FilePath
 
 instance Mountable SSHFS where
-  mount (SSHFS Removable{ label = l } m) False =
+  mount (SSHFS Removable{ deviceSpec = d, label = l } m) False = do
     bracketOnError_
       (mkDirMaybe m)
       (rmDirMaybe m)
-      (io $ runMountNotify "mount" [m] l False)
+      (io $ runMountNotify "sshfs" [d, m] l False)
 
   mount (SSHFS Removable{ label = l } m) True = umountNotify l m
 
@@ -330,10 +448,11 @@ instance Mountable SSHFS where
 
   fmtEntry (SSHFS r _) = fmtEntry r
 
-fstabToSSHFS :: FSTabEntry -> RofiIO MountConf SSHFS
-fstabToSSHFS FSTabEntry{ fstabSpec = s, fstabDir = d } = return $ SSHFS r d
-  where
-    r = Removable { deviceSpec = s, label = takeFileName d }
+instance StaticDevice SSHFS SSHFSConfig where
+  configToDev v SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m }
+                            , _sshfsRemote = t } =
+    let r = Removable { deviceSpec = t, label = takeFileName m }
+    in SSHFS r (appendRoot v m)
 
 --------------------------------------------------------------------------------
 -- | VeraCrypt Devices
@@ -370,13 +489,12 @@ runVeraCrypt stdin args = do
   where
     defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
 
-getVeracryptDevices :: RofiIO MountConf [VeraCrypt]
-getVeracryptDevices = mapM toDev =<< asks vcMounts
-  where
-    toDev (d, s) = do
-      pwd <- asks $ Just . M.findWithDefault readPassword d . passwords
-      let r = Removable { deviceSpec = s, label = takeFileName d }
-      return $ VeraCrypt r d pwd
+instance StaticDevice VeraCrypt VeracryptConfig where
+  configToDev v VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m }
+                                , _veracryptVolume = t
+                                , _veracryptPassword = p } =
+    let r = Removable { deviceSpec = t, label = takeFileName m }
+    in VeraCrypt r (appendRoot v m) $ configToPwd <$> p
 
 --------------------------------------------------------------------------------
 -- | MTP devices
@@ -452,8 +570,8 @@ data Systemd = Systemd
 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
+    operation = if m then "stop" else "start" in
+    io $ runMountNotify "systemctl" ["--user", operation, unit] i m
 
   allInstalled Systemd { sysdType = SystemdVeracrypt } =
     io $ isJust <$> findExecutable "veracrypt"
@@ -525,64 +643,6 @@ class Mountable a where
       mountedPrefix True True  = "* "
       mountedPrefix _ False    = "! "
 
--- TODO add truecrypt volumes
---------------------------------------------------------------------------------
--- | Fstab devices
---
--- Functions to gather all user fstab mounts on the system
-
--- | Intermediate structure to hold fstab devices
-data FSTab = FSTab
-    { sshfsDevices :: [SSHFS]
-    , cifsDevices  :: [CIFS]
-    -- , veracryptDevices :: [VeraCrypt]
-    }
-
--- | Data structure representing an fstab device (or one line in the fstab file)
-data FSTabEntry = FSTabEntry
-    { fstabSpec    :: String
-    , fstabDir     :: FilePath
-    , fstabType    :: String
-    , fstabOptions :: MountOptions
-    }
-
--- | Key/val pairs to represent mount options. A Nothing for the value signifies
--- a standalone option (eg 'rw' and 'ro')
-type MountOptions = M.Map String (Maybe String)
-
--- | Return all user fstab devices from /etc/fstab
-readFSTab :: RofiIO MountConf FSTab
-readFSTab = do
-  -- let i = FSTab { sshfsDevices = [], cifsDevices = [], veracryptDevices = []}
-  let i = FSTab { sshfsDevices = [], cifsDevices = []}
-  fstab <- io $ readFile "/etc/fstab"
-  foldM addFstabDevice i $ fromLines toEntry $ lines fstab
-  where
-    toEntry line = case words line of
-      (('#':_):_)                     -> Nothing
-      [spec, dir, fsType, opts, _, _] -> Just $ FSTabEntry
-                                         { fstabSpec = spec
-                                         , fstabDir = dir
-                                         , fstabType = fsType
-                                         , fstabOptions = parseOptions opts
-                                         }
-      _                               -> Nothing
-    parseOptions = M.fromList . fromCommaSepString
-
--- | Add entry to the fstab devices list, but only if it is a known user mount
-addFstabDevice :: FSTab -> FSTabEntry -> RofiIO MountConf FSTab
-addFstabDevice f@FSTab{..} e@FSTabEntry{..}
-  | M.notMember "users" fstabOptions = return f
-  | fstabType == "cifs" =
-    (\d -> f { cifsDevices = append d cifsDevices }) <$> fstabToCIFS e
-  | fstabType == "fuse.sshfs" =
-    (\d -> f { sshfsDevices = append d sshfsDevices }) <$> fstabToSSHFS e
-  -- | fstabType == "veracrypt" =
-  --   (\d -> f { veracryptDevices = append d veracryptDevices }) <$> fstabToVeraCrypt e
-  | otherwise = return f
-  where
-    append x xs = xs ++ [x]
-
 --------------------------------------------------------------------------------
 -- | Low-level mount functions
 
@@ -668,17 +728,5 @@ splitBy delimiter = foldr f [[]]
     f c l@(x:xs) | c == delimiter = []:l
                  | otherwise = (c:x):xs
 
--- | Like fromCommaSepString but only return substrings with '='
-fromCommaSepString' :: String -> [(String, String)]
-fromCommaSepString' s = [(k, v) | (k, Just v) <- fromCommaSepString s]
-
--- | Split a string of comma-separated values into an alist
--- If the substrings have an '=' in them, the left side will become the key and
--- the right will become the value of the cell. If there is not '=' then the
--- entire substring will become the key and the value will be Nothing
-fromCommaSepString :: String -> [(String, Maybe String)]
-fromCommaSepString = fmap (toCell . splitEq) . splitBy ','
-  where
-    splitEq e = e =~ ("=" :: String) :: (String, String, String)
-    toCell (k, "=", v) = (k, Just v)
-    toCell (k, _, _)   = (k, Nothing)
+appendRoot :: FilePath -> FilePath -> FilePath
+appendRoot root path = if isRelative path then root </> path else path
diff --git a/package.yaml b/package.yaml
index 192e20f..fbbb876 100644
--- a/package.yaml
+++ b/package.yaml
@@ -30,15 +30,14 @@ dependencies:
 - mtl >= 2.2.2
 - directory >= 1.3.3.0
 - bytestring >= 0.10.8.2
-- regex-tdfa >= 1.2.3.2
 - 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
-- word-wrap >= 0.4.1
-- text >= 1.2.3.1
 - X11 >= 1.9.1
+- yaml >= 0.11.1.2
+- vector >= 0.12.0.3
 
 library:
   source-dirs: lib/