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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
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.Map.Merge.Strict qualified as M
import Data.Maybe
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 Safe
import Store qualified as Q
import System.Directory (setCurrentDirectory)
import System.FilePath
import System.INotify
import Text.Printf (printf)
import Version
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],
schemaVersion :: Version
}
deriving (Show)
data Collection = Collection
{ path :: FilePath,
files :: [FilePath],
schema :: U.T
}
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
toProperty k (U.Option (Just (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 . reverse) $
foldM
( \cs c -> do
let cid = G.commitOid c
fs <-
fmap (filter ((== ".json") . takeExtension)) . liftIO $
Q.withStore root ref do
Q.withCommit cid (Q.listFiles "/")
let cls =
M.toList . M.unionsWith (++) $
map (\f -> M.singleton (takeDirectory f) [f]) fs
colls <- forM cls $ \(path, files) -> do
(value : values) <- do
liftIO . Q.withStore root ref . Q.withCommit cid $ do
Q.query (fromString ("SELECT " <> path <> " FROM " <> path))
let schema = U.autoTypes' value values
pure $ Collection path files schema
let schemaVersion =
case headMay cs of
Nothing -> Version 1 0 0
Just c' ->
let Version major' minor' patch' = c'.schemaVersion
schemas' =
M.fromList
( (\coll -> (coll.path, coll.schema))
<$> c'.collections
)
schemas =
M.fromList
( (\coll -> (coll.path, coll.schema))
<$> c.collections
)
in case compareSchemas schemas' schemas of
Just Major -> Version (major' + 1) 0 0
Just Minor -> Version major' (minor' + 1) 0
Just Patch -> Version major' minor' (patch' + 1)
Nothing -> Version major' minor' patch'
c = Commit cid colls schemaVersion
pure (c : cs)
)
[]
cs
compareSchemas ::
M.Map String U.T ->
M.Map String U.T ->
Maybe SchemaDifference
compareSchemas schemas' schemas =
maximumMay
. catMaybes
. M.elems
. M.map (uncurry compareSchemas')
$ M.merge
(M.mapMissing (\_ schema' -> (Just schema', Nothing)))
(M.mapMissing (\_ schema -> (Nothing, Just schema)))
(M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema)))
schemas'
schemas
where
compareSchemas' Nothing Nothing = Nothing
compareSchemas' Nothing (Just _) = Just Minor
compareSchemas' (Just _) Nothing = Just Major
compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema
compareSchema :: U.T -> U.T -> Maybe SchemaDifference
compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts
compareSchema t' t
| t' == t = Nothing
| t' `elem` (U.unify1 t' t) = Just Patch
| t `elem` U.unify1 t' t = Just Minor
| otherwise = Just Major
data SchemaDifference
= Major
| Minor
| Patch
deriving (Show, Eq, Ord)
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 (fromAutoTypes path c.schema)
Right Query -> do
q <-
fromString @Q.Query . LB.toString
<$> W.lazyRequestBody req
r <- liftIO $ Q.withStore root ref do Q.query q
respond . W.responseLBS W.status200 [] $ J.encode r
Right SchemaVersion -> do
repo <- atomically (readTMVar repoT)
respond $
W.responseLBS W.status200 [] $
J.encode (last repo.commits).schemaVersion
Right ListCollections -> do
repo <- atomically (readTMVar repoT)
respond $
W.responseLBS W.status200 [] $
J.encode (map (.path) (last repo.commits).collections)
(traceShowId -> !_) ->
respond $ W.responseLBS W.status200 [] "not implemented"
data Route
= SchemaJson String
| Query
| SchemaVersion
| ListCollections
deriving (Show)
routeP :: P.Parser Route
routeP =
( P.choice
[ pure ListCollections <* P.string "/collections",
pure SchemaVersion <* P.string "/schemaVersion",
SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
pure Query <* P.string "/"
]
)
<* P.endOfInput
|
