support following HEAD

1 files changed, 44 insertions, 20 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 <-