diff options
Diffstat (limited to 'app/Main.hs')
-rw-r--r-- | app/Main.hs | 132 |
1 files changed, 0 insertions, 132 deletions
diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index fce12b4..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,132 +0,0 @@ -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 |