diff options
Diffstat (limited to 'backend/app')
| -rw-r--r-- | backend/app/Main.hs | 64 |
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 <- |