The last time Hackerfall tried to access this page, it returned a not found error. A cached version of the page is below, or clickhereto continue anyway

The Daily Stormer: A Hurricane Alerting Service

With the declining popularity of television and radio, young people are less likely to tune in to official government-run alert systems. At any moment, they may be overrun by surprise flash floods that their older, wiser fellow citizens avoided by paying attention to the news.

This article will show how one can use Haskell to read a government hurricane feed, and post automated alerts to a website and Discord bot. Well name it The Daily Stormer, since a good domain name has recently opened up.

The Data

Official government sources are generally best, but they usually arent the easiest to interface with.

The National Hurricane Center appears to have a few dynamic Trouble Cyclone Feeds that we can use. Here is a complete Haskell program to download and parse them:

{-# LANGUAGE ViewPatterns #-}

import Text.Feed.Import
import Text.Feed.Types
import Text.RSS.Syntax
import Network.Download

import Control.Monad

feedUrls = [
  "http://www.nhc.noaa.gov/nhc_at1.xml",
  "http://www.nhc.noaa.gov/nhc_at2.xml",
  "http://www.nhc.noaa.gov/nhc_at3.xml",
  "http://www.nhc.noaa.gov/nhc_at4.xml",
  "http://www.nhc.noaa.gov/nhc_at5.xml",
  "http://www.nhc.noaa.gov/nhc_ep1.xml",
  "http://www.nhc.noaa.gov/nhc_ep2.xml",
  "http://www.nhc.noaa.gov/nhc_ep3.xml",
  "http://www.nhc.noaa.gov/nhc_ep4.xml",
  "http://www.nhc.noaa.gov/nhc_ep5.xml"
  ]

fetchFeed :: String -> IO Feed
fetchFeed url = either error id <$> openAsFeed url

main = do
  feeds <- mapM fetchFeed feedUrls
  forM feeds $ \feed -> case feed of
    RSSFeed (rssChannel -> (rssTitle -> title)) -> print title
    _ -> error "Unexpected feed type"

The case expression is pattern-matching the <title> attribute from the XML file, which is all we need.

To actually run this, I initialized a new project using stack new daily-stormer. Stack is a tool for managing Haskell projects. Then, I wrote this commit. Finally, I type stack build and stack exec read-feeds in my terminal.

Its output is:

"NHC Atlantic Wallet 1 - No current storm"
"NHC Atlantic Wallet 2 - No current storm"
"NHC Atlantic Wallet 3 - Hurricane Gert (AL082017)"
"NHC Atlantic Wallet 4 - No current storm"
"NHC Atlantic Wallet 5 - No current storm"
"NHC Eastern North Pacific Wallet 1 - No current storm"
"NHC Eastern North Pacific Wallet 2 - No current storm"
"NHC Eastern North Pacific Wallet 3 - No current storm"
"NHC Eastern North Pacific Wallet 4 - No current storm"
"NHC Eastern North Pacific Wallet 5 - No current storm"

Heres how the program will be structured:

Networking

Back in the wild 90s, we wouldnt really use frameworks or libraries. Wed just sort of open a socket to the outside world, and occasionally people would send us messages. At the other end of the spectrum are full-blown web frameworks, with templating languages and connection pools.

warp is a good choice to use for the HTTP layer here.

Recall that we needed components:

Heres a start to an alert service, with the 3rd and 4th parts stubbed out:

{-# LANGUAGE ViewPatterns, OverloadedStrings #-}

import Text.Feed.Import
import Text.Feed.Types
import Text.RSS.Syntax
import Network.Download
import Network.HTTP.Types(status200)
import qualified Network.Wai as W
import qualified Network.Wai.Handler.Warp as W

import Control.Concurrent(forkIO, threadDelay)
import Control.Monad
import Data.IORef
import Data.Time.Clock
import qualified Data.Set as S

data GlobalState = GlobalState {
  currentAlertsRef :: IORef (S.Set String)
  }

main :: IO ()
main = do
  st <- initialize
  startTimer st
  W.run 2000 $ \request respond -> do
    respond $ W.responseLBS status200 [] "BEWARE OF HURRICANES"

initialize :: IO GlobalState
initialize = do
  titles <- fetchTitles
  alertsRef <- newIORef titles
  return $ GlobalState { currentAlertsRef = alertsRef }

startTimer :: GlobalState -> IO ()
startTimer (currentAlertsRef -> alertsRef) = do
  threadId <- forkIO loop
  return ()
  where
    loop = do
      threadDelay $ 10 * seconds
      titles <- fetchTitles
      atomicWriteIORef alertsRef titles
      loop
    seconds = 1000000

fetchTitles :: IO (S.Set String)
fetchTitles = do
  putStrLn "Fetched!"
  return $ S.fromList []

At startup and every 10 seconds after, it will pretend like its fetching status updates from the government:

$ stack exec alerts-service
Fetched!
Fetched!
Fetched!
Fetched!

And you can curl it for some advice:

$ curl localhost:2000
BEWARE OF HURRICANES

Adding the Alerts

Lets change the service to actually fetch those alerts. And then well calculate which alerts are new.

fetchTitles above is where we insert the code from the first section, but lets rename it to fetchAlerts:

feedUrls = [
  "http://www.nhc.noaa.gov/nhc_at1.xml",
  "http://www.nhc.noaa.gov/nhc_at2.xml",
  "http://www.nhc.noaa.gov/nhc_at3.xml",
  "http://www.nhc.noaa.gov/nhc_at4.xml",
  "http://www.nhc.noaa.gov/nhc_at5.xml",
  "http://www.nhc.noaa.gov/nhc_ep1.xml",
  "http://www.nhc.noaa.gov/nhc_ep2.xml",
  "http://www.nhc.noaa.gov/nhc_ep3.xml",
  "http://www.nhc.noaa.gov/nhc_ep4.xml",
  "http://www.nhc.noaa.gov/nhc_ep5.xml"
  ]

fetchAlerts :: IO (S.Set String)
fetchAlerts = do
  feeds <- rights <$> mapM openAsFeed feedUrls
  let titles = catMaybes $ flip Prelude.map feeds $ \feed -> case feed of
        RSSFeed (rssChannel -> (rssTitle -> title)) -> Just title
        _ -> Nothing
  return $ S.fromList titles

The original code threw an exception when it encountered a parsing error. Ive changed it to instead silently drop when it doesnt parse or match our pattern.

Our service will update its alerts, but we need to calculate differences in order to warn people of new hurricanes. Well do that in the timer:

startTimer :: GlobalState -> IO ()
startTimer st@(currentAlertsRef -> alertsRef) = do
  threadId <- forkIO loop
  return ()
  where
    loop = do
      threadDelay $ 10 * seconds
      oldAlerts <- readIORef alertsRef
      updatedAlerts <- fetchAlerts
      let newAlerts = updatedAlerts `S.difference` oldAlerts
      atomicWriteIORef alertsRef updatedAlerts
      unless (S.null newAlerts) $ do
        notifyListeners st newAlerts
      loop
    seconds = 1000000

notifyListeners :: GlobalState -> S.Set String -> IO ()
notifyListeners _ newAlerts = forM_ newAlerts $ \alert -> do
  terminalListener alert
  -- INSERT OTHER LISTENERS HERE

terminalListener :: String -> IO ()
terminalListener alert = print alert

Its polite to poll the government servers every hour, rather than every 10 seconds. To test listeners, I recommend temporarily replacing fetchAlerts with this definition:

fetchAlerts :: IO (S.Set String)
fetchAlerts = do
  now <- getCurrentTime
  putStrLn "Fetched!"
  return $ S.fromList [ "example", show now ]

Our service should now watch the government feed and tell us when theres an incoming hurricane. We should be safe, but other people need to be alerted too.

Discord Listener

We were going to do a Twitter bot here, but they require a mobile phone and life is too short to have one of those

Discord is a chat application like IRC, but you can post images and browse the chat history. Since our alerting service is targeted towards kids vulnerable to sudden flash floods, this will be our most useful way to report alerts to them.

We could hand-roll the client since Discord supports webhooks, but someones already written the discord-hs library to do this. Heres the Discord listener:

data GlobalState = GlobalState {
  currentAlertsRef :: IORef (S.Set String),
  discordChan :: Chan String
  }

-- Get these from Discord web interface
discordToken = undefined
discordChannel = undefined

initializeDiscordBot :: IO (Chan String)
initializeDiscordBot = do
  chan <- newChan
  forkIO $ do
    runBot (Bot discordToken) $ do
      with ReadyEvent $ \(Init v u _ _ _) -> do
        liftIO $ putStrLn $ "Connected to gateway " ++ show v ++ " as user " ++ show u
        loop chan
  return chan
  where
    loop chan = do
      alert <- liftIO $ readChan chan
      fetch' $ CreateMessage discordChannel (pack alert) Nothing
      loop chan

notifyListeners :: GlobalState -> S.Set String -> IO ()
notifyListeners (discordChan -> dchan) newAlerts = forM_ newAlerts $ \alert -> do
  terminalListener alert
  discordListener dchan alert

discordListener :: Chan String -> String -> IO ()
discordListener chan alert = writeChan chan alert

The bot needs to persistently wait in someones Discord channel, so we fork off another thread for it(thats at least 3 threads in total now). We need to pass alerts to the bot when we find them, so we create a Chan String and add it to our global state. The listener will write messages to the channel, while the bot will be in a loop reading messages from the channel.

discord-hs uses Pipes in its example code; its another Haskell library. The problem that pipes solves is that we have all of these APIs and databases and web services and scrapers and files floating around. We want to hook them all together, but theres sockets and connection pools and caching layers and other complexities that need to be initialized and destroyed that get in the way. pipes or its competitors conduit and machines are all good choices to use for this. Hes probably using pipes to store an HTTP session cookie.

Because discord-hs accesses the network, it must use IO underneath the hood. liftIO is a common way to execute an IO action when in a context that is similar-to-but-not-actually IO.

Website

Our website should probably say more than just "BEWARE OF HURRICANES". One improvement would be to display all of the alert titles:

import Data.ByteString.Lazy

main :: IO ()
main = do
  st <- initialize
  startTimer st
  W.run 2000 $ \request respond -> do
    text <- renderState st
    respond $ W.responseLBS status200 [] text

renderState :: GlobalState -> IO ByteString
renderState (currentAlertsRef -> alertsRef) = do
  alerts <- readIORef alertsRef
  return $ encodeUtf8 $ TL.pack $ show alerts

which displays:

fromList ["NHC Atlantic Wallet 1 - No current storm",
"NHC Atlantic Wallet 2 - No current storm",
"NHC Atlantic Wallet 3 - Hurricane Gert (AL082017)",
"NHC Atlantic Wallet 4 - No current storm",
"NHC Atlantic Wallet 5 - No current storm",
"NHC Eastern North Pacific Wallet 1 - No current storm",
"NHC Eastern North Pacific Wallet 2 - No current storm",
"NHC Eastern North Pacific Wallet 3 - No current storm",
"NHC Eastern North Pacific Wallet 4 - No current storm",
"NHC Eastern North Pacific Wallet 5 - No current storm"]

To really call it a website, though, well want to return HTML in our response. blaze-html is a good way to embed HTML in just about any Haskell program. Heres how to get a single unstyled table:

import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Renderer.Utf8 (renderMarkup)

renderState :: GlobalState -> IO BSL.ByteString
renderState (currentAlertsRef -> alertsRef) = do
  alerts <- readIORef alertsRef
  return $ renderMarkup $ html $ do
    head $ do
      title "The Daily Stormer"
      -- link ! rel "stylesheet " type_ "text/css" ! href "http://assets.daily-stormer.michaelburge.us"
    body $ do
      table ! class_ "alerts" $ forM_ alerts $ \alert -> do
        tr $
          td $ toMarkup alert
  where
    title = H.title

You can navigate to port 2000 with your web browser to see the HTML document youd expect.

If you wanted to build out a full website, you might try using an actual web framework at this point. I recommend using a separate asset server to host CSS, images, and other static assets because youd otherwise have to change your code to serve them - and why do extra work?

Conclusion

Weve presented a foundation for how one might build an alerting service to warn people of impending storms. Unfortunately, funding ran dry partway through development, so weve left the code on Github.

Continue reading on www.michaelburge.us