metar 0.0.5 → 0.0.6

raw patch · 4 files changed

+896/−2 lines, 4 filesdep +timePVP ok

version bump matches the API change (PVP)

Dependencies added: time

API changes (from Hackage documentation)

Files

• changelog.md +17/−0
• metar.cabal +5/−2
• src/Data/Aviation/GAF.hs +422/−0
• src/Data/Aviation/GPWT.hs +452/−0

@@ -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

@@ -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

@@ -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+-- <https://www.bom.gov.au/aviation/gaf/gaf.shtml> 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+--+-- @+-- \<input type="checkbox" class="GAF" name="area[]" id="WA-N" value="IDN40000.txt" /\>+-- @+--+-- We keep every @class="GAF"@ checkbox except the invisible @areamap@ one.+--+-- >>> parseAreaCodes (parseTags "<input type=\"checkbox\" class=\"GAF\" id=\"WA-N\" /><input type=\"checkbox\" class=\"GAF\" id=\"VIC\" /><input type=\"checkbox\" class=\"GAF\" id=\"areamap\" />")+-- ["WA-N","VIC"]+--+-- >>> parseAreaCodes (parseTags "<input type=\"text\" id=\"WA-N\" />")+-- []+--+-- >>> 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)

@@ -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+-- <https://www.bom.gov.au/aviation/charts/grid-point-forecasts/> 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+-- @\<a class=\"loc\"\>@ product link. Area codes are inherited from the+-- most recently opened @\<li\>@; the level and time come from each+-- anchor's own @title@ attribute.+--+-- >>> parseGPWTEntries (parseTags "<ul><li>AUS: <a class=\"loc\" href=\"/difacs/aviation/IDY04650.png\" title=\"Low-level, Australia 00Z\">00Z</a></li></ul>")+-- [GPWTEntry {gpwtEntryLevel = GPWTLow, gpwtEntryArea = "AUS", gpwtEntryTime = "00Z", gpwtEntryPid = "IDY04650"}]+--+-- >>> length (parseGPWTEntries (parseTags "<ul><li>AUS: <a class=\"loc\" href=\"/difacs/aviation/IDY04650.png\" title=\"Low-level, Australia 00Z\">00Z</a> <a class=\"loc\" href=\"/difacs/aviation/IDY04651.png\" title=\"Low-level, Australia 03Z\">03Z</a></li></ul>"))+-- 2+--+-- >>> parseGPWTEntries []+-- []+--+-- Anchors without a preceding @\<li\>@ header are skipped:+--+-- >>> parseGPWTEntries (parseTags "<a class=\"loc\" href=\"/difacs/aviation/IDY04650.png\" title=\"Low-level, Australia 00Z\">00Z</a>")+-- []+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 @\<li\>@ 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)))))