Compare commits
3 Commits
3e9b08db08
...
cfe0607e2e
| Author | SHA1 | Date |
|---|---|---|
 Nathan Dwarshuis
|
cfe0607e2e | |
|
Nathan Dwarshuis
|
7094dac44e | |
|
Nathan Dwarshuis
|
e13e4150fd |
|
|
@ -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
|
||||
250
app/rofi-dev.hs
250
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"]
|
||||
[ Option
|
||||
['c']
|
||||
["config"]
|
||||
(ReqArg (\s m -> m {optsConfig = Just s}) "CONF")
|
||||
"The path to the config file"
|
||||
, Option ['m'] ["mount"]
|
||||
, 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
|
||||
|
|
@ -169,20 +198,21 @@ alignEntries ps = zip (align es) as
|
|||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | 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
|
||||
|
|
@ -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,16 +315,18 @@ 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
|
||||
|
|
@ -301,7 +337,8 @@ newtype PromptConfig = PromptConfig
|
|||
{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
|
||||
|
|
@ -400,7 +445,7 @@ configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
|
|||
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
|
||||
|
|
@ -412,24 +457,27 @@ configToTree devMap TreeConfig{ tcParent = p, tcChildren = c } =
|
|||
instance Mountable DeviceConfig where
|
||||
mount DeviceConfig {deviceMount = m, deviceData = devData} False = do
|
||||
m' <- getAbsMountpoint m
|
||||
withTmpMountDir m'
|
||||
$ io
|
||||
$ case devData of
|
||||
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
|
||||
m' <- getAbsMountpoint m
|
||||
runAndRemoveDir m' $ io $ case d of
|
||||
|
|
@ -437,7 +485,9 @@ instance Mountable DeviceConfig where
|
|||
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"
|
||||
|
|
@ -452,7 +502,8 @@ instance Mountable DeviceConfig where
|
|||
b <- (io . isDirMounted) =<< getAbsMountpoint m
|
||||
return $ if b then Mounted else Unmounted
|
||||
|
||||
getLabel DeviceConfig
|
||||
getLabel
|
||||
DeviceConfig
|
||||
{ deviceMount = MountConfig {mpPath = p, mpLabel = l}
|
||||
} = fromMaybe (takeFileName p) l
|
||||
|
||||
|
|
@ -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]
|
||||
|
||||
|
|
@ -521,7 +578,7 @@ 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)
|
||||
|
||||
|
|
@ -531,14 +588,15 @@ runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
|
|||
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
|
||||
|
|
@ -562,15 +620,18 @@ configToPwd (PwdBW (BitwardenConfig { bwKey = k, bwTries = n })) =
|
|||
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
|
||||
|
|
@ -607,7 +668,8 @@ 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"
|
||||
|
|
@ -623,7 +685,7 @@ getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
|
|||
getRemovableActions = mountableToAction getRemovableDevices
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | MTP devices
|
||||
-- MTP devices
|
||||
|
||||
mtpExe :: String
|
||||
mtpExe = "jmtpfs"
|
||||
|
|
@ -641,11 +703,10 @@ instance Mountable MTPFS where
|
|||
-- TODO add autodismount to options
|
||||
let dev = "-device=" ++ b ++ "," ++ n
|
||||
withTmpMountDir m $ io $ runMount mtpExe [dev, m] ""
|
||||
|
||||
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
|
||||
|
|
@ -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,7 +905,8 @@ splitBy :: Char -> String -> [String]
|
|||
splitBy delimiter = foldr f [[]]
|
||||
where
|
||||
f _ [] = []
|
||||
f c l@(x:xs) | c == delimiter = []:l
|
||||
f c l@(x : xs)
|
||||
| c == delimiter = [] : l
|
||||
| otherwise = (c : x) : xs
|
||||
|
||||
appendRoot :: FilePath -> FilePath -> FilePath
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue