rofi-extras/lib/Bitwarden/Internal.hs

316 lines
9.7 KiB
Haskell
Raw Normal View History

module Bitwarden.Internal
2023-02-13 22:19:49 -05:00
( Item (..)
, Login (..)
, Session
, runDaemon
, runClient
, getItems
, callGetSession
2023-02-13 22:19:49 -05:00
)
where
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
--------------------------------------------------------------------------------
2023-02-13 22:19:49 -05:00
-- | 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
2023-02-13 22:19:49 -05:00
{ timeout :: UnixDiffTime
}
-- TODO add a cache so the browse list will load faster
data CurrentSession = CurrentSession
2023-02-22 22:44:44 -05:00
{ timestamp :: !UnixTime
, hash :: !T.Text
2023-02-13 22:19:49 -05:00
}
type Session = MVar (Maybe CurrentSession)
2023-02-22 22:44:44 -05:00
runDaemon :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => Int -> m ()
runDaemon t = do
ses <- newMVar Nothing
2023-02-13 22:19:49 -05:00
let c = BWServerConf {timeout = UnixDiffTime (fromIntegral t) 0}
startService c ses
forever $ threadDelay 1000000
2023-02-22 22:44:44 -05:00
lockSession :: MonadIO m => Session -> m ()
lockSession ses = void $ swapMVar ses Nothing
2023-02-22 22:44:44 -05:00
syncSession :: MonadUnliftIO m => BWServerConf -> Session -> m ()
syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
where
cmd h = readCmdSuccess "bw" ["sync", "--session", h] ""
2023-02-13 22:19:49 -05:00
notify res =
let j = isJust res
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
2023-02-22 22:44:44 -05:00
getSession' :: MonadUnliftIO m => BWServerConf -> Session -> m (Maybe T.Text)
2023-02-13 22:19:49 -05:00
getSession' BWServerConf {timeout = t} ses = do
2023-02-22 22:44:44 -05:00
ut <- liftIO $ getUnixTime
modifyMVar ses $ \s -> case s of
2023-02-13 22:19:49 -05:00
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' "Bitwarden Password"
newHash <- join <$> mapM readSession pwd
2023-02-13 22:19:49 -05:00
(,newHash) <$> mapM newSession newHash
newSession h = do
2023-02-22 22:44:44 -05:00
ut <- liftIO $ getUnixTime
2023-02-13 22:19:49 -05:00
return CurrentSession {timestamp = ut, hash = h}
2023-02-22 22:44:44 -05:00
getSession :: MonadUnliftIO m => BWServerConf -> Session -> m T.Text
getSession conf ses = fromMaybe "" <$> getSession' conf ses
2023-02-22 22:44:44 -05:00
readSession :: MonadIO m => T.Text -> m (Maybe T.Text)
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
2023-02-22 22:44:44 -05:00
notifyStatus :: MonadIO m => Bool -> T.Text -> m ()
notifyStatus succeeded msg =
2023-02-22 22:44:44 -05:00
void $ liftIO $ spawnProcess "notify-send" ["-i", i, T.unpack msg]
where
2023-02-13 22:19:49 -05:00
i =
if succeeded
then "dialog-information-symbolic"
else "dialog-error-symbolic"
--------------------------------------------------------------------------------
2023-02-13 22:19:49 -05:00
-- | 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
2023-02-22 22:44:44 -05:00
data BWClientConf c = BWClientConf
{ bwArgs :: ![T.Text]
, bwEnv :: !c
}
2023-02-22 22:44:44 -05:00
instance HasRofiConf (BWClientConf c) where
defArgs = bwArgs
2023-02-22 22:44:44 -05:00
instance HasLogFunc c => HasLogFunc (BWClientConf c) where
logFuncL = lens bwEnv (\x y -> x {bwEnv = y}) . logFuncL
runClient :: HasLogFunc c => [T.Text] -> RIO c ()
runClient a =
mapRIO (BWClientConf a) $
selectAction $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action"
}
where
2023-02-13 22:19:49 -05:00
ras =
[ ("Browse Logins", browseLogins)
2023-02-22 22:44:44 -05:00
, ("Sync Session", callSyncSession)
, ("Lock Session", callLockSession)
2023-02-13 22:19:49 -05:00
]
2023-02-22 22:44:44 -05:00
browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c ()
browseLogins = getItems >>= selectItem
2023-02-22 22:44:44 -05:00
getItems :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m [Item]
getItems = maybe (return []) getItems' =<< callGetSession
2023-02-22 22:44:44 -05:00
getItems' :: MonadIO m => T.Text -> m [Item]
getItems' session = do
2023-02-22 22:44:44 -05:00
items <- liftIO $ readProcess "bw" ["list", "items", "--session", T.unpack session] ""
return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
where
2023-02-13 22:19:49 -05:00
notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
False
notEmpty _ = True
data Item = Item
2023-02-13 23:31:50 -05:00
{ name :: T.Text
2023-02-13 22:19:49 -05:00
, login :: Login
}
deriving (Show)
instance FromJSON Item where
2023-02-13 22:19:49 -05:00
parseJSON (Object o) =
Item
<$> o .: "name"
<*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
parseJSON _ = mzero
data Login = Login
2023-02-13 23:31:50 -05:00
{ username :: Maybe T.Text
, password :: Maybe T.Text
2023-02-13 22:19:49 -05:00
}
deriving (Show, Generic)
instance FromJSON Login
-- TODO make menu buttons here to go back and to copy without leaving
-- the current menu
2023-02-22 22:44:44 -05:00
selectItem :: (HasLogFunc c, HasRofiConf c) => [Item] -> RIO c ()
2023-02-13 22:19:49 -05:00
selectItem items =
selectAction $
emptyMenu
{ groups = [untitledGroup $ itemsToRofiActions items]
, prompt = Just "Login"
}
2023-02-22 22:44:44 -05:00
itemsToRofiActions :: (HasLogFunc c, HasRofiConf c) => [Item] -> RofiActions c
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
2023-02-22 22:44:44 -05:00
selectCopy :: (HasLogFunc c, HasRofiConf c) => Login -> RIO c ()
2023-02-13 22:19:49 -05:00
selectCopy l =
selectAction $
emptyMenu
{ groups = [untitledGroup $ loginToRofiActions l copy]
, prompt = Just "Copy"
, hotkeys = [copyHotkey, backHotkey]
}
where
2023-02-13 23:31:50 -05:00
copy = io . setClipboardString . T.unpack
copyRepeat s = copy s >> selectCopy l
2023-02-13 22:19:49 -05:00
copyHotkey =
Hotkey
{ keyCombo = "Alt+c"
, keyDescription = "Copy One"
, keyActions = loginToRofiActions l copyRepeat
}
backHotkey =
Hotkey
{ keyCombo = "Alt+q"
, 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)
}
2023-02-14 22:28:26 -05:00
loginToRofiActions :: Login -> (T.Text -> RIO c ()) -> RofiActions c
2023-02-13 22:19:49 -05:00
loginToRofiActions Login {username = u, password = p} a =
toRofiActions $ catMaybes [user, pwd]
where
copyIfJust f = fmap $ liftM2 (,) f a
2023-02-13 23:31:50 -05:00
fmtUsername s = T.concat ["Username (", s, ")"]
fmtPassword s = T.concat ["Password (", T.take 32 (T.replicate (T.length s) "*"), ")"]
user = copyIfJust fmtUsername u
pwd = copyIfJust fmtPassword p
2023-02-22 22:44:44 -05:00
getItemPassword' :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m (Maybe T.Text)
getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
where
2023-02-22 22:44:44 -05:00
getPwd = fmap T.pack . pr
pr s =
liftIO $
readProcess
2023-02-13 23:31:50 -05:00
"bw"
["get", "password", T.unpack item, "--session", T.unpack s]
""
2023-02-22 22:44:44 -05:00
getItemPassword :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m T.Text
2023-02-13 22:19:49 -05:00
getItemPassword conf session item =
fromMaybe ""
<$> getItemPassword' conf session item
--------------------------------------------------------------------------------
2023-02-13 22:19:49 -05:00
-- | DBus
2023-02-22 22:44:44 -05:00
startService :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => BWServerConf -> Session -> m ()
startService c ses = do
2023-02-22 22:44:44 -05:00
client <- liftIO $ connectSession
let flags = [nameAllowReplacement, nameReplaceExisting]
2023-02-22 22:44:44 -05:00
_ <- liftIO $ requestName client busname flags
logInfo "Started rofi bitwarden dbus client"
withRunInIO $ \runIO ->
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
]
}
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"
memGetPassword :: MemberName
memGetPassword = "GetPassword"
2023-02-22 22:44:44 -05:00
callMember :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => MemberName -> m [Variant]
callMember m = do
reply <- callMethod $ methodCall path interface m
case reply of
2023-02-22 22:44:44 -05:00
Left err -> do
logError $
displayBytesUtf8 $
encodeUtf8 $
(T.pack (methodErrorMessage err))
return []
Right body -> return body
2023-02-22 22:44:44 -05:00
callLockSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
callLockSession = void $ callMember memLockSession
2023-02-22 22:44:44 -05:00
callSyncSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
callSyncSession = void $ callMember memSyncSession
2023-02-22 22:44:44 -05:00
callGetSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m (Maybe T.Text)
callGetSession = getBodyString <$> callMember memGetSession
-- TODO maybe will need to add a caller for getItemPassword
2023-02-13 23:31:50 -05:00
getBodyString :: [Variant] -> Maybe T.Text
getBodyString [b] = case fromVariant b :: Maybe T.Text of
Just "" -> Nothing
2023-02-13 22:19:49 -05:00
s -> s
getBodyString _ = Nothing
2023-02-22 22:44:44 -05:00
callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant])
callMethod mc = liftIO $ do
client <- connectSession
2023-02-13 22:19:49 -05:00
reply <- call client mc {methodCallDestination = Just busname}
disconnect client
return $ methodReturnBody <$> reply