blob: b5697d7061b774218e17e9d1241c9b69a3131fd6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
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)
|
