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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | spawns a few processes that serve the que.run website
--
-- : out que-website
--
-- : dep async
-- : dep docopt
-- : dep config-ini
-- : dep process
-- : dep protolude
-- : dep req
-- : dep tasty
-- : dep tasty-hunit
module Biz.Que.Site
( main,
)
where
import Alpha
import qualified Biz.Cli as Cli
import Biz.Test ((@=?))
import qualified Biz.Test as Test
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 = Cli.main <| Cli.Plan help move test
move :: Cli.Arguments -> IO ()
move args = do
let (Just src, Just ns) = (getArg "src", Text.pack </ getArg "ns")
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"
}
where
getArg = Cli.getArg args <. Cli.argument
help :: Cli.Docopt
help =
[Cli.docopt|
que-website
Usage:
que-website <src> <ns>
que-website test
|]
test :: Test.Tree
test = Test.group "Biz.Que.Site" [Test.unit "id" <| 1 @=? (1 :: Integer)]
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 |> void
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 ()
|
