diff options
Diffstat (limited to 'backend')
| -rw-r--r-- | backend/LICENSE | 30 | ||||
| -rw-r--r-- | backend/app/Main.hs | 132 | ||||
| -rw-r--r-- | backend/backend.cabal | 38 |
3 files changed, 200 insertions, 0 deletions
diff --git a/backend/LICENSE b/backend/LICENSE new file mode 100644 index 0000000..c90516a --- /dev/null +++ b/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. diff --git a/backend/app/Main.hs b/backend/app/Main.hs new file mode 100644 index 0000000..e75ce99 --- /dev/null +++ b/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 diff --git a/backend/backend.cabal b/backend/backend.cabal new file mode 100644 index 0000000..1e3e3ed --- /dev/null +++ b/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 |