summaryrefslogtreecommitdiff
path: root/hosts/chaski/services/VaaS/app
diff options
context:
space:
mode:
authorstuebinm2021-10-03 03:13:05 +0200
committerstuebinm2021-10-03 03:13:23 +0200
commit22c6837abde39c5a75baeefa95908792867e42de (patch)
tree00566d70fd0b4dcd0e773177d850129f479a0bb2 /hosts/chaski/services/VaaS/app
parentee21f53dea4f8e069bb8a97d808b9cf1f030a910 (diff)
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).
Diffstat (limited to 'hosts/chaski/services/VaaS/app')
-rw-r--r--hosts/chaski/services/VaaS/app/Main.hs58
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)