From 4cbdad193b36bb9c366582ce3e8888cea69deeeb Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 11 Dec 2020 21:18:17 -0500 Subject: [PATCH] REF move most of the bitwarden code to an internal module --- app/rofi-bw.hs | 266 +----------------------------------- lib/Bitwarden/Internal.hs | 279 ++++++++++++++++++++++++++++++++++++++ package.yaml | 1 + 3 files changed, 285 insertions(+), 261 deletions(-) create mode 100644 lib/Bitwarden/Internal.hs diff --git a/app/rofi-bw.hs b/app/rofi-bw.hs index 4345217..886539c 100644 --- a/app/rofi-bw.hs +++ b/app/rofi-bw.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -------------------------------------------------------------------------------- -- | rofi-bw - a rofi prompt for a bitwarden vault @@ -14,31 +12,25 @@ -- In order to manage the session keys, this utility is split into a daemon and -- client (the former holds the session keys between calls with the latter). -- They communicate via dbus. +-- +-- Most of the heavy-lifting code for this executable is in Bitwarden.Internal +-- to allow parts of this greater rofi library to use the DBus API module Main (main) where -import Control.Concurrent +import Bitwarden.Internal + 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 @@ -64,251 +56,3 @@ checkExe cmd = do 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 BWServerConf = BWServerConf - { timeout :: UnixDiffTime - } - --- TODO add a cache so the browse list will load faster -data CurrentSession = CurrentSession - { timestamp :: UnixTime - , hash :: String - } - -type Session = MVar (Maybe CurrentSession) - -runDaemon :: Int -> IO () -runDaemon t = do - ses <- newMVar Nothing - let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 } - startService c ses - forever $ threadDelay 1000000 - -lockSession :: Session -> IO () -lockSession ses = void $ swapMVar ses Nothing - -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 - in notifyStatus j $ if j then "sync succeeded" else "sync failed" - -getSession' :: BWServerConf -> Session -> IO (Maybe String) -getSession' BWServerConf { timeout = t } ses = do - ut <- getUnixTime - modifyMVar ses $ \s -> case s of - Just CurrentSession { timestamp = ts, hash = h } -> - if diffUnixTime ut ts > t then getNewSession else return (s, Just h) - Nothing -> getNewSession - where - getNewSession = do - pwd <- readPassword - newHash <- join <$> mapM readSession pwd - (, newHash) <$> mapM newSession newHash - newSession h = do - ut <- getUnixTime - return CurrentSession { timestamp = ut, hash = h } - -getSession :: BWServerConf -> Session -> IO String -getSession conf ses = fromMaybe "" <$> getSession' conf ses - -readSession :: String -> IO (Maybe String) -readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] "" - -notifyStatus :: Bool -> String -> IO () -notifyStatus succeeded msg = - void $ spawnProcess "notify-send" ["-i", i, msg] - where - 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 --- 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 - -newtype BWClientConf = BWClientConf [String] - -instance RofiConf BWClientConf where - defArgs (BWClientConf a) = a - -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", io callSyncSession) - , ("Lock Session", io callLockSession) - ] - -browseLogins :: RofiConf c => RofiIO c () -browseLogins = do - session <- io callGetSession - forM_ session $ (io . getItems) >=> selectItem - --- TODO use this in rofi-dev to mount thing using BW passwords -getItems :: String -> IO [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 :: RofiConf c => [Item] -> RofiIO c () -selectItem items = selectAction $ emptyMenu - { groups = [untitledGroup $ itemsToRofiActions items] - , prompt = Just "Login" - } - -itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c -itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i)) - -selectCopy :: RofiConf c => Login -> RofiIO c () -selectCopy l = selectAction $ emptyMenu - { groups = [untitledGroup $ loginToRofiActions l copy] - , prompt = Just "Copy" - , hotkeys = [copyHotkey, backHotkey] - } - 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 :: 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 = "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" - -memSyncSession :: MemberName -memSyncSession = "SyncSession" - -startService :: BWServerConf -> 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 - , autoMethod memSyncSession $ syncSession c ses - ] - } - -callMember :: MemberName -> IO [Variant] -callMember m = do - reply <- callMethod $ methodCall path interface m - case reply of - Left err -> putStrLn (methodErrorMessage err) >> return [] - Right body -> return body - -callLockSession :: IO () -callLockSession = void $ callMember memLockSession - -callSyncSession :: IO () -callSyncSession = void $ callMember memSyncSession - -callGetSession :: IO (Maybe String) -callGetSession = getBodySession <$> callMember memGetSession - -getBodySession :: [Variant] -> Maybe String -getBodySession [b] = case fromVariant b :: Maybe String of - Just "" -> Nothing - s -> s -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 diff --git a/lib/Bitwarden/Internal.hs b/lib/Bitwarden/Internal.hs new file mode 100644 index 0000000..7cd2632 --- /dev/null +++ b/lib/Bitwarden/Internal.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Bitwarden.Internal + ( Item(..) + , Login(..) + , Session + , runDaemon + , runClient + , getItems + , callGetSession + ) where + +import Control.Concurrent +import Control.Monad + +import Data.Aeson +import Data.Maybe +import Data.String +import Data.UnixTime + +import DBus +import DBus.Client + +import GHC.Generics + +import Rofi.Command + +import System.Clipboard +import System.Process + +-------------------------------------------------------------------------------- +-- | 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 BWServerConf = BWServerConf + { timeout :: UnixDiffTime + } + +-- TODO add a cache so the browse list will load faster +data CurrentSession = CurrentSession + { timestamp :: UnixTime + , hash :: String + } + +type Session = MVar (Maybe CurrentSession) + +runDaemon :: Int -> IO () +runDaemon t = do + ses <- newMVar Nothing + let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 } + startService c ses + forever $ threadDelay 1000000 + +lockSession :: Session -> IO () +lockSession ses = void $ swapMVar ses Nothing + +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 + in notifyStatus j $ if j then "sync succeeded" else "sync failed" + +getSession' :: BWServerConf -> Session -> IO (Maybe String) +getSession' BWServerConf { timeout = t } ses = do + ut <- getUnixTime + modifyMVar ses $ \s -> case s of + Just CurrentSession { timestamp = ts, hash = h } -> + if diffUnixTime ut ts > t then getNewSession else return (s, Just h) + Nothing -> getNewSession + where + getNewSession = do + pwd <- readPassword + newHash <- join <$> mapM readSession pwd + (, newHash) <$> mapM newSession newHash + newSession h = do + ut <- getUnixTime + return CurrentSession { timestamp = ut, hash = h } + +getSession :: BWServerConf -> Session -> IO String +getSession conf ses = fromMaybe "" <$> getSession' conf ses + +readSession :: String -> IO (Maybe String) +readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] "" + +notifyStatus :: Bool -> String -> IO () +notifyStatus succeeded msg = + void $ spawnProcess "notify-send" ["-i", i, msg] + where + 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 +-- 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 + +newtype BWClientConf = BWClientConf [String] + +instance RofiConf BWClientConf where + defArgs (BWClientConf a) = a + +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", io callSyncSession) + , ("Lock Session", io callLockSession) + ] + +browseLogins :: RofiConf c => RofiIO c () +browseLogins = do + session <- io callGetSession + forM_ session $ (io . getItems) >=> selectItem + +-- TODO use this in rofi-dev to mount thing using BW passwords +getItems :: String -> IO [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 :: RofiConf c => [Item] -> RofiIO c () +selectItem items = selectAction $ emptyMenu + { groups = [untitledGroup $ itemsToRofiActions items] + , prompt = Just "Login" + } + +itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c +itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i)) + +selectCopy :: RofiConf c => Login -> RofiIO c () +selectCopy l = selectAction $ emptyMenu + { groups = [untitledGroup $ loginToRofiActions l copy] + , prompt = Just "Copy" + , hotkeys = [copyHotkey, backHotkey] + } + 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 :: 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 = "Username (" ++ s ++ ")" + fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")" + user = copyIfJust fmtUsername u + pwd = copyIfJust fmtPassword p + +-------------------------------------------------------------------------------- +-- | DBus + +startService :: BWServerConf -> 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 + , autoMethod memSyncSession $ syncSession c ses + ] + } + +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" + +memSyncSession :: MemberName +memSyncSession = "SyncSession" + +callMember :: MemberName -> IO [Variant] +callMember m = do + reply <- callMethod $ methodCall path interface m + case reply of + Left err -> putStrLn (methodErrorMessage err) >> return [] + Right body -> return body + +callLockSession :: IO () +callLockSession = void $ callMember memLockSession + +callSyncSession :: IO () +callSyncSession = void $ callMember memSyncSession + +callGetSession :: IO (Maybe String) +callGetSession = getBodySession <$> callMember memGetSession + +getBodySession :: [Variant] -> Maybe String +getBodySession [b] = case fromVariant b :: Maybe String of + Just "" -> Nothing + s -> s +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 diff --git a/package.yaml b/package.yaml index 06121fd..192e20f 100644 --- a/package.yaml +++ b/package.yaml @@ -47,6 +47,7 @@ library: - -Werror - -threaded exposed-modules: + - Bitwarden.Internal - Rofi.Command executables: