diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,31 @@ +Copyright 2017,2018 Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +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.cabal b/metar.cabal new file mode 100644 --- /dev/null +++ b/metar.cabal @@ -0,0 +1,100 @@ +name: metar +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: Australian METAR +category: Data, Aviation +description: + Obtain Australian METAR from Bureau of Meteorology (BOM). + . + If that fails, get the METAR from NOAA. +homepage: https://github.com/tonymorris/metar +bug-reports: https://github.com/tonymorris/metar/issues +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: changelog.md + +source-repository head + type: git + location: git@github.com:tonymorris/metar.git + +library + default-language: + Haskell2010 + + build-depends: + base >= 4.8 && < 5 + , HTTP >= 4000 && < 5000 + , lens >= 4 && < 5 + , network-uri >= 2.6 && < 3 + , semigroups >= 0.9 && < 0.19 + , semigroupoids >= 5.2 && < 6 + , tagsoup >= 0.13 && < 0.15 + , tagsoup-selection >= 0.1 && < 0.2 + , transformers >= 0.5 && < 0.6 + , deriving-compat + + ghc-options: + -Wall + + default-extensions: + + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Data.Aviation.Metar + , Data.Aviation.Metar.BOMTAFResult + , Data.Aviation.Metar.TAFResult + , Data.Aviation.Metar.TAFResultT + +executable metar + main-is: + Main.hs + + default-language: + Haskell2010 + + build-depends: + base >= 4.8 && < 5 + , metar + + 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 + , 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,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Main( + main +) where + +import Data.Aviation.Metar(runMETAR) +import System.Environment(getArgs) +import System.IO(IO) + +main :: + IO () +main = + do a <- getArgs + runMETAR a diff --git a/src/Data/Aviation/Metar.hs b/src/Data/Aviation/Metar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Aviation.Metar( + getBOMTAF +, getNOAAMETAR +, getAllMETAR +, getAllTAF +, runMETAR +) where + +import Control.Applicative(pure) +import Control.Category((.)) +import Control.Lens(view, _Wrapped) +import Control.Monad(Monad((>>=))) +import Data.Aviation.Metar.BOMTAFResult(BOMTAFResponse(BOMTAFResponse), bomMETAR, bomTAF) +import Data.Aviation.Metar.TAFResult(TAFResult(ConnErrorResult, ParseErrorResult, TAFResultValue)) +import Data.Aviation.Metar.TAFResultT(TAFResultT(TAFResultT)) +import Data.Char(toUpper) +import Data.Either(Either(Left, Right)) +import Data.Foldable(length) +import Data.Functor(fmap) +import Data.List(intercalate) +import Data.Maybe(Maybe(Nothing, Just)) +import Data.String(String, lines) +import Data.Semigroup((<>)) +import Network.HTTP(Request, Response, setHeaders, setRequestBody, mkRequest, RequestMethod(POST, GET), Header(Header), HeaderName(..), rspBody, simpleHTTP) +import Network.Stream(ConnError) +import Network.URI(URI(URI), URIAuth(URIAuth)) +import Prelude(show) +import System.IO(IO, hPutStrLn, putStrLn, stderr) +import Text.HTML.TagSoup(Tag(TagText)) +import Text.HTML.TagSoup.Tree(TagTree(TagBranch, TagLeaf), parseTree) + +withResult :: + (r -> Maybe a) -> + Either ConnError r -> + TAFResult a +withResult _ (Left e) = + ConnErrorResult e +withResult k (Right s) = + case k s of + Nothing -> + ParseErrorResult + Just z -> + TAFResultValue z + +getBOMTAF :: + String + -> TAFResultT IO BOMTAFResponse +getBOMTAF = + let mkTAFResponse :: + [TagTree String] + -> Maybe BOMTAFResponse + mkTAFResponse (TagBranch "h3" [] [TagLeaf (TagText title)] : TagBranch "p" [("class","product")] tafs : TagBranch "p" [("class","product")] metars:_) = + let tagTexts q = + q >>= \r -> + case r of + TagLeaf (TagText v) -> + [v] + _ -> + [] + in Just (BOMTAFResponse title (tagTexts tafs) (tagTexts metars)) + mkTAFResponse _ = + Nothing + request :: + String + -> Request String + request yxxx = + let reqBody = + "keyword=" <> yxxx <> "&type=search&page=TAF" + in setHeaders + ( + setRequestBody + ( + mkRequest + POST + (URI "http" (Just (URIAuth "" "www.bom.gov.au" "")) "/aviation/php/process.php" "" "") + ) + ("application/x-www-form-urlencoded", reqBody) + ) + [ + Header HdrHost "www.bom.gov.au" + , Header HdrUserAgent "tonymorris/metar" + , Header HdrAccept "*/*" + , Header HdrAcceptLanguage "en-US,en;q=0.5" + , Header HdrAcceptEncoding "text/html" + , Header HdrReferer "http://www.bom.gov.au/aviation/forecasts/taf/" + , Header HdrConnection "keep-alive" + , Header HdrContentType "application/x-www-form-urlencoded" + , Header HdrContentLength (show (length reqBody)) + , Header HdrCookie "check=ok; bom_meteye_windspeed_units_knots=yes" + , Header HdrPragma "no-cache" + , Header HdrCacheControl "no-cache" + , Header (HdrCustom "DNT") "1" + , Header (HdrCustom "X-Requested-With") "XMLHttpRequest" + ] + respTAF :: + Response String + -> Maybe BOMTAFResponse + respTAF = + mkTAFResponse . parseTree . rspBody + in TAFResultT . fmap (withResult respTAF) . simpleHTTP . request + +-- http://tgftp.nws.noaa.gov/data/observations/metar/stations/xxxx.TXT +getNOAAMETAR :: + String + -> TAFResultT IO String +getNOAAMETAR = + let request :: + String + -> Request String + request xxxx = + setHeaders + ( + mkRequest + GET + (URI "http" (Just (URIAuth "" "tgftp.nws.noaa.gov" "")) ("data/observations/metar/stations/" <> fmap toUpper xxxx <> ".TXT") "" "") + ) + [ + Header HdrHost "tgftp.nws.noaa.gov" + , Header HdrUserAgent "tonymorris/metar" + , Header HdrAccept "*/*" + , Header HdrAcceptLanguage "en-US,en;q=0.5" + , Header HdrAcceptEncoding "text/html" + , Header HdrConnection "keep-alive" + , Header HdrPragma "no-cache" + , Header HdrCacheControl "no-cache" + , Header (HdrCustom "DNT") "1" + ] + respMETAR :: + Response String + -> Maybe String + respMETAR r = + case lines (rspBody r) of + [_, r'] -> Just r' + _ -> Nothing + in TAFResultT . fmap (withResult respMETAR) . simpleHTTP . request + +getAllMETAR :: + String + -> TAFResultT IO [String] +getAllMETAR x = + fmap (view bomMETAR) (getBOMTAF x) <> + fmap pure (getNOAAMETAR x) + +getAllTAF :: + String + -> TAFResultT IO [String] +getAllTAF x = + fmap (view bomTAF) (getBOMTAF x) + +runMETAR :: + [String] + -> IO () +runMETAR x = + let stderr' = + hPutStrLn stderr + in case x of + [] -> + stderr' "enter an argument (ICAO code)" + (r:_) -> + let s = view _Wrapped (fmap (intercalate "\n") (getAllMETAR r)) + in s >>= \s' -> + case s' of + TAFResultValue a -> + putStrLn a + ParseErrorResult -> + stderr' ("No METAR for " <> r) + ConnErrorResult e -> + stderr' ("Network connection error " <> show e) diff --git a/src/Data/Aviation/Metar/BOMTAFResult.hs b/src/Data/Aviation/Metar/BOMTAFResult.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar/BOMTAFResult.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Aviation.Metar.BOMTAFResult where + +import Control.Lens(makeClassy) +import Data.Eq(Eq) +import Data.Ord(Ord) +import Data.String(String) +import Prelude(Show) + +data BOMTAFResponse = + BOMTAFResponse { + _bomTitle :: + String + , _bomTAF :: + [String] + , _bomMETAR :: + [String] + } deriving (Eq, Ord, Show) + +makeClassy ''BOMTAFResponse diff --git a/src/Data/Aviation/Metar/TAFResult.hs b/src/Data/Aviation/Metar/TAFResult.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar/TAFResult.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Aviation.Metar.TAFResult 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.Alt(Alt(())) +import Data.Functor.Apply(Apply((<.>))) +import Data.Functor.Bind(Bind((>>-))) +import Data.Functor.Extend(Extend(duplicated)) +import Data.Semigroup(Semigroup((<>))) +import Data.Traversable(Traversable(traverse)) +import Network.Stream(ConnError) +import Prelude(Show) +import Text.Show.Deriving(deriveShow1) + +data TAFResult a = + ConnErrorResult ConnError + | ParseErrorResult + | TAFResultValue a + deriving (Eq, Show) + +makeClassy ''TAFResult +makeClassyPrisms ''TAFResult +deriveEq1 ''TAFResult +deriveShow1 ''TAFResult + +instance Functor TAFResult where + fmap _ (ConnErrorResult e) = + ConnErrorResult e + fmap _ ParseErrorResult = + ParseErrorResult + fmap f (TAFResultValue a) = + TAFResultValue (f a) + +instance Apply TAFResult where + ConnErrorResult e <.> _ = + ConnErrorResult e + ParseErrorResult <.> _ = + ParseErrorResult + TAFResultValue f <.> TAFResultValue a = + TAFResultValue (f a) + TAFResultValue _ <.> ConnErrorResult e = + ConnErrorResult e + TAFResultValue _ <.> ParseErrorResult = + ParseErrorResult + +instance Applicative TAFResult where + pure = + TAFResultValue + (<*>) = + (<.>) + +instance Bind TAFResult where + ConnErrorResult e >>- _ = + ConnErrorResult e + ParseErrorResult >>- _ = + ParseErrorResult + TAFResultValue a >>- f = + f a + +instance Monad TAFResult where + return = + pure + (>>=) = + (>>-) + +instance Foldable TAFResult where + foldr f z (TAFResultValue a) = + f a z + foldr _ z (ConnErrorResult _ ) = + z + foldr _ z ParseErrorResult = + z + +instance Traversable TAFResult where + traverse f (TAFResultValue a) = + TAFResultValue <$> f a + traverse _ (ConnErrorResult e) = + pure (ConnErrorResult e) + traverse _ ParseErrorResult = + pure ParseErrorResult + +instance Alt TAFResult where + TAFResultValue a _ = + TAFResultValue a + ConnErrorResult _ x = + x + ParseErrorResult x = + x + +instance Extend TAFResult where + duplicated (TAFResultValue a) = + TAFResultValue (TAFResultValue a) + duplicated (ConnErrorResult e) = + ConnErrorResult e + duplicated ParseErrorResult = + ParseErrorResult + +instance Semigroup (TAFResult a) where + (<>) = + () diff --git a/src/Data/Aviation/Metar/TAFResultT.hs b/src/Data/Aviation/Metar/TAFResultT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Metar/TAFResultT.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Aviation.Metar.TAFResultT where + +import Control.Applicative(Applicative(pure, (<*>))) +import Control.Category((.)) +import Control.Monad(Monad(return, (>>=)), ap) +import Data.Aviation.Metar.TAFResult(TAFResult(TAFResultValue, 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) + +newtype TAFResultT f a = + TAFResultT + (f (TAFResult a)) + +makeClassy ''TAFResultT +makeWrapped ''TAFResultT + +instance (Eq a, Eq1 f) => Eq (TAFResultT f a) where + TAFResultT x == TAFResultT y = + eq1 x y + +instance (Show a, Show1 f) => Show (TAFResultT f a) where + showsPrec n (TAFResultT x) = + showParen (n > 10) (showString "TafResultT " . showsPrec1 n x) + +deriveEq1 ''TAFResultT +deriveShow1 ''TAFResultT + +instance Functor f => Functor (TAFResultT f) where + fmap f (TAFResultT x) = + TAFResultT (fmap (fmap f) x) + +instance Monad f => Apply (TAFResultT f) where + (<.>) = + ap + +instance Monad f => Applicative (TAFResultT f) where + pure = + TAFResultT . pure . pure + (<*>) = + ap + +instance Monad f => Bind (TAFResultT f) where + (>>-) = + (>>=) + +instance Monad f => Monad (TAFResultT f) where + return = + pure + TAFResultT x >>= f = + TAFResultT + ( + x >>= \x' -> + case x' of + TAFResultValue x'' -> + let TAFResultT r = f x'' + in r + ConnErrorResult e -> + pure (ConnErrorResult e) + ParseErrorResult -> + pure ParseErrorResult + ) + +instance Foldable f => Foldable (TAFResultT f) where + foldr f z (TAFResultT x) = + foldr (\a b -> foldr f b a) z x + +instance Traversable f => Traversable (TAFResultT f) where + traverse f (TAFResultT x) = + TAFResultT <$> traverse (traverse f) x + +instance Monad f => Alt (TAFResultT f) where + TAFResultT x TAFResultT y = + TAFResultT + ( + x >>= \x' -> + case x' of + TAFResultValue x'' -> + pure (TAFResultValue x'') + ConnErrorResult _ -> + y + ParseErrorResult -> + y + ) + +instance Extend f => Extend (TAFResultT f) where + duplicated (TAFResultT x) = + TAFResultT (fmap (TAFResultValue . TAFResultT) (duplicated x)) + +instance MonadIO f => MonadIO (TAFResultT f) where + liftIO = + TAFResultT . liftIO . fmap pure + +instance MonadTrans TAFResultT where + lift = + TAFResultT . fmap pure + +instance Monad f => Semigroup (TAFResultT f a) where + (<>) = + () 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 ()