add gtfs validator as a service

This just runs the GTFS validator as a web service, since it's a
horrible piece of python2 stuff which I don't want to set up every time
I used it (nor except other people to do so if they need it).

6 files changed, 175 insertions, 0 deletions

diff --git a/hosts/chaski/services/VaaS/.gitignore b/hosts/chaski/services/VaaS/.gitignore
new file mode 100644
index 0000000..b5e3679
--- /dev/null
+++ b/hosts/chaski/services/VaaS/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/*
diff --git a/hosts/chaski/services/VaaS/CHANGELOG.md b/hosts/chaski/services/VaaS/CHANGELOG.md
new file mode 100644
index 0000000..500a0d0
--- /dev/null
+++ b/hosts/chaski/services/VaaS/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for haskell
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/hosts/chaski/services/VaaS/app/Main.hs b/hosts/chaski/services/VaaS/app/Main.hs
new file mode 100644
index 0000000..b5697d7
--- /dev/null
+++ b/hosts/chaski/services/VaaS/app/Main.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Control.Exception        (try)
+import           Control.Exception.Base   (handle)
+import qualified Data.ByteString          as BS
+import           Data.ByteString.Base32
+import qualified Data.ByteString.Char8    as C8
+import qualified Data.ByteString.Lazy     as LB
+import           Data.Maybe               (mapMaybe)
+import           Network.HTTP.Client      (httpLbs, newManager, parseRequest,
+                                           responseBody)
+import           Network.HTTP.Client.TLS
+import           Network.HTTP.Types
+import           Network.Wai
+import           Network.Wai.Handler.Warp (run)
+import qualified System.Environment       as SE
+import           System.Process
+
+simpleResponse = responseLBS status200 [("Content-Type", "text/plain")]
+
+simpleError = responseLBS status400 [("Content-Type", "text/plain")]
+
+serveFile filename = do
+  content <- LB.readFile filename
+  pure $ responseLBS status200 [("Content-Type", "text/html")] content
+
+app :: FilePath -> FilePath -> Application
+app validator index req respond =
+    case requestMethod req of
+      "GET" -> case pathInfo req of
+        [] -> serveFile index >>= respond
+        ["validate"] -> do
+          let gtfsuri = head $ mapMaybe (\case { ("gtfs",a) -> Just a; _ -> Nothing }) $ queryString req
+          putStrLn $ "uri is " <> show gtfsuri
+          case gtfsuri of
+            Just uri -> do
+              man <- newManager tlsManagerSettings
+              request <- parseRequest $ C8.unpack uri
+              gtfs <- httpLbs request man
+              let filename = "/tmp/" <> C8.unpack (encodeBase32' uri) <> ".zip"
+              LB.writeFile filename (responseBody gtfs)
+              readProcessWithExitCode "python" [validator,"-n", filename, "--output", "/tmp/gtfs-validated.html"] ""
+
+              serveFile "/tmp/gtfs-validated.html" >>= respond
+
+            Nothing -> respond $ simpleError "missing gtfs parameter"
+        _ -> respond $ simpleError "unknown path"
+      _ -> respond $ simpleError "invalid reqeust method"
+
+main :: IO ()
+main = do
+  args <- SE.getArgs
+  let validator = head args
+  putStrLn "http://localhost:7000/"
+  run 7000 $ app validator (args!!1)
diff --git a/hosts/chaski/services/VaaS/default.nix b/hosts/chaski/services/VaaS/default.nix
new file mode 100644
index 0000000..427270c
--- /dev/null
+++ b/hosts/chaski/services/VaaS/default.nix
@@ -0,0 +1,30 @@
+{ pkgs, compiler ? "default", doBenchmark ? false }:
+
+let
+
+  inherit pkgs;
+
+  f = { mkDerivation, base, base32, bytestring, http-client
+      , http-client-tls, http-types, lib, process, wai, warp
+      }:
+      mkDerivation {
+        pname = "VaaS";
+        version = "0.1.0.0";
+        src = ./.;
+        isLibrary = false;
+        isExecutable = true;
+        executableHaskellDepends = [
+          base base32 bytestring http-client http-client-tls http-types
+          process wai warp
+        ];
+        license = "unknown";
+        hydraPlatforms = lib.platforms.none;
+      };
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+in
+  variant (haskellPackages.callPackage f {})
diff --git a/hosts/chaski/services/VaaS/haskell.cabal b/hosts/chaski/services/VaaS/haskell.cabal
new file mode 100644
index 0000000..262b65f
--- /dev/null
+++ b/hosts/chaski/services/VaaS/haskell.cabal
@@ -0,0 +1,35 @@
+cabal-version:      2.4
+name:               VaaS
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+author:             stuebinm
+maintainer:         stuebinm@disroot.org
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+executable VaaS
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base ^>=4.14.1.0, wai, warp, http-types, bytestring, process,
+                      http-client, http-client-tls, base32
+    hs-source-dirs:   app
+    default-language: Haskell2010
diff --git a/hosts/chaski/services/VaaS/index.html b/hosts/chaski/services/VaaS/index.html
new file mode 100644
index 0000000..a7f59e0
--- /dev/null
+++ b/hosts/chaski/services/VaaS/index.html
@@ -0,0 +1,46 @@
+<!doctype html>
+<html class="no-js" lang="">
+    <head>
+        <meta charset="utf-8">
+        <meta http-equiv="x-ua-compatible" content="ie=edge">
+        <title>GTFS Validator</title>
+        <meta name="description" content="">
+        <meta name="viewport" content="width=device-width, initial-scale=1">
+
+        <link rel="apple-touch-icon" href="/apple-touch-icon.png">
+        <!-- Place favicon.ico in the root directory -->
+
+    </head>
+    <body>
+        <!--[if lt IE 8]>
+            <p class="browserupgrade">
+            You are using an <strong>outdated</strong> browser. Please
+            <a href="http://browsehappy.com/">upgrade your browser</a> to improve
+            your experience.
+            </p>
+        <![endif]-->
+
+        <h1>GTFS Validator</h1>
+        <p>
+            This runs the validator contained in the
+            <a href="https://github.com/google/transitfeed">transitfeed
+                git repository
+            </a>.
+        </p>
+
+        <p>Paste the url to your GTFS zip below</p>
+
+        <input id="url">
+        <button id="submit">Validate</button>
+
+        <script>
+         let submit = document.getElementById("submit");
+         let url = document.getElementById("url");
+
+         submit.onclick = () => {
+             window.location =
+                 "/validate?gtfs=" + url.value
+         }
+        </script>
+    </body>
+</html>