add collections

backend/app/Main.hs

@@ -9,30 +9,26 @@ 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.Map.Merge.Strict qualified as M
 import Data.Maybe
 import Data.String (IsString (fromString))
-import Data.Tagged (Tagged (..), untag)
+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
 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 Route qualified as R
 import Safe
 import Store qualified as Q
 import System.Directory (setCurrentDirectory)
 import System.FilePath
 import System.INotify
-import Text.Printf (printf)
 import Version
 
 data Args = Args
@@ -87,17 +83,17 @@ fromAutoTypes path (U.Object ps) =
         ("$id", J.toJSON @String (path <> ".schema.json")),
         ("title", J.toJSON @String path),
         ("type", J.toJSON @String "object"),
-        ("properties", J.toJSON (M.mapWithKey toProperty ps))
+        ("properties", J.toJSON (M.map toProperty ps))
       ]
   where
-    toProperty k (U.Scalar "string") = "string" :: String
-    toProperty k (U.Option (Just (U.Scalar "string"))) = "string?" :: String
+    toProperty (U.Scalar "string") = "string" :: String
+    toProperty (U.Option (Just (U.Scalar "string"))) = "string?" :: String
 
 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
@@ -114,16 +110,13 @@ initRepo root ref = do
   repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root}
   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
     fmap (Repo . reverse) $
       foldM
         ( \cs c -> do
             let cid = G.commitOid c
-            fs <-
-              fmap (filter ((== ".json") . takeExtension)) . liftIO $
-                Q.withStore root ref do
-                  Q.withCommit cid (Q.listFiles "/")
+            fs <- liftIO $ Q.withStore root ref do
+              Q.withCommit cid (Q.listFiles "/")
             let cls =
                   M.toList . M.unionsWith (++) $
                     map (\f -> M.singleton (takeDirectory f) [f]) fs
@@ -204,45 +197,35 @@ main = do
   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
+        case P.parseOnly R.parser (W.rawPathInfo req) of
+          Right (R.SchemaJson path) -> do
             repo <- atomically (readTMVar repoT)
             let [c] = filter ((== path) . (.path)) (last repo.commits).collections
             respond . W.responseLBS W.status200 [] $
               J.encode (fromAutoTypes path c.schema)
-          Right Query -> do
+          Right R.Query -> do
             q <-
               fromString @Q.Query . LB.toString
                 <$> W.lazyRequestBody req
             r <- liftIO $ Q.withStore root ref do Q.query q
             respond . W.responseLBS W.status200 [] $ J.encode r
-          Right SchemaVersion -> do
+          Right R.SchemaVersion -> do
             repo <- atomically (readTMVar repoT)
             respond $
               W.responseLBS W.status200 [] $
                 J.encode (last repo.commits).schemaVersion
-          Right ListCollections -> do
-            repo <- atomically (readTMVar repoT)
-            respond $
-              W.responseLBS W.status200 [] $
-                J.encode (map (.path) (last repo.commits).collections)
+          Right R.Collections -> do
+            if
+              | W.requestMethod req == "POST" -> do
+                  Right collection <- J.eitherDecode <$> W.lazyRequestBody req
+                  Q.withStore root ref do
+                    Q.writeFile (collection </> ".gitkeep") ""
+                    Q.commit
+                  respond $ W.responseLBS W.status200 [] "{}"
+              | W.requestMethod req == "GET" -> do
+                  repo <- atomically (readTMVar repoT)
+                  respond $
+                    W.responseLBS W.status200 [] $
+                      J.encode (map (.path) (last repo.commits).collections)
           (traceShowId -> !_) ->
             respond $ W.responseLBS W.status200 [] "not implemented"
-
-data Route
-  = SchemaJson String
-  | Query
-  | SchemaVersion
-  | ListCollections
-  deriving (Show)
-
-routeP :: P.Parser Route
-routeP =
-  ( P.choice
-      [ pure ListCollections <* P.string "/collections",
-        pure SchemaVersion <* P.string "/schemaVersion",
-        SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
-        pure Query <* P.string "/"
-      ]
-  )
-    <* P.endOfInput