aboutsummaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-07-29 11:31:06 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-07-29 11:31:06 -0400
commitc2f3e66d8c65e46046f83221996b3a180bd49657 (patch)
treeda30e48c507d5503ab48a6f9ed4d2910dad7abf6 /Assistant
parent5271d699d22f9addb35f2374a2a70da59897bb1d (diff)
show alerts in the sidebar
This has a bug -- it seems long polling can only wait on one page at a time. Need to re-unify the notifiers.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Alert.hs15
-rw-r--r--Assistant/Threads/Watcher.hs10
-rw-r--r--Assistant/Threads/WebApp.hs44
3 files changed, 58 insertions, 11 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index c8bfa48fd..f4220eea9 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -14,12 +14,23 @@ import Yesod
type Widget = forall sub master. GWidget sub master ()
{- Different classes of alerts are displayed differently. -}
-data AlertClass = Activity | Warning | Error | Message
+data AlertClass = Activity | Warning | Error | Success | Message
+ deriving (Eq)
-{- An alert can be a simple message, or a Yesod Widget -}
+{- An alert can be a simple message, or an arbitrary Yesod Widget -}
data AlertMessage = StringAlert String | WidgetAlert Widget
data Alert = Alert
{ alertClass :: AlertClass
+ , alertHeader :: Maybe String
, alertMessage :: AlertMessage
+ , alertBlockDisplay :: Bool
+ }
+
+activityAlert :: Maybe String -> String -> Alert
+activityAlert header message = Alert
+ { alertClass = Activity
+ , alertHeader = header
+ , alertMessage = StringAlert message
+ , alertBlockDisplay = False
}
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index ab57bf04a..5086f95a2 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -19,6 +19,7 @@ import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.Changes
import Assistant.TransferQueue
+import Assistant.Alert
import Logs.Transfer
import Utility.DirWatcher
import Utility.Types.DirWatcher
@@ -60,7 +61,7 @@ watchThread st dstatus transferqueue changechan = do
void $ watchDir "." ignored hooks startup
debug thisThread [ "watching", "."]
where
- startup = statupScan st dstatus
+ startup = startupScan st dstatus
hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
hooks = WatchHooks
{ addHook = hook onAdd
@@ -71,11 +72,12 @@ watchThread st dstatus transferqueue changechan = do
}
{- Initial scartup scan. The action should return once the scan is complete. -}
-statupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
-statupScan st dstatus scanner = do
+startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
+startupScan st dstatus scanner = do
runThreadState st $
showAction "scanning"
- r <- scanner
+ let alert = activityAlert Nothing "Performing startup scan"
+ r <- alertWhile dstatus alert scanner
modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
-- Notice any files that were deleted before watching was started.
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 3db5f368c..132aad22e 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -14,6 +14,7 @@ import Assistant.Common
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.TransferQueue
+import Assistant.Alert hiding (Widget)
import Utility.NotificationBroadcaster
import Utility.WebApp
import Utility.Yesod
@@ -33,7 +34,7 @@ import Network.Socket (PortNumber)
import Text.Blaze.Renderer.String
import Data.Text (Text, pack, unpack)
import qualified Data.Map as M
-import Data.Time.Clock
+import Data.Function
thisThread :: String
thisThread = "WebApp"
@@ -151,14 +152,47 @@ getTransfersR nid = do
sideBarDisplay :: Bool -> Widget
sideBarDisplay noScript = do
- date <- liftIO $ show <$> getCurrentTime
+ let content = do
+ {- Any yesod message appears as the first alert. -}
+ maybe noop rendermessage =<< lift getMessage
+
+ {- Add newest 10 alerts to the sidebar. -}
+ webapp <- lift getYesod
+ alerts <- M.toList . alertMap
+ <$> liftIO (getDaemonStatus $ daemonStatus webapp)
+ mapM_ renderalert $
+ take 10 $ reverse $ sortBy (compare `on` fst) alerts
ident <- lift newIdent
- mmsg <- lift getMessage
$(widgetFile "sidebar")
+
unless noScript $ do
- {- Set up automatic updates of the sidebar. -}
- nid <- lift $ newNotifier transferNotifier
+ {- Set up automatic updates of the sidebar
+ - when alerts come in. -}
+ nid <- lift $ newNotifier alertNotifier
autoUpdate ident (SideBarR nid) (10 :: Int) (10 :: Int)
+ where
+ bootstrapclass Activity = "alert-info"
+ bootstrapclass Warning = "alert"
+ bootstrapclass Error = "alert-error"
+ bootstrapclass Success = "alert-success"
+ bootstrapclass Message = "alert-info"
+
+ renderalert (alertid, alert) = addalert
+ (show alertid)
+ -- Activity alerts auto-close
+ (not noScript && alertClass alert /= Activity)
+ (alertBlockDisplay alert)
+ (bootstrapclass $ alertClass alert)
+ (alertHeader alert)
+ $ case alertMessage alert of
+ StringAlert s -> [whamlet|#{s}|]
+ WidgetAlert w -> w
+
+ rendermessage msg = addalert "yesodmessage" True False
+ "alert-info" Nothing [whamlet|#{msg}|]
+
+ addalert :: String -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
+ addalert alertid closable block divclass heading widget = $(widgetFile "alert")
{- Called by client to get a sidebar display.
-