diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,13 @@ +0.0.5 + +* Update to metar-0.0.5 library +* Use `getMETAR` (BOM for `Y*` codes, NOAA fallback) instead of NOAA only +* Add hlint and fourmolu configuration +* Add `bin/lint.sh` and `bin/test.sh` +* Add doctests; remove empty test-suite +* Add `{-# OPTIONS_GHC -Wall #-}` to all source files +* Remove `NoImplicitPrelude` + 0.0.4 * Update to GHC 9.6.7 compatibility diff --git a/metar-http.cabal b/metar-http.cabal --- a/metar-http.cabal +++ b/metar-http.cabal @@ -1,5 +1,5 @@ name: metar-http -version: 0.0.4 +version: 0.0.5 license: BSD3 license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@sıɹɹoɯʇ> @@ -8,15 +8,15 @@ synopsis: HTTP for METAR category: Data, Aviation description: A trivial HTTP program for getting METAR -homepage: https://gitlab.com/tonymorris/metar-http -bug-reports: https://gitlab.com/tonymorris/metar-http/issues +homepage: https://github.com/tonymorris/metar-http +bug-reports: https://github.com/tonymorris/metar-http/issues cabal-version: >= 1.10 build-type: Simple extra-source-files: changelog.md source-repository head type: git - location: git@gitlab.com:tonymorris/metar-http.git + location: git@github.com:tonymorris/metar-http.git library default-language: @@ -26,7 +26,7 @@ base >= 4.8 && < 5 , http-types >= 0.9 && < 1 , lens >= 4 && < 6 - , metar >= 0.0.4 && < 1.0 + , metar >= 0.0.5 && < 1.0 , network-uri >= 2.6 && < 3 , text >= 1.2 && < 3 , semigroups >= 0.9 && < 1 @@ -41,10 +41,6 @@ -Wall -threaded - default-extensions: - - NoImplicitPrelude - hs-source-dirs: src @@ -66,34 +62,5 @@ -Wall -threaded - 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-http - , 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,14 +1,12 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} -module Main( - main +module Main ( + main, ) where -import System.IO(IO) -import Data.Aviation.Metar.Http(metarHTTP) +import Data.Aviation.Metar.Http (metarHTTP) main :: IO () main = metarHTTP - diff --git a/src/Data/Aviation/Metar/Http.hs b/src/Data/Aviation/Metar/Http.hs --- a/src/Data/Aviation/Metar/Http.hs +++ b/src/Data/Aviation/Metar/Http.hs @@ -1,52 +1,68 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} -module Data.Aviation.Metar.Http( - metarHTTP -, metarHTTPapp +-- | HTTP server exposing METAR observations. Australian aerodromes (ICAO codes +-- beginning with @Y@) are fetched from BOM; other codes fall back to NOAA. +module Data.Aviation.Metar.Http ( + metarHTTP, + metarHTTPapp, ) where -import Control.Category((.), id) -import Control.Lens((^.), (^?), _Wrapped, folded) -import Data.Aviation.Metar(getNOAAMETAR) -import Data.Aviation.Metar.METARResult(_METARResultValue) -import Data.ByteString.Lazy.UTF8 hiding (take, splitAt) -import Data.Eq(Eq) -import Data.Functor((<$>)) -import Data.Function(($)) -import Data.Int(Int) -import Data.List(intercalate, take, splitAt) -import Data.Maybe(Maybe(Nothing, Just)) -import Data.String(String) -import Data.Semigroup((<>)) -import Data.Text(unpack, toLower) -import Data.Tuple(fst) -import Network.HTTP.Types.Header(hContentType) -import Network.HTTP.Types.Status(status404, status200) -import Network.Wai(Application, responseLBS, pathInfo) -import Network.Wai.Handler.Warp(setPort, setTimeout, runSettings, defaultSettings) -import System.Environment(getArgs) -import System.IO(IO) -import Text.Read(Read, reads) -import Text.Show(Show) +import Control.Lens (folded, (^.), (^?), _Wrapped) +import Data.Aviation.Metar (getMETAR) +import Data.Aviation.Metar.METARResult (_METARResultValue) +import Data.ByteString.Lazy.UTF8 (fromString) +import Data.List (intercalate) +import Data.Text (toLower, unpack) +import Network.HTTP.Types.Header (hContentType) +import Network.HTTP.Types.Status (status200, status404) +import Network.Wai (Application, 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 + (Read a) => + String -> + Maybe a readMaybe n = fst <$> reads n ^? folded -data CharLimit = - NoCharLimit +-- | 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 -> + String -> + String charLimit m s = case m of NoCharLimit -> @@ -54,58 +70,49 @@ MaxChars n -> take n s MaxCharsAppend n l -> - let (a, b) = - splitAt n s - b' = - case b of - [] -> - [] - _:_ -> - l - in a <> b' + let (a, b) = splitAt n s + b' = case b of + [] -> [] + _ : _ -> l + in a <> b' -data Format = - Raw +-- | 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 120 "abc")) ["METAR YBAF 071230Z AUTO 16006KT 9999 // NCD 24/20 Q1011 RMK","RF00.0/000.4"] +-- >>> 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 80 "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 -> + [String] -> + String format f s = let limitCalate l x = charLimit l . intercalate x - in case f of + in case f of Raw -> intercalate "\n" s MaxLines n l -> @@ -113,41 +120,69 @@ AllOneLine l -> limitCalate l " " s --- 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) +-- | 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 + [String] -> + Format uriPathFormat [] = Raw -uriPathFormat (q:r) = +uriPathFormat (q : r) = let rawMaybe :: - Read a => - (a -> CharLimit) - -> String - -> CharLimit + (Read a) => + (a -> CharLimit) -> + String -> + CharLimit rawMaybe f n = - case readMaybe n of - Nothing -> - NoCharLimit - Just c -> - f c - r' = - case r of - [] -> - NoCharLimit - s:ss -> - rawMaybe (\n -> case ss of - [] -> - MaxChars n - t:_ -> - MaxCharsAppend n t) s - in case q of + 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' _ -> @@ -157,6 +192,7 @@ Just l -> MaxLines l r' +-- | WAI 'Application' serving METAR observations. metarHTTPapp :: Application metarHTTPapp req withResp = @@ -165,54 +201,55 @@ a <> "\n" <> b a b = a "\n" <> b - in "/metar/" - "raw metar for station " - "/metar//*" - "metar for station all on one line" - "/metar//*/" - "metar for station all on one line truncated at " - "/metar//*//" - "metar for station all on one line truncated at and if truncation occurs, append " - "" + in "/metar/" + "raw metar for station " + "/metar//*" + "metar for station all on one line" + "/metar//*/" + "metar for station all on one line truncated at " + "/metar//*//" + "metar for station all on one line truncated at and if truncation occurs, append " + "" _404 = responseLBS status404 [] msg - in case pathInfo req of - (rpt:xxxx:r) -> + in case pathInfo req of + (rpt : xxxx : r) -> let xxxx' = unpack xxxx modifyOutput :: - [String] - -> String + [String] -> + String modifyOutput = format (uriPathFormat (unpack <$> r)) mt = case toLower rpt of "metar" -> - Just ("METAR", getNOAAMETAR xxxx') + Just ("METAR", getMETAR xxxx') "taf" -> Nothing _ -> Nothing - in case mt of + in case mt of Nothing -> withResp _404 Just (mtt, mtf) -> - do t <- mtf ^. _Wrapped - withResp $ - case t ^? _METARResultValue of - Nothing -> - responseLBS - status404 - [] - ("no " <> mtt <> " found for " <> fromString xxxx') - Just x -> - responseLBS - status200 - [(hContentType, "text/plain")] - (fromString (modifyOutput [x])) + do + t <- mtf ^. _Wrapped + withResp $ + case t ^? _METARResultValue of + Nothing -> + responseLBS + status404 + [] + ("no " <> mtt <> " found for " <> fromString xxxx') + Just x -> + responseLBS + status200 + [(hContentType, "text/plain")] + (fromString (modifyOutput [x])) [] -> withResp $ responseLBS @@ -222,18 +259,16 @@ _ -> withResp _404 +-- | 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:_) -> - case readMaybe q of - Nothing -> - id - Just n -> - setPort n - runSettings (setTimeout 6 (p defaultSettings)) metarHTTPapp + do + a <- getArgs + let p = case a of + [] -> + id + (q : _) -> + maybe id setPort (readMaybe q) + runSettings (setTimeout 6 (p defaultSettings)) metarHTTPapp 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 ()