pairing passphrase entry form, validation, etc

Actually 3 forms in one, this handles the initial passphrase entry, and the
confirmation, and also varys wording if the same user or a different user
is confirming.

2 files changed, 78 insertions, 11 deletions

diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index f384895bd..8a9d897eb 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -21,14 +21,20 @@ data PairReq = PairReq (Verifiable PairData)
 data PairAck = PairAck (Verifiable PairData)
 	deriving (Eq, Read, Show)
 
+fromPairReq :: PairReq -> Verifiable PairData
+fromPairReq (PairReq v) = v
+
+fromPairAck :: PairAck -> Verifiable PairData
+fromPairAck (PairAck v) = v
+
 data PairMsg
 	= PairReqM PairReq
 	| PairAckM PairAck
 	deriving (Eq, Read, Show)
 
 data PairData = PairData
-	{ hostName :: HostName
-	, userName :: UserName
+	{ remoteHostName :: HostName
+	, remoteUserName :: UserName
 	, sshPubKey :: Maybe SshPubKey
 	}
 	deriving (Eq, Read, Show)
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index f555b2905..82f413a00 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -2,7 +2,7 @@
  -
  - Pairing works like this:
  -
- - * The user optns StartPairR, which prompts them for a secret.
+ - * The user opens StartPairR, which prompts them for a secret.
  - * The user submits it. A PairReq is broadcast out. The secret is
  -   stashed away in a list of known pairing secrets.
  - * On another device, it's received, and that causes its webapp to 
@@ -29,23 +29,84 @@ module Assistant.WebApp.Configurators.Pairing where
 
 import Assistant.Common
 import Assistant.Pairing
+import Utility.Verifiable
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
-import Assistant.WebApp.Configurators.Local
-import qualified Types.Remote as R
-import qualified Remote.Rsync as Rsync
-import qualified Command.InitRemote
-import Logs.UUID
-import Logs.Remote
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString.Lazy as B
+import Data.Char
+import System.Posix.User
 
 getStartPairR :: Handler RepHtml
-getStartPairR = undefined
+getStartPairR = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Pairing"
+	promptSecret Nothing $ error "TODO"
 
 getFinishPairR :: PairReq -> Handler RepHtml
-getFinishPairR = undefined
+getFinishPairR req = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Pairing"
+	promptSecret (Just req) $ error "TODO"
+
+data InputSecret = InputSecret { secretText :: Maybe Text }
+
+promptSecret :: Maybe PairReq -> Widget -> Widget
+promptSecret req cont = do
+	((result, form), enctype) <- lift $
+		runFormGet $ renderBootstrap $
+			InputSecret <$> aopt textField "Secret phrase" Nothing
+        case result of
+                FormSuccess v -> do
+			let secret = toSecret $ fromMaybe "" $ secretText v
+			case req of
+				Nothing -> case secretProblem secret of
+					Nothing -> cont
+					Just problem ->
+						showform form enctype $ Just problem
+				Just r ->
+					if verified (fromPairReq r) secret
+						then cont
+						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 badphrase = isJust mproblem
+			let msg = fromMaybe "" mproblem
+			let (username, hostname) = maybe ("", "")
+				(\v -> (T.pack $ remoteUserName v, T.pack $ remoteHostName v))
+				(verifiableVal . fromPairReq <$> req)
+			u <- liftIO $ T.pack . userName
+				<$> (getUserEntryForID =<< getEffectiveUserID)
+			let sameusername = username == u
+                        let authtoken = webAppFormAuthToken
+                        $(widgetFile "configurators/pairing")
+
+{- This counts unicode characters as more than one character,
+ - but that's ok; they *do* provide additional entropy. -}
+secretProblem :: Secret -> Maybe Text
+secretProblem s
+	| B.null s = Just "The secret phrase cannot be left empty. (Remember that punctuation and white space is ignored.)"
+	| B.length s < 7 = Just "Enter a longer secret phrase, at least 6 characters, but really, a phrase is best! This is not a password you'll need to enter every day."
+	| s == toSecret sampleQuote = Just "Speaking of foolishness, don't paste in the example I gave. Enter a different phrase, please!"
+	| otherwise = Nothing
+
+toSecret :: Text -> Secret
+toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s]
+
+{- From Dickens -}
+sampleQuote :: Text
+sampleQuote = T.unwords
+	[ "It was the best of times,"
+	, "it was the worst of times,"
+	, "it was the age of wisdom,"
+	, "it was the age of foolishness."
+	]