diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index f384895bd4..8a9d897ebf 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 f555b29055..82f413a008 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 58218db2a5..b177787c48 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 0000000000..4aa1cdbb01
--- /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 d33a1554b9..a38ec10afd 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.