summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant/Alert.hs16
-rw-r--r--Assistant/DaemonStatus.hs13
-rw-r--r--Assistant/Pairing/Network.hs9
-rw-r--r--Assistant/Threads/PairListener.hs12
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs36
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