summaryrefslogtreecommitdiff
path: root/Assistant/Threads
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-08 19:57:15 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-08 19:57:15 -0400
commite59b0a1c884b4222162b444d0d306f67f2a6ca30 (patch)
tree78c2b8c0cfe9c6c52e31b0de2b4a730a7f080635 /Assistant/Threads
parente6e0877378af85293356b1c7d644a6df6cc40415 (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')
-rw-r--r--Assistant/Threads/PairListener.hs44
-rw-r--r--Assistant/Threads/WebApp.hs11
2 files changed, 38 insertions, 17 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"
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 54627f38e..d7d5c2602 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -49,10 +49,11 @@ webAppThread
-> ScanRemoteMap
-> TransferQueue
-> TransferSlots
+ -> UrlRenderer
-> Maybe (IO String)
-> Maybe (Url -> FilePath -> IO ())
-> NamedThread
-webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = thread $ do
+webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer postfirstrun onstartup = thread $ do
webapp <- WebApp
<$> pure mst
<*> pure dstatus
@@ -64,14 +65,16 @@ webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun on
<*> pure $(embed "static")
<*> newWebAppState
<*> pure postfirstrun
+ setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
app <- toWaiAppPlain webapp
app' <- ifM debugEnabled
( return $ httpDebugLogger app
, return app
)
- runWebApp app' $ \port -> case mst of
- Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
- Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
+ runWebApp app' $ \port -> do
+ case mst of
+ Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
+ Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
where
thread = NamedThread thisThread
getreldir Nothing = return Nothing