diff options
| -rw-r--r-- | backend/app/Main.hs | 64 | ||||
| -rw-r--r-- | backend/backend.cabal | 2 | ||||
| -rw-r--r-- | nix/sources.json | 2 |
3 files changed, 47 insertions, 21 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 82d2d38..6773916 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -3,6 +3,8 @@ module Main where import AutoTypes qualified as U import AutoTypes.Unify qualified as U import Control.Applicative ((<**>)) +import Control.Concurrent +import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans (liftIO) import Data.Aeson qualified as J @@ -14,7 +16,7 @@ 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 Data.Tagged (Tagged (..), untag) import Debug.Trace import Git qualified as G import Git.Libgit2 qualified as GB @@ -26,6 +28,7 @@ import Options.Applicative qualified as A import Store qualified as Q import System.Directory (setCurrentDirectory) import System.FilePath +import System.INotify import Text.Printf (printf) data Args = Args @@ -84,39 +87,60 @@ fromAutoTypes path (U.Object ps) = where toProperty k (U.Scalar "string") = "string" :: String -main :: IO () -main = do - setCurrentDirectory "./blog" - let root = "." - ref = "HEAD" +watch :: TMVar Repo -> FilePath -> G.RefName -> IO () +watch repoT root ref = do + i <- initINotify + qT <- newTQueueIO + wd <- + addWatch i [MoveIn] ".git/refs/heads" $ \e -> + atomically (writeTQueue qT e) + forever do + repo <- initRepo root ref + atomically do putTMVar repoT repo + _ <- atomically do + let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT + readTQueue qT >> loop + _ <- atomically do takeTMVar repoT + pure () + +initRepo :: FilePath -> G.RefName -> IO Repo +initRepo root ref = do repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root} - repo <- G.runRepository GB.lgFactory repo do + 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 + fmap (filter ((== ".json") . takeExtension)) . liftIO $ + Q.withStore root ref do + Q.withCommit cid Q.listAllFiles + let cls = + M.toList . M.unionsWith (++) $ + map (\f -> M.singleton (takeDirectory f) [f]) fs + colls <- forM cls $ \(makeRelative "/" -> path, (file : files)) -> do + (value : values) <- do + liftIO $ Q.withStore root ref do + mapM (Q.withCommit cid . Q.readFile) (file : files) + let schema = fromAutoTypes path $ U.autoTypes' value values pure $ Collection path files schema pure (Commit cid colls) + +main :: IO () +main = do + setCurrentDirectory "../blog" + let root = "." + ref = "refs/heads/master" + repoT <- newEmptyTMVarIO + _ <- forkIO do watch repoT root ref 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 + repo <- atomically (readTMVar repoT) + let [c] = filter ((== path) . (.path)) (last repo.commits).collections respond $ W.responseLBS W.status200 [] (J.encode c.schema) Right Query -> do q <- diff --git a/backend/backend.cabal b/backend/backend.cabal index 1e3e3ed..be7099a 100644 --- a/backend/backend.cabal +++ b/backend/backend.cabal @@ -28,10 +28,12 @@ executable backend filepath, gitlib, gitlib-libgit2, + hinotify, hlibgit2, http-types, mtl, optparse-applicative, + stm, tagged, utf8-string, wai, diff --git a/nix/sources.json b/nix/sources.json index 41fbb44..cd609dd 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -2,7 +2,7 @@ "json2sql": { "branch": "main", "repo": "git@code.nomath.org:~/json2sql", - "rev": "04b43e75fb0822de7db67f108c3545dee451069c", + "rev": "d8b2af98f594e4fc5cc4919c1efe95e1d8d9aafe", "type": "git" }, "nixpkgs": { |