diff --git a/Assistant.hs b/Assistant.hs index 0141f5f561..96eca166c9 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -97,6 +97,10 @@ - ScanRemotes (STM TMVar) - Remotes that have been disconnected, and should be scanned - are indicated by writing to this TMVar. + - UrlRenderer (MVar) + - A Yesod route rendering function is stored here. This allows + - things that need to render Yesod routes to block until the webapp + - has started up and such rendering is possible. -} {-# LANGUAGE CPP #-} @@ -125,6 +129,7 @@ import Assistant.Threads.NetWatcher import Assistant.Threads.TransferScanner import Assistant.Threads.TransferPoller #ifdef WITH_WEBAPP +import Assistant.WebApp import Assistant.Threads.WebApp #ifdef WITH_PAIRING import Assistant.Threads.PairListener @@ -170,12 +175,13 @@ startAssistant assistant daemonize webappwaiter = do transferqueue <- newTransferQueue transferslots <- newTransferSlots scanremotes <- newScanRemoteMap + urlrenderer <- newUrlRenderer mapM_ (startthread dstatus) [ watch $ commitThread st changechan commitchan transferqueue dstatus #ifdef WITH_WEBAPP - , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots Nothing webappwaiter + , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots urlrenderer Nothing webappwaiter #ifdef WITH_PAIRING - , assist $ pairListenerThread st dstatus + , assist $ pairListenerThread st dstatus urlrenderer #endif #endif , assist $ pushThread st dstatus commitchan pushmap diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index cb2366f442..57674e2f31 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -15,6 +15,7 @@ import Utility.Tense import Logs.Transfer import qualified Data.Text as T +import Data.Text (Text) import qualified Data.Map as M import Data.String @@ -49,6 +50,12 @@ data Alert = Alert , alertIcon :: Maybe String , alertCombiner :: Maybe AlertCombiner , alertName :: Maybe AlertName + , alertButton :: Maybe AlertButton + } + +data AlertButton = AlertButton + { buttonUrl :: Text + , buttonLabel :: Text } type AlertPair = (AlertId, Alert) @@ -98,11 +105,11 @@ sortAlertPairs :: [AlertPair] -> [AlertPair] sortAlertPairs = sortBy compareAlertPairs {- Renders an alert's header for display, if it has one. -} -renderAlertHeader :: Alert -> Maybe T.Text +renderAlertHeader :: Alert -> Maybe Text renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert {- Renders an alert's message for display. -} -renderAlertMessage :: Alert -> T.Text +renderAlertMessage :: Alert -> Text renderAlertMessage alert = renderTense (alertTense alert) $ (alertMessageRender alert) (alertData alert) @@ -182,6 +189,7 @@ baseActivityAlert = Alert , alertIcon = Just "refresh" , alertCombiner = Nothing , alertName = Nothing + , alertButton = Nothing } warningAlert :: String -> String -> Alert @@ -196,6 +204,7 @@ warningAlert name msg = Alert , alertIcon = Just "exclamation-sign" , alertCombiner = Just $ dataCombiner (++) , alertName = Just $ WarningAlert name + , alertButton = Nothing } activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert @@ -257,14 +266,15 @@ sanityCheckFixAlert msg = Alert , alertIcon = Just "exclamation-sign" , alertName = Just SanityCheckFixAlert , alertCombiner = Just $ dataCombiner (++) + , alertButton = Nothing } where render dta = tenseWords $ alerthead : dta ++ [alertfoot] alerthead = "The daily sanity check found and fixed a problem:" alertfoot = "If these problems persist, consider filing a bug report." -pairRequestAlert :: String -> String -> Alert -pairRequestAlert repo msg = Alert +pairRequestAlert :: String -> String -> AlertButton -> Alert +pairRequestAlert repo msg button = Alert { alertClass = Message , alertHeader = Just $ tenseWords ["Pair request"] , alertMessageRender = tenseWords @@ -275,6 +285,7 @@ pairRequestAlert repo msg = Alert , alertIcon = Just "info-sign" , alertName = Just $ PairRequestAlert repo , alertCombiner = Just $ dataCombiner $ const id + , alertButton = Just button } fileAlert :: TenseChunk -> FilePath -> Alert diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 4de160aceb..b9c7599f9e 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes #-} + module Assistant.DaemonStatus where import Common.Annex diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 12f10070ce..45496ddf27 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 54627f38e2..d7d5c26024 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 diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index d2c41a3c3f..51972a98c4 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -20,6 +20,7 @@ import Yesod import Text.Hamlet import Data.Text (Text) import Control.Concurrent.STM +import Control.Concurrent data NavBarItem = DashBoard | Config | About deriving (Eq) @@ -116,3 +117,18 @@ webAppFormAuthToken = do - With noscript, clicking it GETs the Route. -} actionButton :: Route WebApp -> (Maybe String) -> String -> String -> Widget actionButton route label buttonclass iconclass = $(widgetFile "actionbutton") + +type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text +type UrlRenderer = MVar (UrlRenderFunc) + +newUrlRenderer :: IO UrlRenderer +newUrlRenderer = newEmptyMVar + +setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO () +setUrlRenderer = putMVar + +{- Blocks until the webapp is running and has called setUrlRenderer. -} +renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text +renderUrl urlrenderer route params = do + r <- readMVar urlrenderer + return $ r route params diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs index 20fd09c2e2..fd1f700388 100644 --- a/Assistant/WebApp/SideBar.hs +++ b/Assistant/WebApp/SideBar.hs @@ -36,24 +36,18 @@ sideBarDisplay = do $(widgetFile "sidebar/main") autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int) where + bootstrapclass :: AlertClass -> Text bootstrapclass Activity = "alert-info" bootstrapclass Warning = "alert" bootstrapclass Error = "alert-error" bootstrapclass Success = "alert-success" bootstrapclass Message = "alert-info" - renderalert (alertid, alert) = addalert - alertid - (alertClosable alert) - (alertBlockDisplay alert) - (bootstrapclass $ alertClass alert) - (renderAlertHeader alert) - (renderAlertMessage alert) - (alertIcon alert) - - addalert :: AlertId -> Bool -> Bool -> Text -> Maybe Text -> Text -> Maybe String -> Widget - addalert i closable block divclass heading message icon = do - let alertid = show i + renderalert (aid, alert) = do + let alertid = show aid + let closable = alertClosable alert + let block = alertBlockDisplay alert + let divclass = bootstrapclass $ alertClass alert $(widgetFile "sidebar/alert") {- Called by client to get a sidebar display. diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 9a3be19d19..7360e1b0cd 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -16,6 +16,7 @@ import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Threads.WebApp +import Assistant.WebApp import Utility.WebApp import Utility.Daemon (checkDaemon, lockPidFile) import Init @@ -92,10 +93,12 @@ firstRun = do scanremotes <- newScanRemoteMap transferqueue <- newTransferQueue transferslots <- newTransferSlots + urlrenderer <- newUrlRenderer v <- newEmptyMVar let callback a = Just $ a v void $ runNamedThread dstatus $ - webAppThread Nothing dstatus scanremotes transferqueue transferslots + webAppThread Nothing dstatus scanremotes + transferqueue transferslots urlrenderer (callback signaler) (callback mainthread) where signaler v = do diff --git a/templates/sidebar/alert.hamlet b/templates/sidebar/alert.hamlet index 85ff584825..a873d171fe 100644 --- a/templates/sidebar/alert.hamlet +++ b/templates/sidebar/alert.hamlet @@ -1,18 +1,24 @@ -
+
$if closable × - $maybe h <- heading + $maybe h <- renderAlertHeader alert $if block

- $case icon + $case alertIcon alert $of Nothing $of Just name # #{h} $else - $case icon + $case alertIcon alert $of Nothing $of Just name # #{h} # - #{message} + #{renderAlertMessage alert} + $case alertButton alert + $of Nothing + $of Just button +
+ + #{buttonLabel button}