add frontend (boilerplate)

backend/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2024, Alexander Foremny
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Alexander Foremny nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

backend/app/Main.hs

@@ -0,0 +1,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 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)
+          (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

backend/backend.cabal

@@ -0,0 +1,38 @@
+cabal-version: 3.4
+name:          backend
+version:       0.1.0.0
+license:       BSD-3-Clause
+license-file:  LICENSE
+maintainer:    aforemny@posteo.de
+author:        Alexander Foremny
+build-type:    Simple
+
+executable backend
+    main-is:            Main.hs
+    hs-source-dirs:     app
+    default-language:   GHC2021
+    default-extensions:
+        BlockArguments LambdaCase OverloadedStrings ViewPatterns
+        OverloadedRecordDot NoFieldSelectors
+
+    ghc-options:        -Wall -threaded
+    build-depends:
+        aeson,
+        astore,
+        attoparsec,
+        autotypes,
+        base,
+        bytestring,
+        containers,
+        directory,
+        filepath,
+        gitlib,
+        gitlib-libgit2,
+        hlibgit2,
+        http-types,
+        mtl,
+        optparse-applicative,
+        tagged,
+        utf8-string,
+        wai,
+        warp