ADD sync session functionality

This commit is contained in:
Nathan Dwarshuis 2020-05-11 22:45:26 -04:00
parent bfdb50d6a5
commit e21b581e6c
1 changed files with 42 additions and 17 deletions

View File

@ -97,25 +97,43 @@ runDaemon t = do
lockSession :: Session -> IO () lockSession :: Session -> IO ()
lockSession ses = void $ swapMVar ses Nothing lockSession ses = void $ swapMVar ses Nothing
getSession :: BWServerConf -> Session -> IO String syncSession :: BWServerConf -> Session -> IO ()
getSession BWServerConf { timeout = t } ses = do 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 ut <- getUnixTime
modifyMVar ses $ \s -> case s of modifyMVar ses $ \s -> case s of
Just CurrentSession { timestamp = ts, hash = h } -> Just CurrentSession { timestamp = ts, hash = h } ->
if diffUnixTime ut ts > t then getNewSession else return (s, h) if diffUnixTime ut ts > t then getNewSession else return (s, Just h)
Nothing -> getNewSession Nothing -> getNewSession
where where
getNewSession = do getNewSession = do
pwd <- readPassword pwd <- readPassword
newHash <- join <$> mapM readSession pwd newHash <- join <$> mapM readSession pwd
(, fromMaybe "" newHash) <$> mapM newSession newHash (, newHash) <$> mapM newSession newHash
newSession h = do newSession h = do
ut <- getUnixTime ut <- getUnixTime
return CurrentSession { timestamp = ut, hash = h } return CurrentSession { timestamp = ut, hash = h }
getSession :: BWServerConf -> Session -> IO String
getSession conf ses = fromMaybe "" <$> getSession' conf ses
readSession :: String -> IO (Maybe String) readSession :: String -> IO (Maybe String)
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] "" 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 -- | Client
-- --
@ -146,6 +164,7 @@ runClient a = do
} }
where where
ras = [ ("Browse Logins", browseLogins) ras = [ ("Browse Logins", browseLogins)
, ("Sync Session", io callSyncSession)
, ("Lock Session", io callLockSession) , ("Lock Session", io callLockSession)
] ]
@ -246,6 +265,9 @@ memGetSession = "GetSession"
memLockSession :: MemberName memLockSession :: MemberName
memLockSession = "LockSession" memLockSession = "LockSession"
memSyncSession :: MemberName
memSyncSession = "SyncSession"
startService :: BWServerConf -> Session -> IO () startService :: BWServerConf -> Session -> IO ()
startService c ses = do startService c ses = do
client <- connectSession client <- connectSession
@ -257,27 +279,30 @@ startService c ses = do
, interfaceMethods = , interfaceMethods =
[ autoMethod memGetSession $ getSession c ses [ autoMethod memGetSession $ getSession c ses
, autoMethod memLockSession $ lockSession ses , autoMethod memLockSession $ lockSession ses
, autoMethod memSyncSession $ syncSession c ses
] ]
} }
callLockSession :: IO () callMember :: MemberName -> IO [Variant]
callLockSession = do callMember m = do
reply <- callMethod $ methodCall path interface memLockSession reply <- callMethod $ methodCall path interface m
case reply of case reply of
Left err -> putStrLn $ methodErrorMessage err Left err -> putStrLn (methodErrorMessage err) >> return []
Right _ -> return () Right body -> return body
callLockSession :: IO ()
callLockSession = void $ callMember memLockSession
callSyncSession :: IO ()
callSyncSession = void $ callMember memSyncSession
callGetSession :: IO (Maybe String) callGetSession :: IO (Maybe String)
callGetSession = do callGetSession = getBodySession <$> callMember memGetSession
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 :: [Variant] -> Maybe String
getBodySession [b] = case ses of { Just "" -> Nothing; _ -> ses } getBodySession [b] = case fromVariant b :: Maybe String of
where Just "" -> Nothing
ses = fromVariant b :: Maybe String s -> s
getBodySession _ = Nothing getBodySession _ = Nothing
callMethod :: MethodCall -> IO (Either MethodError [Variant]) callMethod :: MethodCall -> IO (Either MethodError [Variant])