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).

1 files changed, 58 insertions, 0 deletions

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)