ndwarshuis
/
rofi-extras
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

init commit

This commit is contained in:
Nathan Dwarshuis 2020-04-23 23:32:29 -04:00
commit 49c4f4cf1c
9 changed files with 1087 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored Normal file
View File

@ -0,0 +1,4 @@
.stack-work/
*~
TAGS
*.cabal

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright Nathan Dwarshuis (c) 2020
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Nathan Dwarshuis nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1
README.md Normal file
View File

@ -0,0 +1 @@
# rofi-extras

273
app/rofi-bitwarden.hs Normal file
View File

@ -0,0 +1,273 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Main (main) where
import Control.Concurrent
import Control.Monad
import Data.Aeson
import Data.Maybe
import Data.String
import Data.UnixTime
import DBus
import DBus.Client
import GHC.Generics
import Rofi.Command
import Text.Read
import System.Clipboard
import System.Directory
import System.Environment
import System.Exit
import System.Process
main :: IO ()
main = runChecks >> getArgs >>= parse
parse :: [String] -> IO ()
parse ["-d", t] = case readMaybe t of { Just t' -> runDaemon t'; _ -> usage }
parse ("-c":args) = runClient args
parse _ = usage
usage :: IO ()
usage = putStrLn $ joinNewline
[ "daemon mode: rofi-bw -d TIMEOUT"
, "client mode: rofi-bw -c [ROFI-ARGS]"
]
runChecks :: IO ()
runChecks = checkExe "bw" >> checkExe "rofi"
checkExe :: String -> IO ()
checkExe cmd = do
res <- findExecutable cmd
unless (isJust res) $ do
putStrLn $ "Could not find executable: " ++ cmd
exitWith $ ExitFailure 1
--------------------------------------------------------------------------------
-- | Daemon
--
-- Daemon will export an interface on DBus with two methods:
-- * get current session id - if no session is active, launch Rofi to prompt
-- for a password; return session id or null if password is invalid
-- * lock session - destroy the current session id if active
--
-- The session ID will be valid only as long as TIMEOUT
newtype BWConf = BWConf
{ timeout :: UnixDiffTime
}
data CurrentSession = CurrentSession
{ timestamp :: UnixTime
, hash :: String
}
type Session = MVar (Maybe CurrentSession)
runDaemon :: Int -> IO ()
runDaemon t = do
ses <- newMVar Nothing
let c = BWConf { timeout = UnixDiffTime (fromIntegral t) 0 }
startService c ses
forever $ threadDelay 1000000
lockSession :: Session -> IO ()
lockSession ses = void $ swapMVar ses Nothing
getSession :: BWConf -> Session -> IO String
getSession BWConf { timeout = t } ses = do
ut <- getUnixTime
modifyMVar ses $ \s -> case s of
Just CurrentSession { timestamp = ts, hash = h } ->
if diffUnixTime ut ts > t then getNewSession else return (s, h)
Nothing -> getNewSession
where
getNewSession = do
pwd <- readPassword
newHash <- join <$> mapM readSession pwd
(, fromMaybe "" newHash) <$> mapM newSession newHash
newSession h = do
ut <- getUnixTime
return CurrentSession { timestamp = ut, hash = h }
readPassword :: IO (Maybe String)
readPassword = readCmdSuccess "rofi" args ""
where
args = dmenuArgs ++ ["-p", "Password", "-password"]
readSession :: String -> IO (Maybe String)
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
--------------------------------------------------------------------------------
-- | Client
--
-- The client will get the current session from the daemon (if it can) and then
-- go through a decision-tree like selection process to retrieve information as
-- needed. This will be in the form of the following menus:
--
-- Main menus
-- - Lock Session -> lock the session
-- - Browse logins -> show new menu of all logins
-- - select an entry -> show new menu with entry contents
-- - All -> copy all to clipboard
-- - username (if applicable) -> copy to clipboard
-- - password (if applicable) -> copy to clipboard
-- - anything else (notes and such) -> copy to clipboard
runClient :: [String] -> IO ()
runClient a = do
let c = RofiConf { defArgs = a }
runRofiPrompt c $ selectAction $ emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action"
}
where
ras = [ ("Browse Logins", browseLogins)
, ("Lock Session", io callLockSession)
]
browseLogins :: RofiPrompt ()
browseLogins = do
session <- io callGetSession
forM_ session $ getItems >=> selectItem
getItems :: String -> RofiPrompt [Item]
getItems session = do
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 _ = True
data Item = Item
{ name :: String
, login :: Login
}
deriving (Show)
instance FromJSON Item where
parseJSON (Object o) = Item
<$> o .: "name"
<*> o .:? "login" .!= Login { username = Nothing, password = Nothing }
parseJSON _ = mzero
data Login = Login
{ username :: Maybe String
, password :: Maybe String
}
deriving (Show, Generic)
instance FromJSON Login
-- TODO make menu buttons here to go back and to copy without leaving
-- the current menu
selectItem :: [Item] -> RofiPrompt ()
selectItem items = selectAction $ emptyMenu
{ groups = [untitledGroup $ itemsToRofiActions items]
, prompt = Just "Login"
}
itemsToRofiActions :: [Item] -> RofiActions
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
selectCopy :: Login -> RofiPrompt ()
selectCopy l = selectAction $ emptyMenu
{ groups = [untitledGroup $ loginToRofiActions l copy]
, prompt = Just "Copy"
, hotkeys = [copyHotkey, backHotkey]
}
where
copy = io . setClipboardString
copyRepeat s = copy s >> selectCopy l
copyHotkey = Hotkey
{ keyCombo = "Alt+c"
, keyIndex = 1
, keyDescription = "Copy One"
, keyActions = loginToRofiActions l copyRepeat
}
backHotkey = Hotkey
{ keyCombo = "Alt+q"
, keyIndex = 2
, keyDescription = "Back"
-- TODO this is overly complicated, all entries do the same thing
-- TODO this is slow, we can cache the logins somehow...
, keyActions = loginToRofiActions l (const browseLogins)
}
loginToRofiActions :: Login -> (String -> RofiPrompt ()) -> RofiActions
loginToRofiActions Login { username = u, password = p } a =
toRofiActions $ catMaybes [user, pwd]
where
copyIfJust f = fmap $ liftM2 (,) f a
fmtUsername s = "Username (" ++ s ++ ")"
fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")"
user = copyIfJust fmtUsername u
pwd = copyIfJust fmtPassword p
--------------------------------------------------------------------------------
-- | DBus
busname :: BusName
busname = "org.rofi.bitwarden"
path :: ObjectPath
path = "/bitwarden"
interface :: InterfaceName
interface = "org.rofi.bitwarden.session"
memGetSession :: MemberName
memGetSession = "GetSession"
memLockSession :: MemberName
memLockSession = "LockSession"
startService :: BWConf -> Session -> IO ()
startService c ses = do
client <- connectSession
let flags = [nameAllowReplacement, nameReplaceExisting]
_ <- requestName client busname flags
putStrLn "Started rofi bitwarden dbus client"
export client path defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memGetSession $ getSession c ses
, autoMethod memLockSession $ lockSession ses
]
}
callLockSession :: IO ()
callLockSession = do
reply <- callMethod $ methodCall path interface memLockSession
case reply of
Left err -> putStrLn $ methodErrorMessage err
Right _ -> return ()
callGetSession :: IO (Maybe String)
callGetSession = do
reply <- callMethod $ methodCall path interface memGetSession
case reply of
Left err -> putStrLn (methodErrorMessage err) >> return Nothing
Right body -> return $ getBodySession body
getBodySession :: [Variant] -> Maybe String
getBodySession [b] = case ses of { Just "" -> Nothing; _ -> ses }
where
ses = fromVariant b :: Maybe String
getBodySession _ = Nothing
callMethod :: MethodCall -> IO (Either MethodError [Variant])
callMethod mc = do
client <- connectSession
reply <- call client mc { methodCallDestination = Just busname }
disconnect client
return $ methodReturnBody <$> reply

473
app/rofi-devices.hs Normal file
View File

@ -0,0 +1,473 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Csv hiding (lookup)
import Data.Either
import Data.List
import Data.List.Split (splitOn)
import qualified Data.Map as M
import qualified Data.Map.Ordered as O
import Data.Maybe
import Data.Vector (Vector, toList)
import GHC.Generics (Generic)
import Rofi.Command
import Text.Printf
import Text.Regex.TDFA
import System.Directory
import System.Environment
import System.Process
main :: IO ()
main = check >> getArgs >>= parse
parse :: [String] -> IO ()
parse = runMounts
-- TODO
check :: IO ()
check = return ()
runMounts :: [String] -> IO ()
runMounts a = do
let c = RofiConf { defArgs = a }
runRofiPrompt c runPrompt
runPrompt :: RofiPrompt ()
runPrompt = do
net <- titledGroup "Network Devices" <$> io getNetActions
rmv <- titledGroup "Removable Devices" <$> io getRemovableActions
mtp <- titledGroup "MTP Devices" <$> io getMTPActions
selectAction $ emptyMenu
{ groups = [net, rmv, mtp]
, prompt = Just "Select Device"
}
getNetActions :: IO RofiActions
getNetActions = alignEntries . toRofiActions . catMaybes
<$> (mapM csvToAction =<< getCSV)
alignSep :: String
alignSep = " | "
alignSepPre :: String
alignSepPre = "@@@"
alignEntries :: RofiActions -> RofiActions
alignEntries = O.fromList . withKeys . O.assocs
where
withKeys as = let (ks, vs) = unzip as in zip (align ks) vs
align ks = fmap (intercalate alignSep)
$ transpose
$ mapToLast pad
$ transpose
$ fmap (splitOn alignSepPre) ks
pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs
getMax = maximum . fmap length
mapToLast _ [] = []
mapToLast _ [x] = [x]
mapToLast f (x:xs) = f x : mapToLast f xs
-- | Class and methods for type representing mountable devices
class Mountable a where
-- | Mount the given type (or dismount if False is passed)
mount :: a -> Bool -> IO ()
-- | Check if the mounting utilities are present
allInstalled :: a -> IO Bool
-- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> String
-- | Determine if the given type is mounted or not
isMounted :: a -> IO Bool
-- | Given a mountable type, return a rofi action (string to go in the
-- Rofi prompt and an action to perform when it is selected)
mkAction :: a -> IO (String, RofiPrompt ())
mkAction dev = do
m <- isMounted dev
i <- allInstalled dev
let a = when i $ io $ mount dev m
let s = mountedPrefix m i ++ fmtEntry dev
return (s, a)
where
mountedPrefix False True = " "
mountedPrefix True True = "* "
mountedPrefix _ False = "! "
-- | Key/val pairs to represent mount options. A Nothing for the value signifies
-- a standalone option (eg 'rw' and 'ro')
type MountOptions = M.Map String (Maybe String)
-- | Given a string of comma-separated 'key=val' pairs, return a mount options
-- map
parseMountOptions :: String -> MountOptions
parseMountOptions s = M.fromList $ toCell . splitEq <$> splitBy ',' s
where
splitEq e = e =~ ("=" :: String) :: (String, String, String)
toCell (k, "=", v) = (k, Just v)
toCell (k, _, _) = (k, Nothing)
-- | Given a mount options map, return a string of comma separated items
fmtMountOptions :: MountOptions -> String
fmtMountOptions = intercalate "," . fmap fromCell . M.toList
where
fromCell (k, Just v) = k ++ "=" ++ v
fromCell (k, Nothing) = k
-- | Various credentials to be used with a given mountable type.
-- Secret: represents a lookup using 'secret-tool' where the map represents
-- the attribute/value pairs to pass.
-- NoCredentials: self explanatory
data Credentials = Secret (M.Map String String)
| NoCredentials
deriving (Eq, Show)
-- | Given a string, return a credentials type. The type of credentials is
-- determined by the prefix (which is followed by a colon) and is followed by
-- a comma-separated list of 'key=val' pairs
parseCredentials :: String -> Credentials
parseCredentials c = case splitPrefix c of
("secret", ":", r) -> Secret $ M.fromList $ mapMaybe (toCell . splitEq) $ splitBy ',' r
-- TODO fetch from bitwarden
-- add more here...
_ -> NoCredentials
where
splitPrefix s = s =~ (":" :: String) :: (String, String, String)
splitEq e = e =~ ("=" :: String) :: (String, String, String)
toCell (k, "=", v) = Just (k, v)
toCell _ = Nothing
--------------------------------------------------------------------------------
-- | Removable devices
--
-- A device which can be removed (which is all the devices we care about)
-- This can be minimally described by a device PATH and LABEL. If MOUNTPOINT is
-- Nothing, this represents the device being mounted at a default location.
data Removable = Removable
{ path :: String
, label :: String
, mountpoint :: Maybe String
}
deriving (Eq, Show)
instance Mountable Removable where
-- | (Un)mount the device using udiskctl
mount Removable { path = p, label = l } m = do
res <- readCmdEither "udisksctl" [cmd, "-b", p] ""
notifyMounted (isRight res) m l
where
cmd = if m then "unmount" else "mount"
-- | Need udisksctl to mount and umount
allInstalled _ = isJust <$> findExecutable "udisksctl"
-- | Check if the device is mounted using /proc/mount
isMounted Removable { path = p, mountpoint = m } = do
cur <- curMountpoints
return $ case m of
Just m' -> (p, m') `elem` cur
Nothing -> p `elem` fmap fst cur
-- | Format the Rofi entry like 'LABEL - PATH' and add a star in the front
-- if the device is mounted
fmtEntry Removable { path = p, label = l } = l ++ alignSepPre ++ p
-- | Return list of possible rofi actions for removable devices
-- A 'removable device' is defined as a hotplugged device with a filesystem as
-- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the
-- label shown on the prompt will be 'SIZE Volume' where size is the size of
-- the device
getRemovableDevices :: IO [Removable]
getRemovableDevices = mapMaybe toDev
. lines
. stripWS
<$> readProcess "lsblk" ["-n", "-r", "-o", columns] ""
where
columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE"
-- can't use 'words' here since it will drop spaces in the front
toDev line = case splitBy ' ' line of
("":_) -> Nothing
[_, "1", p, "", s] -> mk p $ s ++ " Volume"
[_, "1", p, l, _] -> mk p l
_ -> Nothing
mk p l = Just $ Removable { path = p
, label = l
, mountpoint = Nothing
}
getRemovableActions :: IO RofiActions
getRemovableActions = alignEntries . toRofiActions
<$> (mapM mkAction =<< getRemovableDevices)
--------------------------------------------------------------------------------
-- | CIFS Devices
--
-- This wraps the Removable device (since it is removable) and also adds its
-- own mount options and credentials for authentication.
data CIFS = CIFS Removable MountOptions Credentials
instance Mountable CIFS where
-- | Mount using udevil
mount (CIFS Removable{..} opts creds) False = do
pwd <- getPassword creds
let opts' = fmtOpts $ addPwd pwd opts
res <- readCmdEither "udevil" (["mount"] ++ opts' ++ ["-t", "cifs", path]) ""
notifyMounted (isRight res) False label
where
addPwd (Just pwd) o = M.insert "password" (Just pwd) o
addPwd Nothing o = o
fmtOpts o = if null o then [] else ["-o", fmtMountOptions o]
-- | Unmount using udevil
mount (CIFS Removable{..} _ _) True = do
res <- readCmdEither "udevil" ["unmount", path] ""
notifyMounted (isRight res) True label
-- | Need udevil and mount.cifs
allInstalled _ = all isJust <$> mapM findExecutable ["udevil", "mount.cifs"]
-- | Return True if mounted. Only checks the removable type wrapped within
isMounted (CIFS r _ _) = isMounted r
-- | Format the Rofi entry like 'LABEL - (CIFS) - PATH' and prefix with a star
-- if mounted
fmtEntry (CIFS r _ _) = fmtNetEntry r "CIFS"
--------------------------------------------------------------------------------
-- | SSHFS Devices
--
-- This wraps the Removable device (since it is removable) and also adds its
-- own mount options. If the path does not point to an aliased entry in the ssh
-- config that specifies the port, hostname, user, and identity file, these
-- need to be passed as mount options.
data SSHFS = SSHFS Removable MountOptions
instance Mountable SSHFS where
-- | Mount using sshfs
mount (SSHFS Removable{..} opts) False =
case mountpoint of
Just m -> cmd m
-- TODO only destroy mountpoint if it is not already another mountpoint
Nothing -> bracketOnError (makeFuseMount label)
(const $ destroyFuseMount label) (const $ cmd $ fmtFusePath label)
where
-- TODO add auto-dismount to options
opts' = if null opts then [] else ["-o", fmtMountOptions opts]
cmd m' = do
res <- readCmdEither "sshfs" ([path, m'] ++ opts') ""
notifyMounted (isRight res) False label
-- | Umount using fusermount
mount (SSHFS r _) True = fuseUnmount r
-- | Need sshfs (assume fuse is also installed)
allInstalled _ = isJust <$> findExecutable "sshfs"
-- | Return True if mounted. Only checks the removable type wrapped within
isMounted (SSHFS r _) = isMounted r
-- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH' and prefix with a
-- star if mounted
fmtEntry (SSHFS r _) = fmtNetEntry r "SSHFS"
-- | Given a removable device, type string, and boolean for if the device is
-- mounted, return a string like 'LABEL - (TYPESTRING) - PATH' and prefix with a
-- star if mounted
fmtNetEntry :: Removable -> String -> String
fmtNetEntry Removable { label = l, path = p } t =
intercalate alignSepPre [l, t, p]
--------------------------------------------------------------------------------
-- | MTP devices
data MTPFS = MTPFS
{ bus :: String
, device :: String
, mountpointMTP :: String
, description :: String
}
deriving (Eq, Show)
instance Mountable MTPFS where
-- | Mount using sshfs
mount MTPFS {..} False = do
-- TODO add autodismount to options
let dev = "-device=" ++ bus ++ "," ++ device
bracketOnError (createDirectoryIfMissing False mountpointMTP)
(const $ removePathForcibly mountpointMTP) $ \_ -> do
res <- readCmdEither "jmtpfs" [dev, mountpointMTP] ""
notifyMounted (isRight res) False description
-- | Umount using fusermount
mount MTPFS { mountpointMTP = m, description = d } True =
finally (fuseUnmount' d m) $ removePathForcibly m
-- | Need jmtpfs (assume fuse is also installed)
allInstalled _ = isJust <$> findExecutable "jmtpfs"
-- | Return True if mounted. Only checks the mountpoint path
isMounted MTPFS { mountpointMTP = m } = elem m . fmap snd <$> curMountpoints
-- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH'
fmtEntry MTPFS { description = d } = d
getMTPDevices :: IO [MTPFS]
getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] ""
where
toDevList = reverse
. takeWhile (not . isPrefixOf "Available devices")
. reverse
. lines
toDev s = case splitOn ", " s of
[busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
in Just $ MTPFS
{ bus = busNum
, device = devNum
, mountpointMTP = fuseMount ++ canonicalize d
, description = d
}
_ -> Nothing
canonicalize = mapMaybe repl
repl c
| c `elem` ("\"*/:<>?\\|" :: String) = Nothing
| c == ' ' = Just '-'
| otherwise = Just c
getMTPActions :: IO RofiActions
getMTPActions = toRofiActions <$> (mapM mkAction =<< getMTPDevices)
-- TODO add truecrypt volumes (see tcplay, will need root)
--------------------------------------------------------------------------------
-- | Csv device parsing
--
-- These devices are stored in a CSV file which needs to be parsed into the
-- appropriate devices types
-- | Represents one parsable line in the network device config .tsv file
data CsvDev = CsvDev
{ csvLabel :: String
, csvType :: String
, csvPath :: String
, csvMountpoint :: Maybe String
, csvMountOptions :: Maybe String
, csvCredentials :: Maybe String
}
deriving (Generic, Show)
instance FromRecord CsvDev
-- | Return a list of all Csv lines from the network config file
getCSV :: IO [CsvDev]
getCSV = do
xdgConf <- getEnv "XDG_CONFIG_HOME"
-- TODO this shouldn't be hardcoded
contents <- B.readFile $ xdgConf ++ "/rofi/devices.tsv"
let opts = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') }
case decodeWith opts HasHeader contents of
Left s -> putStrLn s >> return []
Right v -> return $ toList (v :: Vector CsvDev)
-- TODO split this into each device type so they can be separated in the prompt
-- | Given a parsed csv line from the network config file, return a
-- (ENTRY, ACTION) where ENTRY is a string to appear on the Rofi prompt and
-- ACTION is an action to perform on the device in the csv line when selected
csvToAction :: CsvDev -> IO (Maybe (String, RofiPrompt ()))
csvToAction CsvDev {..}
| csvType == "cifs" = Just <$> mkAction (CIFS r' opts creds)
| csvType == "sshfs" = Just <$> mkAction (SSHFS r opts)
| otherwise = return Nothing
where
r = Removable { label = csvLabel
, path = csvPath
, mountpoint = csvMountpoint
}
opts = maybe M.empty parseMountOptions csvMountOptions
creds = maybe NoCredentials parseCredentials csvCredentials
-- CIFS prefixes the path with two slashes
r' = r { path = smartSlashPrefix csvPath }
smartSlashPrefix s = if "//" `isPrefixOf` s then s else "//" ++ s
--------------------------------------------------------------------------------
-- | Low-level mount functions
-- | Return a list of mountpoints like (PATH, MOUNTPOINT) from /proc/mount
curMountpoints :: IO [(String, String)]
curMountpoints = do
m <- readFile "/proc/mounts"
-- ASSUME this will never fail because the format of this file is fixed
return $ (\(path:mntpnt:_) -> (path, mntpnt)) . words <$> lines m
-- | Given a path, return its mountpoint if it exists
lookupMountpoint :: String -> IO (Maybe String)
lookupMountpoint path = lookup path <$> curMountpoints
-- | Given a removable device, unmount it using fuse
fuseUnmount :: Removable -> IO ()
fuseUnmount Removable { path = p, mountpoint = m, label = l } =
maybe umountDef umount m
where
umount = fuseUnmount' l
umountDef = lookupMountpoint p >>=
mapM_ (liftM2 finally umount removePathForcibly)
fuseUnmount' :: String -> String -> IO ()
fuseUnmount' label path = do
res <- readCmdEither "fusermount" ["-u", path] ""
notifyMounted (isRight res) True label
-- | Given credentials, return a password
getPassword :: Credentials -> IO (Maybe String)
getPassword NoCredentials = return Nothing
getPassword (Secret kvs) = do
let kvs' = concat [[a, b] | (a, b) <- M.toList kvs]
readCmdSuccess "secret-tool" ("lookup":kvs') ""
-- TODO this shouldn't be hardcoded
fuseMount :: FilePath
fuseMount = "/media/ndwar-fuse/"
-- TODO what if there is no trailing slash?
fmtFusePath :: String -> String
fmtFusePath label = fuseMount ++ label
makeFuseMount :: String -> IO ()
makeFuseMount label = createDirectoryIfMissing False $ fmtFusePath label
destroyFuseMount :: String -> IO ()
destroyFuseMount label = removePathForcibly $ fmtFusePath label
--------------------------------------------------------------------------------
-- | Other functions
-- TODO this exists somewhere...
splitBy :: Char -> String -> [String]
splitBy delimiter = foldr f [[]]
where
f _ [] = []
f c l@(x:xs) | c == delimiter = []:l
| otherwise = (c:x):xs
notifyMounted :: Bool -> Bool -> String -> IO ()
notifyMounted succeeded mounted label = void $ spawnProcess "notify-send" [msg]
where
f = if succeeded then "Successfully %sed %s" else "Failed to %s %s"
m = if mounted then "unmount" else "mount" :: String
msg = printf f m label

164
lib/Rofi/Command.hs Normal file
View File

@ -0,0 +1,164 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Rofi.Command
( RofiConf(..)
, RofiMenu(..)
, RofiAction
, RofiActions
, RofiPrompt
, Hotkey(..)
, io
, emptyMenu
, runRofiPrompt
, toRofiActions
, rofiActionKeys
, untitledGroup
, titledGroup
, selectAction
, readCmdSuccess
, readCmdEither
, dmenuArgs
, joinNewline
, stripWS
) where
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
newtype RofiConf = RofiConf
{ defArgs :: [String]
}
deriving (Eq, Show)
type RofiAction = (String, RofiPrompt ())
type RofiActions = M.OMap String (RofiPrompt ())
data RofiGroup = RofiGroup
{ actions :: RofiActions
, title :: Maybe String
}
untitledGroup :: RofiActions -> RofiGroup
untitledGroup a = RofiGroup { actions = a, title = Nothing }
titledGroup :: String -> RofiActions -> RofiGroup
titledGroup t a = (untitledGroup a) { title = Just t }
data Hotkey = Hotkey
{ keyCombo :: String
-- only 1-10 are valid
, keyIndex :: Int
, keyDescription :: String
, keyActions :: RofiActions
}
hotkeyBinding :: Hotkey -> [String]
hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
where
k = "-kb-custom-" ++ show e
hotkeyMsg1 :: Hotkey -> String
hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
c ++ ": <i>" ++ d ++ "</i>"
hotkeyMsg :: [Hotkey] -> [String]
hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey] -> [String]
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
data RofiMenu = RofiMenu
{ groups :: [RofiGroup]
, prompt :: Maybe String
, hotkeys :: [Hotkey]
}
emptyMenu :: RofiMenu
emptyMenu = RofiMenu
{ groups = []
, prompt = Nothing
, hotkeys = []
}
newtype RofiPrompt a = RofiPrompt (ReaderT RofiConf IO a)
deriving (Functor, Monad, MonadIO, MonadReader RofiConf)
instance Applicative RofiPrompt where
pure = return
(<*>) = ap
io :: IO a -> RofiPrompt a
io = liftIO
runRofiPrompt :: RofiConf -> RofiPrompt a -> IO a
runRofiPrompt c (RofiPrompt a) = runReaderT a c
toRofiActions :: [(String, RofiPrompt ())] -> RofiActions
toRofiActions = M.fromList
rofiActionKeys :: RofiActions -> String
rofiActionKeys = joinNewline . map fst . M.assocs
lookupRofiAction :: String -> RofiActions -> RofiPrompt ()
lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
groupEntries :: RofiGroup -> String
groupEntries RofiGroup { actions = a, title = t }
| null a = ""
| otherwise = title' ++ rofiActionKeys a
where
title' = maybe "" (++ "\n") t
menuActions :: RofiMenu -> RofiActions
menuActions = foldr1 (M.<>|) . fmap actions . groups
menuEntries :: RofiMenu -> String
menuEntries = intercalate "\n\n" . fmap groupEntries . groups
selectAction :: RofiMenu -> RofiPrompt ()
selectAction rm = do
let p = maybeOption "-p" $ prompt rm
let hArgs = hotkeyArgs $ hotkeys rm
res <- readRofi (p ++ hArgs) $ menuEntries rm
case res of
Right key -> lookupRofiAction key $ menuActions rm
Left (n, key, _) -> mapM_ (lookupRofiAction key . keyActions)
$ find ((==) n . (+ 9) . keyIndex)
$ hotkeys rm
maybeOption :: String -> Maybe String -> [String]
maybeOption switch = maybe [] (\o -> [switch, o])
dmenuArgs :: [String]
dmenuArgs = ["-dmenu"]
readRofi :: [String] -> String -> RofiPrompt (Either (Int, String, String) String)
readRofi uargs input = do
dargs <- asks defArgs
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
readCmdSuccess cmd args input = either (const Nothing) Just
<$> readCmdEither cmd args input
readCmdEither :: String -> [String] -> String -> IO (Either (Int, String, String) String)
readCmdEither cmd args input = do
(ec, out, err) <- readProcessWithExitCode cmd args input
return $ case ec of
ExitSuccess -> Right $ stripWS out
ExitFailure n -> Left (n, stripWS out, stripWS err)
stripWS :: String -> String
stripWS = reverse . dropWhile isSpace . reverse
joinNewline :: [String] -> String
joinNewline = intercalate "\n"

64
package.yaml Normal file
View File

@ -0,0 +1,64 @@
name: rofi-extras
version: 0.1.0.0
github: "ndwarshuis/rofi-extras"
license: BSD3
author: "Nathan Dwarshuis"
maintainer: "ndwar@yavin4.ch"
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>
dependencies:
- base >= 4.7 && < 5
- process >= 1.6.5.0
- aeson >= 1.4.5.0
- unix-time >= 0.4.7
- dbus >= 1.2.7
- ordered-containers >= 0.2.2
- Clipboard >= 2.3.2.0
- mtl >= 2.2.2
- directory >= 1.3.3.0
- cassava >= 0.5.2.0
- bytestring >= 0.10.8.2
- vector >= 0.12.0.3
- regex-tdfa >= 1.2.3.2
- split >= 0.2.3.4
library:
source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -threaded
exposed-modules:
- Rofi.Command
executables:
rofi-bw:
main: rofi-bitwarden.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras
rofi-dev:
main: rofi-devices.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
dependencies:
- rofi-extras

66
stack.yaml Normal file
View File

@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-14.12
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

12
stack.yaml.lock Normal file
View File

@ -0,0 +1,12 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages: []
snapshots:
- completed:
size: 545658
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml
sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406
original: lts-14.12