init commit
This commit is contained in:
commit
49c4f4cf1c
|
|
@ -0,0 +1,4 @@
|
|||
.stack-work/
|
||||
*~
|
||||
TAGS
|
||||
*.cabal
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue