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
[rofi](https://github.com/davatorium/rofi) interface.
## 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)
## Rofi-Bitwarden
[Bitwarden](https://bitwarden.com/) is an open-source password management server
and this program functions as a client. Unlike many other similar clients, this
@ -72,9 +37,10 @@ Any options after `-c` will be passed to rofi.
### Dependencies
- [bitwarden-cli](https://github.com/bitwarden/cli)
- dbus
- libnotify: desktop notifications
## Device Mounting (rofi-dev)
## Rofi-Devices
This is a manual mounting helper for removable drives, MTP devices, and fstab
entries. It will transparently handle mountpoint creation/destruction.
@ -109,19 +75,6 @@ To specifify that `/media/USER/foo` should use `secret-tool` to find its
password, specify the `-s` option. This would lookup a password for the entry
whose `username` is `bar` and `hostname` is `example.com`:
### Veracrypt
This tool can mount veracrypt vaults...with some hacky effort. Since veracrypt
works at the block device level, it needs root permissions to mount a volume
(which actually involves mounting several devices). The easiest way to make sure
this works is to give veracrypt sudo access like so:
```
<user> ALL=(root) NOPASSWD: /usr/bin/veracrypt,/usr/bin/uptime
```
No idea why `uptime` is also needed for this.
``` sh
rofi-dev -s '/media/USER/foo:username=bar,hostname=example.com'
```
@ -136,58 +89,6 @@ rofi-dev -p '/media/USER/foo'
- udisks2: removable drive mounting
- sshfs: mounting network devices in fstab over ssh
- cifs-utils: mounting network devices in fstab using CIFS/Samba
- veracrypt: to mount veracrypt vaults
- [jmtpfs](https://github.com/JasonFerrara/jmtpfs): mounting MTP devices
- libnotify: desktop notifications
- libsecret: password lookup with `secret-tool`
## Autorandr (rofi-autorandr)
This allows selection of the
[autorandr](https://github.com/phillipberndt/autorandr) configuration via a rofi
menu.
### Dependencies
- autorandr
## Bluetooth (rofi-bw)
This presents a nice menu to select the current bluetooth device.
### Dependencies
- bluez (which should provide the dbus interface for this to work)
## ExpressVPN (rofi-evpn)
This presents a menu to select the current ExpressVPN gateway.
### Dependencies
- expressvpn (from AUR)
- libnotify
## Pinentry (pinentry-rofi)
Analogous to the default [pinentry](https://github.com/gpg/pinentry) prompts,
this presents a rofi prompt for a password with the GPG keyring is unlocked.
Requires the following in `gpg-agent.conf`:
```
pinentry-program /path/to/pinentry-rofi
```
Unlike the other pinentry programs, this one can integrate with bitwarden (via
the above client) by retrieving the password for the gpg keyring if it is stored
in bitwarden. This requires a yaml configuration in the gpg home directoring as
such:
```
bitwarden-name: <name of GPG bitwarden entry>
```
### Dependencies
- rofi-bw (see above): bitwarden integration

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
-- over the current xmonad workspace, and rofi has no concept of what an
-- xmonad workspace is (not that it is supposed to, xmonad is weird...). Rofi
-- accepts the name of an xrandr output onto which it should appear, so this
-- binary determines which xmonad workspace is in focus and calls rofi with the
-- name of that workspace.
-- script provides a way to determine which xmonad workspace is in focus and
-- provide the name of the output displaying said workspace.
--
-- Assumptions: xmonad sets the _NET_DESKTOP_VIEWPORT atom with the positions of
-- the active workspace (actually an array of the positions of all workspaces
@ -19,32 +21,24 @@
-- 2) Use index from (1) and to get the position of the active workspace from
-- _NET_DESKTOP_VIEWPORT
-- 3) Find the name of the xrandr output whose position matches that from (2)
-- 4) Call rofi with the '-m' flag to override the default monitor placement
module Main (main) where
import Data.Maybe
import Graphics.X11.Types
import Graphics.X11.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
import System.Exit
main :: IO ()
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
main = getMonitorName >>= maybe exitFailure (\n -> putStrLn n >> exitSuccess)
data Coord = Coord Int Int deriving (Eq, Show)
data Coord = Coord Int Int
deriving (Eq, Show)
-- TODO bracket this
getMonitorName :: MonadIO m => m (Maybe T.Text)
getMonitorName = liftIO $ do
getMonitorName :: IO (Maybe String)
getMonitorName = do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
index <- getCurrentDesktopIndex dpy root
@ -61,39 +55,39 @@ getDesktopViewports dpy root =
pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT"
where
pairs = reverse . pairs' []
pairs' acc [] = acc
pairs' acc [_] = acc
pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs
pairs' acc _ = acc
getOutputs :: Display -> Window -> IO [(Coord, T.Text)]
getOutputs dpy root =
xrrGetScreenResourcesCurrent dpy root
>>= maybe (return []) resourcesToCells
getOutputs :: Display -> Window -> IO [(Coord, String)]
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
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
}) = do
cinfo <- xrrGetCrtcInfo dpy r c
return $ fmap (\i -> (toCoord i, n)) cinfo
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 = listToMaybe $ drop i xs
| otherwise = go i xs
where
go :: Int -> [a] -> Maybe a
go 0 (x:_) = Just x
go j (_:ys) = go (j - 1) ys
go _ [] = Nothing
getAtom32 :: Display -> Window -> T.Text -> IO [Int]
getAtom32 :: Display -> Window -> String -> IO [Int]
getAtom32 dpy root str = do
a <- internAtom dpy (T.unpack str) False
a <- internAtom dpy str False
p <- getWindowProperty32 dpy a root
return $ maybe [] (fmap fromIntegral) p

View File

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

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

View File

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

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

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

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

View File

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

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:
- README.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/ndwarshuis/rofi-extras#readme>
default-extensions:
- OverloadedStrings
- FlexibleContexts
- FlexibleInstances
- InstanceSigs
- MultiParamTypeClasses
- EmptyCase
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- TupleSections
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- DerivingStrategies
- DeriveDataTypeable
- EmptyDataDecls
- PartialTypeSignatures
- GeneralizedNewtypeDeriving
- StandaloneDeriving
- BangPatterns
- TypeOperators
- ScopedTypeVariables
- TypeApplications
- ConstraintKinds
- RankNTypes
- GADTs
- DefaultSignatures
- NoImplicitPrelude
- FunctionalDependencies
- DataKinds
- TypeFamilies
- BinaryLiterals
- ViewPatterns
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
dependencies:
- base >= 4.7 && < 5
- process >= 1.6.5.0
@ -81,18 +40,24 @@ dependencies:
- yaml >= 0.11.1.2
- vector >= 0.12.0.3
- bimap >= 0.2.4
- dhall >= 1.40.2
- lens >= 5.0.1
- rio
library:
source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -threaded
exposed-modules:
- Bitwarden.Internal
- Rofi.Command
executables:
pinentry-rofi:
main: pinentry-rofi.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
@ -101,6 +66,8 @@ executables:
main: rofi-autorandr.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
@ -109,6 +76,8 @@ executables:
main: rofi-bw.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
@ -117,6 +86,8 @@ executables:
main: rofi-bt.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
@ -125,6 +96,8 @@ executables:
main: rofi-dev.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
@ -133,14 +106,18 @@ executables:
main: rofi-evpn.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
rofi:
main: rofi.hs
current-output:
main: current-output.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- 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]
Description=Mount veracrypt volume for %i
# TODO these scripts moved
[Service]
Type=forking
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: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-20.11
resolver: lts-16.31
# User packages to be built.
# Various formats can be used as shown in the example below.
@ -64,3 +64,11 @@ packages:
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
nix:
enable: true
packages:
- xorg.libX11
- xorg.libXrandr
- xorg.libXScrnSaver
- xorg.libXext
- zlib

View File

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