Compare commits

...

31 Commits

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
27 changed files with 1441 additions and 1483 deletions

View File

@ -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

105
README.md
View File

@ -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

View File

@ -1,106 +1,105 @@
{-# 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 Data.List
import Data.Yaml
import System.Directory
import System.Environment
import System.Exit
import System.FilePath.Posix
import System.IO
import System.Posix.Process
import Bitwarden.Internal
import qualified Data.Text.IO as TI
import Data.Yaml
import RIO
import RIO.Directory
import qualified RIO.List as L
import qualified RIO.Text as T
import System.FilePath.Posix
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"
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 _ [] = noop
processLine _ ["BYE"] = exitSuccess
processLine p ["GETPIN"] = getPin p
processLine _ ["GETINFO", o] = processGetInfo o
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
processLine _ ["OPTION", o] = processOption o
-- these should all do nothing
processLine _ ("SETDESC":_) = noop
processLine _ ("SETOK":_) = noop
processLine _ ("SETNOTOK":_) = noop
processLine _ ("SETCANCEL":_) = noop
processLine _ ("SETPROMPT":_) = noop
processLine _ ("SETERROR":_) = noop
processLine _ ("SETDESC" : _) = noop
processLine _ ("SETOK" : _) = noop
processLine _ ("SETNOTOK" : _) = noop
processLine _ ("SETCANCEL" : _) = noop
processLine _ ("SETPROMPT" : _) = 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
processLine _ ss = unknownCommand $ unwords ss
unknownCommand :: T.Text -> RIO SimpleApp ()
unknownCommand c = putStrLnT $ T.append "ERR 275 Unknown command " c
unknownCommand :: String -> IO ()
unknownCommand c = putStrLn $ "ERR 275 Unknown command " ++ c
getPin :: PinConf -> IO ()
getPin :: PinConf -> RIO SimpleApp ()
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 "pid" = send . show =<< getProcessID
processGetInfo :: T.Text -> RIO SimpleApp ()
processGetInfo "pid" = send . T.pack . show =<< liftIO getProcessID
processGetInfo "version" = noop
processGetInfo "flavor" = 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 s = putStrLn ("D " ++ s) >> ok
send :: T.Text -> RIO SimpleApp ()
send s = putStrLnT (T.append "D " s) >> ok
noop :: IO ()
noop :: RIO SimpleApp ()
noop = ok
ok :: IO ()
ok = putStrLn "OK"
ok :: RIO SimpleApp ()
ok = putStrLnT "OK"
putStrLnT :: MonadIO m => T.Text -> m ()
putStrLnT = liftIO . TI.putStrLn

View File

@ -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 Data.Maybe
import Rofi.Command
import System.Directory
import System.Environment
import System.Exit
import System.FilePath.Posix
import System.Process
import RIO
import RIO.Directory
import qualified RIO.Text as T
import Rofi.Command
import Rofi.IO
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
runChecks :: IO ()
runChecks = checkExe "autorandr" >> checkExe "rofi"
newtype ARClientConf = ARClientConf [T.Text]
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
instance HasRofiConf 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
{ groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
, prompt = Just "Select Profile"
}
runRofi c $
emptyMenu
{ groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
, prompt = Just "Select Profile"
}
where
mkGroup header = titledGroup header . toRofiActions
. fmap (\s -> (" " ++ s, selectProfile s))
mkGroup header =
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 name = do
io $ putStrLn name
io $ void $ spawnProcess "autorandr" ["--change", name]
selectProfile :: T.Text -> RIO ARClientConf ()
selectProfile name =
liftIO $
void $
spawnProcess "autorandr" ["--change", T.unpack name]

View File

@ -1,76 +1,81 @@
--------------------------------------------------------------------------------
-- | 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 Rofi.Command
import System.Environment
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
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
defArgs (RofiBTConf as _) = as
instance HasRofiConf RofiBTConf where
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)
$ getAdapter paths
actions client paths adapter = do
ras <- getRofiActions client paths
runRofiIO (RofiBTConf args adapter) $ selectAction $ emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Select Device"
}
case getAdapter paths of
Nothing -> logError "could not get DBus adapter"
Just adapter -> do
ras <- getRofiActions client paths
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'
, powerAdapterMaybe client >> io (mkAction c')
)
_ -> Nothing
(Just c', Just n') ->
Just
( formatDeviceEntry c' n'
, powerAdapterMaybe client >> io (mkAction c')
)
_ -> Nothing
where
mkAction True = callDeviceDisconnect client dev
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
powered <- io $ getBTProperty client adapter i m
io $ maybe (putStrLn "could not get adapter powered status") powerOnMaybe powered
let powerOnMaybe = flip unless $ void $ liftIO $ setProperty client mc value
powered <- getBTProperty client adapter i m
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 connected name = unwords [prefix connected, name]
formatDeviceEntry :: Bool -> T.Text -> T.Text
formatDeviceEntry connected name = T.unwords [prefix connected, name]
where
prefix True = "#"
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,63 +106,76 @@ 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
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 :: String -> String -> String -> Bool
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `isPrefixOf` c
pathIsAdaptorPrefix :: T.Text -> T.Text -> T.Text -> Bool
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
splitPath :: ObjectPath -> [String]
splitPath =splitOn "/" . dropWhile (=='/') . formatObjectPath
splitPath :: ObjectPath -> [T.Text]
splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
getClient :: IO (Maybe Client)
getClient = either warn (return . Just) =<< try connectSystem
getClient :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client)
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
-> MemberName -> IO (Either MethodError MethodReturn)
callBTMethod client o i m = call client (btMethodCall o i m)
-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-- <$> call client (btMethodCall o i m)
callBTMethod
:: MonadIO m
=> Client
-> ObjectPath
-> InterfaceName
-> MemberName
-> m (Either MethodError MethodReturn)
callBTMethod client o i m = liftIO $ call client (btMethodCall o i m)
getBTProperty :: IsVariant a => Client -> ObjectPath
-> InterfaceName -> MemberName -> IO (Maybe a)
-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-- <$> 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)

View File

@ -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
@ -18,41 +16,30 @@
module Main (main) where
import Bitwarden.Internal
import Control.Monad
import Data.Maybe
import Rofi.Command
import Text.Read
import System.Directory
import System.Environment
import System.Exit
import Bitwarden.Internal
import RIO
import qualified RIO.Text as T
import Rofi.IO
import UnliftIO.Environment
main :: IO ()
main = runChecks >> getArgs >>= parse
main = runSimpleApp $ runChecks >> getArgs >>= parse
-- TODO check if daemon is running when running client
parse :: [String] -> IO ()
parse ["-d", t] = case readMaybe t of { Just t' -> runDaemon t'; _ -> usage }
parse ("-c":args) = runClient args
parse _ = usage
parse :: HasLogFunc c => [String] -> RIO c ()
parse ["-d", t] = case readMaybe t of Just t' -> runDaemon t'; _ -> usage
parse ("-c" : args) = runClient $ fmap T.pack args
parse _ = usage
usage :: IO ()
usage = putStrLn $ joinNewline
[ "daemon mode: rofi-bw -d TIMEOUT"
, "client mode: rofi-bw -c [ROFI-ARGS]"
]
usage :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
usage =
logInfo $
displayBytesUtf8 $
encodeUtf8 $
T.unlines
[ "daemon mode: rofi-bw -d TIMEOUT"
, "client mode: rofi-bw -c [ROFI-ARGS]"
]
runChecks :: IO ()
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
runChecks :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
runChecks = checkExe "bw"

File diff suppressed because it is too large Load Diff

View File

@ -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 Data.List (isPrefixOf)
import Data.List.Split
import Data.Maybe
import Rofi.Command
import System.Environment
import System.Process
import RIO
import qualified RIO.Text as T
import Rofi.Command
import Rofi.IO
import UnliftIO.Environment
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,80 +21,83 @@ runPrompt args = do
run (VPNStatus connected servers) = do
let d = getDisconnectAction <$> connected
let cs = fmap (getConnectAction connected) servers
runRofiIO (RofiVPNConf args) $ selectAction $ emptyMenu
{ groups =
[ untitledGroup $ toRofiActions $ maybeToList d
, untitledGroup $ toRofiActions cs
]
, prompt = Just "Select Action"
}
runRofi (RofiVPNConf $ fmap T.pack args) $
emptyMenu
{ groups =
[ untitledGroup $ toRofiActions $ maybeToList d
, untitledGroup $ toRofiActions cs
]
, 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
procLine l = case words l of
procStatus = listToMaybe . mapMaybe procLine . T.lines
procLine l = case T.words l of
-- the output is green...
("\ESC[1;32;49mConnected":"to":server) -> Just $ unwords server
_ -> Nothing
("\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"
procOut Nothing = do
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
$ mapMaybe (matchLine . splitOn "\t")
$ takeWhile (/= "")
$ drop 1
-- super lame way of matching lines that start with "-----"
$ dropWhile (not . isPrefixOf "-----")
$ lines ls
procOut (Just ls) =
return $
mapMaybe (matchLine . T.split (== '\t')) $
takeWhile (/= "") $
drop 1
-- super lame way of matching lines that start with "-----"
$
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 :: 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 (sid, sname) = pad sid ++ " | " ++ sname
formatServerLine :: VPNServer -> T.Text
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)
("failed to connect to " ++ sname)
notifyIf
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)
("failed to disconnect from " ++ server)
notifyIf
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
data NotifyIcon = IconError | IconInfo
notifyIf :: MonadIO m => Bool -> T.Text -> T.Text -> m ()
notifyIf True s _ = notifyEVPN IconInfo s
notifyIf False _ s = notifyEVPN IconError s
instance Show NotifyIcon where
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"
notifyEVPN :: MonadIO m => NotifyIcon -> T.Text -> m ()
notifyEVPN icon = notify icon "ExpressVPN" . Just

View File

@ -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
-- provide the name of the output displaying said workspace.
-- binary determines which xmonad workspace is in focus and calls rofi with the
-- 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 System.Exit
import Graphics.X11.Types
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrandr
import RIO hiding (Display)
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
deriving (Eq, Show)
data Coord = Coord Int Int deriving (Eq, Show)
getMonitorName :: IO (Maybe String)
getMonitorName = do
-- TODO bracket this
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 [_] = acc
pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs
pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs
pairs' acc _ = acc
getOutputs :: Display -> Window -> IO [(Coord, String)]
getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>=
maybe (return []) resourcesToCells
getOutputs :: Display -> Window -> IO [(Coord, T.Text)]
getOutputs dpy root =
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
, xrr_oi_name = n
, xrr_oi_crtc = c
}) = do
cinfo <- xrrGetCrtcInfo dpy r c
return $ fmap (\i -> (toCoord i, n)) cinfo
infoToCell
r
( Just
XRROutputInfo
{ xrr_oi_connection = 0
, xrr_oi_name = n
, 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
| otherwise = go i xs
where
go :: Int -> [a] -> Maybe a
go 0 (x:_) = Just x
go j (_:ys) = go (j - 1) ys
go _ [] = Nothing
| i < 0 = Nothing
| otherwise = listToMaybe $ drop i xs
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

66
dhall/rofi-dev.dhall Normal file
View File

@ -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
}

View File

@ -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}

14
fourmolu.yaml Normal file
View File

@ -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

View File

@ -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[@]}"

View File

@ -1,36 +1,27 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Bitwarden.Internal
( Item(..)
, Login(..)
( Item (..)
, 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 GHC.Generics
import Rofi.Command
import System.Clipboard
import System.Process
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
}
{ timeout :: UnixDiffTime
}
-- TODO add a cache so the browse list will load faster
data CurrentSession = CurrentSession
{ timestamp :: UnixTime
, hash :: String
}
{ timestamp :: !UnixTime
, 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
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
notify res =
let j = isJust res
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
getSession' :: BWServerConf -> Session -> IO (Maybe String)
getSession' BWServerConf { timeout = t } ses = do
ut <- getUnixTime
getSession' :: MonadUnliftIO m => BWServerConf -> Session -> m (Maybe T.Text)
getSession' BWServerConf {timeout = t} ses = do
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
return CurrentSession { timestamp = ut, hash = h }
ut <- liftIO $ getUnixTime
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
then "dialog-information-symbolic"
else "dialog-error-symbolic"
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,132 +107,155 @@ 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
defArgs (BWClientConf a) = a
instance HasLogFunc c => HasLogFunc (BWClientConf c) where
logFuncL = lens bwEnv (\x y -> x {bwEnv = y}) . logFuncL
runClient :: [String] -> IO ()
runClient a = do
let c = BWClientConf a
runRofiIO c $ selectAction $ emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action"
}
runClient :: HasLogFunc c => [T.Text] -> RIO c ()
runClient a =
mapRIO (BWClientConf a) $
selectAction $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action"
}
where
ras = [ ("Browse Logins", browseLogins)
, ("Sync Session", io callSyncSession)
, ("Lock Session", io callLockSession)
]
ras =
[ ("Browse Logins", browseLogins)
, ("Sync Session", callSyncSession)
, ("Lock Session", callLockSession)
]
browseLogins :: RofiConf c => RofiIO c ()
browseLogins = io getItems >>= selectItem
browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c ()
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 } }
= False
notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
False
notEmpty _ = True
data Item = Item
{ name :: String
, login :: Login
}
deriving (Show)
{ name :: T.Text
, login :: Login
}
deriving (Show)
instance FromJSON Item where
parseJSON (Object o) = Item
<$> o .: "name"
<*> o .:? "login" .!= Login { username = Nothing, password = Nothing }
parseJSON (Object o) =
Item
<$> o .: "name"
<*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
parseJSON _ = mzero
data Login = Login
{ username :: Maybe String
, password :: Maybe String
}
deriving (Show, Generic)
{ username :: Maybe T.Text
, password :: Maybe T.Text
}
deriving (Show, Generic)
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 items = selectAction $ emptyMenu
{ groups = [untitledGroup $ itemsToRofiActions items]
, prompt = Just "Login"
}
selectItem :: (HasLogFunc c, HasRofiConf c) => [Item] -> RIO c ()
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 l = selectAction $ emptyMenu
{ groups = [untitledGroup $ loginToRofiActions l copy]
, prompt = Just "Copy"
, hotkeys = [copyHotkey, backHotkey]
}
selectCopy :: (HasLogFunc c, HasRofiConf c) => Login -> RIO c ()
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
{ keyCombo = "Alt+c"
, keyIndex = 1
, keyDescription = "Copy One"
, keyActions = loginToRofiActions l copyRepeat
}
backHotkey = Hotkey
{ keyCombo = "Alt+q"
, keyIndex = 2
, keyDescription = "Back"
-- 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)
}
copyHotkey =
Hotkey
{ keyCombo = "Alt+c"
, keyDescription = "Copy One"
, keyActions = loginToRofiActions l copyRepeat
}
backHotkey =
Hotkey
{ keyCombo = "Alt+q"
, keyDescription = "Back"
, -- 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)
}
loginToRofiActions :: RofiConf c => Login -> (String -> RofiIO c ()) -> RofiActions c
loginToRofiActions Login { username = u, password = p } a =
loginToRofiActions :: Login -> (T.Text -> RIO c ()) -> RofiActions c
loginToRofiActions Login {username = u, password = p} a =
toRofiActions $ catMaybes [user, pwd]
where
copyIfJust f = fmap $ liftM2 (,) f a
fmtUsername s = "Username (" ++ s ++ ")"
fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")"
fmtUsername s = T.concat ["Username (", 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 conf session item = fromMaybe "" <$>
getItemPassword' conf session item
getItemPassword :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m T.Text
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
putStrLn "Started rofi bitwarden dbus client"
export client path defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memGetSession $ getSession c ses
, autoMethod memLockSession $ lockSession ses
, autoMethod memSyncSession $ syncSession c ses
, autoMethod memGetPassword $ getItemPassword c ses
]
}
_ <- liftIO $ requestName client busname flags
logInfo "Started rofi bitwarden dbus client"
withRunInIO $ \runIO ->
export
client
path
defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ 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"
@ -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 [b] = case fromVariant b :: Maybe String of
getBodyString :: [Variant] -> Maybe T.Text
getBodyString [b] = case fromVariant b :: Maybe T.Text of
Just "" -> Nothing
s -> s
s -> s
getBodyString _ = Nothing
callMethod :: MethodCall -> IO (Either MethodError [Variant])
callMethod mc = do
callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant])
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

View File

@ -1,16 +1,12 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Rofi.Command
( RofiConf(..)
, RofiMenu(..)
( HasRofiConf (..)
, RofiMenu (..)
, RofiAction
, RofiActions
, RofiIO
, RofiGroup
, Hotkey(..)
, Hotkey (..)
, io
, emptyMenu
, runRofiIO
, toRofiActions
, rofiActionKeys
, untitledGroup
@ -23,170 +19,180 @@ module Rofi.Command
, readCmdEither'
, dmenuArgs
, joinNewline
, stripWS
) where
, runRofi
)
where
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import qualified Data.Map.Ordered as OM
import RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import qualified RIO.Vector.Boxed as V
import System.Process
import Data.Char
import Data.List
import qualified Data.Map.Ordered as M
import Data.Maybe
class HasRofiConf c where
defArgs :: c -> [T.Text]
import System.Exit
import System.Process
type RofiAction c = (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 ())
type RofiActions c = OM.OMap T.Text (RIO c ())
data RofiGroup c = RofiGroup
{ actions :: RofiActions c
, title :: Maybe String
}
untitledGroup :: RofiActions c -> RofiGroup c
untitledGroup a = RofiGroup { actions = a, title = Nothing }
titledGroup :: String -> RofiActions c -> RofiGroup c
titledGroup t a = (untitledGroup a) { title = Just t }
data Hotkey c = Hotkey
{ keyCombo :: String
-- only 1-10 are valid
, keyIndex :: Int
, keyDescription :: String
, keyActions :: RofiActions c
}
hotkeyBinding :: Hotkey c -> [String]
hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
where
k = "-kb-custom-" ++ show e
hotkeyMsg1 :: Hotkey c -> String
hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
c ++ ": <i>" ++ d ++ "</i>"
hotkeyMsg :: [Hotkey c] -> [String]
hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey c] -> [String]
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
data RofiMenu c = RofiMenu
{ groups :: [RofiGroup c]
, prompt :: Maybe String
, hotkeys :: [Hotkey c]
}
emptyMenu :: RofiMenu c
emptyMenu = RofiMenu
{ groups = []
, prompt = Nothing
, hotkeys = []
{ actions :: RofiActions c
, title :: Maybe T.Text
}
newtype RofiIO c a = RofiIO (ReaderT c IO a)
deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO)
untitledGroup :: RofiActions c -> RofiGroup c
untitledGroup a = RofiGroup {actions = a, title = Nothing}
instance Applicative (RofiIO c) where
pure = return
(<*>) = ap
titledGroup :: T.Text -> RofiActions c -> RofiGroup c
titledGroup t a = (untitledGroup a) {title = Just t}
data Hotkey c = Hotkey
{ keyCombo :: !T.Text
, keyDescription :: !T.Text
, keyActions :: RofiActions c
}
hotkeyBinding :: Int -> Hotkey c -> [T.Text]
hotkeyBinding i Hotkey {keyCombo = c} = [k, c]
where
k = T.append "-kb-custom-" $ T.pack $ show i
hotkeyMsg1 :: Hotkey c -> T.Text
hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
T.concat [c, ": <i>", d, "</i>"]
hotkeyMsg :: [Hotkey c] -> [T.Text]
hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey c] -> [T.Text]
hotkeyArgs hks =
(hotkeyMsg hks)
++ (concatMap (uncurry hotkeyBinding) $ take 19 $ zip [1 ..] hks)
data RofiMenu c = RofiMenu
{ groups :: ![RofiGroup c]
, prompt :: !(Maybe T.Text)
, hotkeys :: ![Hotkey c]
}
emptyMenu :: RofiMenu c
emptyMenu =
RofiMenu
{ groups = []
, prompt = Nothing
, hotkeys = mempty
}
io :: MonadIO m => IO a -> m a
io = liftIO
runRofiIO :: c -> RofiIO c a -> IO a
runRofiIO c (RofiIO r) = runReaderT r c
toRofiActions :: [(T.Text, RIO c ())] -> RofiActions c
toRofiActions = OM.fromList
toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
toRofiActions = M.fromList
rofiActionKeys :: RofiActions c -> T.Text
rofiActionKeys = joinNewline . map fst . OM.assocs
rofiActionKeys :: RofiActions c -> String
rofiActionKeys = joinNewline . map fst . M.assocs
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
lookupRofiAction :: T.Text -> RofiActions c -> RIO c ()
lookupRofiAction key = fromMaybe err . OM.lookup key
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 = intercalate "\n\n" . filter (not . null) . fmap groupEntries . groups
menuEntries :: RofiMenu c -> T.Text
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)
$ find ((==) n . (+ 9) . keyIndex)
$ hotkeys rm
Right key -> lookupRofiAction key $ menuActions rm
Left (1, _, _) -> exitWith $ ExitFailure 1
Left (n, key, _) -> do
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]
-> String
-> RofiIO c (Either (Int, String, String) String)
readRofi
:: HasRofiConf c
=> [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 cmd args input = either (const Nothing) Just
<$> readCmdEither cmd args input
readCmdSuccess :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m (Maybe T.Text)
readCmdSuccess cmd args input =
either (const Nothing) Just
<$> readCmdEither cmd args input
readCmdEither :: String
-> [String]
-> String
-> IO (Either (Int, String, String) String)
readCmdEither cmd args input = resultToEither
<$> readProcessWithExitCode cmd args input
readCmdEither
:: MonadIO m
=> T.Text
-> [T.Text]
-> T.Text
-> m (Either (Int, T.Text, T.Text) T.Text)
readCmdEither cmd args input = readCmdEither' cmd args input []
readCmdEither' :: String
-> [String]
-> String
-> [(String, String)]
-> IO (Either (Int, String, String) String)
readCmdEither' cmd args input environ = resultToEither
<$> readCreateProcessWithExitCode p input
readCmdEither'
:: MonadIO m
=> T.Text
-> [T.Text]
-> T.Text
-> [(T.Text, T.Text)]
-> 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)
-> Either (Int, String, String) String
resultToEither (ExitSuccess, out, _) = Right $ stripWS out
resultToEither (ExitFailure n, out, err) = Left (n, stripWS out, stripWS err)
-- TODO why strip whitespace?
resultToEither
:: (ExitCode, String, String)
-> 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
stripWS = reverse . dropWhile isSpace . reverse
joinNewline :: [T.Text] -> T.Text
joinNewline = T.intercalate "\n"
joinNewline :: [String] -> String
joinNewline = intercalate "\n"
readPassword :: IO (Maybe String)
readPassword :: MonadIO m => m (Maybe T.Text)
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"]

29
lib/Rofi/IO.hs Normal file
View File

@ -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

5
make_pkgs Normal file
View File

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

View File

@ -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:
main: current-output.hs
rofi:
main: rofi.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras

34
runtime_pkgs Executable file
View File

@ -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

5
scripts/gpg Executable file
View File

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

30
scripts/mount.veracrypt Executable file
View File

@ -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

5
scripts/pass Executable file
View File

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

14
scripts/umount.veracrypt Executable file
View File

@ -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

14
scripts/with_gpg_mount Executable file
View File

@ -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

View File

@ -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.

View File

@ -6,7 +6,7 @@
packages: []
snapshots:
- completed:
size: 545658
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml
sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406
original: lts-14.12
sha256: adbc602422dde10cc330175da7de8609e70afc41449a7e2d6e8b1827aa0e5008
size: 649342
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/11.yaml
original: lts-20.11