Compare commits

..

1 Commits

Author SHA1 Message Date
Nathan Dwarshuis a083017540 ENH build with nix to pull in all c deps 2022-07-22 00:20:46 -04:00
27 changed files with 1477 additions and 1427 deletions

357
.stylish-haskell.yaml Normal file
View File

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

105
README.md
View File

@ -3,42 +3,7 @@
These are some personal programs that use the These are some personal programs that use the
[rofi](https://github.com/davatorium/rofi) interface. [rofi](https://github.com/davatorium/rofi) interface.
## Installation ## Rofi-Bitwarden
Clone this repo and run the following in the repo root.
Install packages needed for building:
```
pacman -S --needed - < make_pkgs
```
Build and install (choose individual targets as needed):
```
stack install
```
See individual sections for other dependencies to install.
## Putting Rofi on the correct screen (rofi)
This is a total hack...actually it isn't because it's written in Haskell and not
bash.
The problem is that when used with xmonad, rofi doesn't place itself on the
"current" workspace since the concept of a "workspace" is weird and specific to
xmonad. The solution is to use this program to query `_NET_DESKTOP_VIEWPORT`
(which my xmonad config sets) and use this determine the name of the active
workspace which can then be fed to rofi using the `-m` flag.
See comments of this binary for details.
### Dependencies
- X11
## Bitwarden (rofi-bw)
[Bitwarden](https://bitwarden.com/) is an open-source password management server [Bitwarden](https://bitwarden.com/) is an open-source password management server
and this program functions as a client. Unlike many other similar clients, this and this program functions as a client. Unlike many other similar clients, this
@ -72,9 +37,10 @@ Any options after `-c` will be passed to rofi.
### Dependencies ### Dependencies
- [bitwarden-cli](https://github.com/bitwarden/cli) - [bitwarden-cli](https://github.com/bitwarden/cli)
- dbus
- libnotify: desktop notifications - libnotify: desktop notifications
## Device Mounting (rofi-dev) ## Rofi-Devices
This is a manual mounting helper for removable drives, MTP devices, and fstab This is a manual mounting helper for removable drives, MTP devices, and fstab
entries. It will transparently handle mountpoint creation/destruction. entries. It will transparently handle mountpoint creation/destruction.
@ -109,19 +75,6 @@ To specifify that `/media/USER/foo` should use `secret-tool` to find its
password, specify the `-s` option. This would lookup a password for the entry password, specify the `-s` option. This would lookup a password for the entry
whose `username` is `bar` and `hostname` is `example.com`: 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 ``` sh
rofi-dev -s '/media/USER/foo:username=bar,hostname=example.com' rofi-dev -s '/media/USER/foo:username=bar,hostname=example.com'
``` ```
@ -136,58 +89,6 @@ rofi-dev -p '/media/USER/foo'
- udisks2: removable drive mounting - udisks2: removable drive mounting
- sshfs: mounting network devices in fstab over ssh - sshfs: mounting network devices in fstab over ssh
- cifs-utils: mounting network devices in fstab using CIFS/Samba - cifs-utils: mounting network devices in fstab using CIFS/Samba
- veracrypt: to mount veracrypt vaults
- [jmtpfs](https://github.com/JasonFerrara/jmtpfs): mounting MTP devices - [jmtpfs](https://github.com/JasonFerrara/jmtpfs): mounting MTP devices
- libnotify: desktop notifications - libnotify: desktop notifications
- libsecret: password lookup with `secret-tool` - 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,12 +1,14 @@
module Main (main) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Run rofi (and display on the correct screen) -- | Return current xrandr output name
-- --
-- Since this seems random, the reason for this is that I want rofi to appear -- 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 -- 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 -- 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 -- accepts the name of an xrandr output onto which it should appear, so this
-- binary determines which xmonad workspace is in focus and calls rofi with the -- script provides a way to determine which xmonad workspace is in focus and
-- name of that workspace. -- provide the name of the output displaying said workspace.
-- --
-- Assumptions: xmonad sets the _NET_DESKTOP_VIEWPORT atom with the positions of -- Assumptions: xmonad sets the _NET_DESKTOP_VIEWPORT atom with the positions of
-- the active workspace (actually an array of the positions of all workspaces -- the active workspace (actually an array of the positions of all workspaces
@ -19,32 +21,24 @@
-- 2) Use index from (1) and to get the position of the active workspace from -- 2) Use index from (1) and to get the position of the active workspace from
-- _NET_DESKTOP_VIEWPORT -- _NET_DESKTOP_VIEWPORT
-- 3) Find the name of the xrandr output whose position matches that from (2) -- 3) Find the name of the xrandr output whose position matches that from (2)
-- 4) Call rofi with the '-m' flag to override the default monitor placement
module Main (main) where import Data.Maybe
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrandr import Graphics.X11.Xrandr
import RIO hiding (Display)
import RIO.Process import System.Exit
import qualified RIO.Text as T
import UnliftIO.Environment
main :: IO () main :: IO ()
main = runSimpleApp $ do main = getMonitorName >>= maybe exitFailure (\n -> putStrLn n >> exitSuccess)
r <- getMonitorName
args <- getArgs
let allArgs = maybe [] (\n -> ["-m", T.unpack n] ++ args) r
c <- proc "/usr/bin/rofi" allArgs runProcess
exitWith c
data Coord = Coord Int Int deriving (Eq, Show) data Coord = Coord Int Int
deriving (Eq, Show)
-- TODO bracket this getMonitorName :: IO (Maybe String)
getMonitorName :: MonadIO m => m (Maybe T.Text) getMonitorName = do
getMonitorName = liftIO $ do
dpy <- openDisplay "" dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy
index <- getCurrentDesktopIndex dpy root index <- getCurrentDesktopIndex dpy root
@ -61,39 +55,39 @@ getDesktopViewports dpy root =
pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT" pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT"
where where
pairs = reverse . pairs' [] pairs = reverse . pairs' []
pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs pairs' acc [] = acc
pairs' acc _ = acc pairs' acc [_] = acc
pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs
getOutputs :: Display -> Window -> IO [(Coord, T.Text)] getOutputs :: Display -> Window -> IO [(Coord, String)]
getOutputs dpy root = getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>=
xrrGetScreenResourcesCurrent dpy root maybe (return []) resourcesToCells
>>= maybe (return []) resourcesToCells
where where
resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r) resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r)
outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r
-- connection: 0 == connected, 1 == disconnected -- connection: 0 == connected, 1 == disconnected
infoToCell infoToCell r (Just XRROutputInfo { xrr_oi_connection = 0
r , xrr_oi_name = n
( Just , xrr_oi_crtc = c
XRROutputInfo }) = do
{ xrr_oi_connection = 0 cinfo <- xrrGetCrtcInfo dpy r c
, xrr_oi_name = n return $ fmap (\i -> (toCoord i, n)) cinfo
, xrr_oi_crtc = c
}
) = do
fmap (\i -> (toCoord i, T.pack n)) <$> xrrGetCrtcInfo dpy r c
infoToCell _ _ = return Nothing infoToCell _ _ = return Nothing
toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c) toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c)
infix 9 !!? infix 9 !!?
(!!?) :: [a] -> Int -> Maybe a (!!?) :: [a] -> Int -> Maybe a
(!!?) xs i (!!?) xs i
| i < 0 = Nothing | i < 0 = Nothing
| otherwise = listToMaybe $ drop i xs | otherwise = go i xs
where
go :: Int -> [a] -> Maybe a
go 0 (x:_) = Just x
go j (_:ys) = go (j - 1) ys
go _ [] = Nothing
getAtom32 :: Display -> Window -> T.Text -> IO [Int] getAtom32 :: Display -> Window -> String -> IO [Int]
getAtom32 dpy root str = do getAtom32 dpy root str = do
a <- internAtom dpy (T.unpack str) False a <- internAtom dpy str False
p <- getWindowProperty32 dpy a root p <- getWindowProperty32 dpy a root
return $ maybe [] (fmap fromIntegral) p return $ maybe [] (fmap fromIntegral) p

View File

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

View File

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

View File

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

View File

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

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

8
install_deps Executable file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -9,56 +9,15 @@ copyright: "2020 Nathan Dwarshuis"
extra-source-files: extra-source-files:
- README.md - 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> 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: dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- process >= 1.6.5.0 - process >= 1.6.5.0
@ -81,18 +40,24 @@ dependencies:
- yaml >= 0.11.1.2 - yaml >= 0.11.1.2
- vector >= 0.12.0.3 - vector >= 0.12.0.3
- bimap >= 0.2.4 - bimap >= 0.2.4
- dhall >= 1.40.2
- lens >= 5.0.1
- rio
library: library:
source-dirs: lib/ source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -threaded
exposed-modules:
- Bitwarden.Internal
- Rofi.Command
executables: executables:
pinentry-rofi: pinentry-rofi:
main: pinentry-rofi.hs main: pinentry-rofi.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -101,6 +66,8 @@ executables:
main: rofi-autorandr.hs main: rofi-autorandr.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -109,6 +76,8 @@ executables:
main: rofi-bw.hs main: rofi-bw.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -117,6 +86,8 @@ executables:
main: rofi-bt.hs main: rofi-bt.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -125,6 +96,8 @@ executables:
main: rofi-dev.hs main: rofi-dev.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -133,14 +106,18 @@ executables:
main: rofi-evpn.hs main: rofi-evpn.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras
rofi: current-output:
main: rofi.hs main: current-output.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
dependencies: dependencies:
- rofi-extras - rofi-extras

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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