3dd4b4058f
Pair requests are sent on all network interfaces, and contain the best available hostname to use to contact the host on that interface. Added a pairing in progress page. Revert "reduce some boilerplate using ghc extensions", because it caused overlapping instances for Text.
128 lines
4.8 KiB
Haskell
128 lines
4.8 KiB
Haskell
{- git-annex assistant webapp configurator for pairing
|
||
-
|
||
- Pairing works like this:
|
||
-
|
||
- * The user opens StartPairR, which prompts them for a secret.
|
||
- * The user submits it. The pairing secret is stored for later.
|
||
- A PairReq is broadcast out.
|
||
- * On another device, it's received, and that causes its webapp to
|
||
- display an Alert.
|
||
- * The user there clicks the button, which opens FinishPairR,
|
||
- which prompts them for the same secret.
|
||
- * The secret is used to verify the PairReq. If it checks out,
|
||
- a PairAck is sent, and the other device adds the ssh key from the
|
||
- PairReq. An Alert is displayed noting that the pairing has been set up.
|
||
- * The PairAck is received back at the device that started the process.
|
||
- It's verified using the stored secret. The ssh key from the PairAck
|
||
- is added. An Alert is displayed noting that the pairing has been set
|
||
- up. The pairing secret is removed to prevent anyone cracking the
|
||
- crypto.
|
||
-
|
||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||
-
|
||
- Licensed under the GNU GPL version 3 or higher.
|
||
-}
|
||
|
||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||
|
||
module Assistant.WebApp.Configurators.Pairing where
|
||
|
||
import Assistant.Common
|
||
import Assistant.Pairing
|
||
import Assistant.DaemonStatus
|
||
import Utility.Verifiable
|
||
import Assistant.WebApp
|
||
import Assistant.WebApp.Types
|
||
import Assistant.WebApp.SideBar
|
||
import Utility.Yesod
|
||
|
||
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 = promptSecret Nothing $ \rawsecret secret -> do
|
||
username <- liftIO $ getUserName
|
||
let sshkey = "" -- TODO generate/read ssh key
|
||
let mkmsg hostname = PairReqM $ PairReq $
|
||
mkVerifiable (PairData hostname username sshkey) secret
|
||
pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
|
||
dstatus <- daemonStatus <$> lift getYesod
|
||
liftIO $ modifyDaemonStatus_ dstatus $
|
||
\s -> s { pairingInProgress = pip : pairingInProgress s }
|
||
lift $ redirect $ InprogressPairR rawsecret
|
||
|
||
getInprogressPairR :: Text -> Handler RepHtml
|
||
getInprogressPairR secret = bootstrap (Just Config) $ do
|
||
sideBarDisplay
|
||
setTitle "Pairing"
|
||
$(widgetFile "configurators/inprogresspairing")
|
||
|
||
getFinishPairR :: PairReq -> Handler RepHtml
|
||
getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
|
||
error "TODO"
|
||
|
||
data InputSecret = InputSecret { secretText :: Maybe Text }
|
||
|
||
promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
|
||
promptSecret req cont = bootstrap (Just Config) $ do
|
||
sideBarDisplay
|
||
setTitle "Pairing"
|
||
((result, form), enctype) <- lift $
|
||
runFormGet $ renderBootstrap $
|
||
InputSecret <$> aopt textField "Secret phrase" Nothing
|
||
case result of
|
||
FormSuccess v -> do
|
||
let rawsecret = fromMaybe "" $ secretText v
|
||
let secret = toSecret rawsecret
|
||
case req of
|
||
Nothing -> case secretProblem secret of
|
||
Nothing -> cont rawsecret secret
|
||
Just problem ->
|
||
showform form enctype $ Just problem
|
||
Just r ->
|
||
if verified (fromPairReq r) secret
|
||
then cont rawsecret secret
|
||
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 <- T.pack <$> liftIO getUserName
|
||
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."
|
||
]
|
||
|
||
getUserName :: IO String
|
||
getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)
|