diff options
| author |  Joey Hess <joey@kitenet.net> | 2012-09-11 12:26:42 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2012-09-11 12:26:42 -0400 |
| commit | 16d27e9c023231dcf80923d72633c80dbd91116e (patch) | |
| tree | 76bc9acd1b735da1fde1c0796146cc774d0928a5 /Assistant | |
| parent | 91edb58d326e59a34c0457c3ea619a1a7953f54f (diff) | |
work around a bug in Yesod
The PathPiece instance for Text results in a 404 for T.empty.
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Pairing.hs | 13 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 7 | ||||
| -rw-r--r-- | Assistant/WebApp/Types.hs | 4 | ||||
| -rw-r--r-- | Assistant/WebApp/routes | 2 |
4 files changed, 22 insertions, 4 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index de69d8410..ca0cc2f39 100644 --- a/Assistant/Pairing.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index be79d574d..b50d32f62 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/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. diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index f12aedee1..8cf5d40ad 100644 --- a/Assistant/WebApp/Types.hs +++ b/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 diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 7c038389c..10f72a87f 100644 --- a/Assistant/WebApp/routes +++ b/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 |