moved the PairStage inside the Verifiable data

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)
+fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData))
+fromPairMsg (PairMsg m) = m
 
-fromPairReq :: PairReq -> Verifiable PairData
-fromPairReq (PairReq v) = v
-
-fromPairAck :: PairAck -> Verifiable PairData
-fromPairAck (PairAck v) = v
-
-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

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"

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

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

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
 

templates/configurators/pairing.hamlet

@@ -24,7 +24,7 @@
         phrase, go ask #{username} ...
   $if badphrase
     <div .alert .alert-error>
-      <i .icon-warning-sign></i> #{msg}
+      <i .icon-warning-sign></i> #{problem}
   <p>
     <form .form-horizontal enctype=#{enctype}>
       <fieldset>