diff options
| -rw-r--r-- | Assistant/Alert.hs | 16 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 13 | ||||
| -rw-r--r-- | Assistant/Pairing/Network.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 12 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 36 |
5 files changed, 65 insertions, 21 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 666098c6f..a2f5db4e3 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -32,7 +32,7 @@ data AlertName = FileAlert TenseChunk | SanityCheckFixAlert | WarningAlert String - | PairRequestAlert String + | PairRequestReceivedAlert String deriving (Eq) {- The first alert is the new alert, the second is an old alert. @@ -148,6 +148,7 @@ makeAlertFiller success alert { alertClass = if c == Activity then c' else c , alertPriority = Filler , alertClosable = True + , alertButton = Nothing , alertIcon = Just $ if success then SuccessIcon else ErrorIcon } where @@ -285,8 +286,15 @@ sanityCheckFixAlert msg = Alert alerthead = "The daily sanity check found and fixed a problem:" alertfoot = "If these problems persist, consider filing a bug report." -pairRequestAlert :: String -> String -> AlertButton -> Alert -pairRequestAlert repo msg button = Alert +pairRequestAlert :: AlertButton -> Alert +pairRequestAlert button = baseActivityAlert + { alertData = [ UnTensed "Pairing request in progress" ] + , alertPriority = High + , alertButton = Just button + } + +pairRequestReceivedAlert :: String -> String -> AlertButton -> Alert +pairRequestReceivedAlert repo msg button = Alert { alertClass = Message , alertHeader = Nothing , alertMessageRender = tenseWords @@ -295,7 +303,7 @@ pairRequestAlert repo msg button = Alert , alertPriority = High , alertClosable = True , alertIcon = Just InfoIcon - , alertName = Just $ PairRequestAlert repo + , alertName = Just $ PairRequestReceivedAlert repo , alertCombiner = Just $ dataCombiner $ const id , alertButton = Just button } diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index b9c7599f9..cbd606680 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -41,8 +41,8 @@ data DaemonStatus = DaemonStatus , lastAlertId :: AlertId -- Ordered list of remotes to talk to. , knownRemotes :: [Remote] - -- Pairing requests that are in progress. - , pairingInProgress :: [PairingInProgress] + -- Pairing request that is in progress. + , pairingInProgress :: Maybe PairingInProgress -- Broadcasts notifications about all changes to the DaemonStatus , changeNotifier :: NotificationBroadcaster -- Broadcasts notifications when queued or current transfers change. @@ -66,7 +66,7 @@ newDaemonStatus = DaemonStatus <*> pure M.empty <*> pure firstAlertId <*> pure [] - <*> pure [] + <*> pure Nothing <*> newNotificationBroadcaster <*> newNotificationBroadcaster <*> newNotificationBroadcaster @@ -260,3 +260,10 @@ alertWhile' dstatus alert a = do (ok, r) <- a updateAlertMap dstatus $ mergeAlert i $ makeAlertFiller ok alert' return r + +{- Displays an alert while performing an activity, then removes it. -} +alertDuring :: DaemonStatusHandle -> Alert -> IO a -> IO a +alertDuring dstatus alert a = do + let alert' = alert { alertClass = Activity } + i <- addAlert dstatus alert' + removeAlert dstatus i `after` a diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index ec7054f9e..2b645a9d9 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -14,7 +14,6 @@ import Utility.ThreadScheduler import Network.Multicast import Network.Info import Network.Socket -import Control.Concurrent import Control.Exception (bracket) import qualified Data.Map as M @@ -31,8 +30,8 @@ multicastAddress :: SomeAddr -> HostName multicastAddress (IPv4Addr _) = "224.0.0.1" multicastAddress (IPv6Addr _) = "ff02::1" -{- Multicasts a message repeatedly on all interfaces until its thread - - is killed, with a 2 second delay between each transmission. +{- Multicasts a message repeatedly on all interfaces forever, + - with a 2 second delay between each transmission. - - The remoteHostAddress is set to the interface's IP address. - @@ -40,8 +39,8 @@ multicastAddress (IPv6Addr _) = "ff02::1" - but it allows new network interfaces to be used as they come up. - On the other hand, the expensive DNS lookups are cached. -} -multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ThreadId -multicastPairMsg mkmsg = forkIO $ go M.empty +multicastPairMsg :: (SomeAddr -> PairMsg) -> IO () +multicastPairMsg mkmsg = go M.empty where go cache = do addrs <- activeNetworkAddresses diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 3dc1a331f..e7104dc28 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -56,7 +56,7 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO () pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do url <- renderUrl urlrenderer (FinishPairR msg) [] - void $ addAlert dstatus $ pairRequestAlert repo + void $ addAlert dstatus $ pairRequestReceivedAlert repo (repo ++ " is sending a pair request.") $ AlertButton { buttonUrl = url @@ -74,16 +74,18 @@ pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do , ":" , (remoteDirectory pairdata) ] - {- Filter out our own pair requests, by checking if we - - can verify using the secrets of any of them. -} - myreq = any (verified v . inProgressSecret) . pairingInProgress - <$> getDaemonStatus dstatus + {- Filter out our own pair request, by checking if we + - can verify using its secret. -} + myreq = maybe False (verified v . inProgressSecret) + . pairingInProgress + <$> getDaemonStatus dstatus {- 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"] } diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 54a791639..d4301473f 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -32,6 +32,7 @@ import Assistant.Pairing #ifdef WITH_PAIRING import Assistant.Pairing.Network import Assistant.Common +import Assistant.Alert import Assistant.DaemonStatus import Utility.Verifiable import Utility.Network @@ -49,22 +50,49 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as B import Data.Char import System.Posix.User +import qualified Control.Exception as E +import Control.Concurrent #endif getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING getStartPairR = promptSecret Nothing $ \rawsecret secret -> do + dstatus <- daemonStatus <$> lift getYesod + urlrender <- lift getUrlRender + let homeurl = urlrender HomeR hostname <- liftIO $ getHostname username <- liftIO $ getUserName reldir <- fromJust . relDir <$> lift getYesod let sshkey = "" -- TODO generate/read ssh key let mkmsg addr = PairMsg $ mkVerifiable (PairReq, PairData hostname addr username reldir sshkey) secret - pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg - dstatus <- daemonStatus <$> lift getYesod - liftIO $ modifyDaemonStatus_ dstatus $ - \s -> s { pairingInProgress = pip : pairingInProgress s } + liftIO $ do + pip <- PairingInProgress secret + <$> sendrequests mkmsg dstatus homeurl + oldpip <- modifyDaemonStatus dstatus $ + \s -> (s { pairingInProgress = Just pip }, pairingInProgress s) + maybe noop stopold oldpip lift $ redirect $ InprogressPairR rawsecret + where + {- Sends pairing messages until the thread is killed, + - and shows an activity alert while doing it. + - + - The button returns the user to the HomeR. This is + - not ideal, but they have to be sent somewhere, and could + - have been on a page specific to the in-process pairing + - that just stopped. + -} + sendrequests mkmsg dstatus homeurl = forkIO $ do + tid <- myThreadId + let selfdestruct = AlertButton + { buttonLabel = "Cancel" + , buttonUrl = homeurl + , buttonAction = Just $ const $ killThread tid + } + alertDuring dstatus (pairRequestAlert selfdestruct) $ do + _ <- E.try (multicastPairMsg mkmsg) :: IO (Either E.SomeException ()) + return () + stopold = killThread . inProgressThreadId #else getStartPairR = noPairing #endif |