diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,27 @@ +Copyright 2016 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: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,44 @@ +#!/usr/bin/env runhaskell +\begin{code} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Verbosity ( Verbosity ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys + +\end{code} 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. diff --git a/ersaconcat.cabal b/ersaconcat.cabal new file mode 100644 --- /dev/null +++ b/ersaconcat.cabal @@ -0,0 +1,97 @@ +name: ersaconcat +version: 0.0.1 +license: BSD3 +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris +copyright: Copyright (C) 2016 Tony Morris +synopsis: A script to concatenate AIP ERSA +category: Aviation +description: A script to concatenate AIP ERSA +homepage: https://github.com/tonymorris/ersaconcat +bug-reports: https://github.com/tonymorris/ersaconcat/issues +cabal-version: >= 1.10 +build-type: Custom +extra-source-files: changelog.md + +source-repository head + type: git + location: git@github.com:tonymorris/ersaconcat.git + +flag small_base + description: Choose the new, split-up base package. + +library + default-language: + Haskell2010 + + build-depends: + base < 5 && >= 4 + , network-uri >= 2.6 && < 3 + , HTTP >= 4000 && < 5000 + , tagsoup >= 0.14 && < 1 + , filepath >= 1.4 && < 2 + , directory >= 1.2 && < 2 + , process >= 1.4 && < 2 + + ghc-options: + -Wall + + default-extensions: + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Data.Aviation.Ersa.Concat + +executable ersaconcat + main-is: + Main.hs + + default-language: + Haskell2010 + + build-depends: + base < 5 && >= 4 + , network-uri >= 2.6 && < 3 + , HTTP >= 4000 && < 5000 + , tagsoup >= 0.14 && < 1 + , filepath >= 1.4 && < 2 + , directory >= 1.2 && < 2 + , process >= 1.4 && < 2 + + ghc-options: + -Wall + + default-extensions: + NoImplicitPrelude + + hs-source-dirs: + src + +test-suite doctests + type: + exitcode-stdio-1.0 + + main-is: + doctests.hs + + default-language: + Haskell2010 + + build-depends: + base < 5 && >= 3 + , doctest >= 0.9.7 + , filepath >= 1.3 + , directory >= 1.1 + , QuickCheck >= 2.0 + , template-haskell >= 2.8 + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test diff --git a/src/Data/Aviation/Ersa/Concat.hs b/src/Data/Aviation/Ersa/Concat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Ersa/Concat.hs @@ -0,0 +1,234 @@ +module Data.Aviation.Ersa.Concat( + ErsaCurrentPending(..) +, currentPendingPath +, ErsaDocument(..) +, hrefs +, ersacontentsRequest +, ersacontentsResponse +, ersahrefs +, ersadocumentsResponse +, (>.>) +, traverseExitCodes +, ErsaConcatDirectories(..) +, defaultErsaConcatDirectories +, baseuri +, getersadocuments +, concatersadocuments +, ersaconcat +, defaultersaconcat +) where + +import Data.Maybe +import Network.HTTP +import Network.URI +import Text.HTML.TagSoup +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Prelude + +data ErsaCurrentPending = + ErsaCurrent + | ErsaPending + deriving (Eq, Ord, Show) + +currentPendingPath :: + ErsaCurrentPending + -> String +currentPendingPath ErsaCurrent = + "current" +currentPendingPath ErsaPending = + "pending" + +data ErsaDocument = + ErsaDocument { + _pg :: + String + , _date :: + String + , _ver :: + String + , _ps :: + ErsaCurrentPending + } + deriving (Eq, Ord, Show) + +hrefs :: + ErsaDocument + -> Tag [Char] + -> Maybe [Char] +hrefs (ErsaDocument _ _ _ j) (TagOpen "a" attrs) = + case attrs of + [("href", e)] -> + let (s, t) = splitAt 18 e + in if s == "/aip/" ++ currentPendingPath j ++ "/ersa/" + then + Just t + else + Nothing + _ -> + Nothing +hrefs _ _ = + Nothing + +ersacontentsRequest :: + ErsaDocument + -> Request String +ersacontentsRequest (ErsaDocument p d v _) = + Request + (URI "http:" (Just (URIAuth "" "www.airservicesaustralia.com" "")) "/aip/aip.asp" ("?pg=" ++ p ++ "&vdate=" ++ d ++ "&ver=" ++ v) "") + GET + [] + "" + +ersacontentsResponse :: + ErsaDocument + -> IO String +ersacontentsResponse d = + do s <- simpleHTTP (ersacontentsRequest d) + getResponseBody s + +ersahrefs :: + ErsaDocument + -> String + -> [String] +ersahrefs d r = + parseTags r >>= + maybeToList . hrefs d + +ersadocumentsResponse :: + ErsaDocument + -> IO [String] +ersadocumentsResponse d = + ersahrefs d <$> ersacontentsResponse d + +(>.>) :: + Monad m => + m ExitCode + -> m ExitCode + -> m ExitCode +a >.> b = + do e <- a + if e == ExitSuccess + then + b + else + return e + +traverseExitCodes :: + (Monad m, Foldable t) => + (a -> m ExitCode) + -> t a + -> m ExitCode +traverseExitCodes f = + foldr (\a b -> f a >.> b) (return ExitSuccess) + +data ErsaConcatDirectories = + ErsaConcatDirectories { + _base :: + ErsaDocument + -> FilePath + , _wgetDirectory :: + FilePath + , _outDirectory :: + FilePath + , _logDirectory :: + FilePath + } + +defaultErsaConcatDirectories :: + ErsaDocument + -> ErsaConcatDirectories +defaultErsaConcatDirectories c = + let base (ErsaDocument p d v j) = + concat ["ersa_", currentPendingPath j, "_pg-", p, "_vdate-", d, "_ver-", v] + in ErsaConcatDirectories + base + ("dist" base c "wget") + ("dist" base c "out") + ("dist" base c "log") + +baseuri :: + String +baseuri = + "https://www.airservicesaustralia.com/aip/pending/ersa/" + +getersadocuments :: + ErsaConcatDirectories + -> ErsaDocument + -> [String] + -> IO ExitCode +getersadocuments (ErsaConcatDirectories f w _ l) d u = + do createDirectoryIfMissing True w + createDirectoryIfMissing True l + traverseExitCodes + (\a -> rawSystem' + (l concat [f d, ".get.err"]) + (l concat [f d, ".get.out"]) + "wget" + [ + "--no-check-certificate" + , "-c" + , "--show-progress" + , "--directory-prefix" + , w + , baseuri ++ a + ]) + u + +-- requires pdftk on PATH +-- requires pdftotext on PATH +concatersadocuments :: + ErsaConcatDirectories + -> ErsaDocument + -> [String] + -> IO ExitCode +concatersadocuments (ErsaConcatDirectories f w o l) d u = + let pdfout = o concat [f d, ".pdf"] + in do createDirectoryIfMissing True o + createDirectoryIfMissing True l + rawSystem' + (l concat [f d, ".concat.err"]) + (l concat [f d, ".concat.out"]) + "pdftk" + (map (w ) u ++ ["output", pdfout, "verbose"]) >.> + rawSystem' + (l concat [f d, ".pdftotxt.err"]) + (l concat [f d, ".pdftotxt.out"]) + "pdftotext" + [pdfout] + +ersaconcat :: + ErsaConcatDirectories + -> ErsaDocument + -> IO ExitCode +ersaconcat a d = + do r <- ersadocumentsResponse d + getersadocuments a d r >.> + concatersadocuments a d r + +defaultersaconcat :: + ErsaDocument + -> IO ExitCode +defaultersaconcat d = + ersaconcat (defaultErsaConcatDirectories d) d + +rawSystem' :: + FilePath + -> FilePath + -> FilePath + -> [String] + -> IO ExitCode +rawSystem' e o cmd args = + withFile e AppendMode $ + \herr -> + withFile o AppendMode $ + \hout -> + do + (_, _, _, ph) <- createProcess_ "ersaconcat" (proc cmd args) { + std_out = UseHandle hout + , std_err = UseHandle herr + } + waitForProcess ph diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,36 @@ +module Main( + main +, ersas +) where + +import Control.Monad((>>=)) +import Data.Aviation.Ersa.Concat(ErsaDocument(ErsaDocument), ErsaCurrentPending(ErsaCurrent, ErsaPending), defaultersaconcat, traverseExitCodes) +import System.Environment(getArgs) +import System.Exit(ExitCode(ExitFailure), exitWith) +import System.IO(IO, hPutStrLn, stderr) + +main :: + IO () +main = + do a <- getArgs + case a of + p:d:v:z -> + defaultersaconcat (ErsaDocument p d v ( case z of + [] -> + ErsaCurrent + _ -> + ErsaPending)) >>= exitWith + [] -> + traverseExitCodes defaultersaconcat ersas >>= exitWith + _ -> + do hPutStrLn stderr "Enter zero arguments for default ERSA list or three arguments for single ERSA [a fourth argument implies the ERSA is pending]" + exitWith (ExitFailure 65535) + +ersas :: + [ErsaDocument] +ersas = + [ + ErsaDocument "40" "18-Aug-2016" "1" ErsaCurrent + , ErsaDocument "40" "10-Nov-2016" "0" ErsaPending + , ErsaDocument "40" "10-Nov-2016" "2" ErsaPending + ] diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,32 @@ +module Main where + +import Build_doctests (deps) +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.FilePath +import Test.DocTest + +main :: + IO () +main = + getSources >>= \sources -> doctest $ + "-isrc" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : map ("-package="++) deps ++ sources + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c