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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
-- | spawns a few processes that serve the que.run website
module Run.Que.Website where
import qualified Control.Concurrent.Async as Async
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as Text
import Network.HTTP.Req
import Protolude
import System.Environment as Environment
import System.FilePath ( (</>) )
import qualified System.Process as Process
import qualified System.Exit as Exit
main :: IO ()
main = do
(src, ns) <- Environment.getArgs >>= \case
[src] -> return (src, "_") -- default to _ ns which is special
[src, ns] -> return (src, ns)
_ -> Exit.die "usage: que-website <srcdir> [namespace]"
putStrLn $ "serving " ++ src ++ " at " ++ ns
loop (Text.pack ns) $ Sources { index = src </> "index.md"
, client = src </> "client.py"
, quescripts = src </> "quescripts.md"
, style = src </> "style.css"
, apidocs = src </> "apidocs.md"
, tutorial = src </> "tutorial.md"
}
data Sources = Sources
{ index :: FilePath
, quescripts :: FilePath
, client :: FilePath
, style :: FilePath
, tutorial :: FilePath
, apidocs :: FilePath
}
loop :: Text -> Sources -> IO ()
loop ns pages@Sources {..} = Async.runConcurrently actions >> loop ns pages
where
actions = traverse
Async.Concurrently
[ toHtml index >>= srv "index"
, toHtml quescripts >>= srv "quescripts"
, BS.readFile client >>= srv "client"
, toHtml tutorial >>= srv "tutorial"
, toHtml apidocs >>= srv "apidocs"
]
srv p = serve $ https "que.run" /: ns /: p
toHtml :: FilePath -> IO ByteString
toHtml md =
BS.pack
<$> Process.readProcess
"pandoc"
[ "--self-contained"
, "--css"
, style
, "-i"
, md
, "--from"
, "markdown"
, "--to"
, "html"
]
[]
-- TODO: recover from 502 errors
serve :: Url scheme -> ByteString -> IO ()
serve path content = runReq defaultHttpConfig $ do
_ <- req POST path (ReqBodyBs content) ignoreResponse mempty
liftIO $ return ()
|
