add doc tests

2 files changed, 45 insertions, 23 deletions

diff --git a/backend/app/Main.hs b/backend/app/Main.hs
index ec98a9a..eac9701 100644
--- a/backend/app/Main.hs
+++ b/backend/app/Main.hs
@@ -21,12 +21,13 @@ import Data.Attoparsec.Char8 qualified as P
 import Data.ByteString.Char8 qualified as B
 import Data.ByteString.Lazy.UTF8 qualified as LB
 import Data.ByteString.UTF8 qualified as B
+import Data.Function (on, (&))
 import Data.List (find)
 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 (..))
+import Data.Tagged (Tagged (..), untag)
 import Data.Text qualified as T
 import Data.UUID qualified as U
 import Data.UUID.V4 qualified as U
@@ -90,6 +91,9 @@ data Commit = Commit
   }
   deriving (Show)
 
+sameCommit :: Commit -> Commit -> Bool
+sameCommit = (==) `on` (G.renderOid . untag . (.id))
+
 data Collection = Collection
   { path :: FilePath,
     files :: [FilePath],
@@ -242,18 +246,29 @@ main = do
 
       logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
 
-      W.runEnv serverPort . restApi root ref repoT $
-        ( \req resp -> do
-            case P.parseOnly R.parser (W.rawPathInfo req) of
-              Right R.Query -> do
-                q <-
-                  fromString @Q.Query . LB.toString
-                    <$> W.lazyRequestBody req
-                r <- liftIO $ Q.withStore root ref do Q.query q
-                resp . W.responseLBS W.status200 [] $ J.encode r
-              (traceShowId -> !_) ->
-                resp $ W.responseLBS W.status200 [] "not implemented"
+      stopM <- newEmptyMVar
+      mapM_
+        ( \hostPref -> flip forkFinally (either throwIO (putMVar stopM)) do
+            W.runSettings
+              ( W.defaultSettings
+                  & W.setPort serverPort
+                  & W.setHost hostPref
+              )
+              . restApi root ref repoT
+              $ ( \req resp -> do
+                    case P.parseOnly R.parser (W.rawPathInfo req) of
+                      Right R.Query -> do
+                        q <-
+                          fromString @Q.Query . LB.toString
+                            <$> W.lazyRequestBody req
+                        r <- liftIO $ Q.withStore root ref do Q.query q
+                        resp . W.responseLBS W.status200 [] $ J.encode r
+                      (traceShowId -> !_) ->
+                        resp $ W.responseLBS W.status200 [] "not implemented"
+                )
         )
+        ["!4", "::1"] -- XXX note !6 does not work..
+      takeMVar stopM
 
 data InvalidSchemaVersion = InvalidSchemaVersion String
   deriving (Show)
@@ -271,24 +286,26 @@ restApi root ref repoT app req resp = do
           Just v -> pure (Just v)
           Nothing -> throwIO (InvalidSchemaVersion v)
   repo <- atomically (readTMVar repoT)
-  let lastCommit = lastCompatible schemaVersion repo.commits
-      rev = lastCommit.id
+  let lastCompatibleCommit = lastCompatible schemaVersion repo.commits
+      rev = lastCompatibleCommit.id
+      lastCommit = last repo.commits
   case drop 1 (B.split '/' (W.rawPathInfo req)) of
     ("api" : "rest" : rs) ->
       case (W.requestMethod req, rs) of
         ("GET", ["schemaVersion"]) -> do
           resp . W.responseLBS W.status200 [] $
-            J.encode lastCommit.schemaVersion
+            J.encode lastCompatibleCommit.schemaVersion
         ("GET", ["collection"]) -> do
           resp . W.responseLBS W.status200 [] $
-            J.encode (map (.path) lastCommit.collections)
+            J.encode (map (.path) lastCompatibleCommit.collections)
         ("GET", ["collection", B.toString -> c, "schema"]) -> do
-          let [collection] = filter ((== c) . (.path)) lastCommit.collections
+          let [collection] = filter ((== c) . (.path)) lastCompatibleCommit.collections
           resp . W.responseLBS W.status200 [] $
             J.encode (fromAutoTypes c collection.schema)
         ("POST", ["collection"]) -> do
+          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
           Right collection <- J.eitherDecode <$> W.lazyRequestBody req
-          Q.withStore root ref $ Q.withCommit rev do
+          Q.withStore root ref do
             Q.writeFile (collection </> ".gitkeep") ""
             Q.commit
           resp $ W.responseLBS W.status200 [] "{}"
@@ -303,21 +320,25 @@ restApi root ref repoT app req resp = do
                     Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                 )
         ("PUT", ["collection", B.toString -> c, B.toString -> i]) -> do
+          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
           o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
           resp . W.responseLBS W.status200 [] . J.encode
-            =<< ( Q.withStore root ref $ Q.withCommit rev do
+            =<< ( Q.withStore root ref do
                     Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i))
                 )
         ("POST", ["collection", B.toString -> c]) -> do
+          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
           i <- ((<> ".json") . U.toText) <$> getUUID
           o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
           resp . W.responseLBS W.status200 [] . J.encode
-            =<< ( Q.withStore root ref $ Q.withCommit rev do
+            =<< ( Q.withStore root ref do
                     Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c))
+                    headMay <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                 )
         ("DELETE", ["collection", B.toString -> c, B.toString -> i]) -> do
+          when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
           resp . W.responseLBS W.status200 [] . J.encode
-            =<< ( Q.withStore root ref $ Q.withCommit rev do
+            =<< ( Q.withStore root ref do
                     Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
                 )
         (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported."
@@ -330,4 +351,4 @@ lastCompatible (Just v) commits
   | otherwise = lastCompatible (Just v) (init commits)
 
 isCompatible :: Version -> Commit -> Bool
-isCompatible v c = c.schemaVersion <= traceShowId v
+isCompatible v c = c.schemaVersion <= v
diff --git a/backend/lib/ACMS/API/REST/Collection.hs b/backend/lib/ACMS/API/REST/Collection.hs
index 9f7cafa..7be3269 100644
--- a/backend/lib/ACMS/API/REST/Collection.hs
+++ b/backend/lib/ACMS/API/REST/Collection.hs
@@ -16,6 +16,7 @@ import Data.Aeson qualified as A
 import Data.Function ((&))
 import Miso.String (MisoString)
 import Text.Printf (printf)
+import Debug.Trace
 
 list :: (APIMonad m) => MisoString -> m [A.Object]
 list c =
@@ -29,7 +30,7 @@ read c i =
     & fetch
     >>= A.throwDecode
 
-update :: (APIMonad m) => MisoString -> MisoString -> A.Object -> m ()
+update :: (APIMonad m) => MisoString -> MisoString -> A.Object -> m A.Object
 update c i o =
   restRequest (printf "/collection/%s/%s" c i)
     & setRequestMethod "PUT"