diff options
Diffstat (limited to 'hosts/chaski/services/VaaS/app')
-rw-r--r-- | hosts/chaski/services/VaaS/app/Main.hs | 58 |
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) |