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 qualified Data.Text.IO as TI
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 :: 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 T.Text)
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' "Bitwarden Password"
      newHash <- join <$> mapM readSession pwd
      (,newHash) <$> mapM newSession newHash
    newSession h = do
      ut <- getUnixTime
      return CurrentSession {timestamp = ut, hash = h}

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

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

notifyStatus :: Bool -> T.Text -> IO ()
notifyStatus succeeded msg =
  void $ 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
newtype BWClientConf = BWClientConf [T.Text]

instance HasRofiConf BWClientConf where
  defArgs (BWClientConf a) = a

runClient :: [T.Text] -> IO ()
runClient a = do
  let c = BWClientConf a
  runRofi c $
    emptyMenu
      { groups = [untitledGroup $ toRofiActions ras]
      , prompt = Just "Action"
      }
  where
    ras =
      [ ("Browse Logins", browseLogins)
      , ("Sync Session", io callSyncSession)
      , ("Lock Session", io callLockSession)
      ]

browseLogins :: HasRofiConf c => RIO c ()
browseLogins = io getItems >>= selectItem

getItems :: IO [Item]
getItems = maybe (return []) getItems' =<< callGetSession

getItems' :: T.Text -> IO [Item]
getItems' session = do
  items <- io $ 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 :: HasRofiConf c => [Item] -> RIO c ()
selectItem items =
  selectAction $
    emptyMenu
      { groups = [untitledGroup $ itemsToRofiActions items]
      , prompt = Just "Login"
      }

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

selectCopy :: 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' :: BWServerConf -> Session -> T.Text -> IO (Maybe T.Text)
getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
  where
    getPwd s =
      T.pack
        <$> readProcess
          "bw"
          ["get", "password", T.unpack item, "--session", T.unpack s]
          ""

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

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

-- | DBus
startService :: BWServerConf -> Session -> IO ()
startService c ses = do
  client <- connectSession
  let flags = [nameAllowReplacement, nameReplaceExisting]
  _ <- requestName client busname flags
  TI.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
          , autoMethod memGetPassword $ 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 :: MemberName -> IO [Variant]
callMember m = do
  reply <- callMethod $ methodCall path interface m
  case reply of
    Left err -> TI.putStrLn (T.pack (methodErrorMessage err)) >> return []
    Right body -> return body

callLockSession :: IO ()
callLockSession = void $ callMember memLockSession

callSyncSession :: IO ()
callSyncSession = void $ callMember memSyncSession

callGetSession :: IO (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 :: MethodCall -> IO (Either MethodError [Variant])
callMethod mc = do
  client <- connectSession
  reply <- call client mc {methodCallDestination = Just busname}
  disconnect client
  return $ methodReturnBody <$> reply