From 6e60b08060a79182a6ae0180dbb7aefbc6011299 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 8 Sep 2012 21:06:10 -0400 Subject: moved the PairStage inside the Verifiable data --- Assistant/Pairing.hs | 39 ++++++++++++------------------- Assistant/Threads/PairListener.hs | 31 ++++++++++++------------ Assistant/WebApp/Configurators/Pairing.hs | 26 ++++++++++----------- Assistant/WebApp/Types.hs | 2 +- Assistant/WebApp/routes | 2 +- templates/configurators/pairing.hamlet | 2 +- 6 files changed, 46 insertions(+), 56 deletions(-) diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index d25d5e56d..c78deace0 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -12,35 +12,26 @@ import Utility.Verifiable import Control.Concurrent import Network.Socket -{- "I'll pair with anybody who shares the secret that can be used to verify - - this request." -} -data PairReq = PairReq (Verifiable PairData) +data PairStage + {- "I'll pair with anybody who shares the secret that can be used + - to verify this request." -} + = PairReq + {- "I've verified your request, and you can verify this to see + - that I know the secret. I set up your ssh key already. + - Here's mine for you to set up." -} + | PairAck + {- "I saw your PairAck; you can stop sending them." -} + | PairDone deriving (Eq, Read, Show) -{- "I've verified your request, and you can verify mine to see that I know - - the secret. I set up your ssh key already. Here's mine for you to set up." -} -data PairAck = PairAck (Verifiable PairData) +newtype PairMsg = PairMsg (Verifiable (PairStage, PairData)) deriving (Eq, Read, Show) -{- "I saw your PairAck; you can stop sending them." - - (This is not repeated, it's just sent in response to a valid PairAck) -} -data PairDone = PairDone (Verifiable PairData) - deriving (Eq, Read, Show) - -fromPairReq :: PairReq -> Verifiable PairData -fromPairReq (PairReq v) = v - -fromPairAck :: PairAck -> Verifiable PairData -fromPairAck (PairAck v) = v +fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData)) +fromPairMsg (PairMsg m) = m -fromPairDone :: PairDone -> Verifiable PairData -fromPairDone (PairDone v) = v - -data PairMsg - = PairReqM PairReq - | PairAckM PairAck - | PairDoneM PairDone - deriving (Eq, Read, Show) +pairMsgStage :: PairMsg -> PairStage +pairMsgStage (PairMsg (Verifiable (s, _) _)) = s data PairData = PairData -- uname -n output, not a full domain name diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 17826744f..d2f572d54 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -45,30 +45,29 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do chunksz = 1024 dispatch Nothing = noop - dispatch (Just (PairReqM m@(PairReq v))) = - pairReqAlert dstatus urlrenderer m - dispatch (Just (PairAckM m)) = - pairAckAlert dstatus m - dispatch (Just (PairDoneM m)) = - pairDoneAlert dstatus m + dispatch (Just m) = case pairMsgStage m of + PairReq -> pairReqAlert dstatus urlrenderer m + PairAck -> pairAckAlert dstatus m + PairDone -> pairDoneAlert dstatus m {- Pair request alerts from the same host combine, - so repeated requests do not add additional alerts. -} -pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairReq -> IO () -pairReqAlert dstatus urlrenderer r@(PairReq v) = unlessM myreq $ do - let pairdata = verifiableVal v +pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO () +pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do + let (_, pairdata) = verifiableVal v let repo = remoteUserName pairdata ++ "@" ++ fromMaybe (showAddr $ remoteAddress pairdata) (remoteHostName pairdata) ++ (remoteDirectory pairdata) - let msg = repo ++ " is sending a pair request." - url <- renderUrl urlrenderer (FinishPairR r) [] - void $ addAlert dstatus $ pairRequestAlert repo msg $ + url <- renderUrl urlrenderer (FinishPairR msg) [] + void $ addAlert dstatus $ pairRequestAlert repo + (repo ++ " is sending a pair request.") $ AlertButton { buttonUrl = url , buttonLabel = T.pack "Respond" } where + v = fromPairMsg msg {- Filter out our own pair requests, by checking if we - can verify using the secrets of any of them. -} myreq = any (verified v . inProgressSecret) . pairingInProgress @@ -82,8 +81,8 @@ pairReqAlert dstatus urlrenderer r@(PairReq v) = unlessM myreq $ do - a list of recently finished pairings, and re-send PairDone in - response to stale PairAcks for them. -} -pairAckAlert :: DaemonStatusHandle -> PairAck -> IO () -pairAckAlert dstatus (PairAck v) = error "TODO" +pairAckAlert :: DaemonStatusHandle -> PairMsg -> IO () +pairAckAlert dstatus msg = error "TODO" {- If we get a valid PairDone, and are sending PairAcks, we can stop - sending them, as the message has been received. @@ -94,5 +93,5 @@ pairAckAlert dstatus (PairAck v) = error "TODO" - Note: This does allow a bad actor to squelch pairing on a network - by sending bogus PairDones. -} -pairDoneAlert :: DaemonStatusHandle -> PairDone -> IO () -pairDoneAlert dstatus (PairDone v) = error "TODO" +pairDoneAlert :: DaemonStatusHandle -> PairMsg -> IO () +pairDoneAlert dstatus msg = error "TODO" diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 8b56f3392..ae94ddafb 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -58,8 +58,8 @@ getStartPairR = promptSecret Nothing $ \rawsecret secret -> do username <- liftIO $ getUserName reldir <- fromJust . relDir <$> lift getYesod let sshkey = "" -- TODO generate/read ssh key - let mkmsg addr = PairReqM $ PairReq $ - mkVerifiable (PairData hostname addr username reldir sshkey) secret + let mkmsg addr = PairMsg $ mkVerifiable + (PairReq, PairData hostname addr username reldir sshkey) secret pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg dstatus <- daemonStatus <$> lift getYesod liftIO $ modifyDaemonStatus_ dstatus $ @@ -79,9 +79,9 @@ getInprogressPairR secret = bootstrap (Just Config) $ do getInprogressPairR _ = noPairing #endif -getFinishPairR :: PairReq -> Handler RepHtml +getFinishPairR :: PairMsg -> Handler RepHtml #ifdef WITH_PAIRING -getFinishPairR req = promptSecret (Just req) $ \_ secret -> do +getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do error "TODO" #else getFinishPairR _ = noPairing @@ -90,8 +90,8 @@ getFinishPairR _ = noPairing #ifdef WITH_PAIRING data InputSecret = InputSecret { secretText :: Maybe Text } -promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml -promptSecret req cont = bootstrap (Just Config) $ do +promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml +promptSecret msg cont = bootstrap (Just Config) $ do sideBarDisplay setTitle "Pairing" ((result, form), enctype) <- lift $ @@ -101,25 +101,25 @@ promptSecret req cont = bootstrap (Just Config) $ do FormSuccess v -> do let rawsecret = fromMaybe "" $ secretText v let secret = toSecret rawsecret - case req of + case msg of Nothing -> case secretProblem secret of Nothing -> cont rawsecret secret Just problem -> showform form enctype $ Just problem - Just r -> - if verified (fromPairReq r) secret + Just m -> + if verified (fromPairMsg m) secret then cont rawsecret secret else showform form enctype $ Just "That's not the right secret phrase." _ -> showform form enctype Nothing where showform form enctype mproblem = do - let start = isNothing req + let start = isNothing msg let badphrase = isJust mproblem - let msg = fromMaybe "" mproblem + let problem = fromMaybe "" mproblem let (username, hostname) = maybe ("", "") - (\v -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v))) - (verifiableVal . fromPairReq <$> req) + (\(_, v) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v))) + (verifiableVal . fromPairMsg <$> msg) u <- T.pack <$> liftIO getUserName let sameusername = username == u let authtoken = webAppFormAuthToken diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index dd3bd4383..d018cddbf 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -93,6 +93,6 @@ instance PathPiece Transfer where toPathPiece = pack . show fromPathPiece = readish . unpack -instance PathPiece PairReq where +instance PathPiece PairMsg where toPathPiece = pack . show fromPathPiece = readish . unpack diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 181b08f28..a266704b2 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -13,7 +13,7 @@ /config/repository/add/rsync.net AddRsyncNetR GET /config/repository/pair/start StartPairR GET /config/repository/pair/inprogress/#Text InprogressPairR GET -/config/repository/pair/finish/#PairReq FinishPairR GET +/config/repository/pair/finish/#PairMsg FinishPairR GET /config/repository/first FirstRepositoryR GET diff --git a/templates/configurators/pairing.hamlet b/templates/configurators/pairing.hamlet index eb16e5b6d..82ca48b5a 100644 --- a/templates/configurators/pairing.hamlet +++ b/templates/configurators/pairing.hamlet @@ -24,7 +24,7 @@ phrase, go ask #{username} ... $if badphrase
- #{msg} + #{problem}

-- cgit v1.2.3