diff options
Diffstat (limited to 'hosts/chaski/services/VaaS/app/Main.hs')
-rw-r--r-- | hosts/chaski/services/VaaS/app/Main.hs | 58 |
1 files changed, 0 insertions, 58 deletions
diff --git a/hosts/chaski/services/VaaS/app/Main.hs b/hosts/chaski/services/VaaS/app/Main.hs deleted file mode 100644 index b5697d7..0000000 --- a/hosts/chaski/services/VaaS/app/Main.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# 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) |