diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,4 +1,4 @@ -Copyright 2018 Tony Morris +Copyright 2018-2026 Tony Morris All rights reserved. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/metar.cabal b/metar.cabal --- a/metar.cabal +++ b/metar.cabal @@ -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. . <> 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 diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -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 diff --git a/src/Data/Aviation/Metar.hs b/src/Data/Aviation/Metar.hs --- a/src/Data/Aviation/Metar.hs +++ b/src/Data/Aviation/Metar.hs @@ -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 "

SYDNEY YSSY 28/07/2026 UTC

METAR YSSY 280600Z NCD Q1018

") +-- [("YSSY","METAR YSSY 280600Z NCD Q1018")] +-- >>> extractStations (parseTags "

Nothing here

ignored

") +-- [] +-- >>> 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 @\@. +-- +-- >>> fst (takeText (parseTags "hello worldrest")) +-- "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 @\

...\@, returning its +-- text and the tags following. If a fresh @\@ appears first we stop and +-- rewind, so the caller can handle it. +-- +-- >>> fst (pickProduct (parseTags "

METAR YSSY hi

rest")) +-- Just "METAR YSSY hi" +-- >>> fst (pickProduct (parseTags "

not product

")) +-- 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) diff --git a/src/Data/Aviation/Metar/Cache.hs b/src/Data/Aviation/Metar/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar/Cache.hs @@ -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) diff --git a/src/Data/Aviation/Metar/METARError.hs b/src/Data/Aviation/Metar/METARError.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar/METARError.hs @@ -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 diff --git a/src/Data/Aviation/Metar/METARResult.hs b/src/Data/Aviation/Metar/METARResult.hs --- a/src/Data/Aviation/Metar/METARResult.hs +++ b/src/Data/Aviation/Metar/METARResult.hs @@ -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 diff --git a/src/Data/Aviation/Metar/METARResultT.hs b/src/Data/Aviation/Metar/METARResultT.hs --- a/src/Data/Aviation/Metar/METARResultT.hs +++ b/src/Data/Aviation/Metar/METARResultT.hs @@ -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 (<>) = () diff --git a/test/Tests.hs b/test/Tests.hs deleted file mode 100644 --- a/test/Tests.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = pure ()