implement server-side alert closing

Rather than using bootstrap's client-side closing.
Now closed alerts stay closed.

3 files changed, 29 insertions, 8 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 18f3ffa5d..4a3b2cf72 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -37,7 +37,15 @@ data Alert = Alert
 	}
 
 {- Higher AlertId indicates a more recent alert. -}
-type AlertId = Integer
+newtype AlertId = AlertId Integer
+        deriving (Read, Show, Eq, Ord)
+
+{- Note: This first alert id is used for yesod's message. -}
+firstAlertId :: AlertId
+firstAlertId = AlertId 0
+
+nextAlertId :: AlertId -> AlertId
+nextAlertId (AlertId i) = AlertId $ succ i
 
 type AlertPair = (AlertId, Alert)
 
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 77387deb8..3c0bfba42 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -61,7 +61,7 @@ newDaemonStatus = DaemonStatus
 	<*> pure Nothing
 	<*> pure M.empty
 	<*> pure M.empty
-	<*> pure 0
+	<*> pure firstAlertId
 	<*> pure []
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
@@ -217,7 +217,7 @@ addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus
 	where
 		go s = (s { alertMax = i, alertMap = m }, i)
 			where
-				i = alertMax s + 1
+				i = nextAlertId $ alertMax s
 				m = M.insertWith' const i alert (alertMap s)
 
 removeAlert :: DaemonStatusHandle -> AlertId -> IO ()
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 44fb44f2b..0de4a50a8 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -93,6 +93,7 @@ mkYesod "WebApp" [parseRoutes|
 /noscriptauto NoScriptAutoR GET
 /transfers/#NotificationId TransfersR GET
 /sidebar/#NotificationId SideBarR GET
+/closealert/#AlertId CloseAlert GET
 /config ConfigR GET
 /addrepository AddRepositoryR GET
 /static StaticR Static getStatic
@@ -102,6 +103,10 @@ instance PathPiece NotificationId where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
 
+instance PathPiece AlertId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
 instance Yesod WebApp where
 	defaultLayout content = do
 		webapp <- getYesod
@@ -110,7 +115,6 @@ instance Yesod WebApp where
 			addStylesheet $ StaticR css_bootstrap_responsive_css
 			addScript $ StaticR jquery_full_js
 			addScript $ StaticR js_bootstrap_dropdown_js
-			addScript $ StaticR js_bootstrap_alert_js
 			$(widgetFile "page")
 		hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
 
@@ -229,7 +233,7 @@ sideBarDisplay noScript = do
 		bootstrapclass Message = "alert-info"
 
 		renderalert (alertid, alert) = addalert
-			(show alertid)
+			alertid
 			(alertClosable alert)
 			(alertBlockDisplay alert)
 			(bootstrapclass $ alertClass alert)
@@ -238,11 +242,14 @@ sideBarDisplay noScript = do
 				StringAlert s -> [whamlet|#{s}|]
 				WidgetAlert w -> w alert
 
-		rendermessage msg = addalert "yesodmessage" True False
+		rendermessage msg = addalert firstAlertId 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")
+		addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
+		addalert i closable block divclass heading widget = do
+			let alertid = show i
+			let closealert = CloseAlert i
+			$(widgetFile "alert")
 
 {- Called by client to get a sidebar display.
  -
@@ -259,6 +266,12 @@ getSideBarR nid = do
 	page <- widgetToPageContent $ sideBarDisplay True
 	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
+
 dashboard :: Bool -> Bool -> Widget
 dashboard noScript warnNoScript = do
 	sideBarDisplay noScript