From 0c01348b65bb3d0364f90ce9785236fa05985f75 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 8 Sep 2012 02:02:39 -0400 Subject: [PATCH] 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. --- Assistant/Pairing.hs | 10 ++- Assistant/WebApp/Configurators/Pairing.hs | 79 ++++++++++++++++++--- Utility/Verifiable.hs | 6 +- templates/configurators/pairing.hamlet | 50 +++++++++++++ templates/configurators/repositories.hamlet | 3 +- 5 files changed, 133 insertions(+), 15 deletions(-) create mode 100644 templates/configurators/pairing.hamlet 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 @@ +
+

+ Pairing with a local computer +

+ $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. +

+ $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 +

+ #{msg} +

+

+
+ ^{form} + ^{authtoken} +
+