summaryrefslogtreecommitdiff
path: root/Assistant/WebApp/SideBar.hs
blob: 2fbd4e8c0fd4cf388554115b2861f8fa3d24c00d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
{- git-annex assistant webapp sidebar
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}

module Assistant.WebApp.SideBar where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Notifications
import Assistant.DaemonStatus
import Assistant.Alert hiding (Widget)
import Utility.NotificationBroadcaster
import Utility.Yesod

import Yesod
import Data.Text (Text)
import qualified Data.Map as M
import Control.Concurrent

sideBarDisplay :: Maybe Widget -> Widget
sideBarDisplay onsidebar = do
	{- If a widget was passed to include on the sidebar, display
	 - it above alerts. -}
	let perpage = maybe noop id onsidebar
	let content = do
		{- Any yesod message appears as the first alert. -}
		maybe noop rendermessage =<< lift getMessage
	
		{- Add newest alerts to the sidebar. -}
		webapp <- lift getYesod
		alertpairs <- M.toList . alertMap
			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
		mapM_ renderalert $
			take displayAlerts $ reverse $ sortAlertPairs alertpairs
	let ident = "sidebar"
	$(widgetFile "sidebar/main")
	autoUpdate ident NotifierSideBarR (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
			alertid
			(alertClosable alert)
			(alertBlockDisplay alert)
			(bootstrapclass $ alertClass alert)
			(alertHeader alert)
			(alertIcon alert)
			$ case alertMessage alert of
				StringAlert s -> [whamlet|#{s}|]
				WidgetAlert w -> w alert

		rendermessage msg = addalert firstAlertId True False
			"alert-info" Nothing (Just "exclamation-sign") [whamlet|#{msg}|]

		addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Maybe String -> Widget -> Widget
		addalert i closable block divclass heading icon widget = do
			let alertid = show i
			let closealert = CloseAlert i
			$(widgetFile "sidebar/alert")

{- Called by client to get a sidebar display.
 -
 - Returns a div, which will be inserted into the calling page.
 -
 - Note that the head of the widget is not included, only its
 - body is. To get the widget head content, the widget is also 
 - inserted onto all pages.
 -}
getSideBarR :: NotificationId -> Handler RepHtml
getSideBarR nid = do
	waitNotifier alertNotifier nid

	{- This 0.1 second delay avoids very transient notifications from
	 - being displayed and churning the sidebar unnecesarily. 
	 -
	 - This needs to be below the level perceptable by the user,
	 - to avoid slowing down user actions like closing alerts. -}
	liftIO $ threadDelay 100000

	page <- widgetToPageContent $ sideBarDisplay Nothing
	hamletToRepHtml $ [hamlet|^{pageBody page}|]

{- Called by the client to close an alert. -}
getCloseAlert :: AlertId -> Handler ()
getCloseAlert i = do
	webapp <- getYesod
	void $ liftIO $ removeAlert (daemonStatus webapp) i