ENH build with nix to pull in all c deps

.stylish-haskell.yaml

@@ -0,0 +1,357 @@
+# 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

README.md

@@ -3,42 +3,7 @@
 These are some personal programs that use the
 [rofi](https://github.com/davatorium/rofi) interface.
 
-## Installation
+## Rofi-Bitwarden
-
-Clone this repo and run the following in the repo root.
-
-Install packages needed for building:
-
-```
-pacman -S --needed - < make_pkgs
-```
-
-Build and install (choose individual targets as needed):
-
-```
-stack install
-```
-
-See individual sections for other dependencies to install.
-
-## Putting Rofi on the correct screen (rofi)
-
-This is a total hack...actually it isn't because it's written in Haskell and not
-bash.
-
-The problem is that when used with xmonad, rofi doesn't place itself on the
-"current" workspace since the concept of a "workspace" is weird and specific to
-xmonad. The solution is to use this program to query `_NET_DESKTOP_VIEWPORT`
-(which my xmonad config sets) and use this determine the name of the active
-workspace which can then be fed to rofi using the `-m` flag.
-
-See comments of this binary for details.
-
-### Dependencies
-
-- X11
-
-## Bitwarden (rofi-bw)
 
 [Bitwarden](https://bitwarden.com/) is an open-source password management server
 and this program functions as a client. Unlike many other similar clients, this
@@ -72,9 +37,10 @@ Any options after `-c` will be passed to rofi.
 
 ### Dependencies
 - [bitwarden-cli](https://github.com/bitwarden/cli)
+- dbus
 - libnotify: desktop notifications
 
-## Device Mounting (rofi-dev)
+## Rofi-Devices
 
 This is a manual mounting helper for removable drives, MTP devices, and fstab
 entries. It will transparently handle mountpoint creation/destruction.
@@ -109,19 +75,6 @@ To specifify that `/media/USER/foo` should use `secret-tool` to find its
 password, specify the `-s` option. This would lookup a password for the entry
 whose `username` is `bar` and `hostname` is `example.com`:
 
-### Veracrypt
-
-This tool can mount veracrypt vaults...with some hacky effort. Since veracrypt
-works at the block device level, it needs root permissions to mount a volume
-(which actually involves mounting several devices). The easiest way to make sure
-this works is to give veracrypt sudo access like so:
-
-```
-<user> ALL=(root) NOPASSWD: /usr/bin/veracrypt,/usr/bin/uptime
-```
-
-No idea why `uptime` is also needed for this.
-
 ``` sh
 rofi-dev -s '/media/USER/foo:username=bar,hostname=example.com'
 ```
@@ -136,58 +89,6 @@ rofi-dev -p '/media/USER/foo'
 - udisks2: removable drive mounting
 - sshfs: mounting network devices in fstab over ssh
 - cifs-utils: mounting network devices in fstab using CIFS/Samba
-- veracrypt: to mount veracrypt vaults
 - [jmtpfs](https://github.com/JasonFerrara/jmtpfs): mounting MTP devices
 - libnotify: desktop notifications
 - libsecret: password lookup with `secret-tool`
-
-## Autorandr (rofi-autorandr)
-
-This allows selection of the
-[autorandr](https://github.com/phillipberndt/autorandr) configuration via a rofi
-menu.
-
-### Dependencies
-
-- autorandr
-
-## Bluetooth (rofi-bw)
-
-This presents a nice menu to select the current bluetooth device.
-
-### Dependencies
-
-- bluez (which should provide the dbus interface for this to work)
-
-## ExpressVPN (rofi-evpn)
-
-This presents a menu to select the current ExpressVPN gateway.
-
-### Dependencies
-
-- expressvpn (from AUR)
-- libnotify
-
-## Pinentry (pinentry-rofi)
-
-Analogous to the default [pinentry](https://github.com/gpg/pinentry) prompts,
-this presents a rofi prompt for a password with the GPG keyring is unlocked.
-
-Requires the following in `gpg-agent.conf`:
-
-```
-pinentry-program /path/to/pinentry-rofi
-```
-
-Unlike the other pinentry programs, this one can integrate with bitwarden (via
-the above client) by retrieving the password for the gpg keyring if it is stored
-in bitwarden. This requires a yaml configuration in the gpg home directoring as
-such:
-
-```
-bitwarden-name: <name of GPG bitwarden entry>
-```
-
-### Dependencies
-
-- rofi-bw (see above): bitwarden integration

app/current-output.hs

@@ -1,12 +1,14 @@
+module Main (main) where
+
 --------------------------------------------------------------------------------
--- Run rofi (and display on the correct screen)
+-- | Return current xrandr output name
 --
 -- Since this seems random, the reason for this is that I want rofi to appear
 -- over the current xmonad workspace, and rofi has no concept of what an
 -- xmonad workspace is (not that it is supposed to, xmonad is weird...). Rofi
 -- accepts the name of an xrandr output onto which it should appear, so this
--- binary determines which xmonad workspace is in focus and calls rofi with the
+-- script provides a way to determine which xmonad workspace is in focus and
--- name of that workspace.
+-- provide the name of the output displaying said workspace.
 --
 -- Assumptions: xmonad sets the _NET_DESKTOP_VIEWPORT atom with the positions of
 -- the active workspace (actually an array of the positions of all workspaces
@@ -19,32 +21,24 @@
 -- 2) Use index from (1) and to get the position of the active workspace from
 --    _NET_DESKTOP_VIEWPORT
 -- 3) Find the name of the xrandr output whose position matches that from (2)
--- 4) Call rofi with the '-m' flag to override the default monitor placement
 
-module Main (main) where
+import           Data.Maybe
 
-import Graphics.X11.Types
+import           Graphics.X11.Types
-import Graphics.X11.Xlib
+import           Graphics.X11.Xlib
-import Graphics.X11.Xlib.Extras
+import           Graphics.X11.Xlib.Extras
-import Graphics.X11.Xrandr
+import           Graphics.X11.Xrandr
-import RIO hiding (Display)
+
-import RIO.Process
+import           System.Exit
-import qualified RIO.Text as T
-import UnliftIO.Environment
 
 main :: IO ()
-main = runSimpleApp $ do
+main = getMonitorName >>= maybe exitFailure (\n -> putStrLn n >> exitSuccess)
-  r <- getMonitorName
-  args <- getArgs
-  let allArgs = maybe [] (\n -> ["-m", T.unpack n] ++ args) r
-  c <- proc "/usr/bin/rofi" allArgs runProcess
-  exitWith c
 
-data Coord = Coord Int Int deriving (Eq, Show)
+data Coord = Coord Int Int
+    deriving (Eq, Show)
 
--- TODO bracket this
+getMonitorName :: IO (Maybe String)
-getMonitorName :: MonadIO m => m (Maybe T.Text)
+getMonitorName = do
-getMonitorName = liftIO $ do
   dpy <- openDisplay ""
   root <- rootWindow dpy $ defaultScreen dpy
   index <- getCurrentDesktopIndex dpy root
@@ -61,39 +55,39 @@ getDesktopViewports dpy root =
   pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT"
   where
     pairs = reverse . pairs' []
-    pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs
+    pairs' acc []         = acc
-    pairs' acc _ = acc
+    pairs' acc [_]        = acc
+    pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs
 
-getOutputs :: Display -> Window -> IO [(Coord, T.Text)]
+getOutputs :: Display -> Window -> IO [(Coord, String)]
-getOutputs dpy root =
+getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>=
-  xrrGetScreenResourcesCurrent dpy root
+  maybe (return []) resourcesToCells
-    >>= maybe (return []) resourcesToCells
   where
     resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r)
     outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r
     -- connection: 0 == connected, 1 == disconnected
-    infoToCell
+    infoToCell r (Just XRROutputInfo { xrr_oi_connection = 0
-      r
+                                     , xrr_oi_name = n
-      ( Just
+                                     , xrr_oi_crtc = c
-          XRROutputInfo
+                                     }) = do
-            { xrr_oi_connection = 0
+      cinfo <- xrrGetCrtcInfo dpy r c
-            , xrr_oi_name = n
+      return $ fmap (\i -> (toCoord i, n)) cinfo
-            , xrr_oi_crtc = c
-            }
-        ) = do
-        fmap (\i -> (toCoord i, T.pack n)) <$> xrrGetCrtcInfo dpy r c
     infoToCell _ _ = return Nothing
     toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c)
 
 infix 9 !!?
-
 (!!?) :: [a] -> Int -> Maybe a
 (!!?) xs i
-  | i < 0 = Nothing
+    | i < 0     = Nothing
-  | otherwise = listToMaybe $ drop i xs
+    | otherwise = go i xs
+  where
+    go :: Int -> [a] -> Maybe a
+    go 0 (x:_)  = Just x
+    go j (_:ys) = go (j - 1) ys
+    go _ []     = Nothing
 
-getAtom32 :: Display -> Window -> T.Text -> IO [Int]
+getAtom32 :: Display -> Window -> String -> IO [Int]
 getAtom32 dpy root str = do
-  a <- internAtom dpy (T.unpack str) False
+  a <- internAtom dpy str False
   p <- getWindowProperty32 dpy a root
   return $ maybe [] (fmap fromIntegral) p

app/pinentry-rofi.hs

@@ -1,105 +1,106 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
--- rofi-pinentry - a simply pinentry proxy for bitwarden
+-- | rofi-pinentry - a simply pinentry proxy for bitwarden
 --
 -- Rather than prompt the user like all the other pinentry programs, call the
 -- bitwarden deamon and prompt for a password there
 
 module Main where
 
-import Bitwarden.Internal
+import           Bitwarden.Internal
-import qualified Data.Text.IO as TI
+
-import Data.Yaml
+import           Data.List
-import RIO
+import           Data.Yaml
-import RIO.Directory
+
-import qualified RIO.List as L
+import           System.Directory
-import qualified RIO.Text as T
+import           System.Environment
-import System.FilePath.Posix
+import           System.Exit
-import System.Posix.Process
+import           System.FilePath.Posix
-import UnliftIO.Environment
+import           System.IO
+import           System.Posix.Process
 
 main :: IO ()
-main = runSimpleApp $ do
+main = do
   hSetBuffering stdout LineBuffering
-  -- NOTE: can't use RIO logging here since that will do to stderr and not
+  putStrLn "OK Pleased to meet you"
-  -- stdout
-  putStrLnT "OK Pleased to meet you"
   pinentryLoop =<< readPinConf
 
-newtype PinConf = PinConf {pcBwName :: T.Text} deriving (Eq, Show)
+newtype PinConf = PinConf { pcBwName :: String } deriving (Eq, Show)
 
 instance FromJSON PinConf where
   parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg"
-  parseJSON _ = fail "pinentry yaml parse error"
+  parseJSON _          = fail "pinentry yaml parse error"
 
-readPinConf :: RIO SimpleApp PinConf
+readPinConf :: IO PinConf
 readPinConf = do
-  c <- liftIO . decodeFileEither =<< pinConfDir
+  c <- decodeFileEither =<< pinConfDir
   case c of
-    Left e -> do
+    Left e  -> print e >> exitWith (ExitFailure 1)
-      logError $ displayShow e
-      exitWith (ExitFailure 1)
     Right r -> return r
 
-pinConfDir :: RIO SimpleApp FilePath
+pinConfDir :: IO FilePath
 pinConfDir = maybe defHome (return . (</> confname)) =<< lookupEnv "GNUPGHOME"
   where
     defHome = (</> ".gnupg" </> confname) <$> getHomeDirectory
     confname = "pinentry-rofi.yml"
 
-pinentryLoop :: PinConf -> RIO SimpleApp ()
+pinentryLoop :: PinConf -> IO ()
 pinentryLoop p = do
-  processLine p . T.words =<< liftIO TI.getLine
+  processLine p . words =<< getLine
   pinentryLoop p
 
-processLine :: PinConf -> [T.Text] -> RIO SimpleApp ()
+processLine :: PinConf -> [String] -> IO ()
-processLine _ [] = noop
+processLine _ []                             = noop
-processLine _ ["BYE"] = exitSuccess
+processLine _ ["BYE"]                        = exitSuccess
-processLine p ["GETPIN"] = getPin p
+processLine p ["GETPIN"]                     = getPin p
-processLine _ ["GETINFO", o] = processGetInfo o
+
+processLine _ ["GETINFO", o]                 = processGetInfo o
+
 -- TODO this might be important
-processLine _ ["OPTION", o] = processOption o
+processLine _ ["OPTION", o]                  = processOption o
+
 -- these should all do nothing
-processLine _ ("SETDESC" : _) = noop
+processLine _ ("SETDESC":_)                  = noop
-processLine _ ("SETOK" : _) = noop
+processLine _ ("SETOK":_)                    = noop
-processLine _ ("SETNOTOK" : _) = noop
+processLine _ ("SETNOTOK":_)                 = noop
-processLine _ ("SETCANCEL" : _) = noop
+processLine _ ("SETCANCEL":_)                = noop
-processLine _ ("SETPROMPT" : _) = noop
+processLine _ ("SETPROMPT":_)                = noop
-processLine _ ("SETERROR" : _) = noop
+processLine _ ("SETERROR":_)                 = noop
+
 -- CONFIRM can take a flag
-processLine _ ["CONFIRM"] = noop
+processLine _ ["CONFIRM"]                    = noop
 processLine _ ["CONFIRM", "--one-button", _] = noop
-processLine _ ss = unknownCommand $ T.unwords ss
 
-unknownCommand :: T.Text -> RIO SimpleApp ()
+processLine _ ss                             = unknownCommand $ unwords ss
-unknownCommand c = putStrLnT $ T.append "ERR 275 Unknown command " c
 
-getPin :: PinConf -> RIO SimpleApp ()
+unknownCommand :: String -> IO ()
+unknownCommand c = putStrLn $ "ERR 275 Unknown command " ++ c
+
+getPin :: PinConf -> IO ()
 getPin p = do
   its <- getItems
-  let w = (password . login) =<< L.find (\i -> pcBwName p == name i) its
+  let w = (password . login) =<< find (\i -> pcBwName p == name i) its
   maybe err send w
   where
-    err = putStrLnT "ERR 83886179 Operation canceled <rofi>"
+    err = putStrLn "ERR 83886179 Operation canceled <rofi>"
 
 -- these are the only supported options for GETINFO; anything else is an error
-processGetInfo :: T.Text -> RIO SimpleApp ()
+processGetInfo :: String -> IO ()
-processGetInfo "pid" = send . T.pack . show =<< liftIO getProcessID
+processGetInfo "pid"     = send . show =<< getProcessID
 processGetInfo "version" = noop
-processGetInfo "flavor" = noop
+processGetInfo "flavor"  = noop
 processGetInfo "ttyinfo" = noop
-processGetInfo _ = putStrLnT "ERR 83886360 IPC parameter error <rofi>"
+processGetInfo _         = putStrLn "ERR 83886360 IPC parameter error <rofi>"
 
-processOption :: T.Text -> RIO SimpleApp ()
+processOption :: String -> IO ()
 processOption _ = noop
 
-send :: T.Text -> RIO SimpleApp ()
+send :: String -> IO ()
-send s = putStrLnT (T.append "D " s) >> ok
+send s = putStrLn ("D " ++ s) >> ok
 
-noop :: RIO SimpleApp ()
+noop :: IO ()
 noop = ok
 
-ok :: RIO SimpleApp ()
+ok :: IO ()
-ok = putStrLnT "OK"
+ok = putStrLn "OK"
-
-putStrLnT :: MonadIO m => T.Text -> m ()
-putStrLnT = liftIO . TI.putStrLn

app/rofi-autorandr.hs

@@ -1,55 +1,65 @@
 --------------------------------------------------------------------------------
--- rofi-autorandr - a rofi prompt to select autorandr profiles
+-- | rofi-autorandr - a rofi prompt to select autorandr profiles
 --
 -- Simple wrapper to select an autorandr profile.
 
+
 module Main (main) where
 
-import RIO
+import           Control.Monad
-import RIO.Directory
+
-import qualified RIO.Text as T
+import           Data.Maybe
-import Rofi.Command
+
-import Rofi.IO
+import           Rofi.Command
-import System.FilePath.Posix
+
-import System.Process
+import           System.Directory
-import UnliftIO.Environment
+import           System.Environment
+import           System.Exit
+import           System.FilePath.Posix
+import           System.Process
 
 main :: IO ()
-main = runSimpleApp $ do
+main = runChecks >> getArgs >>= runPrompt
-  checkExe "autorandr"
-  getArgs >>= runPrompt
 
-newtype ARClientConf = ARClientConf [T.Text]
+-- TOOD not DRY
+runChecks :: IO ()
+runChecks = checkExe "autorandr" >> checkExe "rofi"
 
-instance HasRofiConf ARClientConf where
+checkExe :: String -> IO ()
+checkExe cmd = do
+  res <- findExecutable cmd
+  unless (isJust res) $ do
+    putStrLn $ "Could not find executable: " ++ cmd
+    exitWith $ ExitFailure 1
+
+newtype ARClientConf = ARClientConf [String]
+
+instance RofiConf ARClientConf where
   defArgs (ARClientConf a) = a
 
-runPrompt :: MonadIO m => [String] -> m ()
+runPrompt :: [String] -> IO ()
 runPrompt a = do
-  let c = ARClientConf $ fmap T.pack a
+  let c = ARClientConf a
   staticProfs <- getAutoRandrProfiles
-  runRofi c $
+  runRofiIO c $ selectAction $ emptyMenu
-    emptyMenu
+    { groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
-      { groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
+    , prompt = Just "Select Profile"
-      , prompt = Just "Select Profile"
+    }
-      }
   where
-    mkGroup header =
+    mkGroup header = titledGroup header . toRofiActions
-      titledGroup header
+      . fmap (\s -> ("  " ++ s, selectProfile s))
-        . toRofiActions
-        . fmap (\s -> (T.append "  " s, selectProfile s))
 
-virtProfs :: [T.Text]
+virtProfs :: [String]
 virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"]
 
 -- TODO filter profiles based on which xrandr outputs are actually connected
-getAutoRandrProfiles :: MonadIO m => m [T.Text]
+getAutoRandrProfiles :: IO [String]
 getAutoRandrProfiles = do
   dir <- getAutoRandrDir
   contents <- listDirectory dir
-  (fmap T.pack) <$> filterM (doesDirectoryExist . (dir </>)) contents
+  filterM (doesDirectoryExist . (dir </>)) contents
 
-getAutoRandrDir :: MonadIO m => m FilePath
+getAutoRandrDir :: IO String
 getAutoRandrDir = do
   c <- getXdgDirectory XdgConfig "autorandr"
   e <- doesDirectoryExist c
@@ -57,8 +67,7 @@ getAutoRandrDir = do
   where
     appendToHome p = (</> p) <$> getHomeDirectory
 
-selectProfile :: T.Text -> RIO ARClientConf ()
+selectProfile :: String -> RofiIO ARClientConf ()
-selectProfile name =
+selectProfile name = do
-  liftIO $
+  io $ putStrLn name
-    void $
+  io $ void $ spawnProcess "autorandr" ["--change", name]
-      spawnProcess "autorandr" ["--change", T.unpack name]

app/rofi-bt.hs

@@ -1,81 +1,76 @@
 --------------------------------------------------------------------------------
--- rofi-bt - a prompt to dicsonnect/connect devices
+-- | rofi-bt - a prompt to dicsonnect/connect devices
 --
 
 module Main (main) where
 
-import DBus
+import           Control.Exception
-import DBus.Client
+import           Control.Monad
-import qualified Data.Map as M
+import           Control.Monad.Reader
-import Data.Maybe
+
-import RIO
+import           Data.List
-import qualified RIO.List as L
+import           Data.List.Split
-import qualified RIO.Text as T
+import qualified Data.Map             as M
-import Rofi.Command
+import           Data.Maybe
-import UnliftIO.Environment
+
+import           DBus
+import           DBus.Client
+
+import           Rofi.Command
+
+import           System.Environment
 
 main :: IO ()
-main = runSimpleApp $ getArgs >>= runPrompt
+main = getArgs >>= runPrompt
 
-data RofiBTConf = RofiBTConf
+data RofiBTConf = RofiBTConf [String] ObjectPath
-  { btArgs :: ![T.Text]
-  , btAdapter :: !ObjectPath
-  , btEnv :: !SimpleApp
-  }
 
-instance HasRofiConf RofiBTConf where
+instance RofiConf RofiBTConf where
-  defArgs = btArgs
+  defArgs (RofiBTConf as _) = as
-
-instance HasLogFunc RofiBTConf where
-  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
 
 type BTAction = RofiAction RofiBTConf
 
-runPrompt :: [String] -> RIO SimpleApp ()
+runPrompt :: [String] -> IO ()
 runPrompt args = do
   c <- getClient
-  maybe (logError "could not get DBus client") run c
+  maybe (putStrLn "could not get DBus client") run c
   where
     run client = do
       paths <- M.keys <$> getObjectTree client
-      case getAdapter paths of
+      maybe (putStrLn "could not get DBus adapter") (actions client paths)
-        Nothing -> logError "could not get DBus adapter"
+        $ getAdapter paths
-        Just adapter -> do
+    actions client paths adapter = do
-          ras <- getRofiActions client paths
+      ras <- getRofiActions client paths
-          mapRIO (RofiBTConf (fmap T.pack args) adapter) $
+      runRofiIO (RofiBTConf args adapter) $ selectAction $ emptyMenu
-            selectAction $
+        { groups = [untitledGroup $ toRofiActions ras]
-              emptyMenu
+        , prompt = Just "Select Device"
-                { groups = [untitledGroup $ toRofiActions ras]
+        }
-                , prompt = Just "Select Device"
-                }
 
-getRofiActions :: MonadIO m => Client -> [ObjectPath] -> m [BTAction]
+getRofiActions :: Client -> [ObjectPath] -> IO [BTAction]
 getRofiActions client os = do
   devs <- getDevices client os
   catMaybes <$> mapM (deviceToRofiAction client) devs
 
-deviceToRofiAction :: MonadIO m => Client -> ObjectPath -> m (Maybe BTAction)
+deviceToRofiAction :: Client -> ObjectPath -> IO (Maybe BTAction)
 deviceToRofiAction client dev = do
   c <- getDeviceConnected client dev
   n <- getDeviceName client dev
   return $ case (c, n) of
-    (Just c', Just n') ->
+    (Just c', Just n') -> Just ( formatDeviceEntry c' n'
-      Just
+                               , powerAdapterMaybe client >> io (mkAction c')
-        ( formatDeviceEntry c' n'
+                               )
-        , powerAdapterMaybe client >> io (mkAction c')
+    _                  -> Nothing
-        )
-    _ -> Nothing
   where
-    mkAction True = callDeviceDisconnect client dev
+    mkAction True  = callDeviceDisconnect client dev
     mkAction False = callDeviceConnect client dev
 
-powerAdapterMaybe :: Client -> RIO RofiBTConf ()
+powerAdapterMaybe :: Client -> RofiIO RofiBTConf ()
 powerAdapterMaybe client = do
-  adapter <- asks btAdapter
+  (RofiBTConf _ adapter) <- ask
   let mc = btMethodCall adapter i m
-  let powerOnMaybe = flip unless $ void $ liftIO $ setProperty client mc value
+  let powerOnMaybe = flip unless $ void $ setProperty client mc value
-  powered <- getBTProperty client adapter i m
+  powered <- io $ getBTProperty client adapter i m
-  maybe (logError "could not get adapter powered status") powerOnMaybe powered
+  io $ maybe (putStrLn "could not get adapter powered status") powerOnMaybe powered
   where
     i = interfaceName_ "org.bluez.Adapter1"
     m = memberName_ "Powered"
@@ -83,21 +78,21 @@ powerAdapterMaybe client = do
     -- the 'Set' method
     value = toVariant $ toVariant True
 
-formatDeviceEntry :: Bool -> T.Text -> T.Text
+formatDeviceEntry :: Bool -> String -> String
-formatDeviceEntry connected name = T.unwords [prefix connected, name]
+formatDeviceEntry connected name = unwords [prefix connected, name]
   where
-    prefix True = "#"
+    prefix True  = "#"
     prefix False = " "
 
 getAdapter :: [ObjectPath] -> Maybe ObjectPath
-getAdapter = L.find pathIsAdaptor
+getAdapter = find pathIsAdaptor
 
-getDevices :: MonadIO m => Client -> [ObjectPath] -> m [ObjectPath]
+getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
 getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
 
-type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
+type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
 
-getObjectTree :: MonadIO m => Client -> m ObjectTree
+getObjectTree :: Client -> IO ObjectTree
 getObjectTree client =
   fromMaybe M.empty . eitherMaybe from <$> callBTMethod client o i m
   where
@@ -106,76 +101,63 @@ getObjectTree client =
     m = memberName_ "GetManagedObjects"
     from = fromVariant <=< listToMaybe . methodReturnBody
 
-getDeviceConnected :: MonadIO m => Client -> ObjectPath -> m (Maybe Bool)
+getDeviceConnected :: Client -> ObjectPath -> IO (Maybe Bool)
 getDeviceConnected = getDevProperty "Connected"
 
-getDeviceName :: MonadIO m => Client -> ObjectPath -> m (Maybe T.Text)
+getDeviceName :: Client -> ObjectPath -> IO (Maybe String)
 getDeviceName = getDevProperty "Name"
 
-getDevicePaired :: MonadIO m => Client -> ObjectPath -> m Bool
+getDevicePaired :: Client -> ObjectPath -> IO Bool
 getDevicePaired c = fmap (fromMaybe False) . getDevProperty "Paired" c
 
-callDeviceConnect :: MonadIO m => Client -> ObjectPath -> m ()
+callDeviceConnect :: Client -> ObjectPath -> IO ()
 callDeviceConnect = callDevMethod "Connect"
 
-callDeviceDisconnect :: MonadIO m => Client -> ObjectPath -> m ()
+callDeviceDisconnect :: Client -> ObjectPath -> IO ()
 callDeviceDisconnect = callDevMethod "Disconnect"
 
 pathIsAdaptor :: ObjectPath -> Bool
 pathIsAdaptor o = case splitPath o of
   [a, b, c] -> pathIsAdaptorPrefix a b c
-  _ -> False
+  _         -> False
 
 pathIsDevice :: ObjectPath -> Bool
 pathIsDevice o = case splitPath o of
   [a, b, c, _] -> pathIsAdaptorPrefix a b c
-  _ -> False
+  _            -> False
 
-pathIsAdaptorPrefix :: T.Text -> T.Text -> T.Text -> Bool
+pathIsAdaptorPrefix :: String -> String -> String -> Bool
-pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
+pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `isPrefixOf` c
 
-splitPath :: ObjectPath -> [T.Text]
+splitPath :: ObjectPath -> [String]
-splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
+splitPath =splitOn "/" . dropWhile (=='/') . formatObjectPath
 
-getClient :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client)
+getClient :: IO (Maybe Client)
-getClient = either warn (return . Just) =<< try (liftIO connectSystem)
+getClient = either warn (return . Just) =<< try connectSystem
   where
-    warn e = do
+    warn e = putStrLn (clientErrorMessage e) >> return Nothing
-      logWarn $ displayBytesUtf8 $ encodeUtf8 $ (T.pack $ clientErrorMessage e)
-      return Nothing
 
-callDevMethod :: MonadIO m => T.Text -> Client -> ObjectPath -> m ()
+callDevMethod :: String -> Client -> ObjectPath -> IO ()
 callDevMethod mem client dev =
-  void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem
+  void $ callBTMethod client dev btDevInterface $ memberName_ mem
 
-getDevProperty :: (MonadIO m, IsVariant a) => T.Text -> Client -> ObjectPath -> m (Maybe a)
+getDevProperty :: IsVariant a => String -> Client -> ObjectPath -> IO (Maybe a)
 getDevProperty mem client dev =
-  getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem
+  getBTProperty client dev btDevInterface $ memberName_ mem
 
-callBTMethod
+callBTMethod :: Client -> ObjectPath -> InterfaceName
-  :: MonadIO m
+  -> MemberName -> IO (Either MethodError MethodReturn)
-  => Client
+callBTMethod client o i m = call client (btMethodCall o i m)
-  -> ObjectPath
+  -- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-  -> InterfaceName
+  -- <$> call client (btMethodCall o i m)
-  -> MemberName
-  -> m (Either MethodError MethodReturn)
-callBTMethod client o i m = liftIO $ call client (btMethodCall o i m)
 
--- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
+getBTProperty :: IsVariant a => Client -> ObjectPath
--- <$> call client (btMethodCall o i m)
+  -> InterfaceName -> MemberName -> IO (Maybe a)
-
-getBTProperty
-  :: (MonadIO m, IsVariant a)
-  => Client
-  -> ObjectPath
-  -> InterfaceName
-  -> MemberName
-  -> m (Maybe a)
 getBTProperty client o i m =
-  eitherMaybe fromVariant <$> (liftIO $ getProperty client (btMethodCall o i m))
+  eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m)
 
 btMethodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall
-btMethodCall o i m = (methodCall o i m) {methodCallDestination = Just btBus}
+btMethodCall o i m = (methodCall o i m) { methodCallDestination = Just btBus }
 
 eitherMaybe :: (b -> Maybe c) -> Either a b -> Maybe c
 eitherMaybe = either (const Nothing)

app/rofi-bw.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
--- rofi-bw - a rofi prompt for a bitwarden vault
+-- | rofi-bw - a rofi prompt for a bitwarden vault
 --
 -- This is basically a wrapper around the 'bw' command, which is assumed to be
 -- properly configured before running this command. This shows a system of
@@ -16,30 +18,41 @@
 
 module Main (main) where
 
-import Bitwarden.Internal
+import           Bitwarden.Internal
-import RIO
+
-import qualified RIO.Text as T
+import           Control.Monad
-import Rofi.IO
+
-import UnliftIO.Environment
+import           Data.Maybe
+
+import           Rofi.Command
+
+import           Text.Read
+
+import           System.Directory
+import           System.Environment
+import           System.Exit
 
 main :: IO ()
-main = runSimpleApp $ runChecks >> getArgs >>= parse
+main = runChecks >> getArgs >>= parse
 
 -- TODO check if daemon is running when running client
-parse :: HasLogFunc c => [String] -> RIO c ()
+parse :: [String] -> IO ()
-parse ["-d", t] = case readMaybe t of Just t' -> runDaemon t'; _ -> usage
+parse ["-d", t] = case readMaybe t of { Just t' -> runDaemon t'; _ -> usage }
-parse ("-c" : args) = runClient $ fmap T.pack args
+parse ("-c":args) = runClient args
-parse _ = usage
+parse _         = usage
 
-usage :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
+usage :: IO ()
-usage =
+usage = putStrLn $ joinNewline
-  logInfo $
+  [ "daemon mode: rofi-bw -d TIMEOUT"
-    displayBytesUtf8 $
+  , "client mode: rofi-bw -c [ROFI-ARGS]"
-      encodeUtf8 $
+  ]
-        T.unlines
-          [ "daemon mode: rofi-bw -d TIMEOUT"
-          , "client mode: rofi-bw -c [ROFI-ARGS]"
-          ]
 
-runChecks :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
+runChecks :: IO ()
-runChecks = checkExe "bw"
+runChecks = checkExe "bw" >> checkExe "rofi"
+
+checkExe :: String -> IO ()
+checkExe cmd = do
+  res <- findExecutable cmd
+  unless (isJust res) $ do
+    putStrLn $ "Could not find executable: " ++ cmd
+    exitWith $ ExitFailure 1

app/rofi-evpn.hs

@@ -1,19 +1,24 @@
 --------------------------------------------------------------------------------
--- rofi-evpn - a prompt to dicsonnect/connect with express VPN
+-- | rofi-evpn - a prompt to dicsonnect/connect with express VPN
 --
 
 module Main (main) where
 
-import RIO
+import           Control.Monad
-import qualified RIO.Text as T
+
-import Rofi.Command
+import           Data.List          (isPrefixOf)
-import Rofi.IO
+import           Data.List.Split
-import UnliftIO.Environment
+import           Data.Maybe
+
+import           Rofi.Command
+
+import           System.Environment
+import           System.Process
 
 main :: IO ()
-main = runSimpleApp $ getArgs >>= runPrompt
+main = getArgs >>= runPrompt
 
-runPrompt :: [String] -> RIO SimpleApp ()
+runPrompt :: [String] -> IO ()
 runPrompt args = do
   servers <- getServers
   maybe (return ()) run servers
@@ -21,83 +26,80 @@ runPrompt args = do
     run (VPNStatus connected servers) = do
       let d = getDisconnectAction <$> connected
       let cs = fmap (getConnectAction connected) servers
-      runRofi (RofiVPNConf $ fmap T.pack args) $
+      runRofiIO (RofiVPNConf args) $ selectAction $ emptyMenu
-        emptyMenu
+        { groups =
-          { groups =
+          [ untitledGroup $ toRofiActions $ maybeToList d
-              [ untitledGroup $ toRofiActions $ maybeToList d
+          , untitledGroup $ toRofiActions cs
-              , untitledGroup $ toRofiActions cs
+          ]
-              ]
+        , prompt = Just "Select Action"
-          , prompt = Just "Select Action"
+        }
-          }
 
-newtype RofiVPNConf = RofiVPNConf [T.Text]
+newtype RofiVPNConf = RofiVPNConf [String]
 
-instance HasRofiConf RofiVPNConf where
+instance RofiConf RofiVPNConf where
   defArgs (RofiVPNConf as) = as
 
 type VPNAction = RofiAction RofiVPNConf
 
-type VPNServer = (T.Text, T.Text)
+type VPNServer = (String, String)
 
-data VPNStatus = VPNStatus (Maybe T.Text) [VPNServer] deriving (Show)
+data VPNStatus = VPNStatus (Maybe String) [VPNServer] deriving (Show)
 
-getServers :: MonadIO m => m (Maybe VPNStatus)
+getServers :: IO (Maybe VPNStatus)
 getServers = do
   running <- daemonIsRunning
   if running
     then Just <$> getStatus
-    else notifyEVPN IconError "ExpressVPN daemon not running" >> return Nothing
+    else notify IconError "ExpressVPN daemon not running" >> return Nothing
 
-getStatus :: MonadIO m => m VPNStatus
+getStatus :: IO VPNStatus
 getStatus = do
   connected <- getConnectedServer
   VPNStatus connected <$> getAvailableServers
 
-getConnectedServer :: MonadIO m => m (Maybe T.Text)
+getConnectedServer :: IO (Maybe String)
 getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
   where
-    procStatus = listToMaybe . mapMaybe procLine . T.lines
+    procStatus = listToMaybe . mapMaybe procLine . lines
-    procLine l = case T.words l of
+    procLine l = case words l of
       -- the output is green...
-      ("\ESC[1;32;49mConnected" : "to" : server) -> Just $ T.unwords server
+      ("\ESC[1;32;49mConnected":"to":server) -> Just $ unwords server
-      _ -> Nothing
+      _                                      -> Nothing
 
-getAvailableServers :: MonadIO m => m [VPNServer]
+getAvailableServers :: IO [VPNServer]
 getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
   where
-    procOut Nothing = do
+    procOut Nothing   = do
-      notifyEVPN IconError "failed to get list of servers"
+      notify IconError "failed to get list of servers"
       return []
     -- ASSUME the output has a useless header that ends in a line that starts
     -- with "-----", after which is the stuff we care about, which is followed
     -- by a blank line, after which there is more stuff I don't care about
-    procOut (Just ls) =
+    procOut (Just ls) = return
-      return $
+      $ mapMaybe (matchLine . splitOn "\t")
-        mapMaybe (matchLine . T.split (== '\t')) $
+      $ takeWhile (/= "")
-          takeWhile (/= "") $
+      $ drop 1
-            drop 1
+      -- super lame way of matching lines that start with "-----"
-            -- super lame way of matching lines that start with "-----"
+      $ dropWhile (not . isPrefixOf "-----")
-            $
+      $ lines ls
-              dropWhile (not . T.isPrefixOf "-----") $
-                T.lines ls
     -- The output of this command is very strange; it is delimited (kinda) by
     -- tabs but some lines are long enough that they don't have a tab. In
     -- whatever case, splitting by tabs leads to variable length lists, and the
     -- id is always at the front and the location is always at the end. These
     -- should handle all cases.
-    matchLine [i, _, l] = Just (i, l)
+    matchLine [i, _, l]       = Just (i, l)
-    matchLine [i, _, _, l] = Just (i, l)
+    matchLine [i, _, _, l]    = Just (i, l)
     matchLine [i, _, _, _, l] = Just (i, l)
-    matchLine _ = Nothing
+    matchLine _               = Nothing
 
-daemonIsRunning :: MonadIO m => m Bool
+daemonIsRunning :: IO Bool
 daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""
 
-getDisconnectAction :: T.Text -> VPNAction
+getDisconnectAction :: String -> VPNAction
 getDisconnectAction server =
-  (T.append "Disconnect from " server, io $ void $ disconnect server)
+  ("Disconnect from " ++ server, io $ void $ disconnect server)
 
-getConnectAction :: Maybe T.Text -> VPNServer -> VPNAction
+getConnectAction :: Maybe String -> VPNServer -> VPNAction
 getConnectAction connected server =
   (formatServerLine server, io $ go connected)
   where
@@ -107,40 +109,46 @@ getConnectAction connected server =
     go _ = con
     con = connect server
 
-formatServerLine :: VPNServer -> T.Text
+formatServerLine :: VPNServer -> String
-formatServerLine (sid, sname) = T.concat [pad sid, " | ", sname]
+formatServerLine (sid, sname) = pad sid ++ " | " ++ sname
   where
-    pad s = T.append s $ T.replicate (10 - T.length s) " "
+    pad s = s ++ replicate (10 - length s) ' '
 
-eVPN :: T.Text
+eVPN :: String
 eVPN = "expressvpn"
 
-eVPND :: T.Text
+eVPND :: String
 eVPND = "expressvpnd"
 
-connect :: MonadIO m => VPNServer -> m ()
+connect :: VPNServer -> IO ()
 connect (sid, sname) = do
   res <- readCmdSuccess' eVPN ["connect", sid]
-  notifyIf
+  notifyIf res ("connected to " ++ sname)
-    res
+    ("failed to connect to " ++ sname)
-    (T.append "connected to " sname)
-    (T.append "failed to connect to " sname)
 
-disconnect :: MonadIO m => T.Text -> m Bool
+disconnect :: String -> IO Bool
 disconnect server = do
   res <- readCmdSuccess' eVPN ["disconnect"]
-  notifyIf
+  notifyIf res ("disconnected from " ++ server)
-    res
+    ("failed to disconnect from " ++ server)
-    (T.append "disconnected from " server)
-    (T.append "failed to disconnect from " server)
   return res
 
-readCmdSuccess' :: MonadIO m => T.Text -> [T.Text] -> m Bool
+readCmdSuccess' :: String -> [String] -> IO Bool
 readCmdSuccess' cmd args = isJust <$> readCmdSuccess cmd args ""
 
-notifyIf :: MonadIO m => Bool -> T.Text -> T.Text -> m ()
+-- TODO not DRY
-notifyIf True s _ = notifyEVPN IconInfo s
+data NotifyIcon = IconError | IconInfo
-notifyIf False _ s = notifyEVPN IconError s
 
-notifyEVPN :: MonadIO m => NotifyIcon -> T.Text -> m ()
+instance Show NotifyIcon where
-notifyEVPN icon = notify icon "ExpressVPN" . Just
+  show IconError = "dialog-error-symbolic"
+  show IconInfo  = "dialog-information-symbolic"
+
+notifyIf :: Bool -> String -> String -> IO ()
+notifyIf True s _  = notify IconInfo s
+notifyIf False _ s = notify IconError s
+
+notify :: NotifyIcon -> String -> IO ()
+notify icon body = void $ spawnProcess "notify-send" $ args ++ [body]
+  where
+    args = ["-i", show icon, summary]
+    summary = "ExpressVPN"

dhall/rofi-dev.dhall

@@ -1,66 +0,0 @@
-let MountConfig = { mpPath : Text, mpLabel : Optional Text }
-
-let BitwardenConfig = { bwKey : Text, bwTries : Natural }
-
-let SecretMap = { sKey : Text, sVal : Text }
-
-let SecretConfig = { secretAttributes : List SecretMap }
-
-let PromptConfig = { promptTries : Natural }
-
-let PasswordConfig =
-      < PwdBW : BitwardenConfig | PwdLS : SecretConfig | PwdPr : PromptConfig >
-
-let SSHFSData = { sshfsRemote : Text, sshfsPassword : Optional PasswordConfig }
-
-let CIFSOpts =
-      { cifsoptsUsername : Optional Text
-      , cifsoptsWorkgroup : Optional Text
-      , cifsoptsUID : Optional Natural
-      , cifsoptsGID : Optional Natural
-      , cifsoptsIocharset : Optional Text
-      }
-
-let CIFSData =
-      { cifsRemote : Text
-      , cifsSudo : Bool
-      , cifsPassword : Optional PasswordConfig
-      , cifsOpts : Optional CIFSOpts
-      }
-
-let VeracryptData = { vcVolume : Text, vcPassword : Optional PasswordConfig }
-
-let DataConfig =
-      < VeracryptConfig : VeracryptData
-      | SSHFSConfig : SSHFSData
-      | CIFSConfig : CIFSData
-      >
-
-let DeviceConfig = { deviceMount : MountConfig, deviceData : DataConfig }
-
-let TreeConfig = { tcParent : DeviceConfig, tcChildren : List Text }
-
-let TreeMap = { tKey : Text, tVal : TreeConfig }
-
-let StaticConfig =
-      { scTmpPath : Optional Text
-      , scVerbose : Optional Bool
-      , scDevices : List TreeMap
-      }
-
-in  { StaticConfig
-    , TreeConfig
-    , DeviceConfig
-    , DataConfig
-    , VeracryptData
-    , CIFSData
-    , CIFSOpts
-    , SSHFSData
-    , PasswordConfig
-    , SecretConfig
-    , MountConfig
-    , BitwardenConfig
-    , PromptConfig
-    , TreeMap
-    , SecretMap
-    }

fourmolu.yaml

@@ -1,14 +0,0 @@
-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

install_deps

@@ -0,0 +1,8 @@
+#!/bin/bash
+
+# install all dependencies for rofi to run at full capacity
+
+rofi_pkgs=(rofi bitwarden-cli libnotify rofi-greenclip
+           networkmanager-dmenu-git veracrypt sshfs jmtpfs)
+
+yay --needed --noconfirm --norebuild --removemake -S "${rofi_pkgs[@]}"

lib/Bitwarden/Internal.hs

@@ -1,27 +1,36 @@
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
+
 module Bitwarden.Internal
-  ( Item (..)
+  ( Item(..)
-  , Login (..)
+  , Login(..)
   , Session
   , runDaemon
   , runClient
   , getItems
   , callGetSession
-  )
+  ) where
-where
 
-import DBus
+import           Control.Concurrent
-import DBus.Client
+import           Control.Monad
-import Data.Aeson
+
-import Data.UnixTime
+import           Data.Aeson
-import GHC.Generics
+import           Data.Maybe
-import RIO hiding (timeout)
+import           Data.String
-import qualified RIO.Text as T
+import           Data.UnixTime
-import Rofi.Command
+
-import System.Clipboard
+import           DBus
-import System.Process
+import           DBus.Client
+
+import           GHC.Generics
+
+import           Rofi.Command
+
+import           System.Clipboard
+import           System.Process
 
 --------------------------------------------------------------------------------
-
 -- | Daemon
 --
 -- Daemon will export an interface on DBus with two methods:
@@ -30,69 +39,67 @@ import System.Process
 -- * lock session - destroy the current session id if active
 --
 -- The session ID will be valid only as long as TIMEOUT
+
 newtype BWServerConf = BWServerConf
-  { timeout :: UnixDiffTime
+    { timeout :: UnixDiffTime
-  }
+    }
 
 -- TODO add a cache so the browse list will load faster
 data CurrentSession = CurrentSession
-  { timestamp :: !UnixTime
+    { timestamp :: UnixTime
-  , hash :: !T.Text
+    , hash      :: String
-  }
+    }
 
 type Session = MVar (Maybe CurrentSession)
 
-runDaemon :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => Int -> m ()
+runDaemon :: Int -> IO ()
 runDaemon t = do
   ses <- newMVar Nothing
-  let c = BWServerConf {timeout = UnixDiffTime (fromIntegral t) 0}
+  let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 }
   startService c ses
   forever $ threadDelay 1000000
 
-lockSession :: MonadIO m => Session -> m ()
+lockSession :: Session -> IO ()
 lockSession ses = void $ swapMVar ses Nothing
 
-syncSession :: MonadUnliftIO m => BWServerConf -> Session -> m ()
+syncSession :: BWServerConf -> Session -> IO ()
 syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
   where
     cmd h = readCmdSuccess "bw" ["sync", "--session", h] ""
-    notify res =
+    notify res = let j = isJust res
-      let j = isJust res
+      in notifyStatus j $ if j then "sync succeeded" else "sync failed"
-       in notifyStatus j $ if j then "sync succeeded" else "sync failed"
 
-getSession' :: MonadUnliftIO m => BWServerConf -> Session -> m (Maybe T.Text)
+getSession' :: BWServerConf -> Session -> IO (Maybe String)
-getSession' BWServerConf {timeout = t} ses = do
+getSession' BWServerConf { timeout = t } ses = do
-  ut <- liftIO $ getUnixTime
+  ut <- getUnixTime
   modifyMVar ses $ \s -> case s of
-    Just CurrentSession {timestamp = ts, hash = h} ->
+    Just CurrentSession { timestamp = ts, hash = h } ->
       if diffUnixTime ut ts > t then getNewSession else return (s, Just h)
     Nothing -> getNewSession
   where
     getNewSession = do
       pwd <- readPassword' "Bitwarden Password"
       newHash <- join <$> mapM readSession pwd
-      (,newHash) <$> mapM newSession newHash
+      (, newHash) <$> mapM newSession newHash
     newSession h = do
-      ut <- liftIO $ getUnixTime
+      ut <- getUnixTime
-      return CurrentSession {timestamp = ut, hash = h}
+      return CurrentSession { timestamp = ut, hash = h }
 
-getSession :: MonadUnliftIO m => BWServerConf -> Session -> m T.Text
+getSession :: BWServerConf -> Session -> IO String
 getSession conf ses = fromMaybe "" <$> getSession' conf ses
 
-readSession :: MonadIO m => T.Text -> m (Maybe T.Text)
+readSession :: String -> IO (Maybe String)
 readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
 
-notifyStatus :: MonadIO m => Bool -> T.Text -> m ()
+notifyStatus :: Bool -> String -> IO ()
 notifyStatus succeeded msg =
-  void $ liftIO $ spawnProcess "notify-send" ["-i", i, T.unpack msg]
+  void $ spawnProcess "notify-send" ["-i", i, msg]
   where
-    i =
+    i = if succeeded
-      if succeeded
+      then "dialog-information-symbolic"
-        then "dialog-information-symbolic"
+      else "dialog-error-symbolic"
-        else "dialog-error-symbolic"
 
 --------------------------------------------------------------------------------
-
 -- | Client
 --
 -- The client will get the current session from the daemon (if it can) and then
@@ -107,155 +114,132 @@ notifyStatus succeeded msg =
 --     - username (if applicable) -> copy to clipboard
 --     - password (if applicable) -> copy to clipboard
 --     - anything else (notes and such) -> copy to clipboard
-data BWClientConf c = BWClientConf
-  { bwArgs :: ![T.Text]
-  , bwEnv :: !c
-  }
 
-instance HasRofiConf (BWClientConf c) where
+newtype BWClientConf = BWClientConf [String]
-  defArgs = bwArgs
 
-instance HasLogFunc c => HasLogFunc (BWClientConf c) where
+instance RofiConf BWClientConf where
-  logFuncL = lens bwEnv (\x y -> x {bwEnv = y}) . logFuncL
+  defArgs (BWClientConf a) = a
 
-runClient :: HasLogFunc c => [T.Text] -> RIO c ()
+runClient :: [String] -> IO ()
-runClient a =
+runClient a = do
-  mapRIO (BWClientConf a) $
+  let c = BWClientConf a
-    selectAction $
+  runRofiIO c $ selectAction $ emptyMenu
-      emptyMenu
+    { groups = [untitledGroup $ toRofiActions ras]
-        { groups = [untitledGroup $ toRofiActions ras]
+    , prompt = Just "Action"
-        , prompt = Just "Action"
+    }
-        }
   where
-    ras =
+    ras = [ ("Browse Logins", browseLogins)
-      [ ("Browse Logins", browseLogins)
+          , ("Sync Session", io callSyncSession)
-      , ("Sync Session", callSyncSession)
+          , ("Lock Session", io callLockSession)
-      , ("Lock Session", callLockSession)
+          ]
-      ]
 
-browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c ()
+browseLogins :: RofiConf c => RofiIO c ()
-browseLogins = getItems >>= selectItem
+browseLogins = io getItems >>= selectItem
 
-getItems :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m [Item]
+getItems :: IO [Item]
 getItems = maybe (return []) getItems' =<< callGetSession
 
-getItems' :: MonadIO m => T.Text -> m [Item]
+getItems' :: String -> IO [Item]
 getItems' session = do
-  items <- liftIO $ readProcess "bw" ["list", "items", "--session", T.unpack session] ""
+  items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
   return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
   where
-    notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
+    notEmpty Item { login = Login { username = Nothing, password = Nothing } }
-      False
+      = False
     notEmpty _ = True
 
 data Item = Item
-  { name :: T.Text
+    { name  :: String
-  , login :: Login
+    , login :: Login
-  }
+    }
-  deriving (Show)
+    deriving (Show)
 
 instance FromJSON Item where
-  parseJSON (Object o) =
+  parseJSON (Object o) = Item
-    Item
+    <$> o .: "name"
-      <$> o .: "name"
+    <*> o .:? "login" .!= Login { username = Nothing, password = Nothing }
-      <*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
   parseJSON _ = mzero
 
 data Login = Login
-  { username :: Maybe T.Text
+    { username :: Maybe String
-  , password :: Maybe T.Text
+    , password :: Maybe String
-  }
+    }
-  deriving (Show, Generic)
+    deriving (Show, Generic)
 
 instance FromJSON Login
 
 -- TODO make menu buttons here to go back and to copy without leaving
 -- the current menu
-selectItem :: (HasLogFunc c, HasRofiConf c) => [Item] -> RIO c ()
+selectItem :: RofiConf c => [Item] -> RofiIO c ()
-selectItem items =
+selectItem items = selectAction $ emptyMenu
-  selectAction $
+  { groups = [untitledGroup $ itemsToRofiActions items]
-    emptyMenu
+  , prompt = Just "Login"
-      { groups = [untitledGroup $ itemsToRofiActions items]
+  }
-      , prompt = Just "Login"
-      }
 
-itemsToRofiActions :: (HasLogFunc c, HasRofiConf c) => [Item] -> RofiActions c
+itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
 itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
 
-selectCopy :: (HasLogFunc c, HasRofiConf c) => Login -> RIO c ()
+selectCopy :: RofiConf c => Login -> RofiIO c ()
-selectCopy l =
+selectCopy l = selectAction $ emptyMenu
-  selectAction $
+  { groups = [untitledGroup $ loginToRofiActions l copy]
-    emptyMenu
+  , prompt = Just "Copy"
-      { groups = [untitledGroup $ loginToRofiActions l copy]
+  , hotkeys = [copyHotkey, backHotkey]
-      , prompt = Just "Copy"
+  }
-      , hotkeys = [copyHotkey, backHotkey]
-      }
   where
-    copy = io . setClipboardString . T.unpack
+    copy = io . setClipboardString
     copyRepeat s = copy s >> selectCopy l
-    copyHotkey =
+    copyHotkey = Hotkey
-      Hotkey
+      { keyCombo = "Alt+c"
-        { keyCombo = "Alt+c"
+      , keyIndex = 1
-        , keyDescription = "Copy One"
+      , keyDescription = "Copy One"
-        , keyActions = loginToRofiActions l copyRepeat
+      , keyActions = loginToRofiActions l copyRepeat
-        }
+      }
-    backHotkey =
+    backHotkey = Hotkey
-      Hotkey
+      { keyCombo = "Alt+q"
-        { keyCombo = "Alt+q"
+      , keyIndex = 2
-        , keyDescription = "Back"
+      , keyDescription = "Back"
-        , -- TODO this is overly complicated, all entries do the same thing
+      -- TODO this is overly complicated, all entries do the same thing
-          -- TODO this is slow, we can cache the logins somehow...
+      -- TODO this is slow, we can cache the logins somehow...
-          keyActions = loginToRofiActions l (const browseLogins)
+      , keyActions = loginToRofiActions l (const browseLogins)
-        }
+      }
 
-loginToRofiActions :: Login -> (T.Text -> RIO c ()) -> RofiActions c
+loginToRofiActions :: RofiConf c => Login -> (String -> RofiIO c ()) -> RofiActions c
-loginToRofiActions Login {username = u, password = p} a =
+loginToRofiActions Login { username = u, password = p } a =
   toRofiActions $ catMaybes [user, pwd]
   where
     copyIfJust f = fmap $ liftM2 (,) f a
-    fmtUsername s = T.concat ["Username (", s, ")"]
+    fmtUsername s = "Username (" ++ s ++ ")"
-    fmtPassword s = T.concat ["Password (", T.take 32 (T.replicate (T.length s) "*"), ")"]
+    fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")"
     user = copyIfJust fmtUsername u
     pwd = copyIfJust fmtPassword p
 
-getItemPassword' :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m (Maybe T.Text)
+getItemPassword' :: BWServerConf -> Session -> String -> IO (Maybe String)
 getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
   where
-    getPwd = fmap T.pack . pr
+    getPwd s = readProcess "bw" ["get", "password", item, "--session", s] ""
-    pr s =
-      liftIO $
-        readProcess
-          "bw"
-          ["get", "password", T.unpack item, "--session", T.unpack s]
-          ""
 
-getItemPassword :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m T.Text
+getItemPassword :: BWServerConf -> Session -> String -> IO String
-getItemPassword conf session item =
+getItemPassword conf session item = fromMaybe "" <$>
-  fromMaybe ""
+  getItemPassword' conf session item
-    <$> getItemPassword' conf session item
 
 --------------------------------------------------------------------------------
-
 -- | DBus
-startService :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => BWServerConf -> Session -> m ()
+
+startService :: BWServerConf -> Session -> IO ()
 startService c ses = do
-  client <- liftIO $ connectSession
+  client <- connectSession
   let flags = [nameAllowReplacement, nameReplaceExisting]
-  _ <- liftIO $ requestName client busname flags
+  _ <- requestName client busname flags
-  logInfo "Started rofi bitwarden dbus client"
+  putStrLn "Started rofi bitwarden dbus client"
-  withRunInIO $ \runIO ->
+  export client path defaultInterface
-    export
+    { interfaceName = interface
-      client
+    , interfaceMethods =
-      path
+      [ autoMethod memGetSession $ getSession c ses
-      defaultInterface
+      , autoMethod memLockSession $ lockSession ses
-        { interfaceName = interface
+      , autoMethod memSyncSession $ syncSession c ses
-        , interfaceMethods =
+      , autoMethod memGetPassword $ getItemPassword c ses
-            [ autoMethod memGetSession $ runIO $ getSession c ses
+      ]
-            , autoMethod memLockSession $ runIO $ lockSession ses
+    }
-            , autoMethod memSyncSession $ runIO $ syncSession c ses
-            , autoMethod memGetPassword $ runIO . getItemPassword c ses
-            ]
-        }
 
 busname :: BusName
 busname = "org.rofi.bitwarden"
@@ -278,38 +262,33 @@ memSyncSession = "SyncSession"
 memGetPassword :: MemberName
 memGetPassword = "GetPassword"
 
-callMember :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => MemberName -> m [Variant]
+callMember :: MemberName -> IO [Variant]
 callMember m = do
   reply <- callMethod $ methodCall path interface m
   case reply of
-    Left err -> do
+    Left err   -> putStrLn (methodErrorMessage err) >> return []
-      logError $
-        displayBytesUtf8 $
-          encodeUtf8 $
-            (T.pack (methodErrorMessage err))
-      return []
     Right body -> return body
 
-callLockSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
+callLockSession :: IO ()
 callLockSession = void $ callMember memLockSession
 
-callSyncSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
+callSyncSession :: IO ()
 callSyncSession = void $ callMember memSyncSession
 
-callGetSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m (Maybe T.Text)
+callGetSession :: IO (Maybe String)
 callGetSession = getBodyString <$> callMember memGetSession
 
 -- TODO maybe will need to add a caller for getItemPassword
 
-getBodyString :: [Variant] -> Maybe T.Text
+getBodyString :: [Variant] -> Maybe String
-getBodyString [b] = case fromVariant b :: Maybe T.Text of
+getBodyString [b] = case fromVariant b :: Maybe String of
   Just "" -> Nothing
-  s -> s
+  s       -> s
 getBodyString _ = Nothing
 
-callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant])
+callMethod :: MethodCall -> IO (Either MethodError [Variant])
-callMethod mc = liftIO $ do
+callMethod mc = do
   client <- connectSession
-  reply <- call client mc {methodCallDestination = Just busname}
+  reply <- call client mc { methodCallDestination = Just busname }
   disconnect client
   return $ methodReturnBody <$> reply

lib/Rofi/Command.hs

@@ -1,12 +1,16 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Rofi.Command
-  ( HasRofiConf (..)
+  ( RofiConf(..)
-  , RofiMenu (..)
+  , RofiMenu(..)
   , RofiAction
   , RofiActions
+  , RofiIO
   , RofiGroup
-  , Hotkey (..)
+  , Hotkey(..)
   , io
   , emptyMenu
+  , runRofiIO
   , toRofiActions
   , rofiActionKeys
   , untitledGroup
@@ -19,180 +23,170 @@ module Rofi.Command
   , readCmdEither'
   , dmenuArgs
   , joinNewline
-  , runRofi
+  , stripWS
-  )
+  ) where
-where
 
-import qualified Data.Map.Ordered as OM
+import           Control.Monad.IO.Unlift
-import RIO
+import           Control.Monad.Reader
-import qualified RIO.List as L
-import qualified RIO.Text as T
-import qualified RIO.Vector.Boxed as V
-import System.Process
 
-class HasRofiConf c where
+import           Data.Char
-  defArgs :: c -> [T.Text]
+import           Data.List
+import qualified Data.Map.Ordered        as M
+import           Data.Maybe
 
-type RofiAction c = (T.Text, RIO c ())
+import           System.Exit
+import           System.Process
 
-type RofiActions c = OM.OMap T.Text (RIO c ())
+class RofiConf c where
+  defArgs :: c -> [String]
+
+type RofiAction c = (String, RofiIO c ())
+
+type RofiActions c = M.OMap String (RofiIO c ())
 
 data RofiGroup c = RofiGroup
-  { actions :: RofiActions c
+    { actions :: RofiActions c
-  , title :: Maybe T.Text
+    , title   :: Maybe String
-  }
+    }
 
 untitledGroup :: RofiActions c -> RofiGroup c
-untitledGroup a = RofiGroup {actions = a, title = Nothing}
+untitledGroup a = RofiGroup { actions = a, title = Nothing }
 
-titledGroup :: T.Text -> RofiActions c -> RofiGroup c
+titledGroup :: String -> RofiActions c -> RofiGroup c
-titledGroup t a = (untitledGroup a) {title = Just t}
+titledGroup t a = (untitledGroup a) { title = Just t }
 
 data Hotkey c = Hotkey
-  { keyCombo :: !T.Text
+    { keyCombo       :: String
-  , keyDescription :: !T.Text
+    -- only 1-10 are valid
-  , keyActions :: RofiActions c
+    , keyIndex       :: Int
-  }
+    , keyDescription :: String
+    , keyActions     :: RofiActions c
+    }
 
-hotkeyBinding :: Int -> Hotkey c -> [T.Text]
+hotkeyBinding :: Hotkey c -> [String]
-hotkeyBinding i Hotkey {keyCombo = c} = [k, c]
+hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
   where
-    k = T.append "-kb-custom-" $ T.pack $ show i
+    k = "-kb-custom-" ++ show e
 
-hotkeyMsg1 :: Hotkey c -> T.Text
+hotkeyMsg1 :: Hotkey c -> String
-hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
+hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
-  T.concat [c, ": <i>", d, "</i>"]
+  c ++ ": <i>" ++ d ++ "</i>"
 
-hotkeyMsg :: [Hotkey c] -> [T.Text]
+hotkeyMsg :: [Hotkey c] -> [String]
 hotkeyMsg [] = []
-hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
+hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
 
-hotkeyArgs :: [Hotkey c] -> [T.Text]
+hotkeyArgs :: [Hotkey c] -> [String]
-hotkeyArgs hks =
+hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
-  (hotkeyMsg hks)
-    ++ (concatMap (uncurry hotkeyBinding) $ take 19 $ zip [1 ..] hks)
 
 data RofiMenu c = RofiMenu
-  { groups :: ![RofiGroup c]
+    { groups  :: [RofiGroup c]
-  , prompt :: !(Maybe T.Text)
+    , prompt  :: Maybe String
-  , hotkeys :: ![Hotkey c]
+    , hotkeys :: [Hotkey c]
-  }
+    }
 
 emptyMenu :: RofiMenu c
-emptyMenu =
+emptyMenu = RofiMenu
-  RofiMenu
+  { groups = []
-    { groups = []
+  , prompt = Nothing
-    , prompt = Nothing
+  , hotkeys = []
-    , hotkeys = mempty
+  }
-    }
+
+newtype RofiIO c a = RofiIO (ReaderT c IO a)
+    deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO)
+
+instance Applicative (RofiIO c) where
+  pure = return
+  (<*>) = ap
 
 io :: MonadIO m => IO a -> m a
 io = liftIO
 
-toRofiActions :: [(T.Text, RIO c ())] -> RofiActions c
+runRofiIO :: c -> RofiIO c a -> IO a
-toRofiActions = OM.fromList
+runRofiIO c (RofiIO r) = runReaderT r c
 
-rofiActionKeys :: RofiActions c -> T.Text
+toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
-rofiActionKeys = joinNewline . map fst . OM.assocs
+toRofiActions = M.fromList
 
-lookupRofiAction :: T.Text -> RofiActions c -> RIO c ()
+rofiActionKeys :: RofiActions c -> String
-lookupRofiAction key = fromMaybe err . OM.lookup key
+rofiActionKeys = joinNewline . map fst . M.assocs
-  where
-    err = error $ T.unpack $ T.concat ["could not lookup key: '", key, "'"]
 
-groupEntries :: RofiGroup c -> T.Text
+lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
-groupEntries RofiGroup {actions = a, title = t}
+lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
+
+groupEntries :: RofiGroup c -> String
+groupEntries RofiGroup { actions = a, title = t }
   | null a = ""
-  | otherwise = T.append title' $ rofiActionKeys a
+  | otherwise = title' ++ rofiActionKeys a
   where
-    title' = maybe "" (`T.append` "\n") t
+    title' = maybe "" (++ "\n") t
 
 menuActions :: RofiMenu c -> RofiActions c
-menuActions = L.foldr (OM.<>|) OM.empty . fmap actions . groups
+menuActions = foldr1 (M.<>|) . fmap actions . groups
 
-menuEntries :: RofiMenu c -> T.Text
+menuEntries :: RofiMenu c -> String
-menuEntries = T.intercalate "\n\n" . filter (not . T.null) . fmap groupEntries . groups
+menuEntries = intercalate "\n\n" . filter (not . null) . fmap groupEntries . groups
 
-selectAction :: HasRofiConf c => RofiMenu c -> RIO c ()
+selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
 selectAction rm = do
   let p = maybeOption "-p" $ prompt rm
   let hArgs = hotkeyArgs $ hotkeys rm
   res <- readRofi (p ++ hArgs) $ menuEntries rm
   case res of
-    Right key -> lookupRofiAction key $ menuActions rm
+    Right key        -> lookupRofiAction key $ menuActions rm
-    Left (1, _, _) -> exitWith $ ExitFailure 1
+    Left (n, key, _) -> mapM_ (lookupRofiAction key . keyActions)
-    Left (n, key, _) -> do
+      $ find ((==) n . (+ 9) . keyIndex)
-      maybe
+      $ hotkeys rm
-        (error $ T.unpack $ T.append "could not find key index: " $ T.pack $ show n)
-        (lookupRofiAction key . keyActions)
-        -- this sketchy assumption has to do with the fact that the custom
-        -- keybindings are labeled 1-19 and thus need to be explicitly
-        -- indexed, and the program itself tells the world which key was
-        -- pressed via return code (any possible integer)
-        ((V.fromList $ hotkeys rm) V.!? (n - 10))
 
-runRofi :: (MonadIO m, HasRofiConf c) => c -> RofiMenu c -> m ()
+maybeOption :: String -> Maybe String -> [String]
-runRofi c = runRIO c . selectAction
-
-maybeOption :: T.Text -> Maybe T.Text -> [T.Text]
 maybeOption switch = maybe [] (\o -> [switch, o])
 
-dmenuArgs :: [T.Text]
+dmenuArgs :: [String]
 dmenuArgs = ["-dmenu"]
 
-readRofi
+readRofi :: RofiConf c => [String]
-  :: HasRofiConf c
+  -> String
-  => [T.Text]
+  -> RofiIO c (Either (Int, String, String) String)
-  -> T.Text
-  -> RIO c (Either (Int, T.Text, T.Text) T.Text)
 readRofi uargs input = do
   dargs <- asks defArgs
   io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
 
-readCmdSuccess :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m (Maybe T.Text)
+readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
-readCmdSuccess cmd args input =
+readCmdSuccess cmd args input = either (const Nothing) Just
-  either (const Nothing) Just
+  <$> readCmdEither cmd args input
-    <$> readCmdEither cmd args input
 
-readCmdEither
+readCmdEither :: String
-  :: MonadIO m
+  -> [String]
-  => T.Text
+  -> String
-  -> [T.Text]
+  -> IO (Either (Int, String, String) String)
-  -> T.Text
+readCmdEither cmd args input = resultToEither
-  -> m (Either (Int, T.Text, T.Text) T.Text)
+  <$> readProcessWithExitCode cmd args input
-readCmdEither cmd args input = readCmdEither' cmd args input []
 
-readCmdEither'
+readCmdEither' :: String
-  :: MonadIO m
+  -> [String]
-  => T.Text
+  -> String
-  -> [T.Text]
+  -> [(String, String)]
-  -> T.Text
+  -> IO (Either (Int, String, String) String)
-  -> [(T.Text, T.Text)]
+readCmdEither' cmd args input environ = resultToEither
-  -> m (Either (Int, T.Text, T.Text) T.Text)
+  <$> readCreateProcessWithExitCode p input
-readCmdEither' cmd args input environ =
-  resultToEither
-    <$> (liftIO $ readCreateProcessWithExitCode p (T.unpack input))
   where
-    e = case environ of
+    p = (proc cmd args) { env = Just environ }
-      [] -> Nothing
-      es -> Just $ fmap (bimap T.unpack T.unpack) es
-    p = (proc (T.unpack cmd) (fmap T.unpack args)) {env = e}
 
--- TODO why strip whitespace?
+resultToEither :: (ExitCode, String, String)
-resultToEither
+  -> Either (Int, String, String) String
-  :: (ExitCode, String, String)
+resultToEither (ExitSuccess, out, _)     = Right $ stripWS out
-  -> Either (Int, T.Text, T.Text) T.Text
+resultToEither (ExitFailure n, out, err) = Left (n, stripWS out, stripWS err)
-resultToEither (ExitSuccess, out, _) = Right $ T.stripEnd $ T.pack out
-resultToEither (ExitFailure n, out, err) =
-  Left (n, T.stripEnd $ T.pack out, T.stripEnd $ T.pack err)
 
-joinNewline :: [T.Text] -> T.Text
+stripWS :: String -> String
-joinNewline = T.intercalate "\n"
+stripWS = reverse . dropWhile isSpace . reverse
 
-readPassword :: MonadIO m => m (Maybe T.Text)
+joinNewline :: [String] -> String
+joinNewline = intercalate "\n"
+
+readPassword :: IO (Maybe String)
 readPassword = readPassword' "Password"
 
-readPassword' :: MonadIO m => T.Text -> m (Maybe T.Text)
+readPassword' :: String -> IO (Maybe String)
 readPassword' p = readCmdSuccess "rofi" args ""
   where
     args = dmenuArgs ++ ["-p", p, "-password"]

lib/Rofi/IO.hs

@@ -1,29 +0,0 @@
-module Rofi.IO where
-
-import RIO
-import RIO.Directory
-import qualified RIO.Text as T
-import System.Process
-
-data NotifyIcon = IconError | IconInfo
-
-instance Show NotifyIcon where
-  show IconError = "dialog-error-symbolic"
-  show IconInfo = "dialog-information-symbolic"
-
-notify :: MonadIO m => NotifyIcon -> T.Text -> Maybe T.Text -> m ()
-notify icon summary body =
-  liftIO $
-    void $
-      spawnProcess "notify-send" $
-        maybe args (\b -> args ++ [b]) $
-          fmap T.unpack body
-  where
-    args = ["-i", show icon, T.unpack summary]
-
-checkExe :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => FilePath -> m ()
-checkExe cmd = do
-  res <- findExecutable cmd
-  unless (isJust res) $ do
-    logError $ displayBytesUtf8 $ encodeUtf8 $ T.append "Could not find executable: " $ T.pack cmd
-    exitWith $ ExitFailure 1

make_pkgs

@@ -1,5 +0,0 @@
-libx11
-libxrandr
-libxss
-libxext
-zlib

package.yaml

@@ -9,56 +9,15 @@ copyright:           "2020 Nathan Dwarshuis"
 extra-source-files:
 - README.md
 
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
 description:         Please see the README on GitHub at <https://github.com/ndwarshuis/rofi-extras#readme>
 
-default-extensions:
-  - OverloadedStrings
-  - FlexibleContexts
-  - FlexibleInstances
-  - InstanceSigs
-  - MultiParamTypeClasses
-  - EmptyCase
-  - LambdaCase
-  - MultiWayIf
-  - NamedFieldPuns
-  - TupleSections
-  - DeriveFoldable
-  - DeriveFunctor
-  - DeriveGeneric
-  - DeriveLift
-  - DeriveTraversable
-  - DerivingStrategies
-  - DeriveDataTypeable
-  - EmptyDataDecls
-  - PartialTypeSignatures
-  - GeneralizedNewtypeDeriving
-  - StandaloneDeriving
-  - BangPatterns
-  - TypeOperators
-  - ScopedTypeVariables
-  - TypeApplications
-  - ConstraintKinds
-  - RankNTypes
-  - GADTs
-  - DefaultSignatures
-  - NoImplicitPrelude
-  - FunctionalDependencies
-  - DataKinds
-  - TypeFamilies
-  - BinaryLiterals
-  - ViewPatterns
-
-ghc-options:
-- -Wall
-- -Wcompat
-- -Widentities
-- -Wincomplete-record-updates
-- -Wincomplete-uni-patterns
-- -Wredundant-constraints
-- -Wpartial-fields
-- -Werror
-- -O2
-
 dependencies:
 - base >= 4.7 && < 5
 - process >= 1.6.5.0
@@ -81,18 +40,24 @@ dependencies:
 - yaml >= 0.11.1.2
 - vector >= 0.12.0.3
 - bimap >= 0.2.4
-- dhall >= 1.40.2
-- lens >= 5.0.1
-- rio
 
 library:
   source-dirs: lib/
+  ghc-options:
+  - -Wall
+  - -Werror
+  - -threaded
+  exposed-modules:
+  - Bitwarden.Internal
+  - Rofi.Command
 
 executables:
   pinentry-rofi:
     main: pinentry-rofi.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras
@@ -101,6 +66,8 @@ executables:
     main: rofi-autorandr.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras
@@ -109,6 +76,8 @@ executables:
     main: rofi-bw.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras
@@ -117,6 +86,8 @@ executables:
     main: rofi-bt.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras
@@ -125,6 +96,8 @@ executables:
     main: rofi-dev.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras
@@ -133,14 +106,18 @@ executables:
     main: rofi-evpn.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras
 
-  rofi:
+  current-output:
-    main: rofi.hs
+    main: current-output.hs
     source-dirs: app
     ghc-options:
+    - -Wall
+    - -Werror
     - -threaded
     dependencies:
     - rofi-extras

runtime_pkgs

@@ -1,34 +0,0 @@
-#!/bin/bash
-
-# Show the Pacman/AUR packages necessary for various components in this repo.
-
-# NOTE: this does not list the build dependencies (x11 and friends)
-
-pkgs=(rofi)
-
-while [ "$#" -gt 0 ]; do
-    case "$1" in
-        -a|--autorandr)
-            pkgs+=(autorandr)
-            ;;
-        -b|--bitwarden)
-            pkgs+=(bitwarden-cli libnotify)
-            ;;
-        -d|--devices)
-            pkgs+=(udisks2 cifs-utils veracrypt sshfs jmtpfs libnotify libsecret)
-            ;;
-        -B|--bluetooth)
-            pkgs+=(bluez)
-            ;;
-        -e|--expressvpn)
-            pkgs+=(expressvpn libnotify)
-            ;;
-        *)
-            echo "unknown option: $1"
-            exit 1
-            ;;
-    esac
-    shift
-done
-
-echo "${pkgs[@]}" | tr ' ' '\n' | sort | uniq

scripts/gpg

@@ -1,5 +0,0 @@
-#! /bin/bash
-
-## gpg (override): mount GNUPGHOME before executing
-
-with_gpg_mount /usr/bin/gpg "$@"

scripts/mount-veracrypt@.service

@@ -1,7 +1,6 @@
 [Unit]
 Description=Mount veracrypt volume for %i
 
-# TODO these scripts moved
 [Service]
 Type=forking
 ExecStart=%h/.bin/mount.veracrypt ${BW_NAME} ${VOLUME} ${MOUNTPOINT}

scripts/mount.veracrypt

@@ -1,30 +0,0 @@
-#! /bin/bash
-
-## mount a veracrypt volume
-
-## NOTE this will need the DISPLAY variable in order to prompt for the bitwarden
-## password
-pwd=$(dbus-send --print-reply=literal --session \
-                --dest=org.rofi.bitwarden \
-                /bitwarden org.rofi.bitwarden.session.GetPassword \
-                string:"$1" | \
-          sed -e 's/^ *//g')
-
-## the funny evals are here to expand any literal env variables that may be
-## passed because systemd didn't expand them (yuck)
-volume="$(eval echo "$2")"
-mountpoint="$(eval echo "$3")"
-
-if [[ "$pwd" == "" ]]; then
-    echo "Could not get bitwarden password"
-    exit 1
-else
-    if /usr/bin/sudo /usr/bin/veracrypt \
-                     --text --non-interactive --stdin \
-                     "$volume" "$mountpoint" <<< "$pwd"; then
-        echo "Mounted $1"
-    else
-        echo "Failed to mount $1"
-        exit 1
-    fi
-fi

scripts/pass

@@ -1,5 +0,0 @@
-#! /bin/bash
-
-## pass (override): mount $GNUPGHOME before executing
-
-with_gpg_mount /usr/bin/pass "$@"

scripts/umount.veracrypt

@@ -1,14 +0,0 @@
-#! /bin/bash
-
-## unmount a veracrypt volume
-
-## the funny evals are here to expand any literal env variables that may be
-## passed because systemd didn't expand them (yuck)
-mountpoint="$(eval echo "$1")"
-
-if /usr/bin/sudo /usr/bin/veracrypt -d "$mountpoint"; then
-    echo "Unmounted $1"
-else
-    echo "Failed to unmount $1"
-    exit 1
-fi

scripts/with_gpg_mount

@@ -1,14 +0,0 @@
-#! /bin/bash
-
-## with_gpg_mount: call a program after mounting GNUPGHOME using rofi
-
-bin="$1"
-shift
-
-alias="gnupg"
-
-if rofi-dev -c "$XDG_CONFIG_HOME/rofi/devices.dhall" -m "$alias"; then
-    "$bin" "$@"
-else
-    echo "Could not mount $alias"
-fi

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-20.11
+resolver: lts-16.31
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -64,3 +64,11 @@ packages:
 #
 # Allow a newer minor version of GHC than the snapshot specifies
 # compiler-check: newer-minor
+nix:
+  enable: true
+  packages:
+    - xorg.libX11
+    - xorg.libXrandr
+    - xorg.libXScrnSaver
+    - xorg.libXext
+    - zlib

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    sha256: adbc602422dde10cc330175da7de8609e70afc41449a7e2d6e8b1827aa0e5008
+    size: 534126
-    size: 649342
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/11.yaml
+    sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6
-  original: lts-20.11
+  original: lts-16.31