diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,30 @@ +Copyright 2018 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of QFPL nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.0.1 + +* Initial release diff --git a/metar-http.cabal b/metar-http.cabal new file mode 100644 --- /dev/null +++ b/metar-http.cabal @@ -0,0 +1,97 @@ +name: metar-http +version: 0.0.1 +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, Tony Morris +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 +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 + +library + default-language: + Haskell2010 + + build-depends: + base >= 4.8 && < 5 + , http-types >= 0.9 && < 1 + , lens >= 4 && < 5 + , metar >= 0.0.1 && < 1.0 + , network-uri >= 2.6 && < 3 + , text >= 1.2 && < 1.3 + , semigroups >= 0.9 && < 0.19 + , semigroupoids >= 5.2 && < 6 + , transformers >= 0.5 && < 0.6 + , utf8-string >= 1.0 && < 2 + , warp >= 3.2 && < 3.3 + , wai >= 3.2 && < 3.3 + + + ghc-options: + -Wall + + default-extensions: + + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Data.Aviation.Metar.Http + +executable metar-http + main-is: + Main.hs + + default-language: + Haskell2010 + + build-depends: + base >= 4.8 && < 5 + , metar-http + + ghc-options: + -Wall + + default-extensions: + NoImplicitPrelude + + hs-source-dirs: + src-exe + +test-suite tests + + build-depends: QuickCheck >=2.9.2 && <2.13 + , base >=4.8 && < 5 + , checkers >=0.4.6 && <0.5 + , metar-http + , lens >=4 && <4.18 + , tasty >=0.11 && <1.2 + , tasty-hunit >=0.9 && <0.11 + , tasty-quickcheck >=0.8.4 && <0.11 + + 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 new file mode 100644 --- /dev/null +++ b/src-exe/Main.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Main( + main +) where + +import System.IO(IO) +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 new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar/Http.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Aviation.Metar.Http( + metarHTTP +, metarHTTPapp +) where + +import Control.Category((.), id) +import Control.Lens((^.), (^?), _Wrapped) +import Data.Aviation.Metar(getAllMETAR, getAllTAF) +import Data.Aviation.Metar.TAFResult(_TAFResultValue) +import Data.ByteString.Lazy.UTF8 hiding (take) +import Data.Functor((<$>)) +import Data.Function(($)) +import Data.List(intercalate, take) +import Data.Maybe(Maybe(Nothing, Just), listToMaybe) +import Text.Read(reads) +import Data.Semigroup((<>)) +import Text.Show(show) +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, runSettings, defaultSettings) +import System.Environment(getArgs) +import System.IO(IO) + +metarHTTPapp :: + Application +metarHTTPapp req withResp = + let msg = + "path /metar/ or /metar// or /taf/ or /taf//" + _404 = + responseLBS + status404 + [] + msg + in case pathInfo req of + (rpt:xxxx:r) -> + let xxxx' = + unpack xxxx + tk r' = + case unpack <$> r' of + n:_ -> + take . fst <$> listToMaybe (reads n) + [] -> + Just id + mt = + case toLower rpt of + "metar" -> + Just ("METAR", getAllMETAR xxxx') + "taf" -> + Just ("TAF", getAllTAF xxxx') + _ -> + Nothing + in case mt of + Nothing -> + withResp _404 + Just (mtt, mtf) -> + case tk r of + Nothing -> + withResp $ + responseLBS + status404 + [] + ("not a valid number " <> fromString (show r)) + Just q -> + do t <- (intercalate "\n" . q <$> mtf) ^. _Wrapped + withResp $ + case t ^? _TAFResultValue of + Nothing -> + responseLBS + status404 + [] + ("no " <> mtt <> " found for " <> fromString xxxx') + Just x -> + responseLBS + status200 + [(hContentType, "text/plain")] + (fromString x) + [] -> + withResp $ + responseLBS + status200 + [(hContentType, "text/plain")] + msg + _ -> + withResp _404 + +metarHTTP :: + IO () +metarHTTP = + do a <- getArgs + let p = + case a of + [] -> + id + (q:_) -> + case fst <$> listToMaybe (reads q) of + Nothing -> + id + Just n -> + setPort n + runSettings (p defaultSettings) metarHTTPapp diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure ()