From ade511f6e309a1dd43ece7797127b29af3edba29 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 11 Sep 2012 15:51:27 -0400 Subject: keep webapp snappy by generating ssh keypair in the background --- Assistant/WebApp/Configurators/Pairing.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) (limited to 'Assistant') diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 1a80f1f75..87353be3c 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -87,19 +87,24 @@ getInprogressPairR _ = noPairing -} startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget startPairing stage oncancel alert muuid displaysecret secret = do - keypair <- liftIO $ genSshKeyPair dstatus <- daemonStatus <$> lift getYesod urlrender <- lift getUrlRender - pairdata <- PairData - <$> liftIO getHostname - <*> liftIO getUserName - <*> (fromJust . relDir <$> lift getYesod) - <*> pure (sshPubKey keypair) - <*> liftIO (maybe genUUID return muuid) - liftIO $ do + reldir <- fromJust . relDir <$> lift getYesod + + {- Generating a ssh key pair can take a while, so do it in the + - background. -} + void $ liftIO $ forkIO $ do + keypair <- genSshKeyPair + pairdata <- PairData + <$> getHostname + <*> getUserName + <*> pure reldir + <*> pure (sshPubKey keypair) + <*> (maybe genUUID return muuid) let sender = multicastPairMsg Nothing secret pairdata let pip = PairingInProgress secret Nothing keypair pairdata stage startSending dstatus pip stage $ sendrequests sender dstatus urlrender + lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret where {- Sends pairing messages until the thread is killed, -- cgit v1.2.3