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
159
160
161
162
163
164
165
166
|
module Main where
import AutoTypes qualified as U
import AutoTypes.Unify qualified as U
import Control.Applicative ((<**>))
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Aeson qualified as J
import Data.Attoparsec.Char8 as P
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as LB
import Data.ByteString.Lazy.UTF8 qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.List
import Data.Map qualified as M
import Data.String (IsString (fromString))
import Data.Tagged (Tagged (..), untag)
import Debug.Trace
import Git qualified as G
import Git.Libgit2 qualified as GB
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.Directory (setCurrentDirectory)
import System.FilePath
import System.INotify
import Text.Printf (printf)
data Args = Args
{ cmd :: Cmd
}
args :: A.Parser Args
args = Args <$> cmd'
data Cmd = Serve
cmd' :: A.Parser Cmd
cmd' =
A.hsubparser . mconcat $
[ A.command "serve" . A.info serveCmd $
A.progDesc "Run webserver"
]
serveCmd :: A.Parser Cmd
serveCmd = pure Serve
data Repo = Repo
{ commits :: [Commit]
}
deriving (Show)
data Commit = Commit
{ id :: G.CommitOid GB.LgRepo,
collections :: [Collection]
}
deriving (Show)
data Collection = Collection
{ path :: FilePath,
files :: [FilePath],
schema :: Schema
}
deriving (Show)
data Schema = Schema {unSchema :: J.Value}
deriving (Show)
instance J.ToJSON Schema where
toJSON = J.toJSON . (.unSchema)
fromAutoTypes :: String -> U.T -> Schema
fromAutoTypes path (U.Object ps) =
Schema $
J.object
[ ("$schema", J.toJSON @String "https://json-schema.org/draft/2020-12/schema"),
("$id", J.toJSON @String (path <> ".schema.json")),
("title", J.toJSON @String path),
("type", J.toJSON @String "object"),
("properties", J.toJSON (M.mapWithKey toProperty ps))
]
where
toProperty k (U.Scalar "string") = "string" :: String
watch :: TMVar Repo -> FilePath -> G.RefName -> IO ()
watch repoT root ref = do
i <- initINotify
qT <- newTQueueIO
wd <-
addWatch i [MoveIn] ".git/refs/heads" $ \e ->
atomically (writeTQueue qT e)
forever do
repo <- initRepo root ref
atomically do putTMVar repoT repo
_ <- atomically do
let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT
readTQueue qT >> loop
_ <- atomically do takeTMVar repoT
pure ()
initRepo :: FilePath -> G.RefName -> IO Repo
initRepo root ref = do
repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root}
G.runRepository GB.lgFactory repo do
Just cid <- fmap Tagged <$> G.resolveReference ref
c <- G.lookupCommit cid
cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid
fmap Repo . forM cs $ \c -> do
let cid = G.commitOid c
fs <-
fmap (filter ((== ".json") . takeExtension)) . liftIO $
Q.withStore root ref do
Q.withCommit cid Q.listAllFiles
let cls =
M.toList . M.unionsWith (++) $
map (\f -> M.singleton (takeDirectory f) [f]) fs
colls <- forM cls $ \(makeRelative "/" -> path, (file : files)) -> do
(value : values) <- do
liftIO $ Q.withStore root ref do
mapM (Q.withCommit cid . Q.readFile) (file : files)
let schema = fromAutoTypes path $ U.autoTypes' value values
pure $ Collection path files schema
pure (Commit cid colls)
main :: IO ()
main = do
setCurrentDirectory "../blog"
let root = "."
ref = "refs/heads/master"
repoT <- newEmptyTMVarIO
_ <- forkIO do watch repoT root ref
A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
Args {cmd = Serve} -> do
W.runEnv 8081 $ \req respond -> do
case P.parseOnly routeP (W.rawPathInfo req) of
Right (SchemaJson path) -> do
repo <- atomically (readTMVar repoT)
let [c] = filter ((== path) . (.path)) (last repo.commits).collections
respond $ W.responseLBS W.status200 [] (J.encode c.schema)
Right Query -> 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
(Debug.Trace.traceShowId -> !_) ->
respond $ W.responseLBS W.status200 [] "not implemented"
data Route
= SchemaJson String
| Query
deriving (Show)
routeP :: P.Parser Route
routeP =
( P.choice
[ SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
pure Query <* (P.string "/")
]
)
<* P.endOfInput
|
