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.

5 files changed, 133 insertions, 15 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."
+	]
diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs
index 58218db2a..b177787c4 100644
--- a/Utility/Verifiable.hs
+++ b/Utility/Verifiable.hs
@@ -16,8 +16,8 @@ type HMACDigest = String
 
 {- A value, verifiable using a HMAC digest and a secret. -}
 data Verifiable a = Verifiable
-	{ val :: a
-	, digest :: HMACDigest
+	{ verifiableVal :: a
+	, verifiableDigest :: HMACDigest
 	}
 	deriving (Eq, Read, Show)
 
@@ -25,7 +25,7 @@ mkVerifiable :: Show a => a -> Secret -> Verifiable a
 mkVerifiable a secret = Verifiable a (calcDigest (show a) secret)
 
 verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool
-verified v secret = v == mkVerifiable (val v) secret
+verified v secret = v == mkVerifiable (verifiableVal v) secret
 
 calcDigest :: String -> Secret -> HMACDigest
 calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v
diff --git a/templates/configurators/pairing.hamlet b/templates/configurators/pairing.hamlet
new file mode 100644
index 000000000..4aa1cdbb0
--- /dev/null
+++ b/templates/configurators/pairing.hamlet
@@ -0,0 +1,50 @@
+<div .span9 .hero-unit>
+  <h2>
+    Pairing with a local computer
+  <p>
+    $if start
+      Pair with a computer on your local network (or VPN), and the #
+      two git annex repositories will be combined into one, with changes #
+      kept in sync between all paired devices.
+    $else
+      Pairing with #{username}@#{hostname} will combine the two git annex #
+      repositories into one, with changes kept in sync between them.
+  <p>
+    $if start
+      For security, enter a secret phrase. This same secret phrase will #
+      also need to be entered on the computer you're pairing with. #
+      It will be used to verify you're pairing with the right computer.
+    $else
+      $if sameusername
+        For security, you need to enter the same secret phrase that was #
+        entered on #{hostname} when the pairing was started.
+      $else
+        For security, a secret phrase has been selected, which you need #
+        to enter here to complete the pairing. If you don't know the #
+        phrase, go ask #{username} ...
+  $if badphrase
+    <div .alert .alert-error>
+      <i .icon-warning-sign></i> #{msg}
+  <p>
+    <form .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{authtoken}
+        <div .form-actions>
+          <button .btn .btn-primary type=submit>
+            $if start
+              Start pairing
+            $else
+              Complete pairing
+    <div .alert .alert-info>
+      $if start
+        <p>
+          A good secret phrase is reasonably long. You'll only #
+          type it a few times. Only letters and numbers matter; #
+          punctuation and white space is ignored.
+        <p>
+          A quotation is one good choice, something like: #
+          "#{sampleQuote}"
+      $else
+        Only letters and numbers matter; punctuation and white space is #
+        ignored.
diff --git a/templates/configurators/repositories.hamlet b/templates/configurators/repositories.hamlet
index d33a1554b..a38ec10af 100644
--- a/templates/configurators/repositories.hamlet
+++ b/templates/configurators/repositories.hamlet
@@ -26,7 +26,8 @@
         between computers. 
 
       <h3>
-        <i .icon-plus-sign></i> Local computer
+        <a href="@{StartPairR}">
+          <i .icon-plus-sign></i> Local computer
       <p>
         Pair with a local computer to automatically keep files in sync #
         between computers on your local network.