rofi-extras/lib/Bitwarden/Internal.hs

module Bitwarden.Internal
  ( Item (..)
  , Login (..)
  , Session
  , runDaemon
  , runClient
  , getItems
  , callGetSession
  )
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

--------------------------------------------------------------------------------

-- | 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 :: !T.Text
  }

type Session = MVar (Maybe CurrentSession)

runDaemon :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => Int -> m ()
runDaemon t = do
  ses <- newMVar Nothing
  let c = BWServerConf {timeout = UnixDiffTime (fromIntegral t) 0}
  startService c ses
  forever $ threadDelay 1000000

lockSession :: MonadIO m => Session -> m ()
lockSession ses = void $ swapMVar ses Nothing

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] ""
    notify res =
      let j = isJust res
       in notifyStatus j $ if j then "sync succeeded" else "sync failed"

getSession' :: MonadUnliftIO m => BWServerConf -> Session -> m (Maybe T.Text)
getSession' BWServerConf {timeout = t} ses = do
  ut <- liftIO $ 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' "Bitwarden Password"
      newHash <- join <$> mapM readSession pwd
      (,newHash) <$> mapM newSession newHash
    newSession h = do
      ut <- liftIO $ getUnixTime
      return CurrentSession {timestamp = ut, hash = h}

getSession :: MonadUnliftIO m => BWServerConf -> Session -> m T.Text
getSession conf ses = fromMaybe "" <$> getSession' conf ses

readSession :: MonadIO m => T.Text -> m (Maybe T.Text)
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""

notifyStatus :: MonadIO m => Bool -> T.Text -> m ()
notifyStatus succeeded msg =
  void $ liftIO $ spawnProcess "notify-send" ["-i", i, T.unpack 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
data BWClientConf c = BWClientConf
  { bwArgs :: ![T.Text]
  , bwEnv :: !c
  }

instance HasRofiConf (BWClientConf c) where
  defArgs = bwArgs

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
    ras =
      [ ("Browse Logins", browseLogins)
      , ("Sync Session", callSyncSession)
      , ("Lock Session", callLockSession)
      ]

browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c ()
browseLogins = getItems >>= selectItem

getItems :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m [Item]
getItems = maybe (return []) getItems' =<< callGetSession

getItems' :: MonadIO m => T.Text -> m [Item]
getItems' session = do
  items <- liftIO $ readProcess "bw" ["list", "items", "--session", T.unpack session] ""
  return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
  where
    notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
      False
    notEmpty _ = True

data Item = Item
  { name :: T.Text
  , 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 T.Text
  , password :: Maybe T.Text
  }
  deriving (Show, Generic)

instance FromJSON Login

-- TODO make menu buttons here to go back and to copy without leaving
-- the current menu
selectItem :: (HasLogFunc c, HasRofiConf c) => [Item] -> RIO c ()
selectItem items =
  selectAction $
    emptyMenu
      { groups = [untitledGroup $ itemsToRofiActions items]
      , prompt = Just "Login"
      }

itemsToRofiActions :: (HasLogFunc c, HasRofiConf c) => [Item] -> RofiActions c
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))

selectCopy :: (HasLogFunc c, HasRofiConf c) => Login -> RIO c ()
selectCopy l =
  selectAction $
    emptyMenu
      { groups = [untitledGroup $ loginToRofiActions l copy]
      , prompt = Just "Copy"
      , hotkeys = [copyHotkey, backHotkey]
      }
  where
    copy = io . setClipboardString . T.unpack
    copyRepeat s = copy s >> selectCopy l
    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)
        }

loginToRofiActions :: Login -> (T.Text -> RIO c ()) -> RofiActions c
loginToRofiActions Login {username = u, password = p} a =
  toRofiActions $ catMaybes [user, pwd]
  where
    copyIfJust f = fmap $ liftM2 (,) f a
    fmtUsername s = T.concat ["Username (", s, ")"]
    fmtPassword s = T.concat ["Password (", T.take 32 (T.replicate (T.length s) "*"), ")"]
    user = copyIfJust fmtUsername u
    pwd = copyIfJust fmtPassword p

getItemPassword' :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m (Maybe T.Text)
getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
  where
    getPwd = fmap T.pack . pr
    pr s =
      liftIO $
        readProcess
          "bw"
          ["get", "password", T.unpack item, "--session", T.unpack s]
          ""

getItemPassword :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m T.Text
getItemPassword conf session item =
  fromMaybe ""
    <$> getItemPassword' conf session item

--------------------------------------------------------------------------------

-- | DBus
startService :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => BWServerConf -> Session -> m ()
startService c ses = do
  client <- liftIO $ connectSession
  let flags = [nameAllowReplacement, nameReplaceExisting]
  _ <- 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"

callMember :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => MemberName -> m [Variant]
callMember m = do
  reply <- callMethod $ methodCall path interface m
  case reply of
    Left err -> do
      logError $
        displayBytesUtf8 $
          encodeUtf8 $
            (T.pack (methodErrorMessage err))
      return []
    Right body -> return body

callLockSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
callLockSession = void $ callMember memLockSession

callSyncSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
callSyncSession = void $ callMember memSyncSession

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

getBodyString :: [Variant] -> Maybe T.Text
getBodyString [b] = case fromVariant b :: Maybe T.Text of
  Just "" -> Nothing
  s -> s
getBodyString _ = Nothing

callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant])
callMethod mc = liftIO $ do
  client <- connectSession
  reply <- call client mc {methodCallDestination = Just busname}
  disconnect client
  return $ methodReturnBody <$> reply