143 lines
4.1 KiB
Haskell
143 lines
4.1 KiB
Haskell
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 Store qualified as Q
|
|
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 8081 $ \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)
|
|
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
|