From 0bcabe1c4b1dd74af233674dfa6c6ec3011ce2c0 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Tue, 18 Jan 2022 09:43:24 +0100
Subject: restructuring directories

---
 chaski/services/VaaS/app/Main.hs | 58 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 58 insertions(+)
 create mode 100644 chaski/services/VaaS/app/Main.hs

(limited to 'chaski/services/VaaS/app')

diff --git a/chaski/services/VaaS/app/Main.hs b/chaski/services/VaaS/app/Main.hs
new file mode 100644
index 0000000..b5697d7
--- /dev/null
+++ b/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)
-- 
cgit v1.2.3