diff options
author | 2012-09-08 19:57:15 -0400 | |
---|---|---|
committer | 2012-09-08 19:57:15 -0400 | |
commit | e59b0a1c884b4222162b444d0d306f67f2a6ca30 (patch) | |
tree | 78c2b8c0cfe9c6c52e31b0de2b4a730a7f080635 /Assistant/Threads/PairListener.hs | |
parent | e6e0877378af85293356b1c7d644a6df6cc40415 (diff) |
first pass at alert buttons
They work fine. But I had to go to a lot of trouble to get Yesod to render
routes in a pure function. It may instead make more sense to have each
alert have an assocated IO action, and a single route that runs the IO
action of a given alert id. I just wish I'd realized that before the past
several hours of struggling with something Yesod really doesn't want to
allow.
Diffstat (limited to 'Assistant/Threads/PairListener.hs')
-rw-r--r-- | Assistant/Threads/PairListener.hs | 44 |
1 files changed, 31 insertions, 13 deletions
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 12f10070c..45496ddf2 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -12,17 +12,20 @@ import Assistant.Pairing import Assistant.Pairing.Network import Assistant.ThreadedMonad import Assistant.DaemonStatus +import Assistant.WebApp +import Assistant.WebApp.Types import Assistant.Alert import Utility.Verifiable import Network.Multicast import Network.Socket +import qualified Data.Text as T thisThread :: ThreadName thisThread = "PairListener" -pairListenerThread :: ThreadState -> DaemonStatusHandle -> NamedThread -pairListenerThread st dstatus = thread $ withSocketsDo $ do +pairListenerThread :: ThreadState -> DaemonStatusHandle -> UrlRenderer -> NamedThread +pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort forever $ do msg <- getmsg sock [] @@ -39,19 +42,34 @@ pairListenerThread st dstatus = thread $ withSocketsDo $ do chunksz = 1024 dispatch Nothing = noop - dispatch (Just (PairReqM (PairReq v))) = unlessM (mypair v) $ do - let pairdata = verifiableVal v - let repo = remoteUserName pairdata ++ "@" ++ - fromMaybe (showAddr $ remoteAddress pairdata) - (remoteHostName pairdata) ++ - (remoteDirectory pairdata) - let msg = repo ++ " is sending a pair request." - {- Pair request alerts from the same host combine, - - so repeated requests do not add additional alerts. -} - void $ addAlert dstatus $ pairRequestAlert repo msg - dispatch (Just (PairAckM _)) = noop -- TODO + dispatch (Just (PairReqM r@(PairReq v))) = + unlessM (mypair v) $ + pairReqAlert dstatus urlrenderer r + dispatch (Just (PairAckM r@(PairAck v))) = + unlessM (mypair v) $ + pairAckAlert dstatus r {- Filter out our own pair requests, by checking if we - can verify using the secrets of any of them. -} mypair v = any (verified v . inProgressSecret) . pairingInProgress <$> getDaemonStatus dstatus + +{- Pair request alerts from the same host combine, + - so repeated requests do not add additional alerts. -} +pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairReq -> IO () +pairReqAlert dstatus urlrenderer r@(PairReq v) = do + let pairdata = verifiableVal v + let repo = remoteUserName pairdata ++ "@" ++ + fromMaybe (showAddr $ remoteAddress pairdata) + (remoteHostName pairdata) ++ + (remoteDirectory pairdata) + let msg = repo ++ " is sending a pair request." + url <- renderUrl urlrenderer (FinishPairR r) [] + void $ addAlert dstatus $ pairRequestAlert repo msg $ + AlertButton + { buttonUrl = url + , buttonLabel = T.pack "Respond" + } + +pairAckAlert :: DaemonStatusHandle -> PairAck -> IO () +pairAckAlert dstatus r@(PairAck v) = error "TODO" |