ADD dismount all option

.stylish-haskell.yaml

@@ -1,357 +0,0 @@
-# stylish-haskell configuration file
-# ==================================
-
-# The stylish-haskell tool is mainly configured by specifying steps. These steps
-# are a list, so they have an order, and one specific step may appear more than
-# once (if needed). Each file is processed by these steps in the given order.
-steps:
-  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
-  # by default.
-  # - unicode_syntax:
-  #     # In order to make this work, we also need to insert the UnicodeSyntax
-  #     # language pragma. If this flag is set to true, we insert it when it's
-  #     # not already present. You may want to disable it if you configure
-  #     # language extensions using some other method than pragmas. Default:
-  #     # true.
-  #     add_language_pragma: true
-
-  # Format module header
-  #
-  # Currently, this option is not configurable and will format all exports and
-  # module declarations to minimize diffs
-  #
-  # - module_header:
-  #     # How many spaces use for indentation in the module header.
-  #     indent: 4
-  #
-  #     # Should export lists be sorted?  Sorting is only performed within the
-  #     # export section, as delineated by Haddock comments.
-  #     sort: true
-  #
-  #     # See `separate_lists` for the `imports` step.
-  #     separate_lists: true
-
-  # Format record definitions. This is disabled by default.
-  #
-  # You can control the layout of record fields. The only rules that can't be configured
-  # are these:
-  #
-  # - "|" is always aligned with "="
-  # - "," in fields is always aligned with "{"
-  # - "}" is likewise always aligned with "{"
-  #
-  # - records:
-  #     # How to format equals sign between type constructor and data constructor.
-  #     # Possible values:
-  #     # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
-  #     # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
-  #     equals: "indent 2"
-  #
-  #     # How to format first field of each record constructor.
-  #     # Possible values:
-  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
-  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
-  #     first_field: "indent 2"
-  #
-  #     # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
-  #     field_comment: 2
-  #
-  #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
-  #     deriving: 2
-  #
-  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause
-  #     # Possible values:
-  #     # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
-  #     # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
-  #     via: "indent 2"
-  #
-  #     # Sort typeclass names in the "deriving" list alphabetically.
-  #     sort_deriving: true
-  #
-  #     # Wheter or not to break enums onto several lines
-  #     #
-  #     # Default: false
-  #     break_enums: false
-  #
-  #     # Whether or not to break single constructor data types before `=` sign
-  #     #
-  #     # Default: true
-  #     break_single_constructors: true
-  #
-  #     # Whether or not to curry constraints on function.
-  #     #
-  #     # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
-  #     #
-  #     # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
-  #     #
-  #     # Default: false
-  #     curried_context: false
-
-  # Align the right hand side of some elements.  This is quite conservative
-  # and only applies to statements where each element occupies a single
-  # line.
-  # Possible values:
-  # - always - Always align statements.
-  # - adjacent - Align statements that are on adjacent lines in groups.
-  # - never - Never align statements.
-  # All default to always.
-  - simple_align:
-      cases: always
-      top_level_patterns: always
-      records: always
-      multi_way_if: always
-
-  # Import cleanup
-  - imports:
-      # There are different ways we can align names and lists.
-      #
-      # - global: Align the import names and import list throughout the entire
-      #   file.
-      #
-      # - file: Like global, but don't add padding when there are no qualified
-      #   imports in the file.
-      #
-      # - group: Only align the imports per group (a group is formed by adjacent
-      #   import lines).
-      #
-      # - none: Do not perform any alignment.
-      #
-      # Default: global.
-      align: global
-
-      # The following options affect only import list alignment.
-      #
-      # List align has following options:
-      #
-      # - after_alias: Import list is aligned with end of import including
-      #   'as' and 'hiding' keywords.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #   >                                          init, last, length)
-      #
-      # - with_alias: Import list is aligned with start of alias or hiding.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #   >                                 init, last, length)
-      #
-      # - with_module_name: Import list is aligned `list_padding` spaces after
-      #   the module name.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #                          init, last, length)
-      #
-      #   This is mainly intended for use with `pad_module_names: false`.
-      #
-      #   > import qualified Data.List as List (concat, foldl, foldr, head,
-      #                          init, last, length, scanl, scanr, take, drop,
-      #                          sort, nub)
-      #
-      # - new_line: Import list starts always on new line.
-      #
-      #   > import qualified Data.List      as List
-      #   >     (concat, foldl, foldr, head, init, last, length)
-      #
-      # - repeat: Repeat the module name to align the import list.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head)
-      #   > import qualified Data.List      as List (init, last, length)
-      #
-      # Default: after_alias
-      list_align: after_alias
-
-      # Right-pad the module names to align imports in a group:
-      #
-      # - true: a little more readable
-      #
-      #   > import qualified Data.List       as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #
-      # - false: diff-safe
-      #
-      #   > import qualified Data.List as List (concat, foldl, foldr, init,
-      #   >                                     last, length)
-      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #
-      # Default: true
-      pad_module_names: true
-
-      # Long list align style takes effect when import is too long. This is
-      # determined by 'columns' setting.
-      #
-      # - inline: This option will put as much specs on same line as possible.
-      #
-      # - new_line: Import list will start on new line.
-      #
-      # - new_line_multiline: Import list will start on new line when it's
-      #   short enough to fit to single line. Otherwise it'll be multiline.
-      #
-      # - multiline: One line per import list entry.
-      #   Type with constructor list acts like single import.
-      #
-      #   > import qualified Data.Map as M
-      #   >     ( empty
-      #   >     , singleton
-      #   >     , ...
-      #   >     , delete
-      #   >     )
-      #
-      # Default: inline
-      long_list_align: multiline
-
-      # Align empty list (importing instances)
-      #
-      # Empty list align has following options
-      #
-      # - inherit: inherit list_align setting
-      #
-      # - right_after: () is right after the module name:
-      #
-      #   > import Vector.Instances ()
-      #
-      # Default: inherit
-      empty_list_align: inherit
-
-      # List padding determines indentation of import list on lines after import.
-      # This option affects 'long_list_align'.
-      #
-      # - <integer>: constant value
-      #
-      # - module_name: align under start of module name.
-      #   Useful for 'file' and 'group' align settings.
-      #
-      # Default: 4
-      list_padding: 4
-
-      # Separate lists option affects formatting of import list for type
-      # or class. The only difference is single space between type and list
-      # of constructors, selectors and class functions.
-      #
-      # - true: There is single space between Foldable type and list of it's
-      #   functions.
-      #
-      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
-      #
-      # - false: There is no space between Foldable type and list of it's
-      #   functions.
-      #
-      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
-      #
-      # Default: true
-      separate_lists: true
-
-      # Space surround option affects formatting of import lists on a single
-      # line. The only difference is single space after the initial
-      # parenthesis and a single space before the terminal parenthesis.
-      #
-      # - true: There is single space associated with the enclosing
-      #   parenthesis.
-      #
-      #   > import Data.Foo ( foo )
-      #
-      # - false: There is no space associated with the enclosing parenthesis
-      #
-      #   > import Data.Foo (foo)
-      #
-      # Default: false
-      space_surround: false
-
-      # Enabling this argument will use the new GHC lib parse to format imports.
-      #
-      # This currently assumes a few things, it will assume that you want post
-      # qualified imports. It is also not as feature complete as the old
-      # imports formatting.
-      #
-      # It does not remove redundant lines or merge lines. As such, the full
-      # feature scope is still pending.
-      #
-      # It _is_ however, a fine alternative if you are using features that are
-      # not parseable by haskell src extensions and you're comfortable with the
-      # presets.
-      #
-      # Default: false
-      ghc_lib_parser: false
-
-  # Language pragmas
-  - language_pragmas:
-      # We can generate different styles of language pragma lists.
-      #
-      # - vertical: Vertical-spaced language pragmas, one per line.
-      #
-      # - compact: A more compact style.
-      #
-      # - compact_line: Similar to compact, but wrap each line with
-      #   `{-#LANGUAGE #-}'.
-      #
-      # Default: vertical.
-      style: vertical
-
-      # Align affects alignment of closing pragma brackets.
-      #
-      # - true: Brackets are aligned in same column.
-      #
-      # - false: Brackets are not aligned together. There is only one space
-      #   between actual import and closing bracket.
-      #
-      # Default: true
-      align: true
-
-      # stylish-haskell can detect redundancy of some language pragmas. If this
-      # is set to true, it will remove those redundant pragmas. Default: true.
-      remove_redundant: true
-
-      # Language prefix to be used for pragma declaration, this allows you to
-      # use other options non case-sensitive like "language" or "Language".
-      # If a non correct String is provided, it will default to: LANGUAGE.
-      language_prefix: LANGUAGE
-
-  # Replace tabs by spaces. This is disabled by default.
-  # - tabs:
-  #     # Number of spaces to use for each tab. Default: 8, as specified by the
-  #     # Haskell report.
-  #     spaces: 8
-
-  # Remove trailing whitespace
-  - trailing_whitespace: {}
-
-  # Squash multiple spaces between the left and right hand sides of some
-  # elements into single spaces. Basically, this undoes the effect of
-  # simple_align but is a bit less conservative.
-  # - squash: {}
-
-# A common setting is the number of columns (parts of) code will be wrapped
-# to. Different steps take this into account.
-#
-# Set this to null to disable all line wrapping.
-#
-# Default: 80.
-columns: 80
-
-# By default, line endings are converted according to the OS. You can override
-# preferred format here.
-#
-# - native: Native newline format. CRLF on Windows, LF on other OSes.
-#
-# - lf: Convert to LF ("\n").
-#
-# - crlf: Convert to CRLF ("\r\n").
-#
-# Default: native.
-newline: native
-
-# Sometimes, language extensions are specified in a cabal file or from the
-# command line instead of using language pragmas in the file. stylish-haskell
-# needs to be aware of these, so it can parse the file correctly.
-#
-# No language extensions are enabled by default.
-# language_extensions:
-  # - TemplateHaskell
-  # - QuasiQuotes
-
-# Attempt to find the cabal file in ancestors of the current directory, and
-# parse options (currently only language extensions) from that.
-#
-# Default: true
-cabal: true

app/rofi-dev.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
--- | rofi-dev - a rofi prompt for mountable devices
+-- rofi-dev - a rofi prompt for mountable devices
 --
 -- Like all "mount helpers" this is basically a wrapper for low-level utilities
 -- the mount things from the command line. It also creates/destroys mountpoint
@@ -14,11 +14,9 @@
 module Main (main) where
 
 import Bitwarden.Internal
-
 import Control.Lens
 import Control.Monad
 import Control.Monad.Reader
-
 import Data.List
 import Data.List.Split (splitOn)
 import qualified Data.Map as M
@@ -26,21 +24,16 @@ import           Data.Maybe
 import qualified Data.Text as T
 import Data.Typeable
 import qualified Data.Vector as V
-
 import Dhall hiding (maybe, sequence, void)
 import qualified Dhall.Map as DM
-
 import Rofi.Command
-
-import           Text.Printf
-
 import System.Console.GetOpt
 import System.Directory
 import System.Environment
 import System.FilePath.Posix
 import System.Posix.User (getEffectiveUserName)
 import System.Process
-
+import Text.Printf
 import UnliftIO.Exception
 
 main :: IO ()
@@ -52,7 +45,8 @@ parse args = case getOpt Permute options args of
   (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
   where
     h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
-    defaultOpts r = Opts
+    defaultOpts r =
+      Opts
         { optsConfig = Nothing
         , optsAlias = Nothing
         , optsUnmount = False
@@ -61,13 +55,20 @@ parse args = case getOpt Permute options args of
 
 options :: [OptDescr (Opts -> Opts)]
 options =
-  [ Option ['c'] ["config"]
-    (ReqArg (\s m -> m { optsConfig = Just s } ) "CONF")
+  [ Option
+      ['c']
+      ["config"]
+      (ReqArg (\s m -> m {optsConfig = Just s}) "CONF")
       "The path to the config file"
-  , Option ['m'] ["mount"]
-    (ReqArg (\s m -> m { optsAlias = Just s } ) "ALIAS")
+  , Option
+      ['m']
+      ["mount"]
+      (ReqArg (\s m -> m {optsAlias = Just s}) "ALIAS")
       "Mount the device specified by ALIAS directly"
-  , Option ['u'] ["unmount"] (NoArg (\m -> m { optsUnmount = True } ))
+  , Option
+      ['u']
+      ["unmount"]
+      (NoArg (\m -> m {optsUnmount = True}))
       "Unmount the device specified by ALIAS instead of mounting it."
   ]
 
@@ -76,10 +77,11 @@ data Opts = Opts
   , optsAlias :: Maybe String
   , optsUnmount :: Bool
   , optsRofiArgs :: [String]
-  } deriving Show
+  }
+  deriving (Show)
 
 --------------------------------------------------------------------------------
--- | Main prompt
+-- Main prompt
 --
 -- This command will have one Rofi prompt and will display all available
 -- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like
@@ -92,7 +94,8 @@ runMounts opts = do
   let tmpPath = fromMaybe defaultTmpPath $ scTmpPath =<< static
   let staticDevs = maybe M.empty scDevices static
   let verbose = fromMaybe False $ scVerbose =<< static
-  let mountconf = MountConf
+  let mountconf =
+        MountConf
           { mountconfVolatilePath = tmpPath
           , mountconfRofiArgs = optsRofiArgs opts
           , mountconfStaticDevs = staticDevs
@@ -110,7 +113,9 @@ parseStaticConfig p = do
     Right c -> return $ Just (c :: StaticConfig)
   where
     es = over substitutions (DM.union vars) defaultEvaluateSettings
-    vars = DM.fromList $ catMaybes
+    vars =
+      DM.fromList $
+        catMaybes
           [ toVar (auto :: Decoder TreeConfig)
           , toVar (auto :: Decoder DeviceConfig)
           , toVar (auto :: Decoder DataConfig)
@@ -124,11 +129,17 @@ parseStaticConfig p = do
           , toVar (auto :: Decoder BitwardenConfig)
           , toVar (auto :: Decoder MountConfig)
           ]
-    toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
-      $ listToMaybe $ snd $ splitTyConApp $ typeOf a
+    toVar a =
+      fmap (\n -> (T.pack $ show n, maximum $ expected a)) $
+        listToMaybe $
+          snd $
+            splitTyConApp $
+              typeOf a
 
 runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
-runPrompt gs = selectAction $ emptyMenu
+runPrompt gs =
+  selectAction $
+    emptyMenu
       { groups = gs
       , prompt = Just "Select Device"
       }
@@ -136,10 +147,26 @@ runPrompt gs = selectAction $ emptyMenu
 getGroups :: RofiMountIO [RofiGroup MountConf]
 getGroups = do
   actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
-  return $ mapMaybe mkGroup
-    $ groupBy (\(hx, _) (hy, _) -> hx == hy)
-    $ sortBy (\(hx, _) (hy, _) -> compare hx hy)
-    $ concat actions
+  return $
+    (++ [metaActions]) $
+      mapMaybe mkGroup $
+        groupBy (\(hx, _) (hy, _) -> hx == hy) $
+          sortBy (\(hx, _) (hy, _) -> compare hx hy) $
+            concat actions
+  where
+    metaActions =
+      titledGroup "Meta Actions" $
+        toRofiActions [("  Dismount All", dismountAll)]
+
+dismountAll :: RofiMountIO ()
+dismountAll = do
+  umount =<< asks (configToTree' . mountconfStaticDevs)
+  umount =<< getRemovableDevices
+  umount =<< getMTPDevices
+  return ()
+  where
+    umount :: Mountable a => [a] -> RofiMountIO ()
+    umount = mapM_ (`mountMaybe` True)
 
 mountByAlias :: Bool -> String -> RofiMountIO ()
 mountByAlias unmountFlag alias = do
@@ -148,8 +175,9 @@ mountByAlias unmountFlag alias = do
 
 mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf)
 mkGroup [] = Nothing
-mkGroup as = let ((h, _):_) = as in
-  Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
+mkGroup as =
+  let ((h, _) : _) = as
+   in Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
 
 alignSep :: String
 alignSep = " | "
@@ -158,7 +186,8 @@ alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())]
 alignEntries ps = zip (align es) as
   where
     (es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
-    align = fmap (intercalate alignSep)
+    align =
+      fmap (intercalate alignSep)
         . transpose
         . mapToLast pad
         . transpose
@@ -166,23 +195,24 @@ alignEntries ps = zip (align es) as
     getMax = maximum . fmap length
     mapToLast _ [] = []
     mapToLast _ [x] = [x]
-    mapToLast f (x:xs) = f x : mapToLast f xs
+    mapToLast f (x : xs) = f x : mapToLast f xs
 
 --------------------------------------------------------------------------------
--- | Global config used in the reader monad stack
+-- Global config used in the reader monad stack
 
 data MountConf = MountConf
   { mountconfVolatilePath :: FilePath
   , mountconfRofiArgs :: [String]
   , mountconfStaticDevs :: M.Map String TreeConfig
   , mountconfVerbose :: Bool
-  } deriving Show
+  }
+  deriving (Show)
 
 instance RofiConf MountConf where
-  defArgs MountConf { mountconfRofiArgs = a } = a
+  defArgs MountConf {mountconfRofiArgs = a} = a
 
 --------------------------------------------------------------------------------
--- | Mountable typeclass
+-- Mountable typeclass
 --
 -- Class to provide common interface for anything that can be mounted.
 
@@ -219,7 +249,7 @@ class Mountable a where
   mountState :: a -> RofiMountIO MountState
 
 --------------------------------------------------------------------------------
--- | Actionable typeclass
+-- Actionable typeclass
 --
 -- Class to provide common interface for anything that can be presented in the
 -- Rofi menu as an action. Note that this must be separate from the Mountable
@@ -243,7 +273,7 @@ class Mountable a => Actionable a where
     let h = groupHeader dev
     let action = when i $ mountMaybe dev $ mountedState m
     let entry = case fmtEntry dev of
-              (e:es) -> (mountedPrefix m i ++ e):es
+          (e : es) -> (mountedPrefix m i ++ e) : es
           _ -> []
     return (h, ProtoAction entry action)
     where
@@ -252,13 +282,17 @@ class Mountable a => Actionable a where
       mountedPrefix Mounted True = "* "
       mountedPrefix Partial True = "- "
 
-mountableToAction :: Actionable a => RofiMountIO [a] -> RofiMountIO [(Header, ProtoAction [String])]
+mountableToAction
+  :: Actionable a
+  => RofiMountIO [a]
+  -> RofiMountIO [(Header, ProtoAction [String])]
 mountableToAction ms = mapM mkAction =<< ms
 
 type RofiMountIO a = RofiIO MountConf a
 
 -- headers appear in the order listed here (per Enum)
-data Header = CIFSHeader
+data Header
+  = CIFSHeader
   | SSHFSHeader
   | VeracryptHeader
   | RemovableHeader
@@ -281,27 +315,30 @@ instance Ord Header where
 data ProtoAction a = ProtoAction a (RofiMountIO ())
 
 --------------------------------------------------------------------------------
--- | Static device configuration (dhall)
+-- Static device configuration (dhall)
 
 data MountConfig = MountConfig
   { mpPath :: FilePath
   , mpLabel :: Maybe String
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 data BitwardenConfig = BitwardenConfig
   { bwKey :: String
-  , bwTries :: Integer }
+  , bwTries :: Integer
+  }
   deriving (Show, Generic, FromDhall)
 
 newtype SecretConfig = SecretConfig
-  { secretAttributes :: M.Map String String }
+  {secretAttributes :: M.Map String String}
   deriving (Show, Generic, FromDhall)
 
 newtype PromptConfig = PromptConfig
-  { promptTries :: Integer }
+  {promptTries :: Integer}
   deriving (Show, Generic, FromDhall)
 
-data PasswordConfig = PwdBW BitwardenConfig
+data PasswordConfig
+  = PwdBW BitwardenConfig
   | PwdLS SecretConfig
   | PwdPr PromptConfig
   deriving (Show, Generic, FromDhall)
@@ -312,9 +349,11 @@ data CIFSOpts = CIFSOpts
   , cifsoptsUID :: Maybe Integer
   , cifsoptsGID :: Maybe Integer
   , cifsoptsIocharset :: Maybe String
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
-data DataConfig = VeracryptConfig VeracryptData
+data DataConfig
+  = VeracryptConfig VeracryptData
   | SSHFSConfig SSHFSData
   | CIFSConfig CIFSData
   deriving (Show, Generic, FromDhall)
@@ -322,39 +361,45 @@ data DataConfig = VeracryptConfig VeracryptData
 data VeracryptData = VeracryptData
   { vcVolume :: String
   , vcPassword :: Maybe PasswordConfig
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 data SSHFSData = SSHFSData
   { sshfsRemote :: String
   , sshfsPassword :: Maybe PasswordConfig
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 data CIFSData = CIFSData
   { cifsRemote :: String
   , cifsSudo :: Bool
   , cifsPassword :: Maybe PasswordConfig
   , cifsOpts :: Maybe CIFSOpts
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 data DeviceConfig = DeviceConfig
   { deviceMount :: MountConfig
   , deviceData :: DataConfig
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 data TreeConfig = TreeConfig
   { tcParent :: DeviceConfig
   , tcChildren :: V.Vector String
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 data StaticConfig = StaticConfig
   { scTmpPath :: Maybe String
   , scVerbose :: Maybe Bool
   , scDevices :: M.Map String TreeConfig
-  } deriving (Show, Generic, FromDhall)
+  }
+  deriving (Show, Generic, FromDhall)
 
 --------------------------------------------------------------------------------
--- | Static devices trees
---
+-- Static devices trees
+
 -- Static devices as defined in the config file may declare dependencies on
 -- other static devices, and thus are best represented as a tree. Note that the
 -- tree is both Actionable and Mountable, where each node in the tree is only
@@ -378,29 +423,29 @@ instance Mountable a => Mountable (Tree a) where
   getLabel (Tree p _) = getLabel p
 
 instance Actionable (Tree DeviceConfig) where
-  fmtEntry (Tree p@DeviceConfig{ deviceData = d } _) = [getLabel p, target d]
+  fmtEntry (Tree p@DeviceConfig {deviceData = d} _) = [getLabel p, target d]
     where
-      target (CIFSConfig (CIFSData { cifsRemote = r }))         = r
-      target (SSHFSConfig (SSHFSData { sshfsRemote = r }))      = r
-      target (VeracryptConfig (VeracryptData { vcVolume = v })) = v
+      target (CIFSConfig (CIFSData {cifsRemote = r})) = r
+      target (SSHFSConfig (SSHFSData {sshfsRemote = r})) = r
+      target (VeracryptConfig (VeracryptData {vcVolume = v})) = v
 
-  groupHeader (Tree DeviceConfig{ deviceData = d } _) =
+  groupHeader (Tree DeviceConfig {deviceData = d} _) =
     case d of
-      CIFSConfig{}      -> CIFSHeader
-      SSHFSConfig{}     -> SSHFSHeader
-      VeracryptConfig{} -> VeracryptHeader
+      CIFSConfig {} -> CIFSHeader
+      SSHFSConfig {} -> SSHFSHeader
+      VeracryptConfig {} -> VeracryptHeader
 
 configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
 configToTree' devMap = configToTree devMap <$> M.elems devMap
 
 configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
-configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
+configToTree devMap TreeConfig {tcParent = p, tcChildren = c} =
   Tree p $ fmap go V.toList c
   where
     go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
 
 --------------------------------------------------------------------------------
--- | Static devices
+-- Static devices
 --
 -- This is complex because there may be multiple classes of static devices
 -- in the config file, and each device may depend on another device that is
@@ -410,50 +455,56 @@ configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
 -- outside of these needs to be aware of these different classes.
 
 instance Mountable DeviceConfig where
-  mount DeviceConfig{ deviceMount = m, deviceData = devData} False = do
+  mount DeviceConfig {deviceMount = m, deviceData = devData} False = do
     m' <- getAbsMountpoint m
-    withTmpMountDir m'
-      $ io
-      $ case devData of
-          SSHFSConfig (SSHFSData { sshfsRemote = r, sshfsPassword = p }) ->
+    withTmpMountDir m' $
+      io $
+        case devData of
+          SSHFSConfig (SSHFSData {sshfsRemote = r, sshfsPassword = p}) ->
             mountSSHFS m' p r
-          CIFSConfig (CIFSData
+          CIFSConfig
+            ( CIFSData
                 { cifsRemote = r
                 , cifsSudo = s
                 , cifsPassword = p
                 , cifsOpts = o
-                      }) ->
+                }
+              ) ->
               mountCIFS s r m' o p
-          VeracryptConfig (VeracryptData
+          VeracryptConfig
+            ( VeracryptData
                 { vcPassword = p
                 , vcVolume = v
-                           }) ->
+                }
+              ) ->
               mountVeracrypt m' p v
-
-  mount DeviceConfig{ deviceMount = m, deviceData = d } True = do
+  mount DeviceConfig {deviceMount = m, deviceData = d} True = do
     m' <- getAbsMountpoint m
     runAndRemoveDir m' $ io $ case d of
-      CIFSConfig (CIFSData { cifsSudo = s }) -> runMountSudoMaybe s "umount" [m']
+      CIFSConfig (CIFSData {cifsSudo = s}) -> runMountSudoMaybe s "umount" [m']
       VeracryptConfig _ -> runVeraCrypt ["-d", m'] ""
       _ -> runMount "umount" [m'] ""
 
-  allInstalled DeviceConfig{ deviceData = devData } = io $ isJust
+  allInstalled DeviceConfig {deviceData = devData} =
+    io $
+      isJust
         <$> findExecutable (exe devData)
     where
-      exe SSHFSConfig{}     = "sshfs"
-      exe CIFSConfig{}      = "mount.cifs"
-      exe VeracryptConfig{} = "veracrypt"
+      exe SSHFSConfig {} = "sshfs"
+      exe CIFSConfig {} = "mount.cifs"
+      exe VeracryptConfig {} = "veracrypt"
 
-  mountState DeviceConfig{ deviceMount = m, deviceData = d } = do
+  mountState DeviceConfig {deviceMount = m, deviceData = d} = do
     -- mountState DeviceConfig{ deviceMount = m } = do
     case d of
-      VeracryptConfig{} -> veracryptMountState m
+      VeracryptConfig {} -> veracryptMountState m
       _ -> do
         b <- (io . isDirMounted) =<< getAbsMountpoint m
         return $ if b then Mounted else Unmounted
 
-  getLabel DeviceConfig
-    { deviceMount = MountConfig { mpPath = p, mpLabel = l }
+  getLabel
+    DeviceConfig
+      { deviceMount = MountConfig {mpPath = p, mpLabel = l}
       } = fromMaybe (takeFileName p) l
 
 mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
@@ -462,8 +513,13 @@ mountSSHFS mountpoint pwdConfig remote =
   where
     run other = runMount "sshfs" (other ++ [remote, mountpoint])
 
-mountCIFS :: Bool -> String -> FilePath -> Maybe CIFSOpts
-  -> Maybe PasswordConfig -> IO MountResult
+mountCIFS
+  :: Bool
+  -> String
+  -> FilePath
+  -> Maybe CIFSOpts
+  -> Maybe PasswordConfig
+  -> IO MountResult
 mountCIFS useSudo remote mountpoint opts pwdConfig =
   withPasswordGetter pwdConfig runPwd run
   where
@@ -474,7 +530,8 @@ mountCIFS useSudo remote mountpoint opts pwdConfig =
 fromCIFSOpts :: CIFSOpts -> String
 fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
   where
-    fs = [ ("username", cifsoptsUsername)
+    fs =
+      [ ("username", cifsoptsUsername)
       , ("workgroup", cifsoptsWorkgroup)
       , ("uid", fmap show . cifsoptsUID)
       , ("gid", fmap show . cifsoptsGID)
@@ -484,8 +541,8 @@ fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
 
 mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
 mountVeracrypt mountpoint pwdConfig volume =
-  withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"]))
-  $ runVeraCrypt args ""
+  withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) $
+    runVeraCrypt args ""
   where
     args = [volume, mountpoint]
 
@@ -510,35 +567,36 @@ veracryptMountState mc = do
     auxPath = fmap (\i -> "/tmp/.veracrypt_aux_mnt" ++ [i]) . vcIndex
     vcIndex spec = case reverse spec of
       -- TODO what if I have more than one digit?
-      (i:_) -> if i `elem` ['0'..'9'] then Just i else Nothing
+      (i : _) -> if i `elem` ['0' .. '9'] then Just i else Nothing
       _ -> Nothing
 
 getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
-getAbsMountpoint MountConfig{ mpPath = m } =
+getAbsMountpoint MountConfig {mpPath = m} =
   asks $ flip appendRoot m . mountconfVolatilePath
 
 getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
 getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
 
 --------------------------------------------------------------------------------
--- | Password-getting functions for static devices
+-- Password-getting functions for static devices
 
 type PasswordGetter = IO (Maybe String)
 
 runSecret :: M.Map String String -> PasswordGetter
-runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
+runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') ""
   where
     kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
 
 runBitwarden :: String -> PasswordGetter
-runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
+runBitwarden pname =
+  ((password . login) <=< find (\i -> name i == pname))
     <$> getItems
 
 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
+  if isNothing res
+    then if n <= 0 then return Nothing else runPromptLoop (n - 1) pwd
     else return res
 
 -- configToPwd :: PasswordConfig -> PasswordGetter
@@ -557,20 +615,23 @@ runPromptLoop n pwd = do
 --     runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
 
 configToPwd :: PasswordConfig -> PasswordGetter
-configToPwd (PwdBW (BitwardenConfig { bwKey = k, bwTries = n })) =
+configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) =
   runPromptLoop n $ runBitwarden k
 configToPwd (PwdLS s) = runSecret $ secretAttributes s
 configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
 
-withPasswordGetter :: Maybe PasswordConfig -> (String -> IO MountResult)
-  -> IO MountResult -> IO MountResult
+withPasswordGetter
+  :: Maybe PasswordConfig
+  -> (String -> IO MountResult)
+  -> IO MountResult
+  -> IO MountResult
 withPasswordGetter (Just pwdConfig) runPwd _ =
   maybe (return $ MountError "Password could not be obtained") runPwd
     =<< configToPwd pwdConfig
 withPasswordGetter Nothing _ run = run
 
 --------------------------------------------------------------------------------
--- | Removable devices
+-- Removable devices
 --
 -- A device which can be removed (such as a flash drive). These are distinct
 -- from any device in the static configuration in that they only have device
@@ -583,21 +644,21 @@ data Removable = Removable
   deriving (Eq, Show)
 
 instance Mountable Removable where
-  mount Removable { removablePath = d } m =
+  mount Removable {removablePath = d} m =
     io $ runMount "udisksctl" [c, "-b", d] ""
     where
       c = if m then "unmount" else "mount"
 
   allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"
 
-  mountState Removable { removablePath = d } = do
+  mountState Removable {removablePath = d} = do
     s <- elem d <$> io curDeviceSpecs
     return $ if s then Mounted else Unmounted
 
-  getLabel Removable { removableLabel = l } = l
+  getLabel Removable {removableLabel = l} = l
 
 instance Actionable Removable where
-  fmtEntry Removable { removablePath = d, removableLabel = l } = [l, d]
+  fmtEntry Removable {removablePath = d, removableLabel = l} = [l, d]
 
   groupHeader _ = RemovableHeader
 
@@ -607,23 +668,24 @@ instance Actionable Removable where
 -- label shown on the prompt will be 'SIZE Volume' where size is the size of
 -- the device
 getRemovableDevices :: RofiConf c => RofiIO c [Removable]
-getRemovableDevices = fromLines toDev . lines
+getRemovableDevices =
+  fromLines toDev . lines
     <$> 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
+      ("" : _) -> Nothing
       [_, "1", d, "", s] -> mk d $ s ++ " Volume"
       [_, "1", d, l, _] -> mk d l
       _ -> Nothing
-    mk d l = Just $ Removable { removablePath = d, removableLabel = l }
+    mk d l = Just $ Removable {removablePath = d, removableLabel = l}
 
 getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
 getRemovableActions = mountableToAction getRemovableDevices
 
 --------------------------------------------------------------------------------
--- | MTP devices
+-- MTP devices
 
 mtpExe :: String
 mtpExe = "jmtpfs"
@@ -637,18 +699,17 @@ data MTPFS = MTPFS
   deriving (Eq, Show)
 
 instance Mountable MTPFS where
-  mount MTPFS { mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m } False = do
+  mount MTPFS {mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m} False = do
     -- TODO add autodismount to options
     let dev = "-device=" ++ b ++ "," ++ n
     withTmpMountDir m $ io $ runMount mtpExe [dev, m] ""
-
-  mount MTPFS { mtpfsMountpoint = m } True =
+  mount MTPFS {mtpfsMountpoint = m} True =
     runAndRemoveDir m $ io $ runMount "umount" [m] ""
 
-  -- | return True always since the list won't even show without jmtpfs
+  -- \| return True always since the list won't even show without jmtpfs
   allInstalled _ = return True
 
-  mountState MTPFS { mtpfsMountpoint = m } = do
+  mountState MTPFS {mtpfsMountpoint = m} = do
     s <- io $ isDirMounted m
     return $ if s then Mounted else Unmounted
 
@@ -664,13 +725,16 @@ getMTPDevices = do
       dir <- asks mountconfVolatilePath
       res <- io $ readProcess mtpExe ["-l"] ""
       return $ fromLines (toDev dir) $ toDevList res
-    toDevList = reverse
+    toDevList =
+      reverse
         . takeWhile (not . isPrefixOf "Available devices")
         . reverse
         . lines
     toDev dir s = case splitOn ", " s of
-      [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
-        in Just $ MTPFS
+      [busNum, devNum, _, _, desc, vendor] ->
+        let d = unwords [vendor, desc]
+         in Just $
+              MTPFS
                 { mtpfsBus = busNum
                 , mtpfsDevice = devNum
                 , mtpfsMountpoint = dir </> canonicalize d
@@ -695,7 +759,7 @@ instance Actionable MTPFS where
   groupHeader _ = MTPFSHeader
 
 --------------------------------------------------------------------------------
--- | Notifications
+-- Notifications
 
 data NotifyIcon = IconError | IconInfo
 
@@ -711,13 +775,15 @@ notifyMountResult mounted label result = case result of
     verb = if mounted then "unmount" else "mount" :: String
 
 notify :: NotifyIcon -> String -> Maybe String -> IO ()
-notify icon summary body = void $ spawnProcess "notify-send"
-  $ maybe args (\b -> args ++ [b]) body
+notify icon summary body =
+  void $
+    spawnProcess "notify-send" $
+      maybe args (\b -> args ++ [b]) body
   where
     args = ["-i", show icon, summary]
 
 --------------------------------------------------------------------------------
--- | Mount commands
+-- Mount commands
 
 data MountResult = MountSuccess | MountError String deriving (Show, Eq)
 
@@ -725,7 +791,8 @@ runMount :: String -> [String] -> String -> IO MountResult
 runMount cmd args stdin = eitherToMountResult <$> readCmdEither cmd args stdin
 
 runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
-runMount' cmd args stdin environ = eitherToMountResult
+runMount' cmd args stdin environ =
+  eitherToMountResult
     <$> readCmdEither' cmd args stdin environ
 
 runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
@@ -733,7 +800,8 @@ runMountSudoMaybe useSudo cmd args =
   runMountSudoMaybe' useSudo cmd args []
 
 runMountSudoMaybe' :: Bool -> String -> [String] -> [(String, String)] -> IO MountResult
-runMountSudoMaybe' useSudo cmd args environ = maybe
+runMountSudoMaybe' useSudo cmd args environ =
+  maybe
     (runMount' cmd args "" environ)
     (\r -> runSudoMount' r cmd args environ)
     =<< if useSudo then readPassword' "Sudo Password" else return Nothing
@@ -753,7 +821,7 @@ eitherToMountResult (Right _)        = MountSuccess
 eitherToMountResult (Left (_, _, e)) = MountError e
 
 --------------------------------------------------------------------------------
--- | Low-level mount functions
+-- Low-level mount functions
 
 mountMap :: IO (M.Map FilePath String)
 mountMap = do
@@ -789,7 +857,8 @@ rmDirOnMountError d f = do
 -- | Run a mount command and create the mountpoint if it does not exist, and
 -- remove the mountpoint if a mount error occurs
 withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
-withTmpMountDir m = rmDirOnMountError m
+withTmpMountDir m =
+  rmDirOnMountError m
     . bracketOnError_ (mkDirMaybe m) (rmDirMaybe m)
 
 -- | Run an unmount command and remove the mountpoint if no errors occur
@@ -803,8 +872,10 @@ mkDirMaybe :: FilePath -> RofiMountIO ()
 mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
 
 rmDirMaybe :: FilePath -> RofiMountIO ()
-rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
-  $ asks mountconfVolatilePath >>= io . rmUntil fp
+rmDirMaybe fp =
+  whenInMountDir fp $
+    unlessMountpoint fp $
+      asks mountconfVolatilePath >>= io . rmUntil fp
   where
     rmUntil cur target = unless (target == cur) $ do
       removePathForcibly cur
@@ -824,7 +895,7 @@ isDirMounted :: FilePath -> IO Bool
 isDirMounted fp = elem fp <$> curMountpoints
 
 --------------------------------------------------------------------------------
--- | Other functions
+-- Other functions
 
 fromLines :: (String -> Maybe a) -> [String] -> [a]
 fromLines f = mapMaybe (f . stripWS)
@@ -834,8 +905,9 @@ splitBy :: Char -> String -> [String]
 splitBy delimiter = foldr f [[]]
   where
     f _ [] = []
-    f c l@(x:xs) | c == delimiter = []:l
-                 | otherwise = (c:x):xs
+    f c l@(x : xs)
+      | c == delimiter = [] : l
+      | otherwise = (c : x) : xs
 
 appendRoot :: FilePath -> FilePath -> FilePath
 appendRoot root path = if isRelative path then root </> path else path

fourmolu.yaml

@@ -0,0 +1,14 @@
+indentation: 2
+function-arrows: leading
+comma-style: leading
+import-export-style: leading
+indent-wheres: true
+record-brace-space: true
+newlines-between-decls: 1
+haddock-style: single-line
+haddock-style-module:
+let-style: inline
+in-style: right-align
+respectful: false
+fixities: []
+unicode: never