diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Alert.hs | 19 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 44 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 11 | ||||
| -rw-r--r-- | Assistant/WebApp.hs | 16 | ||||
| -rw-r--r-- | Assistant/WebApp/SideBar.hs | 18 |
6 files changed, 77 insertions, 33 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index cb2366f44..57674e2f3 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 4de160ace..b9c7599f9 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 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 diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index d2c41a3c3..51972a98c 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 20fd09c2e..fd1f70038 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. |