work around a bug in Yesod

The PathPiece instance for Text results in a 404 for T.empty.

Assistant/Pairing.hs

@@ -13,6 +13,8 @@ import Assistant.Ssh
 
 import Control.Concurrent
 import Network.Socket
+import Data.Char
+import qualified Data.Text as T
 
 data PairStage
 	{- "I'll pair with anybody who shares the secret that can be used
@@ -68,3 +70,14 @@ data PairingInProgress = PairingInProgress
 
 data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6
 	deriving (Ord, Eq, Read, Show)
+
+{- This contains the whole secret, just lightly obfuscated to make it not
+ - too obvious. It's only displayed in the user's web browser. -}
+data SecretReminder = SecretReminder [Int]
+	deriving (Show, Eq, Ord, Read)
+
+toSecretReminder :: T.Text -> SecretReminder
+toSecretReminder = SecretReminder . map ord . T.unpack
+
+fromSecretReminder :: SecretReminder -> T.Text
+fromSecretReminder (SecretReminder s) = T.pack $ map chr s

Assistant/WebApp/Configurators/Pairing.hs

@@ -63,9 +63,10 @@ getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
 getFinishPairR _ = noPairing
 #endif
 
-getInprogressPairR :: Text -> Handler RepHtml
+getInprogressPairR :: SecretReminder -> Handler RepHtml
 #ifdef WITH_PAIRING
-getInprogressPairR secret = pairPage $ do
+getInprogressPairR s = pairPage $ do
+	let secret = fromSecretReminder s
 	$(widgetFile "configurators/pairing/inprogress")
 #else
 getInprogressPairR _ = noPairing
@@ -97,7 +98,7 @@ startPairing stage oncancel displaysecret secret = do
 		let sender = multicastPairMsg Nothing secret stage pairdata
 		let pip = PairingInProgress secret Nothing keypair pairdata
 		startSending dstatus pip $ sendrequests sender dstatus urlrender
-	lift $ redirect $ InprogressPairR displaysecret
+	lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
 	where
 		{- Sends pairing messages until the thread is killed,
 		 - and shows an activity alert while doing it.

Assistant/WebApp/Types.hs

@@ -87,3 +87,7 @@ instance PathPiece Transfer where
 instance PathPiece PairMsg where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
+
+instance PathPiece SecretReminder where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -12,7 +12,7 @@
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
 /config/repository/add/rsync.net AddRsyncNetR GET
 /config/repository/pair/start StartPairR GET
-/config/repository/pair/inprogress/#Text InprogressPairR GET
+/config/repository/pair/inprogress/#SecretReminder InprogressPairR GET
 /config/repository/pair/finish/#PairMsg FinishPairR GET
 
 /config/repository/first FirstRepositoryR GET