metar 0.0.4 → 0.0.5

raw patch · 10 files changed

+805/−244 lines, 10 filesdep +directorydep +filepathdep +http-typesdep −QuickCheckdep −checkersdep −tastydep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, filepath, http-types, tagsoup

Dependencies removed: QuickCheck, checkers, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• LICENCE +1/−1
• changelog.md +14/−0
• metar.cabal +10/−38
• src-exe/Main.hs +6/−8
• src/Data/Aviation/Metar.hs +399/−91
• src/Data/Aviation/Metar/Cache.hs +92/−0
• src/Data/Aviation/Metar/METARError.hs +52/−0
• src/Data/Aviation/Metar/METARResult.hs +92/−47
• src/Data/Aviation/Metar/METARResultT.hs +139/−55
• test/Tests.hs +0/−4

@@ -1,4 +1,4 @@-Copyright 2018 Tony Morris+Copyright 2018-2026 Tony Morris  All rights reserved. 

@@ -1,3 +1,17 @@+0.0.5++* Restore BOM (Bureau of Meteorology) support via HTML scraping of the METAR/SPECI page+* New function `getBOMMETAR`; `getMETAR` tries BOM first (for `Y*` codes) then falls back to NOAA+* Cache ICAO → state mapping in `$XDG_CACHE_HOME/metar/icao-states.txt` so most Australian lookups are a single request+* Classify `HttpException` so 404s render as "No METAR for X" and other network errors get a short label+* New module `Data.Aviation.Metar.METARError` with `METARError` sum type (`ConnErrorAt`, `ParseErrorAt`); replaces the old `ConnErrorResult`/`ParseErrorResult` constructors on `METARResult`+* `METARResult` failure now carries a `NonEmpty METARError` so errors accumulate across sources (BOM states + NOAA)+* New module `Data.Aviation.Metar.Cache` (exports `readCache`, `mergeCache`)+* Drop `NoImplicitPrelude`; use standard `Prelude`+* Add `tagsoup`, `directory`, `filepath`, `http-types` dependencies; add upper bounds throughout+* Remove empty `tests` test-suite stanza+* Doctest coverage across all library modules+ 0.0.4  * **BREAKING**: Removed BOM (Bureau of Meteorology) support - NOAA only

@@ -1,16 +1,15 @@ name:               metar-version:            0.0.4+version:            0.0.5 license:            BSD3 license-file:       LICENCE author:             Tony Morris <ʇǝu˙sıɹɹoɯʇ@sıɹɹoɯʇ> maintainer:         Tony Morris <ʇǝu˙sıɹɹoɯʇ@sıɹɹoɯʇ> copyright:          Copyright (c) 2018-2026, Tony Morris-synopsis:           METAR from NOAA+synopsis:           METAR from BOM (Australia) with NOAA fallback category:           Data, Aviation description:-  Obtain METAR observations from NOAA.-  .-  Supports ICAO airport codes available in the NOAA database.+  Obtain METAR observations. Australian aerodromes (ICAO codes beginning with Y)+  are fetched from the Bureau of Meteorology; other codes are fetched from NOAA.   .   <<https://i.imgur.com/VGTogB8.gif>> homepage:           https://github.com/tonymorris/metar@@ -30,27 +29,29 @@   build-depends:                     base >= 4.8 && < 5                     , bytestring >= 0.10 && < 0.13+                    , directory >= 1.3 && < 1.4+                    , filepath >= 1.4 && < 1.6                     , http-client >= 0.5 && < 0.8+                    , http-types >= 0.12 && < 0.13                     , HTTP >= 4000 && < 5000                     , lens >= 4 && < 6                     , semigroups >= 0.9 && < 0.21                     , semigroupoids >= 5.2 && < 7                     , transformers >= 0.5 && < 0.7                     , deriving-compat >= 0.5 && < 0.7+                    , tagsoup >= 0.14 && < 0.15                     , wreq >= 0.5 && < 0.6    ghc-options:                     -Wall -  default-extensions:-  -                    NoImplicitPrelude-   hs-source-dirs:                     src    exposed-modules:                     Data.Aviation.Metar+                    , Data.Aviation.Metar.Cache+                    , Data.Aviation.Metar.METARError                     , Data.Aviation.Metar.METARResult                     , Data.Aviation.Metar.METARResultT @@ -68,34 +69,5 @@   ghc-options:                     -Wall -  default-extensions:-                    NoImplicitPrelude-   hs-source-dirs:                     src-exe--test-suite          tests--  build-depends:      QuickCheck >=2.9.2-                    , base >=4.8 && < 5-                    , checkers >=0.4.6-                    , metar-                    , lens >=4-                    , tasty >=0.11-                    , tasty-hunit >=0.9-                    , tasty-quickcheck >=0.8.4--  type:             -                    exitcode-stdio-1.0--  main-is:          -                    Tests.hs--  hs-source-dirs:   -                    test--  default-language: -                    Haskell2010--  ghc-options:       -                    -Wall

@@ -1,15 +1,13 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-} -module Main(-  main+module Main (+  main, ) where -import Data.Aviation.Metar(runMETAR)-import System.Environment(getArgs)-import System.IO(IO)+import Data.Aviation.Metar (runMETAR)+import System.Environment (getArgs)  main ::   IO () main =-  do  a <- getArgs-      runMETAR a+  getArgs >>= runMETAR

@@ -1,116 +1,424 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-} -module Data.Aviation.Metar(-  getNOAAMETAR-, runMETAR+{- FOURMOLU_DISABLE -}+-- $setup+-- >>> import Text.HTML.TagSoup (parseTags)+{- FOURMOLU_ENABLE -}++-- | Fetching METAR observations from the BOM (Australia) and NOAA (rest of world).+module Data.Aviation.Metar (+  getBOMMETAR,+  getNOAAMETAR,+  getMETAR,+  runMETAR, ) where -import Control.Applicative(pure)-import Control.Category((.))-import Control.Exception(catch)-import Control.Lens(view, _Wrapped, (&), (.~), (^.))-import Control.Monad(Monad((>>=)))-import Data.Aviation.Metar.METARResult(METARResult(ConnErrorResult, ParseErrorResult, METARResultValue))-import Data.Aviation.Metar.METARResultT(METARResultT(METARResultT))-import Data.ByteString.Lazy(ByteString)+import Control.Exception (catch)+import Control.Lens (view, (&), (.~), (^.), _Wrapped)+import Control.Monad (unless)+import Control.Monad.Trans.Class (lift)+import Data.Aviation.Metar.Cache (mergeCache, readCache)+import Data.Aviation.Metar.METARError (METARError (ConnErrorAt, ParseErrorAt))+import Data.Aviation.Metar.METARResult (METARResult (METARResultFailure, METARResultValue))+import Data.Aviation.Metar.METARResultT (METARResultT (METARResultT))+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Char(toUpper)-import Data.Either(Either(Left, Right))-import Data.Function(($))-import Data.Functor(fmap)-import Data.Maybe(Maybe(Nothing, Just))-import Data.String(String)-import Data.Semigroup((<>))-import Network.HTTP.Client(HttpException)-import Network.Stream(ConnError(ErrorMisc))-import Network.Wreq(getWith, defaults, headers, Options, responseBody)-import qualified Network.Wreq as Wreq(Response)-import Prelude(show)-import System.IO(IO, hPutStrLn, putStrLn, stderr)+import Data.Char (isAsciiUpper, isDigit, isSpace, toUpper)+import Data.Functor.Alt ((<!>))+import Data.List.NonEmpty (NonEmpty ((:|)))+import Network.HTTP.Client (HttpException (HttpExceptionRequest, InvalidUrlException), HttpExceptionContent (ConnectionTimeout, ResponseTimeout, StatusCodeException), responseStatus)+import Network.HTTP.Types.Status (statusCode)+import Network.Stream (ConnError (ErrorMisc))+import Network.Wreq (FormParam ((:=)), Options, defaults, getWith, headers, postWith, responseBody)+import qualified Network.Wreq as Wreq (Response)+import System.IO (hPutStrLn, stderr)+import Text.HTML.TagSoup (Tag (TagClose, TagOpen, TagText), parseTags) +-- | The seven BOM state selectors accepted by @process.php@.+--+-- >>> length bomStates+-- 7+-- >>> head bomStates+-- "New-South-Wales"+-- >>> last bomStates+-- "Northern-Territory"+bomStates ::+  [String]+bomStates =+  [ "New-South-Wales"+  , "Victoria"+  , "Queensland"+  , "Western-Australia"+  , "South-Australia"+  , "Tasmania"+  , "Northern-Territory"+  ]++-- | HTTP options used when POSTing to the BOM aviation observations endpoint.+--+-- >>> :t bomOptions+-- bomOptions :: Options+bomOptions ::+  Options+bomOptions =+  defaults+    & headers+      .~ [ ("User-Agent", "tonymorris/metar")+         , ("Accept", "*/*")+         , ("Accept-Language", "en-US,en;q=0.5")+         , ("Referer", "https://www.bom.gov.au/aviation/observations/metar-speci/")+         , ("X-Requested-With", "XMLHttpRequest")+         , ("Cookie", "check=ok")+         ]++-- | Translate an 'HttpException' into a 'METARError' tagged with a source.+-- 404s become 'ParseErrorAt' (upstream doesn't have this ICAO); other+-- failures become 'ConnErrorAt' with a short label.+--+-- >>> :t classifyHttp+-- classifyHttp :: String -> HttpException -> METARError+classifyHttp ::+  String ->+  HttpException ->+  METARError+classifyHttp src (HttpExceptionRequest _ content) =+  case content of+    StatusCodeException resp _ ->+      case statusCode (responseStatus resp) of+        404 -> ParseErrorAt src "HTTP 404"+        n -> ConnErrorAt src (ErrorMisc ("HTTP " <> show n))+    ResponseTimeout ->+      ConnErrorAt src (ErrorMisc "response timeout")+    ConnectionTimeout ->+      ConnErrorAt src (ErrorMisc "connection timeout")+    other ->+      ConnErrorAt src (ErrorMisc (show other))+classifyHttp src (InvalidUrlException url reason) =+  ConnErrorAt src (ErrorMisc ("invalid URL: " ++ url ++ " (" ++ reason ++ ")"))++-- | Build a single-element failure result.+--+-- >>> :t failWith+-- failWith :: METARError -> METARResult a+failWith ::+  METARError ->+  METARResult a+failWith e =+  METARResultFailure (e :| [])++-- | Extract @(ICAO, product-text)@ pairs from a BOM aviation response body.+--+-- >>> extractStations (parseTags "<h3>SYDNEY YSSY 28/07/2026 UTC</h3><p class=\"product\">METAR YSSY 280600Z NCD Q1018</p>")+-- [("YSSY","METAR YSSY 280600Z NCD Q1018")]+-- >>> extractStations (parseTags "<h3>Nothing here</h3><p>ignored</p>")+-- []+-- >>> extractStations []+-- []+extractStations ::+  [Tag String] ->+  [(String, String)]+extractStations tags =+  let go (TagOpen "h3" _ : ts) =+        let (title, ts') = takeText ts+            (product', ts'') = pickProduct ts'+         in case (extractIcao title, product') of+              (Just i, Just p) -> (i, p) : go ts''+              _ -> go ts''+      go (_ : ts) = go ts+      go [] = []+   in go tags++-- | Concatenate 'TagText' contents up to the next @\</h3\>@.+--+-- >>> fst (takeText (parseTags "hello <b>world</b></h3>rest"))+-- "hello world"+-- >>> takeText []+-- ("",[])+takeText ::+  [Tag String] ->+  (String, [Tag String])+takeText =+  let go acc (TagClose "h3" : rest) = (acc, rest)+      go acc (TagText t : rest) = go (acc <> t) rest+      go acc (_ : rest) = go acc rest+      go acc [] = (acc, [])+   in go ""++-- | Find and consume the next @\<p class="product"\>...\</p\>@, returning its+-- text and the tags following. If a fresh @\<h3\>@ appears first we stop and+-- rewind, so the caller can handle it.+--+-- >>> fst (pickProduct (parseTags "<p class=\"product\">METAR YSSY hi</p>rest"))+-- Just "METAR YSSY hi"+-- >>> fst (pickProduct (parseTags "<p>not product</p>"))+-- Nothing+-- >>> fst (pickProduct [])+-- Nothing+pickProduct ::+  [Tag String] ->+  (Maybe String, [Tag String])+pickProduct (TagOpen "p" attrs : rest)+  | lookup "class" attrs == Just "product" =+      let (inside, rest') = break isPClose rest+          txt = concatMap tagText inside+       in (Just txt, drop 1 rest')+ where+  isPClose (TagClose "p") = True+  isPClose _ = False+  tagText (TagText t) = t+  tagText (TagOpen "br" _) = " "+  tagText _ = ""+pickProduct (TagOpen "h3" _ : rest) =+  (Nothing, TagOpen "h3" [] : rest)+pickProduct (_ : rest) =+  pickProduct rest+pickProduct [] =+  (Nothing, [])++-- | Pull the ICAO out of an aerodrome heading. Returns the last four-letter+-- upper-case-alphanumeric token in the title (so multi-word airport names work).+--+-- >>> extractIcao "SYDNEY YSSY 28/07/2026 UTC"+-- Just "YSSY"+-- >>> extractIcao "MOUNT ISA YBMA 28/07/2026 UTC"+-- Just "YBMA"+-- >>> extractIcao "no icao here"+-- Nothing+-- >>> extractIcao ""+-- Nothing+extractIcao ::+  String ->+  Maybe String+extractIcao title =+  let ws = wordsBySpace title+      isIcao s = length s == 4 && all (\c -> isAsciiUpper c || isDigit c) s+      lastIcao (s : rest)+        | isIcao s = case lastIcao rest of+            Just later -> Just later+            Nothing -> Just s+        | otherwise = lastIcao rest+      lastIcao [] = Nothing+   in lastIcao ws++-- | Split on any whitespace. Equivalent to 'Prelude.words'.+--+-- >>> wordsBySpace "hello world"+-- ["hello","world"]+-- >>> wordsBySpace "  spaced   out   "+-- ["spaced","out"]+-- >>> wordsBySpace ""+-- []+wordsBySpace ::+  String ->+  [String]+wordsBySpace s =+  case dropWhile isSpace s of+    "" -> []+    s' -> let (w, s'') = break isSpace s' in w : wordsBySpace s''++-- | Locate the METAR/SPECI product line for a given ICAO in a list of parsed+-- station entries.+--+-- >>> findMETAR "YSSY" [("YSSY", "METAR YSSY 280600Z NCD Q1018")]+-- Just "METAR YSSY 280600Z NCD Q1018"+-- >>> findMETAR "YSSY" [("YSSY", "SPECI YSSY 280601Z 27015G30KT Q1017")]+-- Just "SPECI YSSY 280601Z 27015G30KT Q1017"+-- >>> findMETAR "YSSY" [("YMML", "METAR YMML 280600Z ...")]+-- Nothing+-- >>> findMETAR "YSSY" []+-- Nothing+-- >>> findMETAR "YSSY" [("YSSY", "not a metar")]+-- Nothing+findMETAR ::+  String ->+  [(String, String)] ->+  Maybe String+findMETAR icao =+  let matches (i, p) =+        i == icao && (isPrefixOf "METAR " p || isPrefixOf "SPECI " p)+      go [] = Nothing+      go (s : ss) = if matches s then Just (snd s) else go ss+   in go+ where+  isPrefixOf p s = take (length p) s == p++-- | POST to @process.php@ for one BOM state selector. Network exceptions are+-- caught and returned in the 'Left'.+--+-- >>> :t requestState+-- requestState+--   :: String -> IO (Either HttpException (Wreq.Response ByteString))+requestState ::+  String ->+  IO (Either HttpException (Wreq.Response ByteString))+requestState state =+  let url = "https://www.bom.gov.au/aviation/php/process.php"+      body :: [FormParam]+      body =+        [ "state" := state+        , "page" := ("metar-speci" :: String)+        ]+   in catch (fmap Right (postWith bomOptions url body)) (pure . Left)++-- | Fetch a single state, populate the cache with everything we learned, and+-- return the METAR for the target ICAO (if it was in that state's response).+--+-- >>> :t fetchState+-- fetchState :: String -> String -> METARResultT IO String+fetchState ::+  String ->+  String ->+  METARResultT IO String+fetchState icao state =+  METARResultT $+    requestState state >>= \case+      Left e ->+        pure (failWith (classifyHttp state e))+      Right resp ->+        let stations = extractStations (parseTags (BS.unpack (resp ^. responseBody)))+            entries = fmap (\(i, _) -> (i, state)) stations+         in do+              unless (null entries) (mergeCache entries)+              pure $ case findMETAR icao stations of+                Just m -> METARResultValue m+                Nothing -> failWith (ParseErrorAt state (icao <> " not in response"))++-- | Fetch a METAR from the Bureau of Meteorology. Only @Y*@ ICAOs+-- (Australia's block) are attempted; anything else returns a+-- 'ParseErrorAt' at @"BOM"@ without a network call. Uses the on-disk cache+-- to pick a state first; falls back to scanning all seven states on a miss.+--+-- >>> :t getBOMMETAR+-- getBOMMETAR :: String -> METARResultT IO String+getBOMMETAR ::+  String ->+  METARResultT IO String+getBOMMETAR icao =+  let icao' = fmap toUpper icao+   in case icao' of+        ('Y' : _) ->+          do+            cached <- lift readCache+            case lookup icao' cached of+              Just state ->+                fetchState icao' state <!> scanAllStates icao' [state]+              Nothing ->+                scanAllStates icao' []+        _ ->+          METARResultT (pure (failWith (ParseErrorAt "BOM" (icao' <> " is not an Australian ICAO (Y*)"))))++-- | Try every state (except any already tried) in order.+--+-- >>> :t scanAllStates+-- scanAllStates :: String -> [String] -> METARResultT IO String+scanAllStates ::+  String ->+  [String] ->+  METARResultT IO String+scanAllStates icao exclude =+  let remaining = filter (`notElem` exclude) bomStates+   in case remaining of+        [] -> METARResultT (pure (failWith (ParseErrorAt "BOM" (icao <> " not found in any state"))))+        rs -> foldr1 (<!>) (fmap (fetchState icao) rs)++-- | Fetch a METAR from NOAA's @tgftp.nws.noaa.gov@ station-file endpoint.+--+-- >>> :t getNOAAMETAR+-- getNOAAMETAR :: String -> METARResultT IO String getNOAAMETAR ::-  String-  -> METARResultT IO String+  String ->+  METARResultT IO String getNOAAMETAR =   let options ::         Options       options =-        defaults & headers .~-          [-            (-              "Host"-            , "tgftp.nws.noaa.gov"-            )-          , (-              "User-Agent"-            , "tonymorris/metar"-            )-          , (-              "Accept"-            , "*/*"-            )-          , (-              "Accept-Language"-            , "en-US,en;q=0.5"-            )-          , (-              "Accept-Encoding"-            , "text/html"-            )-          , (-              "Connection"-            , "keep-alive"-            )-          , (-              "Pragma"-            , "no-cache"-            )-          , (-              "Cache-Control"-            , "no-cache"-            )-          , (-              "DNT"-            , "1"-            )-          ]+        defaults+          & headers+            .~ [ ("Host", "tgftp.nws.noaa.gov")+               , ("User-Agent", "tonymorris/metar")+               , ("Accept", "*/*")+               , ("Accept-Language", "en-US,en;q=0.5")+               , ("Accept-Encoding", "text/html")+               , ("Connection", "keep-alive")+               , ("Pragma", "no-cache")+               , ("Cache-Control", "no-cache")+               , ("DNT", "1")+               ]       request xxxx =-        catch (fmap Right (getWith options ("https://tgftp.nws.noaa.gov/data/observations/metar/stations/" <> fmap toUpper xxxx <> ".TXT")))-          (\e ->  let e' :: HttpException-                      e' = e-                  in pure . Left . ErrorMisc . show $ e')+        catch+          (fmap Right (getWith options ("https://tgftp.nws.noaa.gov/data/observations/metar/stations/" <> fmap toUpper xxxx <> ".TXT")))+          (pure . Left)       respMETAR ::-        Wreq.Response ByteString-        -> Maybe String+        Wreq.Response ByteString ->+        Maybe String       respMETAR r =         case BS.lines (r ^. responseBody) of           [_, r'] -> Just (BS.unpack r')           _ -> Nothing-  in METARResultT . fmap (\result -> case result of-        Left e -> ConnErrorResult e-        Right response -> case respMETAR response of-          Nothing -> ParseErrorResult-          Just metar -> METARResultValue metar) . request+   in METARResultT+        . fmap+          ( \case+              Left e -> failWith (classifyHttp "NOAA" e)+              Right response ->+                case respMETAR response of+                  Just m -> METARResultValue m+                  Nothing -> failWith (ParseErrorAt "NOAA" "unexpected response format")+          )+        . request +-- | Fetch a METAR. Try BOM first (which itself returns a 'ParseErrorAt' for+-- non-@Y*@ codes), then fall back to NOAA. Errors from both sources are+-- accumulated in the 'METARResultFailure' list.+--+-- >>> :t getMETAR+-- getMETAR :: String -> METARResultT IO String+getMETAR ::+  String ->+  METARResultT IO String+getMETAR icao =+  getBOMMETAR icao <!> getNOAAMETAR icao++-- | Render one 'METARError' as a human-readable line.+--+-- >>> renderError (ConnErrorAt "NOAA" (ErrorMisc "response timeout"))+-- "NOAA: connection error: response timeout"+-- >>> renderError (ParseErrorAt "New-South-Wales" "not in response")+-- "New-South-Wales: not in response"+renderError ::+  METARError ->+  String+renderError (ConnErrorAt src (ErrorMisc msg)) =+  src <> ": connection error: " <> msg+renderError (ConnErrorAt src e) =+  src <> ": connection error: " <> show e+renderError (ParseErrorAt src msg) =+  src <> ": " <> msg++-- | CLI entry point. Takes the argv list and prints a METAR to @stdout@ or+-- all accumulated errors to @stderr@.+--+-- >>> :t runMETAR+-- runMETAR :: [String] -> IO () runMETAR ::-  [String]-  -> IO ()+  [String] ->+  IO () runMETAR x =   let stderr' =         hPutStrLn stderr-  in  case x of+   in case x of         [] ->-          do  putStrLn ("metar version " <> VERSION_metar)-              stderr' "enter an argument (ICAO code)"-        (r:_) ->-          let s = view _Wrapped (getNOAAMETAR r)-          in  s >>= \s' ->-              case s' of+          do+            putStrLn ("metar version " <> VERSION_metar)+            stderr' "enter an argument (ICAO code)"+        (r : _) ->+          let s = view _Wrapped (getMETAR r)+           in s >>= \case                 METARResultValue a ->                   putStrLn a-                ParseErrorResult ->-                  stderr' ("No METAR for " <> r)-                ConnErrorResult e ->-                  stderr' ("Network connection error " <> show e)+                METARResultFailure (e :| es) ->+                  do+                    stderr' ("No METAR for " <> r <> ":")+                    mapM_ (stderr' . ("  " <>) . renderError) (e : es)

@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -Wall #-}++{- FOURMOLU_DISABLE -}+-- $setup+-- >>> import Data.Aviation.Metar.Cache+{- FOURMOLU_ENABLE -}++-- | On-disk cache of ICAO → BOM-state associations.+--+-- The cache lives at @$XDG_CACHE_HOME/metar/icao-states.txt@ (usually+-- @~/.cache/metar/icao-states.txt@). One @ICAO STATE@ pair per line.+module Data.Aviation.Metar.Cache (+  readCache,+  mergeCache,+) where++import Control.Exception (IOException, catch)+import System.Directory (XdgDirectory (XdgCache), createDirectoryIfMissing, doesFileExist, getXdgDirectory, renameFile)+import System.FilePath (takeDirectory, (</>))++-- | Absolute path to the cache file (under @XdgCache@).+--+-- >>> :t cachePath+-- cachePath :: IO String+cachePath ::+  IO String+cachePath =+  fmap (</> "icao-states.txt") (getXdgDirectory XdgCache "metar")++-- | Discard 'IOException' and return the given fallback.+--+-- >>> :t ignoreIO+-- ignoreIO :: a -> IOException -> IO a+ignoreIO ::+  a ->+  IOException ->+  IO a+ignoreIO a _ =+  pure a++-- | Read all @ICAO STATE@ pairs from the cache file.+-- Returns @[]@ if the file is missing or unreadable.+--+-- >>> :t readCache+-- readCache :: IO [(String, String)]+readCache ::+  IO [(String, String)]+readCache =+  let parseLine ln =+        case words ln of+          [i, s] -> [(i, s)]+          _ -> []+      readIt = do+        p <- cachePath+        ex <- doesFileExist p+        if not ex+          then pure []+          else fmap (concatMap parseLine . lines) (readFile p)+   in catch readIt (ignoreIO [])++-- | Overwrite the cache file with the given entries. Writes atomically via+-- @tmp + rename@. Silently ignores I/O errors.+--+-- >>> :t writeCache+-- writeCache :: [(String, String)] -> IO ()+writeCache ::+  [(String, String)] ->+  IO ()+writeCache entries =+  let body =+        unlines (fmap (\(i, s) -> i <> " " <> s) entries)+      write = do+        p <- cachePath+        createDirectoryIfMissing True (takeDirectory p)+        let tmp = p <> ".tmp"+        writeFile tmp body+        renameFile tmp p+   in catch write (ignoreIO ())++-- | Merge new entries into the existing cache. New ICAOs overwrite any+-- existing state assignment for the same ICAO.+--+-- >>> :t mergeCache+-- mergeCache :: [(String, String)] -> IO ()+mergeCache ::+  [(String, String)] ->+  IO ()+mergeCache new =+  readCache >>= \old ->+    let newIcaos = fmap fst new+        kept = filter (\(i, _) -> i `notElem` newIcaos) old+     in writeCache (new <> kept)

@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -Wall #-}++-- | A single failure during METAR lookup, tagged with the source (which BOM+-- state or which upstream API) and either a connection failure or a parse-level+-- reason.+module Data.Aviation.Metar.METARError (+  METARError (..),+  connError,+  parseError,+) where++import Network.Stream (ConnError)++-- $setup+-- >>> import Data.Aviation.Metar.METARError+-- >>> import Network.Stream++-- | Description of one thing that went wrong at one source.+--+-- >>> connError "NOAA" (ErrorMisc "boom")+-- ConnErrorAt "NOAA" (ErrorMisc "boom")+-- >>> parseError "New-South-Wales" "not found"+-- ParseErrorAt "New-South-Wales" "not found"+data METARError+  = -- | Network failure at the named source.+    ConnErrorAt String ConnError+  | -- | Non-network failure at the named source, e.g. HTTP 404 or ICAO+    -- absent from the response.+    ParseErrorAt String String+  deriving (Eq, Show)++-- | Build a 'ConnErrorAt'.+--+-- >>> connError "BOM" (ErrorMisc "response timeout")+-- ConnErrorAt "BOM" (ErrorMisc "response timeout")+connError ::+  String ->+  ConnError ->+  METARError+connError =+  ConnErrorAt++-- | Build a 'ParseErrorAt'.+--+-- >>> parseError "NOAA" "HTTP 404"+-- ParseErrorAt "NOAA" "HTTP 404"+parseError ::+  String ->+  String ->+  METARError+parseError =+  ParseErrorAt

@@ -1,28 +1,40 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-} +-- | METAR observation result. module Data.Aviation.Metar.METARResult where -import Control.Applicative(Applicative(pure, (<*>)))-import Control.Lens(makeClassy, makeClassyPrisms)-import Control.Monad(Monad(return, (>>=)))-import Data.Eq(Eq)-import Data.Eq.Deriving(deriveEq1)-import Data.Foldable(Foldable(foldr))-import Data.Functor(Functor(fmap), (<$>))-import Data.Functor.Apply(Apply((<.>)))-import Data.Functor.Bind(Bind((>>-)))-import Data.Functor.Extend(Extend(duplicated))-import Data.Traversable(Traversable(traverse))-import Network.Stream(ConnError)-import Prelude(Show)-import Text.Show.Deriving(deriveShow1)+import Control.Lens (makeClassy, makeClassyPrisms)+import Data.Aviation.Metar.METARError (METARError)+import Data.Eq.Deriving (deriveEq1)+import Data.Functor.Apply (Apply ((<.>)))+import Data.Functor.Bind (Bind ((>>-)))+import Data.Functor.Extend (Extend (duplicated))+import Data.List.NonEmpty (NonEmpty)+import Text.Show.Deriving (deriveShow1) -data METARResult a =-  ConnErrorResult ConnError-  | ParseErrorResult+{- FOURMOLU_DISABLE -}+-- $setup+-- >>> import Data.Aviation.Metar.METARError+-- >>> import Data.Aviation.Metar.METARResult+-- >>> import Data.Functor.Apply ((<.>))+-- >>> import Data.Functor.Bind ((>>-))+-- >>> import Data.Functor.Extend (duplicated)+-- >>> import Data.List.NonEmpty (NonEmpty((:|)))+-- >>> import Network.Stream+{- FOURMOLU_ENABLE -}++-- | Either a METAR value or a non-empty list of everything that went wrong+-- while trying to obtain one.+--+-- >>> METARResultValue "METAR YSSY 280600Z" :: METARResult String+-- METARResultValue "METAR YSSY 280600Z"+-- >>> METARResultFailure (ParseErrorAt "NOAA" "HTTP 404" :| []) :: METARResult String+-- METARResultFailure (ParseErrorAt "NOAA" "HTTP 404" :| [])+data METARResult a+  = METARResultFailure (NonEmpty METARError)   | METARResultValue a   deriving (Eq, Show) @@ -31,66 +43,99 @@ deriveEq1 ''METARResult deriveShow1 ''METARResult +-- | 'fmap' rewraps 'METARResultValue', preserving the failure constructor.+--+-- >>> fmap (+ 1) (METARResultValue 3 :: METARResult Int)+-- METARResultValue 4+-- >>> fmap (+ 1) (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int)+-- METARResultFailure (ParseErrorAt "src" "why" :| []) instance Functor METARResult where-  fmap _ (ConnErrorResult e) =-    ConnErrorResult e-  fmap _ ParseErrorResult =-    ParseErrorResult+  fmap _ (METARResultFailure es) =+    METARResultFailure es   fmap f (METARResultValue a) =     METARResultValue (f a) +-- | '<.>' fails fast on the left; two failures do not accumulate here (only+-- 'Data.Functor.Alt.<!>' accumulates).+--+-- >>> (METARResultValue (+ 1) :: METARResult (Int -> Int)) <.> METARResultValue 3+-- METARResultValue 4+-- >>> (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult (Int -> Int)) <.> METARResultValue 3+-- METARResultFailure (ParseErrorAt "src" "why" :| [])+-- >>> (METARResultValue (+ 1) :: METARResult (Int -> Int)) <.> METARResultFailure (ParseErrorAt "src" "why" :| [])+-- METARResultFailure (ParseErrorAt "src" "why" :| []) instance Apply METARResult where-  ConnErrorResult e <.> _ =-    ConnErrorResult e-  ParseErrorResult <.> _ =-    ParseErrorResult+  METARResultFailure es <.> _ =+    METARResultFailure es   METARResultValue f <.> METARResultValue a =     METARResultValue (f a)-  METARResultValue _ <.> ConnErrorResult e =-    ConnErrorResult e-  METARResultValue _ <.> ParseErrorResult =-    ParseErrorResult+  METARResultValue _ <.> METARResultFailure es =+    METARResultFailure es +-- | 'pure' wraps a value with 'METARResultValue'.+--+-- >>> pure 3 :: METARResult Int+-- METARResultValue 3 instance Applicative METARResult where   pure =     METARResultValue   (<*>) =     (<.>) +-- | Kleisli bind: threads a value forward and short-circuits on failure.+--+-- >>> (METARResultValue 3 :: METARResult Int) >>- (\x -> METARResultValue (x + 1))+-- METARResultValue 4+-- >>> (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int) >>- (\x -> METARResultValue (x + 1))+-- METARResultFailure (ParseErrorAt "src" "why" :| []) instance Bind METARResult where-  ConnErrorResult e >>- _ =-    ConnErrorResult e-  ParseErrorResult >>- _ =-    ParseErrorResult+  METARResultFailure es >>- _ =+    METARResultFailure es   METARResultValue a >>- f =     f a +-- | 'Monad' inherits from 'Bind' and 'Applicative'.+--+-- >>> (METARResultValue 3 :: METARResult Int) >>= (\x -> METARResultValue (x + 10))+-- METARResultValue 13 instance Monad METARResult where   return =     pure   (>>=) =     (>>-) +-- | Folding contributes the value once for 'METARResultValue', zero times for failure.+--+-- >>> foldr (+) 0 (METARResultValue 5 :: METARResult Int)+-- 5+-- >>> foldr (+) 0 (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int)+-- 0 instance Foldable METARResult where   foldr f z (METARResultValue a) =     f a z-  foldr _ z (ConnErrorResult _ ) =-    z-  foldr _ z ParseErrorResult =+  foldr _ z (METARResultFailure _) =     z +-- | 'traverse' commutes 'METARResult' with an inner effect.+--+-- >>> traverse Just (METARResultValue 3 :: METARResult Int)+-- Just (METARResultValue 3)+-- >>> traverse Just (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int)+-- Just (METARResultFailure (ParseErrorAt "src" "why" :| [])) instance Traversable METARResult where   traverse f (METARResultValue a) =     METARResultValue <$> f a-  traverse _ (ConnErrorResult e) =-    pure (ConnErrorResult e)-  traverse _ ParseErrorResult =-    pure ParseErrorResult+  traverse _ (METARResultFailure es) =+    pure (METARResultFailure es) +-- | 'duplicated' nests a value inside a second layer.+--+-- >>> duplicated (METARResultValue 3 :: METARResult Int)+-- METARResultValue (METARResultValue 3)+-- >>> duplicated (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int)+-- METARResultFailure (ParseErrorAt "src" "why" :| []) instance Extend METARResult where   duplicated (METARResultValue a) =     METARResultValue (METARResultValue a)-  duplicated (ConnErrorResult e) =-    ConnErrorResult e-  duplicated ParseErrorResult =-    ParseErrorResult+  duplicated (METARResultFailure es) =+    METARResultFailure es

@@ -1,45 +1,63 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall #-} +-- | Monad transformer over 'METARResult'. module Data.Aviation.Metar.METARResultT where -import Control.Applicative(Applicative(pure, (<*>)))-import Control.Category((.))-import Control.Monad(Monad(return, (>>=)), ap)-import Data.Aviation.Metar.METARResult(METARResult(METARResultValue, ConnErrorResult, ParseErrorResult))-import Data.Eq(Eq((==)))-import Data.Foldable(Foldable(foldr))-import Data.Functor(Functor(fmap), (<$>))-import Data.Functor.Alt(Alt((<!>)))-import Data.Functor.Apply(Apply((<.>)))-import Data.Functor.Bind(Bind((>>-)))-import Data.Functor.Classes(Eq1, Show1, eq1, showsPrec1)-import Data.Functor.Extend(Extend(duplicated))-import Data.Ord((>))-import Data.Semigroup(Semigroup((<>))) import Control.Lens hiding ((<.>))-import Control.Monad.IO.Class(MonadIO(liftIO))-import Control.Monad.Trans.Class(MonadTrans(lift))-import Data.Eq.Deriving(deriveEq1)-import Prelude(Show(showsPrec), showParen, showString)-import Text.Show.Deriving(deriveShow1)+import Control.Monad (ap)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Data.Aviation.Metar.METARResult (METARResult (METARResultFailure, METARResultValue))+import Data.Eq.Deriving (deriveEq1)+import Data.Functor.Alt (Alt ((<!>)))+import Data.Functor.Apply (Apply ((<.>)))+import Data.Functor.Bind (Bind ((>>-)))+import Data.Functor.Classes (Eq1, Show1, eq1, showsPrec1)+import Data.Functor.Extend (Extend (duplicated))+import Text.Show.Deriving (deriveShow1) -newtype METARResultT f a =-  METARResultT-    (f (METARResult a))+{- FOURMOLU_DISABLE -}+-- $setup+-- >>> import Data.Aviation.Metar.METARError+-- >>> import Data.Aviation.Metar.METARResult+-- >>> import Data.Aviation.Metar.METARResultT+-- >>> import Data.Functor.Identity (Identity(Identity, runIdentity))+-- >>> import Data.Functor.Alt ((<!>))+-- >>> import Data.Functor.Apply ((<.>))+-- >>> import Data.Functor.Bind ((>>-))+-- >>> import Data.Functor.Extend (duplicated)+-- >>> import Data.List.NonEmpty (NonEmpty((:|)))+-- >>> import Network.Stream+{- FOURMOLU_ENABLE -} +-- | Wraps @f (METARResult a)@ so error propagation happens automatically inside @f@.+newtype METARResultT f a+  = METARResultT+      (f (METARResult a))+ makeClassy ''METARResultT makeWrapped ''METARResultT +-- | Equality on the wrapped @f@.+--+-- >>> METARResultT (Identity (METARResultValue (3 :: Int))) == METARResultT (Identity (METARResultValue 3))+-- True+-- >>> METARResultT (Identity (METARResultValue (3 :: Int))) == METARResultT (Identity (METARResultFailure (ParseErrorAt "src" "why" :| [])))+-- False instance (Eq a, Eq1 f) => Eq (METARResultT f a) where   METARResultT x == METARResultT y =     eq1 x y +-- | Show delegates to the underlying @f (METARResult a)@.+--+-- >>> show (METARResultT (Identity (METARResultValue (3 :: Int))))+-- "TafResultT Identity (METARResultValue 3)" instance (Show a, Show1 f) => Show (METARResultT f a) where   showsPrec n (METARResultT x) =     showParen (n > 10) (showString "TafResultT " . showsPrec1 n x)@@ -47,75 +65,141 @@ deriveEq1 ''METARResultT deriveShow1 ''METARResultT -instance Functor f => Functor (METARResultT f) where+-- | Maps under both layers.+--+-- >>> let METARResultT x = fmap (+ 1) (METARResultT (Identity (METARResultValue (3 :: Int)))) in runIdentity x+-- METARResultValue 4+instance (Functor f) => Functor (METARResultT f) where   fmap f (METARResultT x) =     METARResultT (fmap (fmap f) x) -instance Monad f => Apply (METARResultT f) where+-- | 'Apply' derived from 'ap' — sequences two effectful lookups.+--+-- >>> let a = METARResultT (Identity (METARResultValue ((+ 1) :: Int -> Int)))+-- >>> let b = METARResultT (Identity (METARResultValue (3 :: Int)))+-- >>> let METARResultT x = a <.> b in runIdentity x+-- METARResultValue 4+instance (Monad f) => Apply (METARResultT f) where   (<.>) =     ap -instance Monad f => Applicative (METARResultT f) where+-- | 'pure' injects a value through both layers.+--+-- >>> let METARResultT x = (pure 5 :: METARResultT Identity Int) in runIdentity x+-- METARResultValue 5+instance (Monad f) => Applicative (METARResultT f) where   pure =     METARResultT . pure . pure   (<*>) =     ap -instance Monad f => Bind (METARResultT f) where+-- | 'Bind' equals '>>=' on the underlying monad.+--+-- >>> let m = METARResultT (Identity (METARResultValue (3 :: Int)))+-- >>> let METARResultT x = m >>- (\v -> pure (v + 10)) in runIdentity x+-- METARResultValue 13+instance (Monad f) => Bind (METARResultT f) where   (>>-) =     (>>=) -instance Monad f => Monad (METARResultT f) where+-- | Short-circuiting bind: 'METARResultFailure' propagates unchanged.+--+-- >>> let ok = METARResultT (Identity (METARResultValue (3 :: Int)))+-- >>> let METARResultT x = ok >>= (\v -> pure (v * 2)) in runIdentity x+-- METARResultValue 6+-- >>> let bad = METARResultT (Identity (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int))+-- >>> let METARResultT x = bad >>= (\v -> pure (v * 2)) in runIdentity x+-- METARResultFailure (ParseErrorAt "src" "why" :| [])+instance (Monad f) => Monad (METARResultT f) where   return =     pure   METARResultT x >>= f =     METARResultT-      (-        x >>= \x' ->-        case x' of+      ( x >>= \case           METARResultValue x'' ->             let METARResultT r = f x''-            in  r-          ConnErrorResult e ->-            pure (ConnErrorResult e)-          ParseErrorResult ->-            pure ParseErrorResult+             in r+          METARResultFailure es ->+            pure (METARResultFailure es)       ) -instance Foldable f => Foldable (METARResultT f) where+-- | Fold sees the underlying value if there is one.+--+-- >>> foldr (+) 0 (METARResultT (Identity (METARResultValue (5 :: Int))))+-- 5+-- >>> foldr (+) 0 (METARResultT (Identity (METARResultFailure (ParseErrorAt "src" "why" :| []) :: METARResult Int)))+-- 0+instance (Foldable f) => Foldable (METARResultT f) where   foldr f z (METARResultT x) =-    foldr (\a b -> foldr f b a) z x+    foldr (flip (foldr f)) z x -instance Traversable f => Traversable (METARResultT f) where+-- | Traverse commutes the effect and the transformer.+--+-- >>> traverse Just (METARResultT (Identity (METARResultValue (5 :: Int))))+-- Just (TafResultT (Identity (METARResultValue 5)))+instance (Traversable f) => Traversable (METARResultT f) where   traverse f (METARResultT x) =     METARResultT <$> traverse (traverse f) x -instance Monad f => Alt (METARResultT f) where+-- | Left-biased choice that /accumulates/ failures: try the left; on failure,+-- run the right; if the right also fails, concatenate their error lists.+-- The first success wins.+--+-- >>> let ok = METARResultT (Identity (METARResultValue (1 :: Int)))+-- >>> let alt = METARResultT (Identity (METARResultValue (2 :: Int)))+-- >>> let METARResultT x = ok <!> alt in runIdentity x+-- METARResultValue 1+-- >>> let bad = METARResultT (Identity (METARResultFailure (ParseErrorAt "a" "1" :| []) :: METARResult Int))+-- >>> let METARResultT x = bad <!> alt in runIdentity x+-- METARResultValue 2+-- >>> let bad2 = METARResultT (Identity (METARResultFailure (ParseErrorAt "b" "2" :| []) :: METARResult Int))+-- >>> let METARResultT x = bad <!> bad2 in runIdentity x+-- METARResultFailure (ParseErrorAt "a" "1" :| [ParseErrorAt "b" "2"])+instance (Monad f) => Alt (METARResultT f) where   METARResultT x <!> METARResultT y =     METARResultT-      (-        x >>= \x' ->-        case x' of-          METARResultValue x'' ->-            pure (METARResultValue x'')-          ConnErrorResult _ ->-            y-          ParseErrorResult ->-            y+      ( x >>= \case+          METARResultValue a ->+            pure (METARResultValue a)+          METARResultFailure es ->+            y >>= \case+              METARResultValue a ->+                pure (METARResultValue a)+              METARResultFailure es' ->+                pure (METARResultFailure (es <> es'))       ) -instance Extend f => Extend (METARResultT f) where+-- | 'duplicated' nests the value inside a fresh 'METARResultValue' inside the transformer.+--+-- >>> let m = METARResultT (Identity (METARResultValue (7 :: Int)))+-- >>> let METARResultT (Identity outer) = duplicated m in case outer of METARResultValue (METARResultT (Identity inner)) -> inner; _ -> METARResultFailure (ParseErrorAt "impossible" "" :| [])+-- METARResultValue 7+instance (Extend f) => Extend (METARResultT f) where   duplicated (METARResultT x) =     METARResultT (fmap (METARResultValue . METARResultT) (duplicated x)) -instance MonadIO f => MonadIO (METARResultT f) where+-- | 'liftIO' lifts an 'IO' action into the transformer.+--+-- >>> let METARResultT act = (liftIO (pure (5 :: Int)) :: METARResultT IO Int) in act+-- METARResultValue 5+instance (MonadIO f) => MonadIO (METARResultT f) where   liftIO =     METARResultT . liftIO . fmap pure +-- | 'lift' wraps an @f a@ so it becomes a successful @METARResultT f a@.+--+-- >>> let METARResultT x = (lift (Identity (5 :: Int)) :: METARResultT Identity Int) in runIdentity x+-- METARResultValue 5 instance MonadTrans METARResultT where   lift =     METARResultT . fmap pure -instance Monad f => Semigroup (METARResultT f a) where+-- | 'Semigroup' is 'Alt': accumulates failures, first success wins.+--+-- >>> let bad = METARResultT (Identity (METARResultFailure (ParseErrorAt "a" "1" :| []) :: METARResult Int))+-- >>> let ok  = METARResultT (Identity (METARResultValue (9 :: Int)))+-- >>> let METARResultT x = bad <> ok in runIdentity x+-- METARResultValue 9+instance (Monad f) => Semigroup (METARResultT f a) where   (<>) =     (<!>)

@@ -1,4 +0,0 @@-module Main where--main :: IO ()-main = pure ()