diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,20 @@ +0.0.6 + +* New module `Data.Aviation.GAF` — fetches BOM Graphical Area Forecast PNGs + * Parses area codes from `gaf.shtml` and area→product-id rotations from + `gaf-pub.js`; picks current/next based on UTC hour boundaries at + 05/11/17/23 + * Exposes `getGAF`, `GAFPeriod`, `GAFError`, `GAFImage` +* New module `Data.Aviation.GPWT` — fetches BOM Grid Point Wind & + Temperature forecast PNGs + * Parses the grid-point-forecasts page for the full (level, area, time) + → product-id map + * Routes `IDY*` products through `/fwo/aviation/` and `IDX*` products + through `/difacs/aviation/` + * Normalises area codes so `VIC/TAS`, `VIC-TAS` and `VICTAS` all match + * Exposes `getGPWT`, `GPWTLevel`, `GPWTEntry`, `GPWTError`, `GPWTImage` +* Add `time` dependency + 0.0.5 * Restore BOM (Bureau of Meteorology) support via HTML scraping of the METAR/SPECI page diff --git a/metar.cabal b/metar.cabal --- a/metar.cabal +++ b/metar.cabal @@ -1,5 +1,5 @@ name: metar -version: 0.0.5 +version: 0.0.6 license: BSD3 license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@sıɹɹoɯʇ> @@ -40,6 +40,7 @@ , transformers >= 0.5 && < 0.7 , deriving-compat >= 0.5 && < 0.7 , tagsoup >= 0.14 && < 0.15 + , time >= 1.9 && < 2 , wreq >= 0.5 && < 0.6 ghc-options: @@ -49,7 +50,9 @@ src exposed-modules: - Data.Aviation.Metar + Data.Aviation.GAF + , Data.Aviation.GPWT + , Data.Aviation.Metar , Data.Aviation.Metar.Cache , Data.Aviation.Metar.METARError , Data.Aviation.Metar.METARResult diff --git a/src/Data/Aviation/GAF.hs b/src/Data/Aviation/GAF.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/GAF.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{- FOURMOLU_DISABLE -} +-- $setup +-- >>> import Text.HTML.TagSoup (parseTags) +{- FOURMOLU_ENABLE -} + +-- | Fetching Graphical Area Forecasts (GAFs) from the Australian Bureau of +-- Meteorology. +-- +-- The BOM's aviation site publishes a national GAF page at +-- that lists ten forecast +-- areas (@WA-N@, @WA-S@, @NT@, @QLD-N@, @QLD-S@, @SA@, @NSW-W@, @NSW-E@, +-- @VIC@, @TAS@). For each area there are four rotating PNG products; which +-- product is \"current\" and which is \"next\" depends on the current UTC +-- hour. This module parses the HTML page for the valid area codes and the +-- accompanying JavaScript for the area→product mapping, then fetches the +-- appropriate PNG. +module Data.Aviation.GAF ( + -- * Types + GAFPeriod (..), + GAFError (..), + GAFImage (..), + + -- * Fetching + getGAF, + + -- * Parsing (exported for testing) + parseAreaCodes, + parsePids, + normaliseArea, + hourIndex, + pickPid, + renderGAFError, +) where + +import Control.Exception (catch) +import Control.Lens ((&), (.~), (^.)) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, isSpace, toUpper) +import Data.List (find) +import Data.Time.Clock (UTCTime (utctDayTime), getCurrentTime) +import Network.HTTP.Client (HttpException) +import Network.Wreq (Options, defaults, getWith, headers, responseBody) +import Text.HTML.TagSoup (Tag (TagOpen), parseTags) + +-- | Which of the two forecast periods a caller wants. +-- +-- >>> [GAFCurrent, GAFNext] +-- [GAFCurrent,GAFNext] +data GAFPeriod + = GAFCurrent + | GAFNext + deriving (Eq, Show) + +-- | One raw GAF image response. +data GAFImage = GAFImage + { gafContentType :: String + , gafBytes :: BL.ByteString + } + deriving (Eq, Show) + +-- | Something that can go wrong while retrieving a GAF. +data GAFError + = -- | Requested area code was not one of the codes exposed by the BOM + -- GAF page. The list of valid codes is returned for the caller to render. + GAFUnknownArea String [String] + | -- | The BOM GAF HTML did not contain any recognisable area entries. + GAFAreasParseError + | -- | The BOM GAF JavaScript did not contain a product-id block for the + -- (normalised) area name. + GAFPidsParseError String + | -- | A network request failed. First field is the source label. + GAFHttpError String String + deriving (Eq, Show) + +-- | Render a 'GAFError' as a single line of human-readable text. +-- +-- >>> renderGAFError (GAFUnknownArea "ZZZ" ["WA-N", "VIC"]) +-- "unknown area \"ZZZ\" (valid: WA-N, VIC)" +-- +-- >>> renderGAFError GAFAreasParseError +-- "no GAF areas found on gaf.shtml" +-- +-- >>> renderGAFError (GAFPidsParseError "WAN") +-- "no product ids for area WAN in gaf-pub.js" +-- +-- >>> renderGAFError (GAFHttpError "gaf.shtml" "connection timeout") +-- "gaf.shtml: connection timeout" +renderGAFError :: + GAFError -> + String +renderGAFError e = + case e of + GAFUnknownArea a valid -> + "unknown area " <> show a <> " (valid: " <> commaList valid <> ")" + GAFAreasParseError -> + "no GAF areas found on gaf.shtml" + GAFPidsParseError a -> + "no product ids for area " <> a <> " in gaf-pub.js" + GAFHttpError src msg -> + src <> ": " <> msg + where + commaList [] = "" + commaList [x] = x + commaList (x : xs) = x <> ", " <> commaList xs + +-- | HTTP options used when talking to bom.gov.au. Sending a browser-shaped +-- User-Agent (and the @check=ok@ cookie the site expects) is necessary to +-- avoid the anti-scraping block page. +bomOptions :: + Options +bomOptions = + defaults + & headers + .~ [ ("User-Agent", "Mozilla/5.0 (X11; Linux x86_64; rv:120.0) Gecko/20100101 Firefox/120.0") + , ("Accept", "*/*") + , ("Accept-Language", "en-US,en;q=0.5") + , ("Cookie", "check=ok") + ] + +-- | Extract the GAF area codes from the @gaf.shtml@ page. The relevant +-- markup looks like +-- +-- @ +-- \ +-- @ +-- +-- We keep every @class="GAF"@ checkbox except the invisible @areamap@ one. +-- +-- >>> parseAreaCodes (parseTags "") +-- ["WA-N","VIC"] +-- +-- >>> parseAreaCodes (parseTags "") +-- [] +-- +-- >>> parseAreaCodes [] +-- [] +parseAreaCodes :: + [Tag String] -> + [String] +parseAreaCodes = + let isCheckbox attrs = + lookup "type" attrs == Just "checkbox" + && lookup "class" attrs == Just "GAF" + go (TagOpen "input" attrs : rest) + | isCheckbox attrs = + case lookup "id" attrs of + Just i | i /= "areamap" -> i : go rest + _ -> go rest + go (_ : rest) = go rest + go [] = [] + in go + +-- | Extract area→product-id mappings from the @gaf-pub.js@ script. Each area +-- has a JavaScript line of the form +-- +-- @ +-- WAN = ['IDY42054', 'IDY42055', 'IDY42056', 'IDY42057']; //area id #0 (WA - North) +-- @ +-- +-- We look for those four-element string-array assignments and key them by +-- the JS variable name. Duplicate keys keep the first occurrence. +-- +-- >>> parsePids "WAN = ['IDY42054', 'IDY42055', 'IDY42056', 'IDY42057'];" +-- [("WAN",["IDY42054","IDY42055","IDY42056","IDY42057"])] +-- +-- >>> parsePids "WAS=['A','B','C','D'];\nVIC = ['E','F','G','H'];" +-- [("WAS",["A","B","C","D"]),("VIC",["E","F","G","H"])] +-- +-- Non-matching lines are ignored: +-- +-- >>> parsePids "states = [WAN, WAS];" +-- [] +-- +-- >>> parsePids "" +-- [] +parsePids :: + String -> + [(String, [String])] +parsePids src = + [ (name, items) + | line <- lines src + , Just (name, items) <- [parsePidLine line] + , length items == 4 + ] + +-- | Parse a single @NAME = ['a','b','c','d'];@ style assignment. Returns +-- 'Nothing' if the line does not match that shape. +-- +-- >>> parsePidLine "WAN = ['A', 'B', 'C', 'D'];" +-- Just ("WAN",["A","B","C","D"]) +-- +-- >>> parsePidLine " QLDN=['A','B','C','D'] ;" +-- Just ("QLDN",["A","B","C","D"]) +-- +-- >>> parsePidLine "states = [WAN, WAS];" +-- Nothing +-- +-- >>> parsePidLine "" +-- Nothing +parsePidLine :: + String -> + Maybe (String, [String]) +parsePidLine s0 = + let s = dropWhile isSpace s0 + (name, rest1) = span isIdent s + in if null name + then Nothing + else + let rest2 = dropWhile isSpace rest1 + in case rest2 of + '=' : rest3 -> + let rest4 = dropWhile isSpace rest3 + in case rest4 of + '[' : rest5 -> + case readStringArray rest5 of + Just items -> Just (name, items) + Nothing -> Nothing + _ -> Nothing + _ -> Nothing + where + isIdent c = c == '_' || isAsciiUpper c || isAsciiLower c || isDigit c + +-- | Read a comma-separated list of quoted strings, terminated by @]@. +-- Returns 'Nothing' if the syntax does not match. +-- +-- >>> readStringArray "'a', 'b', 'c']" +-- Just ["a","b","c"] +-- +-- >>> readStringArray "\"a\", \"b\"]" +-- Just ["a","b"] +-- +-- >>> readStringArray "]" +-- Just [] +-- +-- >>> readStringArray "not-a-string]" +-- Nothing +readStringArray :: + String -> + Maybe [String] +readStringArray s = + case dropWhile isSpace s of + ']' : _ -> Just [] + '\'' : rest -> takeQuoted '\'' rest + '"' : rest -> takeQuoted '"' rest + _ -> Nothing + where + takeQuoted q rest = + let (item, rest') = break (== q) rest + in case rest' of + _ : rest'' -> + let rest''' = dropWhile isSpace rest'' + in case rest''' of + ',' : more -> + fmap (item :) (readStringArray more) + ']' : _ -> + Just [item] + _ -> Nothing + [] -> Nothing + +-- | Convert an area code from BOM UI form (@\"WA-N\"@) to the JavaScript +-- variable name form (@\"WAN\"@) used in @gaf-pub.js@. +-- +-- >>> normaliseArea "WA-N" +-- "WAN" +-- +-- >>> normaliseArea "QLD-S" +-- "QLDS" +-- +-- >>> normaliseArea "VIC" +-- "VIC" +-- +-- >>> normaliseArea "nsw-w" +-- "NSWW" +normaliseArea :: + String -> + String +normaliseArea = + fmap toUpper . filter (\c -> c /= '-' && c /= ' ') + +-- | Map a UTC hour (0-23) and a requested period to an index into the +-- four-element product list. The BOM rotation happens at 05, 11, 17 and 23 +-- UTC. +-- +-- >>> map (\h -> hourIndex h GAFCurrent) [0, 4, 5, 10, 11, 16, 17, 22, 23] +-- [3,3,0,0,1,1,2,2,3] +-- +-- >>> map (\h -> hourIndex h GAFNext) [0, 4, 5, 10, 11, 16, 17, 22, 23] +-- [0,0,1,1,2,2,3,3,0] +hourIndex :: + Int -> + GAFPeriod -> + Int +hourIndex h p = + let base + | h >= 5 && h < 11 = 0 + | h >= 11 && h < 17 = 1 + | h >= 17 && h < 23 = 2 + | otherwise = 3 + in case p of + GAFCurrent -> base + GAFNext -> (base + 1) `mod` 4 + +-- | Select the appropriate product id from a four-element list given a UTC +-- hour and the requested period. +-- +-- >>> pickPid 6 GAFCurrent ["a", "b", "c", "d"] +-- Just "a" +-- +-- >>> pickPid 6 GAFNext ["a", "b", "c", "d"] +-- Just "b" +-- +-- >>> pickPid 23 GAFCurrent ["a", "b", "c", "d"] +-- Just "d" +-- +-- >>> pickPid 23 GAFNext ["a", "b", "c", "d"] +-- Just "a" +-- +-- >>> pickPid 6 GAFCurrent ["only-one"] +-- Nothing +pickPid :: + Int -> + GAFPeriod -> + [String] -> + Maybe String +pickPid h p pids = + let go 0 (x : _) = Just x + go n (_ : xs) = go (n - 1) xs + go _ [] = Nothing + in if length pids >= 4 + then go (hourIndex h p) pids + else Nothing + +-- | Fetch either the current or next GAF image for the given area code. +-- +-- The area code must be one of the codes advertised on @gaf.shtml@ +-- (@WA-N@, @WA-S@, @NT@, @QLD-N@, @QLD-S@, @SA@, @NSW-W@, @NSW-E@, @VIC@, +-- @TAS@); it is matched case-insensitively. +-- +-- >>> :t getGAF +-- getGAF :: String -> GAFPeriod -> IO (Either GAFError GAFImage) +getGAF :: + String -> + GAFPeriod -> + IO (Either GAFError GAFImage) +getGAF areaIn period = + let want = fmap toUpper areaIn + in fetchAreas >>= \case + Left err -> pure (Left err) + Right areas -> + case find (\a -> fmap toUpper a == want) areas of + Nothing -> pure (Left (GAFUnknownArea areaIn areas)) + Just areaCode -> + fetchPids >>= \case + Left err -> pure (Left err) + Right pidMap -> + let key = normaliseArea areaCode + in case lookup key pidMap of + Nothing -> pure (Left (GAFPidsParseError key)) + Just pids -> + do + h <- currentUtcHour + case pickPid h period pids of + Nothing -> pure (Left (GAFPidsParseError key)) + Just pid -> fetchImage pid + +-- | Fetch and parse the GAF landing page for its list of area codes. +fetchAreas :: + IO (Either GAFError [String]) +fetchAreas = + let url = "https://www.bom.gov.au/aviation/gaf/gaf.shtml" + in httpGet "gaf.shtml" url >>= \case + Left err -> pure (Left err) + Right body -> + case parseAreaCodes (parseTags (BLC.unpack body)) of + [] -> pure (Left GAFAreasParseError) + xs -> pure (Right xs) + +-- | Fetch and parse the GAF publication script for its area→PID map. +fetchPids :: + IO (Either GAFError [(String, [String])]) +fetchPids = + let url = "https://www.bom.gov.au/scripts/aviation/forecasts/gaf-pub.js" + in httpGet "gaf-pub.js" url >>= \case + Left err -> pure (Left err) + Right body -> pure (Right (parsePids (BLC.unpack body))) + +-- | Fetch the actual GAF PNG for a given product id. +fetchImage :: + String -> + IO (Either GAFError GAFImage) +fetchImage pid = + let url = "https://www.bom.gov.au/fwo/aviation/" <> pid <> ".png" + in httpGet pid url >>= \case + Left err -> pure (Left err) + Right body -> pure (Right (GAFImage "image/png" body)) + +-- | Wrap a Wreq GET call, catching 'HttpException's and returning them as a +-- 'GAFHttpError' tagged with the given source label. +httpGet :: + String -> + String -> + IO (Either GAFError BL.ByteString) +httpGet src url = + catch + (fmap (Right . (^. responseBody)) (getWith bomOptions url)) + (\e -> pure (Left (GAFHttpError src (show (e :: HttpException))))) + +-- | Read the current UTC hour of day. +-- +-- >>> :t currentUtcHour +-- currentUtcHour :: IO Int +currentUtcHour :: + IO Int +currentUtcHour = + do + now <- getCurrentTime + pure (floor (utctDayTime now / 3600) `mod` 24) diff --git a/src/Data/Aviation/GPWT.hs b/src/Data/Aviation/GPWT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/GPWT.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{- FOURMOLU_DISABLE -} +-- $setup +-- >>> import Text.HTML.TagSoup (parseTags) +{- FOURMOLU_ENABLE -} + +-- | Fetching Grid Point Wind and Temperature forecasts (GPWTs) from the +-- Australian Bureau of Meteorology. +-- +-- The BOM's aviation site publishes GPWT charts at +-- in three +-- flight-level bands ('GPWTLow', 'GPWTMid', 'GPWTHigh'). Each band offers a +-- number of area codes (e.g. @AUS@, @NSW@, @QLD-N@, @VIC\/TAS@, @TIMS@) and +-- eight three-hourly time slices (@00Z@, @03Z@ ... @21Z@). This module +-- parses the HTML page for the (level, area, time) → product-id map and +-- fetches the requested PNG. +module Data.Aviation.GPWT ( + -- * Types + GPWTLevel (..), + GPWTError (..), + GPWTImage (..), + GPWTEntry (..), + + -- * Fetching + getGPWT, + + -- * Parsing (exported for testing) + parseGPWTEntries, + parseLevel, + levelPrefix, + levelAndTimeFromTitle, + pidFromHref, + normaliseCode, + normaliseTime, + renderGPWTError, +) where + +import Control.Exception (catch) +import Control.Lens ((&), (.~), (^.)) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, isSpace, toUpper) +import Data.List (nub, sort) +import Network.HTTP.Client (HttpException) +import Network.Wreq (Options, defaults, getWith, headers, responseBody) +import Text.HTML.TagSoup (Tag (TagOpen, TagText), parseTags) + +-- | The three flight-level bands published on the GPWT page. +-- +-- >>> [GPWTLow, GPWTMid, GPWTHigh] +-- [GPWTLow,GPWTMid,GPWTHigh] +data GPWTLevel + = GPWTLow + | GPWTMid + | GPWTHigh + deriving (Eq, Show) + +-- | One (level, area, time) product parsed from the GPWT page. +-- +-- The @gpwtEntryPid@ is the bare product identifier (without the @.png@ +-- suffix), e.g. @\"IDY04650\"@. +data GPWTEntry = GPWTEntry + { gpwtEntryLevel :: GPWTLevel + , gpwtEntryArea :: String + , gpwtEntryTime :: String + , gpwtEntryPid :: String + } + deriving (Eq, Show) + +-- | One raw GPWT image response. +data GPWTImage = GPWTImage + { gpwtContentType :: String + , gpwtBytes :: BL.ByteString + } + deriving (Eq, Show) + +-- | Something that can go wrong while retrieving a GPWT. +data GPWTError + = -- | The URL segment for the level was not one of @low@, @mid@, @high@. + GPWTUnknownLevel String + | -- | No product for the requested (level, area, time) triple. The valid + -- (area, [time]) pairs at that level are returned for the caller to + -- render. + GPWTNoSuchProduct GPWTLevel String String [(String, [String])] + | -- | The BOM GPWT page did not contain any recognisable product entries. + GPWTParseError + | -- | A network request failed. First field is the source label. + GPWTHttpError String String + deriving (Eq, Show) + +-- | Render a 'GPWTError' as a single line of human-readable text. +-- +-- >>> renderGPWTError (GPWTUnknownLevel "xyz") +-- "unknown level \"xyz\" (valid: low, mid, high)" +-- +-- >>> renderGPWTError (GPWTNoSuchProduct GPWTLow "ZZZ" "99Z" [("AUS", ["00Z","03Z"])]) +-- "no low-level GPWT for area \"ZZZ\" time \"99Z\" (valid: AUS [00Z, 03Z])" +-- +-- >>> renderGPWTError GPWTParseError +-- "no GPWT products found on grid-point-forecasts page" +-- +-- >>> renderGPWTError (GPWTHttpError "grid-point-forecasts" "connection timeout") +-- "grid-point-forecasts: connection timeout" +renderGPWTError :: + GPWTError -> + String +renderGPWTError e = + case e of + GPWTUnknownLevel l -> + "unknown level " <> show l <> " (valid: low, mid, high)" + GPWTNoSuchProduct lv area time valid -> + "no " + <> levelPrefix lv + <> "-level GPWT for area " + <> show area + <> " time " + <> show time + <> " (valid: " + <> renderValid valid + <> ")" + GPWTParseError -> + "no GPWT products found on grid-point-forecasts page" + GPWTHttpError src msg -> + src <> ": " <> msg + where + renderValid xs = + intercalateSep "; " [a <> " [" <> intercalateSep ", " ts <> "]" | (a, ts) <- xs] + intercalateSep _ [] = "" + intercalateSep _ [x] = x + intercalateSep sep (x : xs) = x <> sep <> intercalateSep sep xs + +-- | Prefix used in BOM's title attributes (@\"Low-level\"@, @\"Mid-level\"@, +-- @\"High-level\"@) for the given 'GPWTLevel', lowercased. +-- +-- >>> map levelPrefix [GPWTLow, GPWTMid, GPWTHigh] +-- ["low","mid","high"] +levelPrefix :: + GPWTLevel -> + String +levelPrefix GPWTLow = "low" +levelPrefix GPWTMid = "mid" +levelPrefix GPWTHigh = "high" + +-- | Parse a URL segment (@low@\/@mid@\/@high@, case-insensitive) into a +-- 'GPWTLevel'. +-- +-- >>> map parseLevel ["low", "Mid", "HIGH"] +-- [Just GPWTLow,Just GPWTMid,Just GPWTHigh] +-- +-- >>> parseLevel "other" +-- Nothing +-- +-- >>> parseLevel "" +-- Nothing +parseLevel :: + String -> + Maybe GPWTLevel +parseLevel s = + case fmap toUpper s of + "LOW" -> Just GPWTLow + "MID" -> Just GPWTMid + "HIGH" -> Just GPWTHigh + _ -> Nothing + +-- | Normalise an area code for comparison. Uppercases and drops every +-- character that is not a letter or digit, so callers can use any of +-- @\"VIC\/TAS\"@, @\"VIC-TAS\"@ or @\"VICTAS\"@ interchangeably. +-- +-- >>> map normaliseCode ["VIC/TAS", "vic-tas", "victas", "QLD-N", "qldn"] +-- ["VICTAS","VICTAS","VICTAS","QLDN","QLDN"] +normaliseCode :: + String -> + String +normaliseCode = + fmap toUpper . filter isAlnum + where + isAlnum c = isAsciiUpper c || isAsciiLower c || isDigit c + +-- | Normalise a time slot for comparison. Uppercases, strips whitespace, and +-- pads a single leading zero if only one digit was given before the @Z@. +-- +-- >>> map normaliseTime ["00Z", "03z", "9Z", "18Z", " 21z "] +-- ["00Z","03Z","09Z","18Z","21Z"] +-- +-- >>> normaliseTime "notatime" +-- "NOTATIME" +normaliseTime :: + String -> + String +normaliseTime = + let padZ s = + case s of + [d, 'Z'] | isDigit d -> ['0', d, 'Z'] + _ -> s + in padZ . fmap toUpper . filter (not . isSpace) + +-- | Extract the trailing @\"XXZ\"@ time from a BOM title attribute and pair +-- it with a 'GPWTLevel'. Titles look like @\"Low-level, Australia 00Z\"@. +-- +-- >>> levelAndTimeFromTitle "Low-level, Australia 00Z" +-- Just (GPWTLow,"00Z") +-- +-- >>> levelAndTimeFromTitle "Mid-level, North-East 12Z" +-- Just (GPWTMid,"12Z") +-- +-- >>> levelAndTimeFromTitle "High-level, Tasman 21Z" +-- Just (GPWTHigh,"21Z") +-- +-- >>> levelAndTimeFromTitle "Something else" +-- Nothing +-- +-- Malformed times (BOM has one @\"015\"@ typo entry) are rejected: +-- +-- >>> levelAndTimeFromTitle "Mid-level, South-East 015" +-- Nothing +levelAndTimeFromTitle :: + String -> + Maybe (GPWTLevel, String) +levelAndTimeFromTitle t = + let (prefix, rest0) = break (== ',') t + rest = dropWhile isSpace (drop 1 rest0) + in do + lv <- case prefix of + "Low-level" -> Just GPWTLow + "Mid-level" -> Just GPWTMid + "High-level" -> Just GPWTHigh + _ -> Nothing + tm <- case reverse (words rest) of + (w : _) | isValidTime w -> Just w + _ -> Nothing + Just (lv, tm) + where + isValidTime [d1, d2, 'Z'] = isDigit d1 && isDigit d2 + isValidTime _ = False + +-- | Extract a product id (without the @.png@ suffix) from an anchor's +-- @href@ attribute. +-- +-- >>> pidFromHref "/difacs/aviation/IDY04650.png" +-- Just "IDY04650" +-- +-- >>> pidFromHref "/fwo/aviation/IDY04651.png" +-- Just "IDY04651" +-- +-- >>> pidFromHref "/aviation/gaf/gaf.shtml" +-- Nothing +-- +-- >>> pidFromHref "" +-- Nothing +pidFromHref :: + String -> + Maybe String +pidFromHref href = + let base = reverse (takeWhile (/= '/') (reverse href)) + in case reverse base of + 'g' : 'n' : 'p' : '.' : rest -> + let name = reverse rest + in if not (null name) && all (\c -> isAsciiUpper c || isDigit c) name + then Just name + else Nothing + _ -> Nothing + +-- | Walk a parsed HTML tag stream and emit one 'GPWTEntry' per +-- @\@ product link. Area codes are inherited from the +-- most recently opened @\@; the level and time come from each +-- anchor's own @title@ attribute. +-- +-- >>> parseGPWTEntries (parseTags "") +-- [GPWTEntry {gpwtEntryLevel = GPWTLow, gpwtEntryArea = "AUS", gpwtEntryTime = "00Z", gpwtEntryPid = "IDY04650"}] +-- +-- >>> length (parseGPWTEntries (parseTags "")) +-- 2 +-- +-- >>> parseGPWTEntries [] +-- [] +-- +-- Anchors without a preceding @\@ header are skipped: +-- +-- >>> parseGPWTEntries (parseTags "00Z") +-- [] +parseGPWTEntries :: + [Tag String] -> + [GPWTEntry] +parseGPWTEntries = + let go _ [] = [] + go _ (TagOpen "li" _ : ts) = + let (code, ts') = takeAreaCode ts + in go (Just code) ts' + go area (TagOpen "a" attrs : ts) + | lookup "class" attrs == Just "loc" + , Just href <- lookup "href" attrs + , Just title <- lookup "title" attrs + , Just pid <- pidFromHref href + , Just (lv, tm) <- levelAndTimeFromTitle title + , Just areaC <- area = + GPWTEntry lv areaC tm pid : go area ts + go area (_ : ts) = go area ts + in go Nothing + +-- | Consume the first non-whitespace text node after a @\@ open tag +-- and return the trimmed content up to (but not including) any @\':\'@. +-- +-- >>> takeAreaCode (parseTags "AUS: some link") +-- ("AUS",[TagText " some link"]) +-- +-- >>> takeAreaCode (parseTags " NE:") +-- ("NE",[TagText ""]) +-- +-- >>> fst (takeAreaCode (parseTags "VIC/TAS:")) +-- "VIC/TAS" +-- +-- >>> takeAreaCode [] +-- ("",[]) +takeAreaCode :: + [Tag String] -> + (String, [Tag String]) +takeAreaCode ts0 = + case dropWhile isBlankText ts0 of + TagText t : rest -> + let (before, after) = break (== ':') t + code = strip before + rest' = case after of + ':' : more -> TagText more : rest + _ -> rest + in (code, rest') + _ -> ("", ts0) + where + isBlankText (TagText s) = all isSpace s + isBlankText _ = False + strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +-- | HTTP options used when talking to bom.gov.au. Sending a browser-shaped +-- User-Agent (and the @check=ok@ cookie the site expects) is necessary to +-- avoid the anti-scraping block page. +bomOptions :: + Options +bomOptions = + defaults + & headers + .~ [ ("User-Agent", "Mozilla/5.0 (X11; Linux x86_64; rv:120.0) Gecko/20100101 Firefox/120.0") + , ("Accept", "*/*") + , ("Accept-Language", "en-US,en;q=0.5") + , ("Cookie", "check=ok") + ] + +-- | Fetch a GPWT image for a given level, area code, and time slot. +-- +-- Area codes are matched via 'normaliseCode' (case-insensitive, punctuation +-- ignored) so @\"VIC/TAS\"@, @\"vic-tas\"@ and @\"VICTAS\"@ all resolve to +-- the same product. Time slots are normalised with 'normaliseTime' so +-- @\"9Z\"@, @\"09z\"@ and @\"09Z\"@ are equivalent. +-- +-- >>> :t getGPWT +-- getGPWT +-- :: GPWTLevel -> String -> String -> IO (Either GPWTError GPWTImage) +getGPWT :: + GPWTLevel -> + String -> + String -> + IO (Either GPWTError GPWTImage) +getGPWT level areaIn timeIn = + fetchEntries >>= \case + Left err -> pure (Left err) + Right es -> + let wantArea = normaliseCode areaIn + wantTime = normaliseTime timeIn + matches = + [ e + | e <- es + , gpwtEntryLevel e == level + , normaliseCode (gpwtEntryArea e) == wantArea + , normaliseTime (gpwtEntryTime e) == wantTime + ] + in case matches of + (e : _) -> fetchImage (gpwtEntryPid e) + [] -> pure (Left (GPWTNoSuchProduct level areaIn timeIn (validPairs level es))) + +-- | Collect @(area, [times])@ pairs for a given level, in the order they +-- first appeared, with times sorted lexicographically. +-- +-- >>> validPairs GPWTLow [GPWTEntry GPWTLow "AUS" "03Z" "A", GPWTEntry GPWTLow "AUS" "00Z" "B", GPWTEntry GPWTHigh "AUS" "00Z" "C"] +-- [("AUS",["00Z","03Z"])] +validPairs :: + GPWTLevel -> + [GPWTEntry] -> + [(String, [String])] +validPairs level es = + let filtered = filter (\e -> gpwtEntryLevel e == level) es + areas = nub (fmap gpwtEntryArea filtered) + in [ (a, sort (nub [gpwtEntryTime e | e <- filtered, gpwtEntryArea e == a])) + | a <- areas + ] + +-- | Fetch and parse the GPWT landing page for its full product list. +fetchEntries :: + IO (Either GPWTError [GPWTEntry]) +fetchEntries = + let url = "https://www.bom.gov.au/aviation/charts/grid-point-forecasts/" + in httpGet "grid-point-forecasts" url >>= \case + Left err -> pure (Left err) + Right body -> + case parseGPWTEntries (parseTags (BLC.unpack body)) of + [] -> pure (Left GPWTParseError) + xs -> pure (Right xs) + +-- | Fetch the actual GPWT PNG for a given product id. BOM serves @IDY*@ +-- products from @\/fwo\/aviation\/@ and @IDX*@ products from +-- @\/difacs\/aviation\/@; the HTML's @href@ is not reliable across both +-- families, so we route by product-id prefix instead of trusting it. +fetchImage :: + String -> + IO (Either GPWTError GPWTImage) +fetchImage pid = + let url = "https://www.bom.gov.au" <> imagePath pid <> pid <> ".png" + in httpGet pid url >>= \case + Left err -> pure (Left err) + Right body -> pure (Right (GPWTImage "image/png" body)) + +-- | Choose the URL base for a GPWT product id. +-- +-- >>> imagePath "IDY04650" +-- "/fwo/aviation/" +-- +-- >>> imagePath "IDX0129" +-- "/difacs/aviation/" +-- +-- >>> imagePath "IDX0476" +-- "/difacs/aviation/" +-- +-- >>> imagePath "OTHER" +-- "/difacs/aviation/" +imagePath :: + String -> + String +imagePath pid = + case pid of + 'I' : 'D' : 'Y' : _ -> "/fwo/aviation/" + _ -> "/difacs/aviation/" + +-- | Wrap a Wreq GET call, catching 'HttpException's and returning them as a +-- 'GPWTHttpError' tagged with the given source label. +httpGet :: + String -> + String -> + IO (Either GPWTError BL.ByteString) +httpGet src url = + catch + (fmap (Right . (^. responseBody)) (getWith bomOptions url)) + (\e -> pure (Left (GPWTHttpError src (show (e :: HttpException)))))