FIX pinentry bug

ADD lots of little files that were scattered around
ENH revert failed last two commits
2024-03-13 21:58:28 -04:00 · 2024-01-07 11:50:22 -05:00 · 2024-01-07 11:49:30 -05:00 · 2023-02-22 23:02:04 -05:00 · 2023-02-22 22:44:44 -05:00 · 2023-02-16 22:53:00 -05:00
27 changed files with 1441 additions and 1483 deletions
--- a/.stylish-haskell.yaml
+++ b/.stylish-haskell.yaml
@ -1,357 +0,0 @@
 # stylish-haskell configuration file
 # ==================================
 # The stylish-haskell tool is mainly configured by specifying steps. These steps
 # are a list, so they have an order, and one specific step may appear more than
 # once (if needed). Each file is processed by these steps in the given order.
 steps:
  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
  # by default.
  # - unicode_syntax:
  #     # In order to make this work, we also need to insert the UnicodeSyntax
  #     # language pragma. If this flag is set to true, we insert it when it's
  #     # not already present. You may want to disable it if you configure
  #     # language extensions using some other method than pragmas. Default:
  #     # true.
  #     add_language_pragma: true
  # Format module header
  #
  # Currently, this option is not configurable and will format all exports and
  # module declarations to minimize diffs
  #
  # - module_header:
  #     # How many spaces use for indentation in the module header.
  #     indent: 4
  #
  #     # Should export lists be sorted?  Sorting is only performed within the
  #     # export section, as delineated by Haddock comments.
  #     sort: true
  #
  #     # See `separate_lists` for the `imports` step.
  #     separate_lists: true
  # Format record definitions. This is disabled by default.
  #
  # You can control the layout of record fields. The only rules that can't be configured
  # are these:
  #
  # - "|" is always aligned with "="
  # - "," in fields is always aligned with "{"
  # - "}" is likewise always aligned with "{"
  #
  # - records:
  #     # How to format equals sign between type constructor and data constructor.
  #     # Possible values:
  #     # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
  #     # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
  #     equals: "indent 2"
  #
  #     # How to format first field of each record constructor.
  #     # Possible values:
  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
  #     first_field: "indent 2"
  #
  #     # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
  #     field_comment: 2
  #
  #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
  #     deriving: 2
  #
  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause
  #     # Possible values:
  #     # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
  #     # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
  #     via: "indent 2"
  #
  #     # Sort typeclass names in the "deriving" list alphabetically.
  #     sort_deriving: true
  #
  #     # Wheter or not to break enums onto several lines
  #     #
  #     # Default: false
  #     break_enums: false
  #
  #     # Whether or not to break single constructor data types before `=` sign
  #     #
  #     # Default: true
  #     break_single_constructors: true
  #
  #     # Whether or not to curry constraints on function.
  #     #
  #     # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
  #     #
  #     # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
  #     #
  #     # Default: false
  #     curried_context: false
  # Align the right hand side of some elements.  This is quite conservative
  # and only applies to statements where each element occupies a single
  # line.
  # Possible values:
  # - always - Always align statements.
  # - adjacent - Align statements that are on adjacent lines in groups.
  # - never - Never align statements.
  # All default to always.
  - simple_align:
      cases: always
      top_level_patterns: always
      records: always
      multi_way_if: always
  # Import cleanup
  - imports:
      # There are different ways we can align names and lists.
      #
      # - global: Align the import names and import list throughout the entire
      #   file.
      #
      # - file: Like global, but don't add padding when there are no qualified
      #   imports in the file.
      #
      # - group: Only align the imports per group (a group is formed by adjacent
      #   import lines).
      #
      # - none: Do not perform any alignment.
      #
      # Default: global.
      align: global
      # The following options affect only import list alignment.
      #
      # List align has following options:
      #
      # - after_alias: Import list is aligned with end of import including
      #   'as' and 'hiding' keywords.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #   >                                          init, last, length)
      #
      # - with_alias: Import list is aligned with start of alias or hiding.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #   >                                 init, last, length)
      #
      # - with_module_name: Import list is aligned `list_padding` spaces after
      #   the module name.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #                          init, last, length)
      #
      #   This is mainly intended for use with `pad_module_names: false`.
      #
      #   > import qualified Data.List as List (concat, foldl, foldr, head,
      #                          init, last, length, scanl, scanr, take, drop,
      #                          sort, nub)
      #
      # - new_line: Import list starts always on new line.
      #
      #   > import qualified Data.List      as List
      #   >     (concat, foldl, foldr, head, init, last, length)
      #
      # - repeat: Repeat the module name to align the import list.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head)
      #   > import qualified Data.List      as List (init, last, length)
      #
      # Default: after_alias
      list_align: after_alias
      # Right-pad the module names to align imports in a group:
      #
      # - true: a little more readable
      #
      #   > import qualified Data.List       as List (concat, foldl, foldr,
      #   >                                           init, last, length)
      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
      #   >                                           init, last, length)
      #
      # - false: diff-safe
      #
      #   > import qualified Data.List as List (concat, foldl, foldr, init,
      #   >                                     last, length)
      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
      #   >                                           init, last, length)
      #
      # Default: true
      pad_module_names: true
      # Long list align style takes effect when import is too long. This is
      # determined by 'columns' setting.
      #
      # - inline: This option will put as much specs on same line as possible.
      #
      # - new_line: Import list will start on new line.
      #
      # - new_line_multiline: Import list will start on new line when it's
      #   short enough to fit to single line. Otherwise it'll be multiline.
      #
      # - multiline: One line per import list entry.
      #   Type with constructor list acts like single import.
      #
      #   > import qualified Data.Map as M
      #   >     ( empty
      #   >     , singleton
      #   >     , ...
      #   >     , delete
      #   >     )
      #
      # Default: inline
      long_list_align: multiline
      # Align empty list (importing instances)
      #
      # Empty list align has following options
      #
      # - inherit: inherit list_align setting
      #
      # - right_after: () is right after the module name:
      #
      #   > import Vector.Instances ()
      #
      # Default: inherit
      empty_list_align: inherit
      # List padding determines indentation of import list on lines after import.
      # This option affects 'long_list_align'.
      #
      # - <integer>: constant value
      #
      # - module_name: align under start of module name.
      #   Useful for 'file' and 'group' align settings.
      #
      # Default: 4
      list_padding: 4
      # Separate lists option affects formatting of import list for type
      # or class. The only difference is single space between type and list
      # of constructors, selectors and class functions.
      #
      # - true: There is single space between Foldable type and list of it's
      #   functions.
      #
      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
      #
      # - false: There is no space between Foldable type and list of it's
      #   functions.
      #
      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
      #
      # Default: true
      separate_lists: true
      # Space surround option affects formatting of import lists on a single
      # line. The only difference is single space after the initial
      # parenthesis and a single space before the terminal parenthesis.
      #
      # - true: There is single space associated with the enclosing
      #   parenthesis.
      #
      #   > import Data.Foo ( foo )
      #
      # - false: There is no space associated with the enclosing parenthesis
      #
      #   > import Data.Foo (foo)
      #
      # Default: false
      space_surround: false
      # Enabling this argument will use the new GHC lib parse to format imports.
      #
      # This currently assumes a few things, it will assume that you want post
      # qualified imports. It is also not as feature complete as the old
      # imports formatting.
      #
      # It does not remove redundant lines or merge lines. As such, the full
      # feature scope is still pending.
      #
      # It _is_ however, a fine alternative if you are using features that are
      # not parseable by haskell src extensions and you're comfortable with the
      # presets.
      #
      # Default: false
      ghc_lib_parser: false
  # Language pragmas
  - language_pragmas:
      # We can generate different styles of language pragma lists.
      #
      # - vertical: Vertical-spaced language pragmas, one per line.
      #
      # - compact: A more compact style.
      #
      # - compact_line: Similar to compact, but wrap each line with
      #   `{-#LANGUAGE #-}'.
      #
      # Default: vertical.
      style: vertical
      # Align affects alignment of closing pragma brackets.
      #
      # - true: Brackets are aligned in same column.
      #
      # - false: Brackets are not aligned together. There is only one space
      #   between actual import and closing bracket.
      #
      # Default: true
      align: true
      # stylish-haskell can detect redundancy of some language pragmas. If this
      # is set to true, it will remove those redundant pragmas. Default: true.
      remove_redundant: true
      # Language prefix to be used for pragma declaration, this allows you to
      # use other options non case-sensitive like "language" or "Language".
      # If a non correct String is provided, it will default to: LANGUAGE.
      language_prefix: LANGUAGE
  # Replace tabs by spaces. This is disabled by default.
  # - tabs:
  #     # Number of spaces to use for each tab. Default: 8, as specified by the
  #     # Haskell report.
  #     spaces: 8
  # Remove trailing whitespace
  - trailing_whitespace: {}
  # Squash multiple spaces between the left and right hand sides of some
  # elements into single spaces. Basically, this undoes the effect of
  # simple_align but is a bit less conservative.
  # - squash: {}
 # A common setting is the number of columns (parts of) code will be wrapped
 # to. Different steps take this into account.
 #
 # Set this to null to disable all line wrapping.
 #
 # Default: 80.
 columns: 80
 # By default, line endings are converted according to the OS. You can override
 # preferred format here.
 #
 # - native: Native newline format. CRLF on Windows, LF on other OSes.
 #
 # - lf: Convert to LF ("\n").
 #
 # - crlf: Convert to CRLF ("\r\n").
 #
 # Default: native.
 newline: native
 # Sometimes, language extensions are specified in a cabal file or from the
 # command line instead of using language pragmas in the file. stylish-haskell
 # needs to be aware of these, so it can parse the file correctly.
 #
 # No language extensions are enabled by default.
 # language_extensions:
  # - TemplateHaskell
  # - QuasiQuotes
 # Attempt to find the cabal file in ancestors of the current directory, and
 # parse options (currently only language extensions) from that.
 #
 # Default: true
 cabal: true
--- a/README.md
+++ b/README.md
@ -3,7 +3,42 @@
 These are some personal programs that use the
 [rofi](https://github.com/davatorium/rofi) interface.
-## Rofi-Bitwarden
+## Installation
 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
@ -37,10 +72,9 @@ Any options after `-c` will be passed to rofi.
 ### Dependencies
 - [bitwarden-cli](https://github.com/bitwarden/cli)
 - dbus
 - libnotify: desktop notifications
-## Rofi-Devices
+## Device Mounting (rofi-dev)
 This is a manual mounting helper for removable drives, MTP devices, and fstab
 entries. It will transparently handle mountpoint creation/destruction.
@ -75,6 +109,19 @@ 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'
 ```
@ -89,6 +136,58 @@ 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
--- a/app/pinentry-rofi.hs
+++ b/app/pinentry-rofi.hs
@ -1,7 +1,5 @@
 {-# 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
@ -9,98 +7,99 @@
 module Main where
 import Bitwarden.Internal
-
+import qualified Data.Text.IO as TI
 import           Data.List
 import Data.Yaml
-
+import RIO
-import           System.Directory
+import RIO.Directory
-import           System.Environment
+import qualified RIO.List as L
-import           System.Exit
+import qualified RIO.Text as T
 import System.FilePath.Posix
 import           System.IO
 import System.Posix.Process
 import UnliftIO.Environment
 main :: IO ()
-main = do
+main = runSimpleApp $ do
  hSetBuffering stdout LineBuffering
-  putStrLn "OK Pleased to meet you"
+  -- NOTE: can't use RIO logging here since that will do to stderr and not
  -- stdout
  putStrLnT "OK Pleased to meet you"
  pinentryLoop =<< readPinConf
-newtype PinConf = PinConf { pcBwName :: String } deriving (Eq, Show)
+newtype PinConf = PinConf {pcBwName :: T.Text} deriving (Eq, Show)
 instance FromJSON PinConf where
  parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg"
  parseJSON _ = fail "pinentry yaml parse error"
-readPinConf :: IO PinConf
+readPinConf :: RIO SimpleApp PinConf
 readPinConf = do
-  c <- decodeFileEither =<< pinConfDir
+  c <- liftIO . decodeFileEither =<< pinConfDir
  case c of
-    Left e  -> print e >> exitWith (ExitFailure 1)
+    Left e -> do
      logError $ displayShow e
      exitWith (ExitFailure 1)
    Right r -> return r
-pinConfDir :: IO FilePath
+pinConfDir :: RIO SimpleApp FilePath
 pinConfDir = maybe defHome (return . (</> confname)) =<< lookupEnv "GNUPGHOME"
  where
    defHome = (</> ".gnupg" </> confname) <$> getHomeDirectory
    confname = "pinentry-rofi.yml"
-pinentryLoop :: PinConf -> IO ()
+pinentryLoop :: PinConf -> RIO SimpleApp ()
 pinentryLoop p = do
-  processLine p . words =<< getLine
+  processLine p . T.words =<< liftIO TI.getLine
  pinentryLoop p
-processLine :: PinConf -> [String] -> IO ()
+processLine :: PinConf -> [T.Text] -> RIO SimpleApp ()
 processLine _ [] = noop
 processLine _ ["BYE"] = exitSuccess
 processLine p ["GETPIN"] = getPin p
 processLine _ ["GETINFO", o] = processGetInfo o
 -- TODO this might be important
 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", "--one-button", _] = noop
 processLine _ ss = unknownCommand $ T.unwords ss
-processLine _ ss                             = unknownCommand $ unwords ss
+unknownCommand :: T.Text -> RIO SimpleApp ()
 unknownCommand c = putStrLnT $ T.append "ERR 275 Unknown command " c
-unknownCommand :: String -> IO ()
+getPin :: PinConf -> RIO SimpleApp ()
 unknownCommand c = putStrLn $ "ERR 275 Unknown command " ++ c
 getPin :: PinConf -> IO ()
 getPin p = do
  its <- getItems
-  let w = (password . login) =<< find (\i -> pcBwName p == name i) its
+  let w = (password . login) =<< L.find (\i -> pcBwName p == name i) its
  maybe err send w
  where
-    err = putStrLn "ERR 83886179 Operation canceled <rofi>"
+    err = putStrLnT "ERR 83886179 Operation canceled <rofi>"
 -- these are the only supported options for GETINFO; anything else is an error
-processGetInfo :: String -> IO ()
+processGetInfo :: T.Text -> RIO SimpleApp ()
-processGetInfo "pid"     = send . show =<< getProcessID
+processGetInfo "pid" = send . T.pack . show =<< liftIO getProcessID
 processGetInfo "version" = noop
 processGetInfo "flavor" = noop
 processGetInfo "ttyinfo" = noop
-processGetInfo _         = putStrLn "ERR 83886360 IPC parameter error <rofi>"
+processGetInfo _ = putStrLnT "ERR 83886360 IPC parameter error <rofi>"
-processOption :: String -> IO ()
+processOption :: T.Text -> RIO SimpleApp ()
 processOption _ = noop
-send :: String -> IO ()
+send :: T.Text -> RIO SimpleApp ()
-send s = putStrLn ("D " ++ s) >> ok
+send s = putStrLnT (T.append "D " s) >> ok
-noop :: IO ()
+noop :: RIO SimpleApp ()
 noop = ok
-ok :: IO ()
+ok :: RIO SimpleApp ()
-ok = putStrLn "OK"
+ok = putStrLnT "OK"
 putStrLnT :: MonadIO m => T.Text -> m ()
 putStrLnT = liftIO . TI.putStrLn
--- a/app/rofi-autorandr.hs
+++ b/app/rofi-autorandr.hs
@ -1,65 +1,55 @@
 --------------------------------------------------------------------------------
-- | 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           Control.Monad
+import RIO
-
+import RIO.Directory
-import           Data.Maybe
+import qualified RIO.Text as T
 import Rofi.Command
-
+import Rofi.IO
 import           System.Directory
 import           System.Environment
 import           System.Exit
 import System.FilePath.Posix
 import System.Process
 import UnliftIO.Environment
 main :: IO ()
-main = runChecks >> getArgs >>= runPrompt
+main = runSimpleApp $ do
  checkExe "autorandr"
  getArgs >>= runPrompt
-- TOOD not DRY
+newtype ARClientConf = ARClientConf [T.Text]
 runChecks :: IO ()
 runChecks = checkExe "autorandr" >> checkExe "rofi"
-checkExe :: String -> IO ()
+instance HasRofiConf ARClientConf where
 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 :: [String] -> IO ()
+runPrompt :: MonadIO m => [String] -> m ()
 runPrompt a = do
-  let c = ARClientConf a
+  let c = ARClientConf $ fmap T.pack a
  staticProfs <- getAutoRandrProfiles
-  runRofiIO c $ selectAction $ emptyMenu
+  runRofi c $
    emptyMenu
      { groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
      , prompt = Just "Select Profile"
      }
  where
-    mkGroup header = titledGroup header . toRofiActions
+    mkGroup header =
-      . fmap (\s -> ("  " ++ s, selectProfile s))
+      titledGroup header
        . toRofiActions
        . fmap (\s -> (T.append "  " s, selectProfile s))
-virtProfs :: [String]
+virtProfs :: [T.Text]
 virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"]
 -- TODO filter profiles based on which xrandr outputs are actually connected
-getAutoRandrProfiles :: IO [String]
+getAutoRandrProfiles :: MonadIO m => m [T.Text]
 getAutoRandrProfiles = do
  dir <- getAutoRandrDir
  contents <- listDirectory dir
-  filterM (doesDirectoryExist . (dir </>)) contents
+  (fmap T.pack) <$> filterM (doesDirectoryExist . (dir </>)) contents
-getAutoRandrDir :: IO String
+getAutoRandrDir :: MonadIO m => m FilePath
 getAutoRandrDir = do
  c <- getXdgDirectory XdgConfig "autorandr"
  e <- doesDirectoryExist c
@ -67,7 +57,8 @@ getAutoRandrDir = do
  where
    appendToHome p = (</> p) <$> getHomeDirectory
-selectProfile :: String -> RofiIO ARClientConf ()
+selectProfile :: T.Text -> RIO ARClientConf ()
-selectProfile name = do
+selectProfile name =
-  io $ putStrLn name
+  liftIO $
-  io $ void $ spawnProcess "autorandr" ["--change", name]
+    void $
      spawnProcess "autorandr" ["--change", T.unpack name]
--- a/app/rofi-bt.hs
+++ b/app/rofi-bt.hs
@ -1,62 +1,67 @@
 --------------------------------------------------------------------------------
-- | rofi-bt - a prompt to dicsonnect/connect devices
+-- rofi-bt - a prompt to dicsonnect/connect devices
 --
 module Main (main) where
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.Reader
 import           Data.List
 import           Data.List.Split
 import qualified Data.Map             as M
 import           Data.Maybe
 import DBus
 import DBus.Client
-
+import qualified Data.Map as M
 import Data.Maybe
 import RIO
 import qualified RIO.List as L
 import qualified RIO.Text as T
 import Rofi.Command
-
+import UnliftIO.Environment
 import           System.Environment
 main :: IO ()
-main = getArgs >>= runPrompt
+main = runSimpleApp $ getArgs >>= runPrompt
-data RofiBTConf = RofiBTConf [String] ObjectPath
+data RofiBTConf = RofiBTConf
  { btArgs :: ![T.Text]
  , btAdapter :: !ObjectPath
  , btEnv :: !SimpleApp
  }
-instance RofiConf RofiBTConf where
+instance HasRofiConf RofiBTConf where
-  defArgs (RofiBTConf as _) = as
+  defArgs = btArgs
 instance HasLogFunc RofiBTConf where
  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
 type BTAction = RofiAction RofiBTConf
-runPrompt :: [String] -> IO ()
+runPrompt :: [String] -> RIO SimpleApp ()
 runPrompt args = do
  c <- getClient
-  maybe (putStrLn "could not get DBus client") run c
+  maybe (logError "could not get DBus client") run c
  where
    run client = do
      paths <- M.keys <$> getObjectTree client
-      maybe (putStrLn "could not get DBus adapter") (actions client paths)
+      case getAdapter paths of
-        $ getAdapter paths
+        Nothing -> logError "could not get DBus adapter"
-    actions client paths adapter = do
+        Just adapter -> do
          ras <- getRofiActions client paths
-      runRofiIO (RofiBTConf args adapter) $ selectAction $ emptyMenu
+          mapRIO (RofiBTConf (fmap T.pack args) adapter) $
            selectAction $
              emptyMenu
                { groups = [untitledGroup $ toRofiActions ras]
                , prompt = Just "Select Device"
                }
-getRofiActions :: Client -> [ObjectPath] -> IO [BTAction]
+getRofiActions :: MonadIO m => Client -> [ObjectPath] -> m [BTAction]
 getRofiActions client os = do
  devs <- getDevices client os
  catMaybes <$> mapM (deviceToRofiAction client) devs
-deviceToRofiAction :: Client -> ObjectPath -> IO (Maybe BTAction)
+deviceToRofiAction :: MonadIO m => Client -> ObjectPath -> m (Maybe BTAction)
 deviceToRofiAction client dev = do
  c <- getDeviceConnected client dev
  n <- getDeviceName client dev
  return $ case (c, n) of
-    (Just c', Just n') -> Just ( formatDeviceEntry c' n'
+    (Just c', Just n') ->
      Just
        ( formatDeviceEntry c' n'
        , powerAdapterMaybe client >> io (mkAction c')
        )
    _ -> Nothing
@ -64,13 +69,13 @@ deviceToRofiAction client dev = do
    mkAction True = callDeviceDisconnect client dev
    mkAction False = callDeviceConnect client dev
-powerAdapterMaybe :: Client -> RofiIO RofiBTConf ()
+powerAdapterMaybe :: Client -> RIO RofiBTConf ()
 powerAdapterMaybe client = do
-  (RofiBTConf _ adapter) <- ask
+  adapter <- asks btAdapter
  let mc = btMethodCall adapter i m
-  let powerOnMaybe = flip unless $ void $ setProperty client mc value
+  let powerOnMaybe = flip unless $ void $ liftIO $ setProperty client mc value
-  powered <- io $ getBTProperty client adapter i m
+  powered <- getBTProperty client adapter i m
-  io $ maybe (putStrLn "could not get adapter powered status") powerOnMaybe powered
+  maybe (logError "could not get adapter powered status") powerOnMaybe powered
  where
    i = interfaceName_ "org.bluez.Adapter1"
    m = memberName_ "Powered"
@ -78,21 +83,21 @@ powerAdapterMaybe client = do
    -- the 'Set' method
    value = toVariant $ toVariant True
-formatDeviceEntry :: Bool -> String -> String
+formatDeviceEntry :: Bool -> T.Text -> T.Text
-formatDeviceEntry connected name = unwords [prefix connected, name]
+formatDeviceEntry connected name = T.unwords [prefix connected, name]
  where
    prefix True = "#"
    prefix False = " "
 getAdapter :: [ObjectPath] -> Maybe ObjectPath
-getAdapter = find pathIsAdaptor
+getAdapter = L.find pathIsAdaptor
-getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
+getDevices :: MonadIO m => Client -> [ObjectPath] -> m [ObjectPath]
 getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
-type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
+type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
-getObjectTree :: Client -> IO ObjectTree
+getObjectTree :: MonadIO m => Client -> m ObjectTree
 getObjectTree client =
  fromMaybe M.empty . eitherMaybe from <$> callBTMethod client o i m
  where
@ -101,19 +106,19 @@ getObjectTree client =
    m = memberName_ "GetManagedObjects"
    from = fromVariant <=< listToMaybe . methodReturnBody
-getDeviceConnected :: Client -> ObjectPath -> IO (Maybe Bool)
+getDeviceConnected :: MonadIO m => Client -> ObjectPath -> m (Maybe Bool)
 getDeviceConnected = getDevProperty "Connected"
-getDeviceName :: Client -> ObjectPath -> IO (Maybe String)
+getDeviceName :: MonadIO m => Client -> ObjectPath -> m (Maybe T.Text)
 getDeviceName = getDevProperty "Name"
-getDevicePaired :: Client -> ObjectPath -> IO Bool
+getDevicePaired :: MonadIO m => Client -> ObjectPath -> m Bool
 getDevicePaired c = fmap (fromMaybe False) . getDevProperty "Paired" c
-callDeviceConnect :: Client -> ObjectPath -> IO ()
+callDeviceConnect :: MonadIO m => Client -> ObjectPath -> m ()
 callDeviceConnect = callDevMethod "Connect"
-callDeviceDisconnect :: Client -> ObjectPath -> IO ()
+callDeviceDisconnect :: MonadIO m => Client -> ObjectPath -> m ()
 callDeviceDisconnect = callDevMethod "Disconnect"
 pathIsAdaptor :: ObjectPath -> Bool
@ -126,38 +131,51 @@ pathIsDevice o = case splitPath o of
  [a, b, c, _] -> pathIsAdaptorPrefix a b c
  _ -> False
-pathIsAdaptorPrefix :: String -> String -> String -> Bool
+pathIsAdaptorPrefix :: T.Text -> T.Text -> T.Text -> Bool
-pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `isPrefixOf` c
+pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
-splitPath :: ObjectPath -> [String]
+splitPath :: ObjectPath -> [T.Text]
-splitPath =splitOn "/" . dropWhile (=='/') . formatObjectPath
+splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
-getClient :: IO (Maybe Client)
+getClient :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client)
-getClient = either warn (return . Just) =<< try connectSystem
+getClient = either warn (return . Just) =<< try (liftIO connectSystem)
  where
-    warn e = putStrLn (clientErrorMessage e) >> return Nothing
+    warn e = do
      logWarn $ displayBytesUtf8 $ encodeUtf8 $ (T.pack $ clientErrorMessage e)
      return Nothing
-callDevMethod :: String -> Client -> ObjectPath -> IO ()
+callDevMethod :: MonadIO m => T.Text -> Client -> ObjectPath -> m ()
 callDevMethod mem client dev =
-  void $ callBTMethod client dev btDevInterface $ memberName_ mem
+  void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem
-getDevProperty :: IsVariant a => String -> Client -> ObjectPath -> IO (Maybe a)
+getDevProperty :: (MonadIO m, IsVariant a) => T.Text -> Client -> ObjectPath -> m (Maybe a)
 getDevProperty mem client dev =
-  getBTProperty client dev btDevInterface $ memberName_ mem
+  getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem
-callBTMethod :: Client -> ObjectPath -> InterfaceName
+callBTMethod
-  -> MemberName -> IO (Either MethodError MethodReturn)
+  :: MonadIO m
-callBTMethod client o i m = call client (btMethodCall o i m)
+  => Client
-  -- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
+  -> ObjectPath
-  -- <$> call client (btMethodCall o i m)
+  -> InterfaceName
  -> MemberName
  -> m (Either MethodError MethodReturn)
 callBTMethod client o i m = liftIO $ call client (btMethodCall o i m)
-getBTProperty :: IsVariant a => Client -> ObjectPath
+-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-  -> InterfaceName -> MemberName -> IO (Maybe a)
+-- <$> call client (btMethodCall o i m)
 getBTProperty
  :: (MonadIO m, IsVariant a)
  => Client
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m (Maybe a)
 getBTProperty client o i m =
-  eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m)
+  eitherMaybe fromVariant <$> (liftIO $ 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)
--- a/app/rofi-bw.hs
+++ b/app/rofi-bw.hs
@ -1,7 +1,5 @@
 {-# 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
@ -19,40 +17,29 @@
 module Main (main) where
 import Bitwarden.Internal
-
+import RIO
-import           Control.Monad
+import qualified RIO.Text as T
-
+import Rofi.IO
-import           Data.Maybe
+import UnliftIO.Environment
 import           Rofi.Command
 import           Text.Read
 import           System.Directory
 import           System.Environment
 import           System.Exit
 main :: IO ()
-main = runChecks >> getArgs >>= parse
+main = runSimpleApp $ runChecks >> getArgs >>= parse
 -- TODO check if daemon is running when running client
-parse :: [String] -> IO ()
+parse :: HasLogFunc c => [String] -> RIO c ()
-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 args
+parse ("-c" : args) = runClient $ fmap T.pack args
 parse _ = usage
-usage :: IO ()
+usage :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
-usage = putStrLn $ joinNewline
+usage =
  logInfo $
    displayBytesUtf8 $
      encodeUtf8 $
        T.unlines
          [ "daemon mode: rofi-bw -d TIMEOUT"
          , "client mode: rofi-bw -c [ROFI-ARGS]"
          ]
-runChecks :: IO ()
+runChecks :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
-runChecks = checkExe "bw" >> checkExe "rofi"
+runChecks = checkExe "bw"
 checkExe :: String -> IO ()
 checkExe cmd = do
  res <- findExecutable cmd
  unless (isJust res) $ do
    putStrLn $ "Could not find executable: " ++ cmd
    exitWith $ ExitFailure 1
--- a/app/rofi-dev.hs
+++ b/app/rofi-dev.hs
--- a/app/rofi-evpn.hs
+++ b/app/rofi-evpn.hs
@ -1,24 +1,19 @@
 --------------------------------------------------------------------------------
-- | 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           Control.Monad
+import RIO
-
+import qualified RIO.Text as T
 import           Data.List          (isPrefixOf)
 import           Data.List.Split
 import           Data.Maybe
 import Rofi.Command
-
+import Rofi.IO
-import           System.Environment
+import UnliftIO.Environment
 import           System.Process
 main :: IO ()
-main = getArgs >>= runPrompt
+main = runSimpleApp $ getArgs >>= runPrompt
-runPrompt :: [String] -> IO ()
+runPrompt :: [String] -> RIO SimpleApp ()
 runPrompt args = do
  servers <- getServers
  maybe (return ()) run servers
@ -26,7 +21,8 @@ runPrompt args = do
    run (VPNStatus connected servers) = do
      let d = getDisconnectAction <$> connected
      let cs = fmap (getConnectAction connected) servers
-      runRofiIO (RofiVPNConf args) $ selectAction $ emptyMenu
+      runRofi (RofiVPNConf $ fmap T.pack args) $
        emptyMenu
          { groups =
              [ untitledGroup $ toRofiActions $ maybeToList d
              , untitledGroup $ toRofiActions cs
@ -34,54 +30,56 @@ runPrompt args = do
          , prompt = Just "Select Action"
          }
-newtype RofiVPNConf = RofiVPNConf [String]
+newtype RofiVPNConf = RofiVPNConf [T.Text]
-instance RofiConf RofiVPNConf where
+instance HasRofiConf RofiVPNConf where
  defArgs (RofiVPNConf as) = as
 type VPNAction = RofiAction RofiVPNConf
-type VPNServer = (String, String)
+type VPNServer = (T.Text, T.Text)
-data VPNStatus = VPNStatus (Maybe String) [VPNServer] deriving (Show)
+data VPNStatus = VPNStatus (Maybe T.Text) [VPNServer] deriving (Show)
-getServers :: IO (Maybe VPNStatus)
+getServers :: MonadIO m => m (Maybe VPNStatus)
 getServers = do
  running <- daemonIsRunning
  if running
    then Just <$> getStatus
-    else notify IconError "ExpressVPN daemon not running" >> return Nothing
+    else notifyEVPN IconError "ExpressVPN daemon not running" >> return Nothing
-getStatus :: IO VPNStatus
+getStatus :: MonadIO m => m VPNStatus
 getStatus = do
  connected <- getConnectedServer
  VPNStatus connected <$> getAvailableServers
-getConnectedServer :: IO (Maybe String)
+getConnectedServer :: MonadIO m => m (Maybe T.Text)
 getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
  where
-    procStatus = listToMaybe . mapMaybe procLine . lines
+    procStatus = listToMaybe . mapMaybe procLine . T.lines
-    procLine l = case words l of
+    procLine l = case T.words l of
      -- the output is green...
-      ("\ESC[1;32;49mConnected":"to":server) -> Just $ unwords server
+      ("\ESC[1;32;49mConnected" : "to" : server) -> Just $ T.unwords server
      _ -> Nothing
-getAvailableServers :: IO [VPNServer]
+getAvailableServers :: MonadIO m => m [VPNServer]
 getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
  where
    procOut Nothing = do
-      notify IconError "failed to get list of servers"
+      notifyEVPN 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) = return
+    procOut (Just ls) =
-      $ mapMaybe (matchLine . splitOn "\t")
+      return $
-      $ takeWhile (/= "")
+        mapMaybe (matchLine . T.split (== '\t')) $
-      $ drop 1
+          takeWhile (/= "") $
            drop 1
            -- 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
@ -92,14 +90,14 @@ getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
    matchLine [i, _, _, _, l] = Just (i, l)
    matchLine _ = Nothing
-daemonIsRunning :: IO Bool
+daemonIsRunning :: MonadIO m => m Bool
 daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""
-getDisconnectAction :: String -> VPNAction
+getDisconnectAction :: T.Text -> VPNAction
 getDisconnectAction server =
-  ("Disconnect from " ++ server, io $ void $ disconnect server)
+  (T.append "Disconnect from " server, io $ void $ disconnect server)
-getConnectAction :: Maybe String -> VPNServer -> VPNAction
+getConnectAction :: Maybe T.Text -> VPNServer -> VPNAction
 getConnectAction connected server =
  (formatServerLine server, io $ go connected)
  where
@ -109,46 +107,40 @@ getConnectAction connected server =
    go _ = con
    con = connect server
-formatServerLine :: VPNServer -> String
+formatServerLine :: VPNServer -> T.Text
-formatServerLine (sid, sname) = pad sid ++ " | " ++ sname
+formatServerLine (sid, sname) = T.concat [pad sid, " | ", sname]
  where
-    pad s = s ++ replicate (10 - length s) ' '
+    pad s = T.append s $ T.replicate (10 - T.length s) " "
-eVPN :: String
+eVPN :: T.Text
 eVPN = "expressvpn"
-eVPND :: String
+eVPND :: T.Text
 eVPND = "expressvpnd"
-connect :: VPNServer -> IO ()
+connect :: MonadIO m => VPNServer -> m ()
 connect (sid, sname) = do
  res <- readCmdSuccess' eVPN ["connect", sid]
-  notifyIf res ("connected to " ++ sname)
+  notifyIf
-    ("failed to connect to " ++ sname)
+    res
    (T.append "connected to " sname)
    (T.append "failed to connect to " sname)
-disconnect :: String -> IO Bool
+disconnect :: MonadIO m => T.Text -> m Bool
 disconnect server = do
  res <- readCmdSuccess' eVPN ["disconnect"]
-  notifyIf res ("disconnected from " ++ server)
+  notifyIf
-    ("failed to disconnect from " ++ server)
+    res
    (T.append "disconnected from " server)
    (T.append "failed to disconnect from " server)
  return res
-readCmdSuccess' :: String -> [String] -> IO Bool
+readCmdSuccess' :: MonadIO m => T.Text -> [T.Text] -> m Bool
 readCmdSuccess' cmd args = isJust <$> readCmdSuccess cmd args ""
-- TODO not DRY
+notifyIf :: MonadIO m => Bool -> T.Text -> T.Text -> m ()
-data NotifyIcon = IconError | IconInfo
+notifyIf True s _ = notifyEVPN IconInfo s
 notifyIf False _ s = notifyEVPN IconError s
-instance Show NotifyIcon where
+notifyEVPN :: MonadIO m => NotifyIcon -> T.Text -> m ()
-  show IconError = "dialog-error-symbolic"
+notifyEVPN icon = notify icon "ExpressVPN" . Just
  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"
--- a/app/current-output.hs
+++ b/app/current-output.hs
@ -1,14 +1,12 @@
 module Main (main) where
 --------------------------------------------------------------------------------
-- | Return current xrandr output name
+-- Run rofi (and display on the correct screen)
 --
 -- 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
-- script provides a way to determine which xmonad workspace is in focus and
+-- binary determines which xmonad workspace is in focus and calls rofi with the
-- provide the name of the output displaying said workspace.
+-- name of that 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
@ -21,24 +19,32 @@ module Main (main) where
 -- 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
-import           Data.Maybe               (catMaybes, maybe)
+module Main (main) where
 import Graphics.X11.Types
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras
 import Graphics.X11.Xrandr
-
+import RIO hiding (Display)
-import           System.Exit
+import RIO.Process
 import qualified RIO.Text as T
 import UnliftIO.Environment
 main :: IO ()
-main = getMonitorName >>= maybe exitFailure (\n -> putStrLn n >> exitSuccess)
+main = runSimpleApp $ do
  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
+data Coord = Coord Int Int deriving (Eq, Show)
    deriving (Eq, Show)
-getMonitorName :: IO (Maybe String)
+-- TODO bracket this
-getMonitorName = do
+getMonitorName :: MonadIO m => m (Maybe T.Text)
 getMonitorName = liftIO $ do
  dpy <- openDisplay ""
  root <- rootWindow dpy $ defaultScreen dpy
  index <- getCurrentDesktopIndex dpy root
@ -55,39 +61,39 @@ getDesktopViewports dpy root =
  pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT"
  where
    pairs = reverse . pairs' []
-    pairs' acc []         = acc
+    pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs
-    pairs' acc [_]        = acc
+    pairs' acc _ = acc
    pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs
-getOutputs :: Display -> Window -> IO [(Coord, String)]
+getOutputs :: Display -> Window -> IO [(Coord, T.Text)]
-getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>=
+getOutputs dpy root =
-  maybe (return []) resourcesToCells
+  xrrGetScreenResourcesCurrent dpy root
    >>= 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 r (Just XRROutputInfo { xrr_oi_connection = 0
+    infoToCell
      r
      ( Just
          XRROutputInfo
            { xrr_oi_connection = 0
            , xrr_oi_name = n
            , xrr_oi_crtc = c
-                                     }) = do
+            }
-      cinfo <- xrrGetCrtcInfo dpy r c
+        ) = do
-      return $ fmap (\i -> (toCoord i, n)) cinfo
+        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
-    | otherwise = go i xs
+  | otherwise = listToMaybe $ drop 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 -> String -> IO [Int]
+getAtom32 :: Display -> Window -> T.Text -> IO [Int]
 getAtom32 dpy root str = do
-  a <- internAtom dpy str False
+  a <- internAtom dpy (T.unpack str) False
  p <- getWindowProperty32 dpy a root
  return $ maybe [] (fmap fromIntegral) p
--- a/dhall/rofi-dev.dhall
+++ b/dhall/rofi-dev.dhall
@ -0,0 +1,66 @@
 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
    }
--- a/etc/systemd/user/mount-sshfs@.service
+++ b/etc/systemd/user/mount-sshfs@.service
--- a/etc/systemd/user/mount-veracrypt@.service
+++ b/etc/systemd/user/mount-veracrypt@.service
@ -1,6 +1,7 @@
 [Unit]
 Description=Mount veracrypt volume for %i
 # TODO these scripts moved
 [Service]
 Type=forking
 ExecStart=%h/.bin/mount.veracrypt ${BW_NAME} ${VOLUME} ${MOUNTPOINT}
--- a/fourmolu.yaml
+++ b/fourmolu.yaml
@ -0,0 +1,14 @@
 indentation: 2
 function-arrows: leading
 comma-style: leading
 import-export-style: leading
 indent-wheres: true
 record-brace-space: true
 newlines-between-decls: 1
 haddock-style: single-line
 haddock-style-module:
 let-style: inline
 in-style: right-align
 respectful: false
 fixities: []
 unicode: never
--- a/8
+++ b/8
@ -1,8 +0,0 @@
 #!/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[@]}"
--- a/lib/Bitwarden/Internal.hs
+++ b/lib/Bitwarden/Internal.hs
@ -1,36 +1,27 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections     #-}
 module Bitwarden.Internal
-  ( Item(..)
+  ( Item (..)
-  , Login(..)
+  , Login (..)
  , Session
  , runDaemon
  , runClient
  , getItems
  , callGetSession
-  ) where
+  )
-
+where
 import           Control.Concurrent
 import           Control.Monad
 import           Data.Aeson
 import           Data.Maybe
 import           Data.String
 import           Data.UnixTime
 import DBus
 import DBus.Client
-
+import Data.Aeson
 import Data.UnixTime
 import GHC.Generics
-
+import RIO hiding (timeout)
 import qualified RIO.Text as T
 import Rofi.Command
 import System.Clipboard
 import System.Process
 --------------------------------------------------------------------------------
 -- | Daemon
 --
 -- Daemon will export an interface on DBus with two methods:
@ -39,67 +30,69 @@ 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
  }
 -- TODO add a cache so the browse list will load faster
 data CurrentSession = CurrentSession
-    { timestamp :: UnixTime
+  { timestamp :: !UnixTime
-    , hash      :: String
+  , hash :: !T.Text
  }
 type Session = MVar (Maybe CurrentSession)
-runDaemon :: Int -> IO ()
+runDaemon :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => Int -> m ()
 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 :: Session -> IO ()
+lockSession :: MonadIO m => Session -> m ()
 lockSession ses = void $ swapMVar ses Nothing
-syncSession :: BWServerConf -> Session -> IO ()
+syncSession :: MonadUnliftIO m => BWServerConf -> Session -> m ()
 syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
  where
    cmd h = readCmdSuccess "bw" ["sync", "--session", h] ""
-    notify res = let j = isJust res
+    notify res =
      let j = isJust res
       in notifyStatus j $ if j then "sync succeeded" else "sync failed"
-getSession' :: BWServerConf -> Session -> IO (Maybe String)
+getSession' :: MonadUnliftIO m => BWServerConf -> Session -> m (Maybe T.Text)
-getSession' BWServerConf { timeout = t } ses = do
+getSession' BWServerConf {timeout = t} ses = do
-  ut <- getUnixTime
+  ut <- liftIO $ 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 <- getUnixTime
+      ut <- liftIO $ getUnixTime
-      return CurrentSession { timestamp = ut, hash = h }
+      return CurrentSession {timestamp = ut, hash = h}
-getSession :: BWServerConf -> Session -> IO String
+getSession :: MonadUnliftIO m => BWServerConf -> Session -> m T.Text
 getSession conf ses = fromMaybe "" <$> getSession' conf ses
-readSession :: String -> IO (Maybe String)
+readSession :: MonadIO m => T.Text -> m (Maybe T.Text)
 readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
-notifyStatus :: Bool -> String -> IO ()
+notifyStatus :: MonadIO m => Bool -> T.Text -> m ()
 notifyStatus succeeded msg =
-  void $ spawnProcess "notify-send" ["-i", i, msg]
+  void $ liftIO $ spawnProcess "notify-send" ["-i", i, T.unpack msg]
  where
-    i = if succeeded
+    i =
      if succeeded
        then "dialog-information-symbolic"
        else "dialog-error-symbolic"
 --------------------------------------------------------------------------------
 -- | Client
 --
 -- The client will get the current session from the daemon (if it can) and then
@ -114,55 +107,63 @@ 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
  }
-newtype BWClientConf = BWClientConf [String]
+instance HasRofiConf (BWClientConf c) where
  defArgs = bwArgs
-instance RofiConf BWClientConf where
+instance HasLogFunc c => HasLogFunc (BWClientConf c) where
-  defArgs (BWClientConf a) = a
+  logFuncL = lens bwEnv (\x y -> x {bwEnv = y}) . logFuncL
-runClient :: [String] -> IO ()
+runClient :: HasLogFunc c => [T.Text] -> RIO c ()
-runClient a = do
+runClient a =
-  let c = BWClientConf a
+  mapRIO (BWClientConf a) $
-  runRofiIO c $ selectAction $ emptyMenu
+    selectAction $
      emptyMenu
        { groups = [untitledGroup $ toRofiActions ras]
        , prompt = Just "Action"
        }
  where
-    ras = [ ("Browse Logins", browseLogins)
+    ras =
-          , ("Sync Session", io callSyncSession)
+      [ ("Browse Logins", browseLogins)
-          , ("Lock Session", io callLockSession)
+      , ("Sync Session", callSyncSession)
      , ("Lock Session", callLockSession)
      ]
-browseLogins :: RofiConf c => RofiIO c ()
+browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c ()
-browseLogins = io getItems >>= selectItem
+browseLogins = getItems >>= selectItem
-getItems :: IO [Item]
+getItems :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m [Item]
 getItems = maybe (return []) getItems' =<< callGetSession
-getItems' :: String -> IO [Item]
+getItems' :: MonadIO m => T.Text -> m [Item]
 getItems' session = do
-  items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
+  items <- liftIO $ readProcess "bw" ["list", "items", "--session", T.unpack 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  :: String
+  { name :: T.Text
  , login :: Login
  }
  deriving (Show)
 instance FromJSON Item where
-  parseJSON (Object o) = Item
+  parseJSON (Object o) =
    Item
      <$> o .: "name"
-    <*> o .:? "login" .!= Login { username = Nothing, password = Nothing }
+      <*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
  parseJSON _ = mzero
 data Login = Login
-    { username :: Maybe String
+  { username :: Maybe T.Text
-    , password :: Maybe String
+  , password :: Maybe T.Text
  }
  deriving (Show, Generic)
@ -170,74 +171,89 @@ instance FromJSON Login
 -- TODO make menu buttons here to go back and to copy without leaving
 -- the current menu
-selectItem :: RofiConf c => [Item] -> RofiIO c ()
+selectItem :: (HasLogFunc c, HasRofiConf c) => [Item] -> RIO c ()
-selectItem items = selectAction $ emptyMenu
+selectItem items =
  selectAction $
    emptyMenu
      { groups = [untitledGroup $ itemsToRofiActions items]
      , prompt = Just "Login"
      }
-itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
+itemsToRofiActions :: (HasLogFunc c, HasRofiConf c) => [Item] -> RofiActions c
 itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
-selectCopy :: RofiConf c => Login -> RofiIO c ()
+selectCopy :: (HasLogFunc c, HasRofiConf c) => Login -> RIO c ()
-selectCopy l = selectAction $ emptyMenu
+selectCopy l =
  selectAction $
    emptyMenu
      { groups = [untitledGroup $ loginToRofiActions l copy]
      , prompt = Just "Copy"
      , hotkeys = [copyHotkey, backHotkey]
      }
  where
-    copy = io . setClipboardString
+    copy = io . setClipboardString . T.unpack
    copyRepeat s = copy s >> selectCopy l
-    copyHotkey = Hotkey
+    copyHotkey =
      Hotkey
        { keyCombo = "Alt+c"
      , keyIndex = 1
        , keyDescription = "Copy One"
        , keyActions = loginToRofiActions l copyRepeat
        }
-    backHotkey = Hotkey
+    backHotkey =
      Hotkey
        { keyCombo = "Alt+q"
      , keyIndex = 2
        , 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...
-      , keyActions = loginToRofiActions l (const browseLogins)
+          keyActions = loginToRofiActions l (const browseLogins)
        }
-loginToRofiActions :: RofiConf c => Login -> (String -> RofiIO c ()) -> RofiActions c
+loginToRofiActions :: Login -> (T.Text -> RIO 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 = "Username (" ++ s ++ ")"
+    fmtUsername s = T.concat ["Username (", s, ")"]
-    fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")"
+    fmtPassword s = T.concat ["Password (", T.take 32 (T.replicate (T.length s) "*"), ")"]
    user = copyIfJust fmtUsername u
    pwd = copyIfJust fmtPassword p
-getItemPassword' :: BWServerConf -> Session -> String -> IO (Maybe String)
+getItemPassword' :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m (Maybe T.Text)
 getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
  where
-    getPwd s = readProcess "bw" ["get", "password", item, "--session", s] ""
+    getPwd = fmap T.pack . pr
    pr s =
      liftIO $
        readProcess
          "bw"
          ["get", "password", T.unpack item, "--session", T.unpack s]
          ""
-getItemPassword :: BWServerConf -> Session -> String -> IO String
+getItemPassword :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m T.Text
-getItemPassword conf session item = fromMaybe "" <$>
+getItemPassword conf session item =
-  getItemPassword' conf session item
+  fromMaybe ""
    <$> getItemPassword' conf session item
 --------------------------------------------------------------------------------
 -- | DBus
-startService :: BWServerConf -> Session -> IO ()
+-- | DBus
 startService :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => BWServerConf -> Session -> m ()
 startService c ses = do
-  client <- connectSession
+  client <- liftIO $ connectSession
  let flags = [nameAllowReplacement, nameReplaceExisting]
-  _ <- requestName client busname flags
+  _ <- liftIO $ requestName client busname flags
-  putStrLn "Started rofi bitwarden dbus client"
+  logInfo "Started rofi bitwarden dbus client"
-  export client path defaultInterface
+  withRunInIO $ \runIO ->
    export
      client
      path
      defaultInterface
        { interfaceName = interface
        , interfaceMethods =
-      [ autoMethod memGetSession $ getSession c ses
+            [ autoMethod memGetSession $ runIO $ getSession c ses
-      , autoMethod memLockSession $ lockSession ses
+            , autoMethod memLockSession $ runIO $ lockSession ses
-      , autoMethod memSyncSession $ syncSession c ses
+            , autoMethod memSyncSession $ runIO $ syncSession c ses
-      , autoMethod memGetPassword $ getItemPassword c ses
+            , autoMethod memGetPassword $ runIO . getItemPassword c ses
            ]
        }
@ -262,33 +278,38 @@ memSyncSession = "SyncSession"
 memGetPassword :: MemberName
 memGetPassword = "GetPassword"
-callMember :: MemberName -> IO [Variant]
+callMember :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => MemberName -> m [Variant]
 callMember m = do
  reply <- callMethod $ methodCall path interface m
  case reply of
-    Left err   -> putStrLn (methodErrorMessage err) >> return []
+    Left err -> do
      logError $
        displayBytesUtf8 $
          encodeUtf8 $
            (T.pack (methodErrorMessage err))
      return []
    Right body -> return body
-callLockSession :: IO ()
+callLockSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
 callLockSession = void $ callMember memLockSession
-callSyncSession :: IO ()
+callSyncSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
 callSyncSession = void $ callMember memSyncSession
-callGetSession :: IO (Maybe String)
+callGetSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m (Maybe T.Text)
 callGetSession = getBodyString <$> callMember memGetSession
 -- TODO maybe will need to add a caller for getItemPassword
-getBodyString :: [Variant] -> Maybe String
+getBodyString :: [Variant] -> Maybe T.Text
-getBodyString [b] = case fromVariant b :: Maybe String of
+getBodyString [b] = case fromVariant b :: Maybe T.Text of
  Just "" -> Nothing
  s -> s
 getBodyString _ = Nothing
-callMethod :: MethodCall -> IO (Either MethodError [Variant])
+callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant])
-callMethod mc = do
+callMethod mc = liftIO $ do
  client <- connectSession
-  reply <- call client mc { methodCallDestination = Just busname }
+  reply <- call client mc {methodCallDestination = Just busname}
  disconnect client
  return $ methodReturnBody <$> reply
--- a/lib/Rofi/Command.hs
+++ b/lib/Rofi/Command.hs
@ -1,16 +1,12 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Rofi.Command
-  ( RofiConf(..)
+  ( HasRofiConf (..)
-  , RofiMenu(..)
+  , RofiMenu (..)
  , RofiAction
  , RofiActions
  , RofiIO
  , RofiGroup
-  , Hotkey(..)
+  , Hotkey (..)
  , io
  , emptyMenu
  , runRofiIO
  , toRofiActions
  , rofiActionKeys
  , untitledGroup
@ -23,170 +19,180 @@ module Rofi.Command
  , readCmdEither'
  , dmenuArgs
  , joinNewline
-  , stripWS
+  , runRofi
-  ) where
+  )
 where
-import           Control.Monad.IO.Unlift
+import qualified Data.Map.Ordered as OM
-import           Control.Monad.Reader
+import RIO
-
+import qualified RIO.List as L
-import           Data.Char
+import qualified RIO.Text as T
-import           Data.List
+import qualified RIO.Vector.Boxed as V
 import qualified Data.Map.Ordered        as M
 import           Data.Maybe
 import           System.Exit
 import System.Process
-class RofiConf c where
+class HasRofiConf c where
-  defArgs :: c -> [String]
+  defArgs :: c -> [T.Text]
-type RofiAction c = (String, RofiIO c ())
+type RofiAction c = (T.Text, RIO c ())
-type RofiActions c = M.OMap String (RofiIO c ())
+type RofiActions c = OM.OMap T.Text (RIO c ())
 data RofiGroup c = RofiGroup
  { actions :: RofiActions c
-    , title   :: Maybe String
+  , title :: Maybe T.Text
  }
 untitledGroup :: RofiActions c -> RofiGroup c
-untitledGroup a = RofiGroup { actions = a, title = Nothing }
+untitledGroup a = RofiGroup {actions = a, title = Nothing}
-titledGroup :: String -> RofiActions c -> RofiGroup c
+titledGroup :: T.Text -> 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       :: String
+  { keyCombo :: !T.Text
-    -- only 1-10 are valid
+  , keyDescription :: !T.Text
    , keyIndex       :: Int
    , keyDescription :: String
  , keyActions :: RofiActions c
  }
-hotkeyBinding :: Hotkey c -> [String]
+hotkeyBinding :: Int -> Hotkey c -> [T.Text]
-hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
+hotkeyBinding i Hotkey {keyCombo = c} = [k, c]
  where
-    k = "-kb-custom-" ++ show e
+    k = T.append "-kb-custom-" $ T.pack $ show i
-hotkeyMsg1 :: Hotkey c -> String
+hotkeyMsg1 :: Hotkey c -> T.Text
-hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
+hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
-  c ++ ": <i>" ++ d ++ "</i>"
+  T.concat [c, ": <i>", d, "</i>"]
-hotkeyMsg :: [Hotkey c] -> [String]
+hotkeyMsg :: [Hotkey c] -> [T.Text]
 hotkeyMsg [] = []
-hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
+hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
-hotkeyArgs :: [Hotkey c] -> [String]
+hotkeyArgs :: [Hotkey c] -> [T.Text]
-hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
+hotkeyArgs hks =
  (hotkeyMsg hks)
    ++ (concatMap (uncurry hotkeyBinding) $ take 19 $ zip [1 ..] hks)
 data RofiMenu c = RofiMenu
-    { groups  :: [RofiGroup c]
+  { groups :: ![RofiGroup c]
-    , prompt  :: Maybe String
+  , prompt :: !(Maybe T.Text)
-    , hotkeys :: [Hotkey c]
+  , hotkeys :: ![Hotkey c]
  }
 emptyMenu :: RofiMenu c
-emptyMenu = RofiMenu
+emptyMenu =
  RofiMenu
    { groups = []
    , 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
-runRofiIO :: c -> RofiIO c a -> IO a
+toRofiActions :: [(T.Text, RIO c ())] -> RofiActions c
-runRofiIO c (RofiIO r) = runReaderT r c
+toRofiActions = OM.fromList
-toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
+rofiActionKeys :: RofiActions c -> T.Text
-toRofiActions = M.fromList
+rofiActionKeys = joinNewline . map fst . OM.assocs
-rofiActionKeys :: RofiActions c -> String
+lookupRofiAction :: T.Text -> RofiActions c -> RIO c ()
-rofiActionKeys = joinNewline . map fst . M.assocs
+lookupRofiAction key = fromMaybe err . OM.lookup key
 lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
 lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
 groupEntries :: RofiGroup c -> String
 groupEntries RofiGroup { actions = a, title = t }
  | null a = ""
  | otherwise = title' ++ rofiActionKeys a
  where
-    title' = maybe "" (++ "\n") t
+    err = error $ T.unpack $ T.concat ["could not lookup key: '", key, "'"]
 groupEntries :: RofiGroup c -> T.Text
 groupEntries RofiGroup {actions = a, title = t}
  | null a = ""
  | otherwise = T.append title' $ rofiActionKeys a
  where
    title' = maybe "" (`T.append` "\n") t
 menuActions :: RofiMenu c -> RofiActions c
-menuActions = foldr1 (M.<>|) . fmap actions . groups
+menuActions = L.foldr (OM.<>|) OM.empty . fmap actions . groups
-menuEntries :: RofiMenu c -> String
+menuEntries :: RofiMenu c -> T.Text
-menuEntries = intercalate "\n\n" . filter (not . null) . fmap groupEntries . groups
+menuEntries = T.intercalate "\n\n" . filter (not . T.null) . fmap groupEntries . groups
-selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
+selectAction :: HasRofiConf c => RofiMenu c -> RIO 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
-    Left (n, key, _) -> mapM_ (lookupRofiAction key . keyActions)
+    Left (1, _, _) -> exitWith $ ExitFailure 1
-      $ find ((==) n . (+ 9) . keyIndex)
+    Left (n, key, _) -> do
-      $ hotkeys rm
+      maybe
        (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))
-maybeOption :: String -> Maybe String -> [String]
+runRofi :: (MonadIO m, HasRofiConf c) => c -> RofiMenu c -> m ()
 runRofi c = runRIO c . selectAction
 maybeOption :: T.Text -> Maybe T.Text -> [T.Text]
 maybeOption switch = maybe [] (\o -> [switch, o])
-dmenuArgs :: [String]
+dmenuArgs :: [T.Text]
 dmenuArgs = ["-dmenu"]
-readRofi :: RofiConf c => [String]
+readRofi
-  -> String
+  :: HasRofiConf c
-  -> RofiIO c (Either (Int, String, String) String)
+  => [T.Text]
  -> 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 :: String -> [String] -> String -> IO (Maybe String)
+readCmdSuccess :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m (Maybe T.Text)
-readCmdSuccess cmd args input = either (const Nothing) Just
+readCmdSuccess cmd args input =
  either (const Nothing) Just
    <$> readCmdEither cmd args input
-readCmdEither :: String
+readCmdEither
-  -> [String]
+  :: MonadIO m
-  -> String
+  => T.Text
-  -> IO (Either (Int, String, String) String)
+  -> [T.Text]
-readCmdEither cmd args input = resultToEither
+  -> T.Text
-  <$> readProcessWithExitCode cmd args input
+  -> m (Either (Int, T.Text, T.Text) T.Text)
 readCmdEither cmd args input = readCmdEither' cmd args input []
-readCmdEither' :: String
+readCmdEither'
-  -> [String]
+  :: MonadIO m
-  -> String
+  => T.Text
-  -> [(String, String)]
+  -> [T.Text]
-  -> IO (Either (Int, String, String) String)
+  -> T.Text
-readCmdEither' cmd args input environ = resultToEither
+  -> [(T.Text, T.Text)]
-  <$> readCreateProcessWithExitCode p input
+  -> m (Either (Int, T.Text, T.Text) T.Text)
 readCmdEither' cmd args input environ =
  resultToEither
    <$> (liftIO $ readCreateProcessWithExitCode p (T.unpack input))
  where
-    p = (proc cmd args) { env = Just environ }
+    e = case environ of
      [] -> Nothing
      es -> Just $ fmap (bimap T.unpack T.unpack) es
    p = (proc (T.unpack cmd) (fmap T.unpack args)) {env = e}
-resultToEither :: (ExitCode, String, String)
+-- TODO why strip whitespace?
-  -> Either (Int, String, String) String
+resultToEither
-resultToEither (ExitSuccess, out, _)     = Right $ stripWS out
+  :: (ExitCode, String, String)
-resultToEither (ExitFailure n, out, err) = Left (n, stripWS out, stripWS err)
+  -> Either (Int, T.Text, T.Text) T.Text
 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)
-stripWS :: String -> String
+joinNewline :: [T.Text] -> T.Text
-stripWS = reverse . dropWhile isSpace . reverse
+joinNewline = T.intercalate "\n"
-joinNewline :: [String] -> String
+readPassword :: MonadIO m => m (Maybe T.Text)
 joinNewline = intercalate "\n"
 readPassword :: IO (Maybe String)
 readPassword = readPassword' "Password"
-readPassword' :: String -> IO (Maybe String)
+readPassword' :: MonadIO m => T.Text -> m (Maybe T.Text)
 readPassword' p = readCmdSuccess "rofi" args ""
  where
    args = dmenuArgs ++ ["-p", p, "-password"]
--- a/lib/Rofi/IO.hs
+++ b/lib/Rofi/IO.hs
@ -0,0 +1,29 @@
 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
--- a/5
+++ b/5
@ -0,0 +1,5 @@
 libx11
 libxrandr
 libxss
 libxext
 zlib
--- a/package.yaml
+++ b/package.yaml
@ -9,15 +9,56 @@ 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
@ -40,24 +81,18 @@ 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
@ -66,8 +101,6 @@ executables:
    main: rofi-autorandr.hs
    source-dirs: app
    ghc-options:
    - -Wall
    - -Werror
    - -threaded
    dependencies:
    - rofi-extras
@ -76,8 +109,6 @@ executables:
    main: rofi-bw.hs
    source-dirs: app
    ghc-options:
    - -Wall
    - -Werror
    - -threaded
    dependencies:
    - rofi-extras
@ -86,8 +117,6 @@ executables:
    main: rofi-bt.hs
    source-dirs: app
    ghc-options:
    - -Wall
    - -Werror
    - -threaded
    dependencies:
    - rofi-extras
@ -96,8 +125,6 @@ executables:
    main: rofi-dev.hs
    source-dirs: app
    ghc-options:
    - -Wall
    - -Werror
    - -threaded
    dependencies:
    - rofi-extras
@ -106,18 +133,14 @@ executables:
    main: rofi-evpn.hs
    source-dirs: app
    ghc-options:
    - -Wall
    - -Werror
    - -threaded
    dependencies:
    - rofi-extras
-  current-output:
+  rofi:
-    main: current-output.hs
+    main: rofi.hs
    source-dirs: app
    ghc-options:
    - -Wall
    - -Werror
    - -threaded
    dependencies:
    - rofi-extras
--- a/34
+++ b/34
@ -0,0 +1,34 @@
 #!/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
--- a/scripts/gpg
+++ b/scripts/gpg
@ -0,0 +1,5 @@
 #! /bin/bash
 ## gpg (override): mount GNUPGHOME before executing
 with_gpg_mount /usr/bin/gpg "$@"
--- a/scripts/mount.veracrypt
+++ b/scripts/mount.veracrypt
@ -0,0 +1,30 @@
 #! /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
--- a/scripts/pass
+++ b/scripts/pass
@ -0,0 +1,5 @@
 #! /bin/bash
 ## pass (override): mount $GNUPGHOME before executing
 with_gpg_mount /usr/bin/pass "$@"
--- a/scripts/umount.veracrypt
+++ b/scripts/umount.veracrypt
@ -0,0 +1,14 @@
 #! /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
--- a/scripts/with_gpg_mount
+++ b/scripts/with_gpg_mount
@ -0,0 +1,14 @@
 #! /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
--- a/stack.yaml
+++ b/stack.yaml
@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-14.12
+resolver: lts-20.11
 # User packages to be built.
 # Various formats can be used as shown in the example below.
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 545658
+    sha256: adbc602422dde10cc330175da7de8609e70afc41449a7e2d6e8b1827aa0e5008
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml
+    size: 649342
-    sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/11.yaml
-  original: lts-14.12
+  original: lts-20.11
Author	SHA1	Message	Date
Nathan Dwarshuis	5a9f421dcb	FIX pinentry bug	2024-03-13 21:58:28 -04:00
Nathan Dwarshuis	ae5de98e46	ADD lots of little files that were scattered around	2024-01-07 11:50:22 -05:00
Nathan Dwarshuis	a963be1421	ENH revert failed last two commits	2024-01-07 11:49:30 -05:00
Nathan Dwarshuis	04c430efc6	REF clean up nondry code	2023-02-22 23:02:04 -05:00
Nathan Dwarshuis	c3fc38d785	REF wrap everything in simpleapp	2023-02-22 22:44:44 -05:00
Nathan Dwarshuis	05ecda045e	REF bracket display lookup	2023-02-16 22:53:00 -05:00
Nathan Dwarshuis	6acd60187e	FIX return codes from keys	2023-02-16 22:40:24 -05:00
Nathan Dwarshuis	57b4c2d805	REF use text fun	2023-02-15 22:45:23 -05:00
Nathan Dwarshuis	b6f32a1b0f	REF clean up process functions	2023-02-15 22:43:46 -05:00
Nathan Dwarshuis	9086915e52	FIX don't pad all segments	2023-02-15 22:41:17 -05:00
Nathan Dwarshuis	2584df39a5	REF some stuff	2023-02-14 23:32:04 -05:00
Nathan Dwarshuis	1e54682f1c	REF remove partial lists from dev	2023-02-14 23:09:12 -05:00
Nathan Dwarshuis	49c3947b5a	REF use rio monad for rofi	2023-02-14 22:28:26 -05:00
Nathan Dwarshuis	9fcdd1b5f1	ENH import dhall types dynamically	2023-02-14 00:37:50 -05:00
Nathan Dwarshuis	09ce10a942	REF use text everywhere	2023-02-13 23:31:50 -05:00
Nathan Dwarshuis	4265a5947c	REF use rio and better flags	2023-02-13 22:19:49 -05:00
Nathan Dwarshuis	cfe0607e2e	ADD dismount all option	2023-01-24 09:22:19 -05:00
Nathan Dwarshuis	7094dac44e	ENH kill stylish haskell with fury	2023-01-24 09:22:09 -05:00
Nathan Dwarshuis	e13e4150fd	ADD formatting config	2023-01-24 09:21:46 -05:00
Nathan Dwarshuis	3e9b08db08	ENH call rofi directly	2022-08-07 22:18:40 -04:00
Nathan Dwarshuis	d06d5d5a0b	ENH inject config types into dhall code	2022-08-07 13:55:41 -04:00
Nathan Dwarshuis	74070ebb30	ENH use dhall for config	2022-08-07 11:42:06 -04:00
Nathan Dwarshuis	f09f636f56	ENH update resolver	2022-08-06 18:50:45 -04:00
Nathan Dwarshuis	a1b84ab4f2	FIX typo	2022-08-01 00:31:05 -04:00
Nathan Dwarshuis	a1b5c64e62	REF rename runtime package lister	2022-07-31 23:30:56 -04:00
Nathan Dwarshuis	7bf89de504	REF make script easier to read	2022-07-31 23:12:53 -04:00
Nathan Dwarshuis	76d09200a5	ENH move install script to scripts dir and print pkgs	2022-07-31 21:28:45 -04:00
Nathan Dwarshuis	cd53449266	ENH update readme	2022-07-31 21:04:19 -04:00
Nathan Dwarshuis	f84407b793	FIX don't use partial fields	2022-07-31 20:30:27 -04:00
Nathan Dwarshuis	5fb8b404dc	FIX make program not puke if jmtpfs is not found (even when not needed)	2022-07-26 23:17:20 -04:00
Nathan Dwarshuis	2bd8decb52	ADD build deps list	2022-07-26 22:48:57 -04:00