implement pair request broadcasts

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.
This commit is contained in:
Joey Hess 2012-09-08 13:04:19 -04:00
parent 0c01348b65
commit 3dd4b4058f
7 changed files with 174 additions and 30 deletions

View file

@ -3,8 +3,8 @@
- Pairing works like this:
-
- * 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.
- * 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,
@ -15,8 +15,8 @@
- * 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. Note that multiple other devices could also send PairAcks, and
- as long as they're valid, all those devices are paired with.
- up. The pairing secret is removed to prevent anyone cracking the
- crypto.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
@ -29,6 +29,7 @@ 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
@ -44,35 +45,48 @@ import Data.Char
import System.Posix.User
getStartPairR :: Handler RepHtml
getStartPairR = bootstrap (Just Config) $ do
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"
promptSecret Nothing $ error "TODO"
$(widgetFile "configurators/inprogresspairing")
getFinishPairR :: PairReq -> Handler RepHtml
getFinishPairR req = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Pairing"
promptSecret (Just req) $ error "TODO"
getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
error "TODO"
data InputSecret = InputSecret { secretText :: Maybe Text }
promptSecret :: Maybe PairReq -> Widget -> Widget
promptSecret req cont = do
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 secret = toSecret $ fromMaybe "" $ secretText v
let rawsecret = fromMaybe "" $ secretText v
let secret = toSecret rawsecret
case req of
Nothing -> case secretProblem secret of
Nothing -> cont
Nothing -> cont rawsecret secret
Just problem ->
showform form enctype $ Just problem
Just r ->
if verified (fromPairReq r) secret
then cont
then cont rawsecret secret
else showform form enctype $ Just
"That's not the right secret phrase."
_ -> showform form enctype Nothing
@ -84,8 +98,7 @@ promptSecret req cont = do
let (username, hostname) = maybe ("", "")
(\v -> (T.pack $ remoteUserName v, T.pack $ remoteHostName v))
(verifiableVal . fromPairReq <$> req)
u <- liftIO $ T.pack . userName
<$> (getUserEntryForID =<< getEffectiveUserID)
u <- T.pack <$> liftIO getUserName
let sameusername = username == u
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/pairing")
@ -110,3 +123,6 @@ sampleQuote = T.unwords
, "it was the age of wisdom,"
, "it was the age of foolishness."
]
getUserName :: IO String
getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)