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

backend/app/Route.hs

@@ -0,0 +1,21 @@
+module Route (Route (..), parser) where
+
+import Data.Attoparsec.Char8 qualified as P
+
+data Route
+  = SchemaJson String
+  | Query
+  | SchemaVersion
+  | Collections
+  deriving (Show)
+
+parser :: P.Parser Route
+parser =
+  ( P.choice
+      [ pure Collections <* 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

backend/backend.cabal

@@ -10,10 +10,11 @@ build-type:    Simple
 executable backend
     main-is:            Main.hs
     hs-source-dirs:     app
+    other-modules:      Route
     default-language:   GHC2021
     default-extensions:
         BlockArguments LambdaCase OverloadedStrings ViewPatterns
-        OverloadedRecordDot NoFieldSelectors
+        OverloadedRecordDot NoFieldSelectors MultiWayIf
 
     ghc-options:        -Wall -threaded
     build-depends:

frontend/app/Api.hs

@@ -2,6 +2,7 @@
 
 module Api
   ( fetchCollections,
+    createCollection,
     fetchSchema,
     fetchSchemaVersion,
     fetchPosts,
@@ -33,6 +34,15 @@ fetchCollections :: JSM (Either String [String])
 fetchCollections =
   A.eitherDecode <$> fetch (fromString "http://localhost:8081/collections")
 
+createCollection :: String -> JSM (Either String ())
+createCollection collection =
+  A.eitherDecode
+    <$> fetch
+      ( fromString "http://localhost:8081/collections"
+          & setRequestMethod "POST"
+          & setRequestBodyLBS (A.encode (A.toJSON collection))
+      )
+
 fetchSchemaVersion :: JSM (Either String Version)
 fetchSchemaVersion =
   A.eitherDecode <$> fetch (fromString "http://localhost:8081/schemaVersion")

frontend/app/Page/NewCollection.hs

@@ -7,9 +7,12 @@ module Page.NewCollection
   )
 where
 
+import Api
+import Data.Aeson qualified as A
 import Data.Text qualified as T
 import Form qualified as F
 import Miso
+import Miso.String (toMisoString)
 
 data Model = Model
   { input :: T.Text
@@ -24,19 +27,29 @@ data Action
   = NoOp
   | FormChanged T.Text
   | FormSubmitted T.Text
+  | CollectionCreated (Either String ())
   deriving (Eq, Show)
 
 updateModel :: Action -> Model -> Effect Action Model
 updateModel NoOp m = noEff m
 updateModel (FormChanged input) m = noEff m {input}
-updateModel (FormSubmitted _) m = noEff m
+updateModel (FormSubmitted collection) m =
+  m <# do
+    CollectionCreated <$> createCollection (T.unpack collection)
+updateModel (CollectionCreated (Left err)) m =
+  m <# do
+    pure NoOp <* consoleLog (toMisoString err)
+-- TODO reload collections in main app
+updateModel (CollectionCreated (Right _)) m = noEff m
 
 viewModel :: Model -> View Action
 viewModel m = do
   div_ [] $
     [ h3_ [] [text "new collection"],
       either FormChanged FormSubmitted
-        <$> F.runForm collectionForm m.input
+        <$> F.runForm collectionForm m.input,
+      pre_ [] [text (toMisoString (A.encode m.input))],
+      pre_ [] [text (toMisoString (A.encode (collectionForm.fill m.input)))]
     ]
 
 collectionForm :: F.Form T.Text T.Text