diff options
author | 2012-09-11 15:06:29 -0400 | |
---|---|---|
committer | 2012-09-11 15:09:00 -0400 | |
commit | 2c1ceeeaf9a1cad8477e86e8c73c7f7a2de510ab (patch) | |
tree | 294a8fc2eda701d0936c77d3f27ac3448780ca24 /Assistant/WebApp/Configurators/Pairing.hs | |
parent | aace44454a8866e8dab251c2b9c98e2d48e3f071 (diff) |
pairing works!!
Finally.
Last bug fixes here: Send PairResp with same UUID in the PairReq.
Fix off-by-one in code that filters out our own pairing messages.
Also reworked the pairing alerts, which are still slightly buggy.
Diffstat (limited to 'Assistant/WebApp/Configurators/Pairing.hs')
-rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 14 |
1 files changed, 8 insertions, 6 deletions
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 20ef35c83..ddd9a97b7 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -42,7 +42,7 @@ import Control.Concurrent {- Starts sending out pair requests. -} getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING -getStartPairR = promptSecret Nothing $ startPairing PairReq noop +getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing #else getStartPairR = noPairing #endif @@ -54,11 +54,13 @@ getFinishPairR :: PairMsg -> Handler RepHtml #ifdef WITH_PAIRING getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do liftIO $ setup - startPairing PairAck cleanup "" secret + startPairing PairAck cleanup alert uuid "" secret where + alert = pairRequestAcknowledgedAlert $ pairRepo msg setup = setupAuthorizedKeys msg cleanup = removeAuthorizedKeys False $ remoteSshPubKey $ pairMsgData msg + uuid = Just $ pairUUID $ pairMsgData msg #else getFinishPairR _ = noPairing #endif @@ -83,8 +85,8 @@ getInprogressPairR _ = noPairing - - Redirects to the pairing in progress page. -} -startPairing :: PairStage -> IO () -> Text -> Secret -> Widget -startPairing stage oncancel displaysecret secret = do +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 @@ -93,7 +95,7 @@ startPairing stage oncancel displaysecret secret = do <*> liftIO getUserName <*> (fromJust . relDir <$> lift getYesod) <*> pure (sshPubKey keypair) - <*> liftIO genUUID + <*> liftIO (maybe genUUID return muuid) liftIO $ do let sender = multicastPairMsg Nothing secret pairdata let pip = PairingInProgress secret Nothing keypair pairdata stage @@ -117,7 +119,7 @@ startPairing stage oncancel displaysecret secret = do oncancel killThread tid } - alertDuring dstatus (pairingAlert selfdestruct) $ do + alertDuring dstatus (alert selfdestruct) $ do _ <- E.try (sender stage) :: IO (Either E.SomeException ()) return () |