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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
-- | spawns a few processes that serve the que.run website
--
-- : exe que-website
--
-- : dep async
-- : dep config-ini
-- : dep process
-- : dep protolude
-- : dep req
module Run.Que.Website
( main
)
where
import qualified Control.Concurrent.Async as Async
import Com.Simatime.Alpha
import qualified Data.ByteString.Char8 as BS
import qualified Data.Ini.Config as Config
import qualified Data.Text as Text
import Data.Text.Encoding ( encodeUtf8 )
import qualified Data.Text.IO as Text
import Network.HTTP.Req
import qualified System.Directory as Directory
import System.Environment as Environment
import qualified System.Exit as Exit
import System.FilePath ( (</>) )
import qualified System.Process as Process
main :: IO ()
main = do
(src, ns) <- Environment.getArgs >>= \case
[src] -> return (src, "_") -- default to _ ns which is special
[src, ns] -> return (src, Text.pack ns)
_ -> Exit.die "usage: que-website <srcdir> [namespace]"
mKey <- getKey ns
putText $ "serving " <> Text.pack src <> " at " <> ns
run mKey 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"
, fontLink = src </> "font.html"
}
getKey :: Namespace -> IO (Maybe Key)
getKey ns = do
home <- Directory.getHomeDirectory
let file = home </> ".config" </> "que.conf"
exists <- (Directory.doesFileExist file)
unless exists <| panic <| "not found: " <> Text.pack file
conf <- Text.readFile file
print (home </> ".config" </> "que.conf")
auth ns
|> Config.parseIniFile conf
|> either errorParsingConf identity
|> return
errorParsingConf :: error
errorParsingConf = panic "could not parse ~/.config/que.conf"
data Sources = Sources
{ index :: FilePath
, quescripts :: FilePath
, client :: FilePath
, style :: FilePath
, tutorial :: FilePath
, apidocs :: FilePath
, fontLink :: FilePath
}
type Namespace = Text
type Key = Text
auth :: Namespace -> Config.IniParser (Maybe Key)
auth "pub" = pure Nothing
auth ns = Config.sectionMb ns <| Config.field "key"
run :: Maybe Key -> Text -> Sources -> IO ()
run key ns Sources {..} = Async.runConcurrently actions >> return ()
where
actions = traverse
Async.Concurrently
[ forever <| toHtml index >>= serve key ns "index"
, forever <| toHtml quescripts >>= serve key ns "quescripts"
, forever <| BS.readFile client >>= serve key ns "client"
, forever <| toHtml tutorial >>= serve key ns "tutorial"
, forever <| toHtml apidocs >>= serve key ns "apidocs"
]
toHtml :: FilePath -> IO ByteString
toHtml md =
BS.pack
<$> Process.readProcess
"pandoc"
[ "--include-in-header"
, fontLink
, "--include-in-header"
, style
, "-i"
, md
, "--from"
, "markdown"
, "--to"
, "html"
]
[]
serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO ()
serve Nothing "pub" path content = runReq defaultHttpConfig $ do
_ <- req POST
(http "que.run" /: "pub" /: path)
(ReqBodyBs content)
ignoreResponse
mempty
liftIO $ return ()
serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p
serve (Just key) ns path content = runReq defaultHttpConfig $ do
let options =
header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound
_ <- req POST
(http "que.run" /: ns /: path)
(ReqBodyBs content)
ignoreResponse
options
liftIO $ return ()
|
