diff options
| -rw-r--r-- | Assistant/Alert.hs | 21 | ||||
| -rw-r--r-- | Assistant/Pairing.hs | 1 | ||||
| -rw-r--r-- | Assistant/Pairing/Network.hs | 26 | ||||
| -rw-r--r-- | Assistant/Ssh.hs | 3 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 26 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 14 |
6 files changed, 51 insertions, 40 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 7eb8550cc..2a08c9ce0 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -32,7 +32,7 @@ data AlertName = FileAlert TenseChunk | SanityCheckFixAlert | WarningAlert String - | PairRequestReceivedAlert String + | PairAlert String deriving (Eq) {- The first alert is the new alert, the second is an old alert. @@ -293,18 +293,27 @@ pairingAlert button = baseActivityAlert , alertButton = Just button } -pairRequestReceivedAlert :: String -> String -> AlertButton -> Alert -pairRequestReceivedAlert repo msg button = Alert +pairRequestReceivedAlert :: String -> AlertButton -> Alert +pairRequestReceivedAlert repo button = Alert { alertClass = Message , alertHeader = Nothing , alertMessageRender = tenseWords - , alertData = [UnTensed $ T.pack msg] + , alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."] , alertBlockDisplay = False , alertPriority = High , alertClosable = True , alertIcon = Just InfoIcon - , alertName = Just $ PairRequestReceivedAlert repo - , alertCombiner = Just $ dataCombiner $ const id + , alertName = Just $ PairAlert repo + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertButton = Just button + } + +pairRequestAcknowledgedAlert :: String -> AlertButton -> Alert +pairRequestAcknowledgedAlert repo button = baseActivityAlert + { alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"] + , alertPriority = High + , alertName = Just $ PairAlert repo + , alertCombiner = Just $ dataCombiner $ \_old new -> new , alertButton = Just button } diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index c519dbd88..5d097ab7d 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -68,6 +68,7 @@ data PairingInProgress = PairingInProgress , inProgressPairData :: PairData , inProgressPairStage :: PairStage } + deriving (Show) data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6 deriving (Ord, Eq, Read, Show) diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 18351321b..768d6b7c2 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -58,14 +58,14 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats threadDelaySeconds (Seconds 2) go cache' $ pred <$> n sendinterface cache i = void $ catchMaybeIO $ - withSocketsDo $ bracket - (multicastSender (multicastAddress i) pairingPort) - (sClose . fst) - (\(sock, addr) -> do + withSocketsDo $ bracket setup cleanup use + where + setup = multicastSender (multicastAddress i) pairingPort + cleanup (sock, _) = sClose sock -- FIXME does not work + use (sock, addr) = do setInterface sock (showAddr i) maybe noop (\s -> void $ sendTo sock s addr) (M.lookup i cache) - ) updatecache cache [] = cache updatecache cache (i:is) | M.member i cache = updatecache cache is @@ -106,3 +106,19 @@ activeNetworkAddresses :: IO [SomeAddr] activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr) . concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni]) <$> getNetworkInterfaces + +{- A human-visible description of the repository being paired with. + - Note that the repository's description is not shown to the user, because + - it could be something like "my repo", which is confusing when pairing + - with someone else's repo. However, this has the same format as the + - default decription of a repo. -} +pairRepo :: PairMsg -> String +pairRepo msg = concat + [ remoteUserName d + , "@" + , fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d) + , ":" + , remoteDirectory d + ] + where + d = pairMsgData msg diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index eefc2a2e2..47c2cb48a 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -32,6 +32,9 @@ data SshKeyPair = SshKeyPair , sshPrivKey :: String } +instance Show SshKeyPair where + show = sshPubKey + type SshPubKey = String {- ssh -ofoo=bar command-line option -} diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index d4f8a07c8..14d189dd2 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -17,7 +17,6 @@ import Assistant.DaemonStatus import Assistant.WebApp import Assistant.WebApp.Types import Assistant.Alert -import Utility.Tense import Network.Multicast import Network.Socket @@ -40,7 +39,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ sane <- checkSane msg (pip, verified) <- verificationCheck m =<< (pairingInProgress <$> getDaemonStatus dstatus) - let wrongstage = maybe False (\p -> pairMsgStage m < inProgressPairStage p) pip + let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip case (wrongstage, sane, pairMsgStage m) of -- ignore our own messages, and -- out of order messages @@ -107,32 +106,13 @@ pairReqReceived True _ _ _ = noop -- ignore our own PairReq pairReqReceived False dstatus urlrenderer msg = do url <- renderUrl urlrenderer (FinishPairR msg) [] void $ addAlert dstatus $ pairRequestReceivedAlert repo - (repo ++ " is sending a pair request.") $ AlertButton { buttonUrl = url , buttonLabel = T.pack "Respond" - , buttonAction = Just onclick + , buttonAction = Nothing } where - pairdata = pairMsgData msg - repo = concat - [ remoteUserName pairdata - , "@" - , fromMaybe (showAddr $ pairMsgAddr msg) - (remoteHostName pairdata) - , ":" - , (remoteDirectory pairdata) - ] - {- Remove the button when it's clicked, and change the - - alert to be in progress. This alert cannot be entirely - - removed since more pair request messages are coming in - - and would re-add it. -} - onclick i = updateAlert dstatus i $ \alert -> Just $ alert - { alertButton = Nothing - , alertClass = Activity - , alertIcon = Just ActivityIcon - , alertData = [UnTensed $ T.pack $ "pair request with " ++ repo ++ " in progress"] - } + repo = pairRepo msg {- When a verified PairAck is seen, a host is ready to pair with us, and has - already configured our ssh key. Stop sending PairReqs, finish the pairing, diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 20ef35c83..ddd9a97b7 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -42,7 +42,7 @@ import Control.Concurrent {- Starts sending out pair requests. -} getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING -getStartPairR = promptSecret Nothing $ startPairing PairReq noop +getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing #else getStartPairR = noPairing #endif @@ -54,11 +54,13 @@ getFinishPairR :: PairMsg -> Handler RepHtml #ifdef WITH_PAIRING getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do liftIO $ setup - startPairing PairAck cleanup "" secret + startPairing PairAck cleanup alert uuid "" secret where + alert = pairRequestAcknowledgedAlert $ pairRepo msg setup = setupAuthorizedKeys msg cleanup = removeAuthorizedKeys False $ remoteSshPubKey $ pairMsgData msg + uuid = Just $ pairUUID $ pairMsgData msg #else getFinishPairR _ = noPairing #endif @@ -83,8 +85,8 @@ getInprogressPairR _ = noPairing - - Redirects to the pairing in progress page. -} -startPairing :: PairStage -> IO () -> Text -> Secret -> Widget -startPairing stage oncancel displaysecret secret = do +startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget +startPairing stage oncancel alert muuid displaysecret secret = do keypair <- liftIO $ genSshKeyPair dstatus <- daemonStatus <$> lift getYesod urlrender <- lift getUrlRender @@ -93,7 +95,7 @@ startPairing stage oncancel displaysecret secret = do <*> liftIO getUserName <*> (fromJust . relDir <$> lift getYesod) <*> pure (sshPubKey keypair) - <*> liftIO genUUID + <*> liftIO (maybe genUUID return muuid) liftIO $ do let sender = multicastPairMsg Nothing secret pairdata let pip = PairingInProgress secret Nothing keypair pairdata stage @@ -117,7 +119,7 @@ startPairing stage oncancel displaysecret secret = do oncancel killThread tid } - alertDuring dstatus (pairingAlert selfdestruct) $ do + alertDuring dstatus (alert selfdestruct) $ do _ <- E.try (sender stage) :: IO (Either E.SomeException ()) return () |