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
|
module Main where
import AutoTypes qualified as U
import AutoTypes.Unify qualified as U
import Control.Applicative ((<**>))
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 (..))
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 System.Directory (setCurrentDirectory)
import System.FilePath
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
main :: IO ()
main = do
setCurrentDirectory "./blog"
let root = "."
ref = "HEAD"
repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root}
repo <- 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
let showCommit c = G.commitLog c
fmap Repo . forM cs $ \c -> do
let cid = G.commitOid c
let tid = G.commitTree c
t <- G.lookupTree tid
fs <-
filter ((== ".json") . takeExtension)
. map B.toString
. map fst
<$> G.listTreeEntries t
let cls = M.toList (M.unionsWith (++) (map (\f -> M.singleton (takeDirectory f) [f]) fs))
colls <- forM cls $ \(path, (file : files)) -> do
schema <-
fmap (fromAutoTypes path) . liftIO $ -- TODO read from HEAD
U.autoTypes file files
pure $ Collection path files schema
pure (Commit cid colls)
A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
Args {cmd = Serve} -> do
W.runEnv 8080 $ \req respond -> do
case P.parseOnly routeP (W.rawPathInfo req) of
Right (SchemaJson path) -> do
let [c] = filter ((== path) . (.path)) (head repo.commits).collections
respond $ W.responseLBS W.status200 [] (J.encode c.schema)
(Debug.Trace.traceShowId -> !_) ->
respond $ W.responseLBS W.status200 [] "OK"
data Route
= SchemaJson String
deriving (Show)
routeP :: P.Parser Route
routeP =
( SchemaJson
<$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json"))
)
<* P.endOfInput
|
