blob: 3b7f59d116f8aaadc06069872b7754442cc60605 (
plain)
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
|
{-# LANGUAGE LambdaCase #-}
module Main
( main,
)
where
import Control.Applicative ((<**>))
import Control.Monad.Trans (liftIO)
import Data.Aeson qualified as J
import Data.ByteString.Lazy.Char8 qualified as LB
import Data.ByteString.Lazy.UTF8 qualified as LB
import Data.String (IsString (fromString))
import Data.Vector qualified as V
import Network.HTTP.Types.Method qualified as W
import Network.HTTP.Types.Status qualified as W
import Network.Wai qualified as W
import Network.Wai.Handler.Warp qualified as W
import Options.Applicative qualified as A
import Store qualified as Q
import System.Console.Repline qualified as R
import System.Directory (setCurrentDirectory)
import Text.Printf (printf)
data Args = Args
{ cmd :: Cmd
}
args :: A.Parser Args
args =
Args <$> cmd_
data Cmd
= Repl
| Serve
cmd_ :: A.Parser Cmd
cmd_ =
A.hsubparser . mconcat $
[ A.command "repl" . A.info replCmd $
A.progDesc "Interactively execute statements",
A.command "serve" . A.info serveCmd $
A.progDesc "Run webserver"
]
replCmd, serveCmd :: A.Parser Cmd
replCmd =
pure Repl
serveCmd =
pure Serve
main :: IO ()
main = do
setCurrentDirectory "./data"
let root = "."
ref = "HEAD"
A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
Args {cmd = Repl} -> do
-- TODO Catch `ParseError` exception
--
-- @topic repl
-- TODO Add query auto-completion
--
-- @topic repl
R.evalRepl
(const . pure $ ">>> ")
( liftIO
. ( ( \case
J.Array xs -> mapM_ (LB.putStrLn . J.encode) (V.toList xs)
x -> LB.putStrLn (J.encode x)
)
=<<
)
. Q.withStore root ref
. Q.query
. fromString
)
([])
(Just ':')
(Just "paste")
(R.Word (\_ -> pure ["SELECT"]))
(pure ())
(pure R.Exit)
Args {cmd = Serve} -> do
W.runEnv 8080 $ \req respond -> do
if
| W.requestMethod req == W.methodPost -> do
q <-
fromString @Q.Query . LB.toString
<$> W.lazyRequestBody req
r <- liftIO $ Q.withStore root ref (Q.query q)
respond . W.responseLBS W.status200 [] $
J.encode r
| otherwise ->
respond $ W.responseLBS W.status200 [] "OK"
|
