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 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, "/")
[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"
}
data Sources = Sources
{ index :: FilePath
, quescripts :: FilePath
, client :: FilePath
, style :: FilePath
}
loop :: Text -> Sources -> IO ()
loop ns pages@Sources {..} = do
_ <-
Async.runConcurrently
$ (,,,)
<$> Async.Concurrently
(toHtml style index >>= serve (https "que.run" /: ns /: "index.html"))
<*> Async.Concurrently
( BS.readFile client
>>= serve (https "que.run" /: ns /: "_client" /: "python")
)
<*> Async.Concurrently
( toHtml style quescripts
>>= serve (https "que.run" /: ns /: "_page" /: "quescripts")
)
loop ns pages
toHtml :: FilePath -> FilePath -> IO ByteString
toHtml style md =
BS.pack
<$> Process.readProcess
"pandoc"
[ "--self-contained"
, "--css"
, style
, "-i"
, md
, "--from"
, "markdown"
, "--to"
, "html"
]
[]
serve :: Url scheme -> ByteString -> IO ()
serve path content = runReq defaultHttpConfig $ do
_ <- req POST path (ReqBodyBs content) ignoreResponse mempty
liftIO $ return ()
|
