metar-http-0.0.6: src/Data/Aviation/Metar/Http.hs
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
-- | HTTP server exposing METAR observations, BOM Graphical Area Forecast
-- (GAF) images, and BOM Grid Point Wind and Temperature (GPWT) images.
--
-- @/metar/\<icao\>@ returns a METAR observation as text: Australian aerodromes
-- (ICAO codes beginning with @Y@) are fetched from BOM; other codes fall back
-- to NOAA.
--
-- @/gaf/\<area\>/current@ and @/gaf/\<area\>/next@ return the corresponding
-- BOM GAF PNG image. Areas are @WA-N@, @WA-S@, @NT@, @QLD-N@, @QLD-S@, @SA@,
-- @NSW-W@, @NSW-E@, @VIC@, @TAS@.
--
-- @/gpwt/\<level\>/\<area\>/\<time\>@ returns the corresponding BOM GPWT PNG.
-- @level@ is @low@, @mid@ or @high@; @area@ is one of the codes advertised on
-- the grid-point-forecasts page (e.g. @AUS@, @NSW@, @QLD-N@, @VIC-TAS@,
-- @TIMS@); @time@ is a 3-hourly UTC slot like @00Z@, @03Z@ ... @21Z@.
module Data.Aviation.Metar.Http (
metarHTTP,
metarHTTPapp,
) where
import Control.Lens (folded, (^.), (^?), _Wrapped)
import Data.Aviation.GAF (GAFError (GAFHttpError, GAFUnknownArea), GAFImage (GAFImage), GAFPeriod (GAFCurrent, GAFNext), getGAF, renderGAFError)
import Data.Aviation.GPWT (GPWTError (GPWTHttpError, GPWTNoSuchProduct, GPWTUnknownLevel), GPWTImage (GPWTImage), getGPWT, parseLevel, renderGPWTError)
import Data.Aviation.Metar (getMETAR)
import Data.Aviation.Metar.METARResult (_METARResultValue)
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.List (intercalate)
import Data.Text (Text, toLower, unpack)
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Types.Status (status200, status404, status502)
import Network.Wai (Application, Response, pathInfo, responseLBS)
import Network.Wai.Handler.Warp (defaultSettings, runSettings, setPort, setTimeout)
import System.Environment (getArgs)
{- FOURMOLU_DISABLE -}
-- $setup
-- >>> import Data.Aviation.Metar.Http
{- FOURMOLU_ENABLE -}
-- | Parse a value using its 'Read' instance, returning 'Nothing' on failure.
--
-- >>> readMaybe "42" :: Maybe Int
-- Just 42
--
-- >>> readMaybe "notanumber" :: Maybe Int
-- Nothing
readMaybe ::
(Read a) =>
String ->
Maybe a
readMaybe n =
fst <$> reads n ^? folded
-- | How to truncate a rendered METAR line.
data CharLimit
= NoCharLimit
| MaxChars Int
| MaxCharsAppend Int String
deriving (Eq, Show)
-- | Apply a 'CharLimit' to a string.
--
-- >>> charLimit NoCharLimit "hello world"
-- "hello world"
--
-- >>> charLimit (MaxChars 5) "hello world"
-- "hello"
--
-- >>> charLimit (MaxCharsAppend 5 "...") "hello world"
-- "hello..."
--
-- >>> charLimit (MaxCharsAppend 5 "...") "hi"
-- "hi"
charLimit ::
CharLimit ->
String ->
String
charLimit m s =
case m of
NoCharLimit ->
s
MaxChars n ->
take n s
MaxCharsAppend n l ->
let (a, b) = splitAt n s
b' = case b of
[] -> []
_ : _ -> l
in a <> b'
-- | How to format a list of METAR lines for a response body.
data Format
= Raw
| MaxLines Int CharLimit
| AllOneLine CharLimit
deriving (Eq, Show)
-- | Render lines of METAR text according to the given 'Format'.
--
-- >>> format (MaxLines 3 NoCharLimit) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK\nRF00.0/000.4"
--
-- >>> format (MaxLines 1 NoCharLimit) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK"
--
-- >>> format (MaxLines 1 (MaxChars 15)) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 0712"
--
-- >>> format (MaxLines 1 (MaxCharsAppend 15 "abc")) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 0712abc"
--
-- >>> format (AllOneLine (MaxCharsAppend 15 "abc")) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 0712abc"
--
-- >>> format (AllOneLine (MaxCharsAppend 150 "abc")) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK RF00.0/000.4"
--
-- >>> format (AllOneLine (MaxCharsAppend 60 "abc")) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"]
-- "METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK abc"
format ::
Format ->
[String] ->
String
format f s =
let limitCalate l x =
charLimit l . intercalate x
in case f of
Raw ->
intercalate "\n" s
MaxLines n l ->
limitCalate l "\n" . take n $ s
AllOneLine l ->
limitCalate l " " s
-- | Parse the trailing URI path components into a 'Format'.
--
-- URI grammar:
--
-- @
-- (empty) -> Raw
-- * -> AllOneLine NoCharLimit
-- *\/n -> AllOneLine (MaxChars n)
-- *\/n\/xyz -> AllOneLine (MaxCharsAppend n xyz)
-- n -> MaxLines n NoCharLimit
-- n\/m -> MaxLines n (MaxChars m)
-- n\/m\/xyz -> MaxLines n (MaxCharsAppend m xyz)
-- @
--
-- >>> uriPathFormat []
-- Raw
--
-- >>> uriPathFormat ["*"]
-- AllOneLine NoCharLimit
--
-- >>> uriPathFormat ["*", "80"]
-- AllOneLine (MaxChars 80)
--
-- >>> uriPathFormat ["*", "80", "..."]
-- AllOneLine (MaxCharsAppend 80 "...")
--
-- >>> uriPathFormat ["3"]
-- MaxLines 3 NoCharLimit
--
-- >>> uriPathFormat ["3", "40"]
-- MaxLines 3 (MaxChars 40)
--
-- >>> uriPathFormat ["3", "40", "..."]
-- MaxLines 3 (MaxCharsAppend 40 "...")
--
-- >>> uriPathFormat ["notanumber"]
-- Raw
uriPathFormat ::
[String] ->
Format
uriPathFormat [] =
Raw
uriPathFormat (q : r) =
let rawMaybe ::
(Read a) =>
(a -> CharLimit) ->
String ->
CharLimit
rawMaybe f n =
maybe NoCharLimit f (readMaybe n)
r' = case r of
[] ->
NoCharLimit
s : ss ->
rawMaybe
( \n -> case ss of
[] ->
MaxChars n
t : _ ->
MaxCharsAppend n t
)
s
in case q of
"*" ->
AllOneLine r'
_ ->
case readMaybe q of
Nothing ->
Raw
Just l ->
MaxLines l r'
-- | WAI 'Application' serving METAR observations and BOM GAF images.
metarHTTPapp ::
Application
metarHTTPapp req withResp =
let msg =
let a </> b =
a <> "\n" <> b
a <//> b =
a </> "\n" <> b
in "/metar/<icao>"
</> "raw metar for station <icao>"
<//> "/metar/<icao>/*"
</> "metar for station <icao> all on one line"
<//> "/metar/<icao>/*/<maxchars>"
</> "metar for station <icao> all on one line truncated at <maxchars>"
<//> "/metar/<icao>/*/<maxchars>/<appendstr>"
</> "metar for station <icao> all on one line truncated at <maxchars> and if truncation occurs, append <appendstr>"
<//> "/gaf/<area>/current"
</> "current BOM Graphical Area Forecast (PNG) for <area> (WA-N, WA-S, NT, QLD-N, QLD-S, SA, NSW-W, NSW-E, VIC, TAS)"
<//> "/gaf/<area>/next"
</> "next BOM Graphical Area Forecast (PNG) for <area>"
<//> "/gpwt/<level>/<area>/<time>"
</> "BOM Grid Point Wind & Temperature forecast (PNG); <level> is low, mid or high; <area> e.g. AUS, NSW, QLD-N, VIC-TAS, TIMS; <time> is a 3-hourly UTC slot like 00Z, 03Z ... 21Z"
<//> ""
_404 =
responseLBS
status404
[]
msg
in case pathInfo req of
["gaf", area, periodTxt]
| Just period <- gafPeriod (toLower periodTxt) ->
do
r <- getGAF (unpack area) period
withResp (gafResponse r)
["gpwt", levelTxt, area, timeTxt] ->
let levelStr = unpack (toLower levelTxt)
in case parseLevel levelStr of
Nothing ->
withResp $
responseLBS
status404
[(hContentType, "text/plain")]
(fromString (renderGPWTError (GPWTUnknownLevel levelStr)))
Just lv ->
do
r <- getGPWT lv (unpack area) (unpack timeTxt)
withResp (gpwtResponse r)
(rpt : xxxx : r)
| toLower rpt == "metar" ->
let xxxx' = unpack xxxx
modifyOutput = format (uriPathFormat (unpack <$> r))
in do
t <- getMETAR xxxx' ^. _Wrapped
withResp $
case t ^? _METARResultValue of
Nothing ->
responseLBS
status404
[]
("no METAR found for " <> fromString xxxx')
Just x ->
responseLBS
status200
[(hContentType, "text/plain")]
(fromString (modifyOutput [x]))
[] ->
withResp $
responseLBS
status200
[(hContentType, "text/plain")]
msg
_ ->
withResp _404
-- | Parse the trailing path segment of a @/gaf/<area>/...@ request into a
-- 'GAFPeriod'.
--
-- >>> gafPeriod "current"
-- Just GAFCurrent
--
-- >>> gafPeriod "next"
-- Just GAFNext
--
-- >>> gafPeriod "other"
-- Nothing
gafPeriod ::
Text ->
Maybe GAFPeriod
gafPeriod t =
case t of
"current" -> Just GAFCurrent
"next" -> Just GAFNext
_ -> Nothing
-- | Turn a GAF fetch outcome into a WAI response. Successful fetches serve
-- the raw image bytes with the BOM-declared content type; errors map to
-- @404@ (unknown area) or @502@ (upstream failure) with a plain-text body.
gafResponse ::
Either GAFError GAFImage ->
Response
gafResponse r =
case r of
Right (GAFImage ct bs) ->
responseLBS
status200
[(hContentType, BS.pack ct)]
bs
Left err@(GAFUnknownArea _ _) ->
responseLBS
status404
[(hContentType, "text/plain")]
(fromString (renderGAFError err))
Left err@(GAFHttpError _ _) ->
responseLBS
status502
[(hContentType, "text/plain")]
(fromString (renderGAFError err))
Left err ->
responseLBS
status502
[(hContentType, "text/plain")]
(fromString (renderGAFError err))
-- | Turn a GPWT fetch outcome into a WAI response. Successful fetches serve
-- the raw image bytes with the BOM-declared content type; errors map to
-- @404@ (unknown level, or no product for the requested area/time) or @502@
-- (upstream failure) with a plain-text body.
gpwtResponse ::
Either GPWTError GPWTImage ->
Response
gpwtResponse r =
case r of
Right (GPWTImage ct bs) ->
responseLBS
status200
[(hContentType, BS.pack ct)]
bs
Left err@(GPWTUnknownLevel _) ->
responseLBS
status404
[(hContentType, "text/plain")]
(fromString (renderGPWTError err))
Left err@(GPWTNoSuchProduct{}) ->
responseLBS
status404
[(hContentType, "text/plain")]
(fromString (renderGPWTError err))
Left err@(GPWTHttpError _ _) ->
responseLBS
status502
[(hContentType, "text/plain")]
(fromString (renderGPWTError err))
Left err ->
responseLBS
status502
[(hContentType, "text/plain")]
(fromString (renderGPWTError err))
-- | Run 'metarHTTPapp' with Warp, optionally taking a port from the first
-- command-line argument.
metarHTTP ::
IO ()
metarHTTP =
do
a <- getArgs
let p = case a of
[] ->
id
(q : _) ->
maybe id setPort (readMaybe q)
runSettings (setTimeout 6 (p defaultSettings)) metarHTTPapp