moved the PairStage inside the Verifiable data
This commit is contained in:
parent
1ab3ce352b
commit
6e60b08060
6 changed files with 46 additions and 56 deletions
|
@ -12,35 +12,26 @@ import Utility.Verifiable
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Network.Socket
|
import Network.Socket
|
||||||
|
|
||||||
{- "I'll pair with anybody who shares the secret that can be used to verify
|
data PairStage
|
||||||
- this request." -}
|
{- "I'll pair with anybody who shares the secret that can be used
|
||||||
data PairReq = PairReq (Verifiable PairData)
|
- to verify this request." -}
|
||||||
|
= PairReq
|
||||||
|
{- "I've verified your request, and you can verify this to see
|
||||||
|
- that I know the secret. I set up your ssh key already.
|
||||||
|
- Here's mine for you to set up." -}
|
||||||
|
| PairAck
|
||||||
|
{- "I saw your PairAck; you can stop sending them." -}
|
||||||
|
| PairDone
|
||||||
deriving (Eq, Read, Show)
|
deriving (Eq, Read, Show)
|
||||||
|
|
||||||
{- "I've verified your request, and you can verify mine to see that I know
|
newtype PairMsg = PairMsg (Verifiable (PairStage, PairData))
|
||||||
- the secret. I set up your ssh key already. Here's mine for you to set up." -}
|
|
||||||
data PairAck = PairAck (Verifiable PairData)
|
|
||||||
deriving (Eq, Read, Show)
|
deriving (Eq, Read, Show)
|
||||||
|
|
||||||
{- "I saw your PairAck; you can stop sending them."
|
fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData))
|
||||||
- (This is not repeated, it's just sent in response to a valid PairAck) -}
|
fromPairMsg (PairMsg m) = m
|
||||||
data PairDone = PairDone (Verifiable PairData)
|
|
||||||
deriving (Eq, Read, Show)
|
|
||||||
|
|
||||||
fromPairReq :: PairReq -> Verifiable PairData
|
pairMsgStage :: PairMsg -> PairStage
|
||||||
fromPairReq (PairReq v) = v
|
pairMsgStage (PairMsg (Verifiable (s, _) _)) = s
|
||||||
|
|
||||||
fromPairAck :: PairAck -> Verifiable PairData
|
|
||||||
fromPairAck (PairAck v) = v
|
|
||||||
|
|
||||||
fromPairDone :: PairDone -> Verifiable PairData
|
|
||||||
fromPairDone (PairDone v) = v
|
|
||||||
|
|
||||||
data PairMsg
|
|
||||||
= PairReqM PairReq
|
|
||||||
| PairAckM PairAck
|
|
||||||
| PairDoneM PairDone
|
|
||||||
deriving (Eq, Read, Show)
|
|
||||||
|
|
||||||
data PairData = PairData
|
data PairData = PairData
|
||||||
-- uname -n output, not a full domain name
|
-- uname -n output, not a full domain name
|
||||||
|
|
|
@ -45,30 +45,29 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
|
||||||
chunksz = 1024
|
chunksz = 1024
|
||||||
|
|
||||||
dispatch Nothing = noop
|
dispatch Nothing = noop
|
||||||
dispatch (Just (PairReqM m@(PairReq v))) =
|
dispatch (Just m) = case pairMsgStage m of
|
||||||
pairReqAlert dstatus urlrenderer m
|
PairReq -> pairReqAlert dstatus urlrenderer m
|
||||||
dispatch (Just (PairAckM m)) =
|
PairAck -> pairAckAlert dstatus m
|
||||||
pairAckAlert dstatus m
|
PairDone -> pairDoneAlert dstatus m
|
||||||
dispatch (Just (PairDoneM m)) =
|
|
||||||
pairDoneAlert dstatus m
|
|
||||||
|
|
||||||
{- Pair request alerts from the same host combine,
|
{- Pair request alerts from the same host combine,
|
||||||
- so repeated requests do not add additional alerts. -}
|
- so repeated requests do not add additional alerts. -}
|
||||||
pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairReq -> IO ()
|
pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
|
||||||
pairReqAlert dstatus urlrenderer r@(PairReq v) = unlessM myreq $ do
|
pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
|
||||||
let pairdata = verifiableVal v
|
let (_, pairdata) = verifiableVal v
|
||||||
let repo = remoteUserName pairdata ++ "@" ++
|
let repo = remoteUserName pairdata ++ "@" ++
|
||||||
fromMaybe (showAddr $ remoteAddress pairdata)
|
fromMaybe (showAddr $ remoteAddress pairdata)
|
||||||
(remoteHostName pairdata) ++
|
(remoteHostName pairdata) ++
|
||||||
(remoteDirectory pairdata)
|
(remoteDirectory pairdata)
|
||||||
let msg = repo ++ " is sending a pair request."
|
url <- renderUrl urlrenderer (FinishPairR msg) []
|
||||||
url <- renderUrl urlrenderer (FinishPairR r) []
|
void $ addAlert dstatus $ pairRequestAlert repo
|
||||||
void $ addAlert dstatus $ pairRequestAlert repo msg $
|
(repo ++ " is sending a pair request.") $
|
||||||
AlertButton
|
AlertButton
|
||||||
{ buttonUrl = url
|
{ buttonUrl = url
|
||||||
, buttonLabel = T.pack "Respond"
|
, buttonLabel = T.pack "Respond"
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
|
v = fromPairMsg msg
|
||||||
{- Filter out our own pair requests, by checking if we
|
{- Filter out our own pair requests, by checking if we
|
||||||
- can verify using the secrets of any of them. -}
|
- can verify using the secrets of any of them. -}
|
||||||
myreq = any (verified v . inProgressSecret) . pairingInProgress
|
myreq = any (verified v . inProgressSecret) . pairingInProgress
|
||||||
|
@ -82,8 +81,8 @@ pairReqAlert dstatus urlrenderer r@(PairReq v) = unlessM myreq $ do
|
||||||
- a list of recently finished pairings, and re-send PairDone in
|
- a list of recently finished pairings, and re-send PairDone in
|
||||||
- response to stale PairAcks for them.
|
- response to stale PairAcks for them.
|
||||||
-}
|
-}
|
||||||
pairAckAlert :: DaemonStatusHandle -> PairAck -> IO ()
|
pairAckAlert :: DaemonStatusHandle -> PairMsg -> IO ()
|
||||||
pairAckAlert dstatus (PairAck v) = error "TODO"
|
pairAckAlert dstatus msg = error "TODO"
|
||||||
|
|
||||||
{- If we get a valid PairDone, and are sending PairAcks, we can stop
|
{- If we get a valid PairDone, and are sending PairAcks, we can stop
|
||||||
- sending them, as the message has been received.
|
- sending them, as the message has been received.
|
||||||
|
@ -94,5 +93,5 @@ pairAckAlert dstatus (PairAck v) = error "TODO"
|
||||||
- Note: This does allow a bad actor to squelch pairing on a network
|
- Note: This does allow a bad actor to squelch pairing on a network
|
||||||
- by sending bogus PairDones.
|
- by sending bogus PairDones.
|
||||||
-}
|
-}
|
||||||
pairDoneAlert :: DaemonStatusHandle -> PairDone -> IO ()
|
pairDoneAlert :: DaemonStatusHandle -> PairMsg -> IO ()
|
||||||
pairDoneAlert dstatus (PairDone v) = error "TODO"
|
pairDoneAlert dstatus msg = error "TODO"
|
||||||
|
|
|
@ -58,8 +58,8 @@ getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
|
||||||
username <- liftIO $ getUserName
|
username <- liftIO $ getUserName
|
||||||
reldir <- fromJust . relDir <$> lift getYesod
|
reldir <- fromJust . relDir <$> lift getYesod
|
||||||
let sshkey = "" -- TODO generate/read ssh key
|
let sshkey = "" -- TODO generate/read ssh key
|
||||||
let mkmsg addr = PairReqM $ PairReq $
|
let mkmsg addr = PairMsg $ mkVerifiable
|
||||||
mkVerifiable (PairData hostname addr username reldir sshkey) secret
|
(PairReq, PairData hostname addr username reldir sshkey) secret
|
||||||
pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
|
pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
|
||||||
dstatus <- daemonStatus <$> lift getYesod
|
dstatus <- daemonStatus <$> lift getYesod
|
||||||
liftIO $ modifyDaemonStatus_ dstatus $
|
liftIO $ modifyDaemonStatus_ dstatus $
|
||||||
|
@ -79,9 +79,9 @@ getInprogressPairR secret = bootstrap (Just Config) $ do
|
||||||
getInprogressPairR _ = noPairing
|
getInprogressPairR _ = noPairing
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
getFinishPairR :: PairReq -> Handler RepHtml
|
getFinishPairR :: PairMsg -> Handler RepHtml
|
||||||
#ifdef WITH_PAIRING
|
#ifdef WITH_PAIRING
|
||||||
getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
|
getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
||||||
error "TODO"
|
error "TODO"
|
||||||
#else
|
#else
|
||||||
getFinishPairR _ = noPairing
|
getFinishPairR _ = noPairing
|
||||||
|
@ -90,8 +90,8 @@ getFinishPairR _ = noPairing
|
||||||
#ifdef WITH_PAIRING
|
#ifdef WITH_PAIRING
|
||||||
data InputSecret = InputSecret { secretText :: Maybe Text }
|
data InputSecret = InputSecret { secretText :: Maybe Text }
|
||||||
|
|
||||||
promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
|
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
|
||||||
promptSecret req cont = bootstrap (Just Config) $ do
|
promptSecret msg cont = bootstrap (Just Config) $ do
|
||||||
sideBarDisplay
|
sideBarDisplay
|
||||||
setTitle "Pairing"
|
setTitle "Pairing"
|
||||||
((result, form), enctype) <- lift $
|
((result, form), enctype) <- lift $
|
||||||
|
@ -101,25 +101,25 @@ promptSecret req cont = bootstrap (Just Config) $ do
|
||||||
FormSuccess v -> do
|
FormSuccess v -> do
|
||||||
let rawsecret = fromMaybe "" $ secretText v
|
let rawsecret = fromMaybe "" $ secretText v
|
||||||
let secret = toSecret rawsecret
|
let secret = toSecret rawsecret
|
||||||
case req of
|
case msg of
|
||||||
Nothing -> case secretProblem secret of
|
Nothing -> case secretProblem secret of
|
||||||
Nothing -> cont rawsecret secret
|
Nothing -> cont rawsecret secret
|
||||||
Just problem ->
|
Just problem ->
|
||||||
showform form enctype $ Just problem
|
showform form enctype $ Just problem
|
||||||
Just r ->
|
Just m ->
|
||||||
if verified (fromPairReq r) secret
|
if verified (fromPairMsg m) secret
|
||||||
then cont rawsecret secret
|
then cont rawsecret secret
|
||||||
else showform form enctype $ Just
|
else showform form enctype $ Just
|
||||||
"That's not the right secret phrase."
|
"That's not the right secret phrase."
|
||||||
_ -> showform form enctype Nothing
|
_ -> showform form enctype Nothing
|
||||||
where
|
where
|
||||||
showform form enctype mproblem = do
|
showform form enctype mproblem = do
|
||||||
let start = isNothing req
|
let start = isNothing msg
|
||||||
let badphrase = isJust mproblem
|
let badphrase = isJust mproblem
|
||||||
let msg = fromMaybe "" mproblem
|
let problem = fromMaybe "" mproblem
|
||||||
let (username, hostname) = maybe ("", "")
|
let (username, hostname) = maybe ("", "")
|
||||||
(\v -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
|
(\(_, v) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
|
||||||
(verifiableVal . fromPairReq <$> req)
|
(verifiableVal . fromPairMsg <$> msg)
|
||||||
u <- T.pack <$> liftIO getUserName
|
u <- T.pack <$> liftIO getUserName
|
||||||
let sameusername = username == u
|
let sameusername = username == u
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
|
|
|
@ -93,6 +93,6 @@ instance PathPiece Transfer where
|
||||||
toPathPiece = pack . show
|
toPathPiece = pack . show
|
||||||
fromPathPiece = readish . unpack
|
fromPathPiece = readish . unpack
|
||||||
|
|
||||||
instance PathPiece PairReq where
|
instance PathPiece PairMsg where
|
||||||
toPathPiece = pack . show
|
toPathPiece = pack . show
|
||||||
fromPathPiece = readish . unpack
|
fromPathPiece = readish . unpack
|
||||||
|
|
|
@ -13,7 +13,7 @@
|
||||||
/config/repository/add/rsync.net AddRsyncNetR GET
|
/config/repository/add/rsync.net AddRsyncNetR GET
|
||||||
/config/repository/pair/start StartPairR GET
|
/config/repository/pair/start StartPairR GET
|
||||||
/config/repository/pair/inprogress/#Text InprogressPairR GET
|
/config/repository/pair/inprogress/#Text InprogressPairR GET
|
||||||
/config/repository/pair/finish/#PairReq FinishPairR GET
|
/config/repository/pair/finish/#PairMsg FinishPairR GET
|
||||||
|
|
||||||
/config/repository/first FirstRepositoryR GET
|
/config/repository/first FirstRepositoryR GET
|
||||||
|
|
||||||
|
|
|
@ -24,7 +24,7 @@
|
||||||
phrase, go ask #{username} ...
|
phrase, go ask #{username} ...
|
||||||
$if badphrase
|
$if badphrase
|
||||||
<div .alert .alert-error>
|
<div .alert .alert-error>
|
||||||
<i .icon-warning-sign></i> #{msg}
|
<i .icon-warning-sign></i> #{problem}
|
||||||
<p>
|
<p>
|
||||||
<form .form-horizontal enctype=#{enctype}>
|
<form .form-horizontal enctype=#{enctype}>
|
||||||
<fieldset>
|
<fieldset>
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue