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
|
{-# 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 Que.Website
( main
)
where
import Alpha
import qualified Control.Concurrent.Async as Async
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"
}
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
}
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"
, 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 ()
|
