diff options
| -rw-r--r-- | Assistant/Alert.hs | 15 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 10 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 44 | ||||
| -rw-r--r-- | templates/sidebar.hamlet | 17 |
4 files changed, 59 insertions, 27 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. - diff --git a/templates/sidebar.hamlet b/templates/sidebar.hamlet index 3b5048151..32900b920 100644 --- a/templates/sidebar.hamlet +++ b/templates/sidebar.hamlet @@ -1,18 +1,3 @@ <div .span3 ##{ident}> <div .sidebar-nav> - $maybe msg <- mmsg - <div .alert .alert-info> - <a .close data-dismiss="alert" href="#">×</a> - #{msg} - <div .alert .alert-info> - <a .close data-dismiss="alert" href="#">×</a> - <b>This is just a demo.</b> If this were not just a demo, - I'd not be filling this sidebar with silly alerts. - <div .alert .alert-success> - <a .close data-dismiss="alert" href="#">×</a> - <b>Well done!</b> - You successfully read this important alert message. - <div .alert .alert-error> - <a .close data-dismiss="alert" href="#">×</a> - <b>Whoops!</b> - Unable to connect to blah blah.. #{date} + ^{content} |