add doc tests

9 files changed, 169 insertions, 61 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"
diff --git a/cli/app/Main.hs b/cli/app/Main.hs
index eaabd0a..ef7a8ad 100644
--- a/cli/app/Main.hs
+++ b/cli/app/Main.hs
@@ -18,6 +18,7 @@ import Options.Applicative qualified as O
 import Text.ParserCombinators.ReadP qualified as R
 import Text.ParserCombinators.ReadPrec qualified as R
 import Text.Read (Read (..))
+import Debug.Trace
 
 data Args = Args
   { cmd :: Cmd
@@ -96,18 +97,18 @@ main =
       { cmd = CollectionCmd cmd
       } -> case cmd of
         CollectionAdd (Collection cn) -> do
-          print
+          LB.putStr . J.encodePretty
             =<< ACMS.API.REST.Collection.create cn
             =<< J.throwDecode
             =<< LB.getContents
         CollectionView CollectionItem {collection = Collection cn, itemFileName} ->
-          print
+          LB.putStr . J.encodePretty
             =<< ACMS.API.REST.Collection.read cn itemFileName
         CollectionDelete CollectionItem {collection = Collection cn, itemFileName} ->
-          print
+          LB.putStr . J.encodePretty
             =<< ACMS.API.REST.Collection.delete cn itemFileName
         CollectionEdit CollectionItem {collection = Collection cn, itemFileName} ->
-          print
+          LB.putStr . J.encodePretty
             =<< ACMS.API.REST.Collection.update cn itemFileName
             =<< J.throwDecode
             =<< LB.getContents
diff --git a/cli/cli.cabal b/cli/cli.cabal
index bb98d8b..4a21270 100644
--- a/cli/cli.cabal
+++ b/cli/cli.cabal
@@ -8,7 +8,7 @@ author:          Alexander Foremny
 build-type:      Simple
 extra-doc-files: CHANGELOG.md
 
-executable cli
+executable acms
     main-is:          Main.hs
     hs-source-dirs:   app
     other-modules:
diff --git a/default.nix b/default.nix
index eacf111..5fa2da4 100644
--- a/default.nix
+++ b/default.nix
@@ -1,30 +1,12 @@
-{ pkgs ? import sources.nixpkgs { }
+{ pkgs ? import sources.nixpkgs { overlays = [ (import ./pkgs { }) ]; }
 , sources ? import ./nix/sources.nix
 }:
 let
-  haskellPackages = pkgs.haskell.packages.ghc98.override {
-    overrides = self: super: {
-      astore = self.callCabal2nix "astore" sources.json2sql { };
-      autotypes = self.callCabal2nix "autotypes" ./autotypes { };
-      backend = self.callCabal2nix "backend" ./backend { };
-      common = self.callCabal2nix "common" ./common { };
-      frontend = self.callCabal2nix "frontend" ./frontend { };
-      cli = self.callCabal2nix "cli" ./cli { };
-      sh = pkgs.haskell.lib.dontCheck (self.callCabal2nix "sh" sources.sh { });
-      websockets = pkgs.haskell.lib.doJailbreak super.websockets;
-    };
-  };
-
-  jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc98.override {
-    overrides = self: super: {
-      backend = self.callCabal2nix "backend" ./backend { };
-      common = self.callCabal2nix "common" ./common { };
-      frontend = self.callCabal2nix "frontend" ./frontend { };
-    };
-  };
+  haskellPackages = pkgs.haskell.packages.ghc98;
+  jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc98;
 in
 rec {
-  inherit (haskellPackages) backend;
+  inherit (haskellPackages) backend cli;
   inherit (jsHaskellPackages) frontend;
   shell = haskellPackages.shellFor {
     packages = _: [
diff --git a/docs/get-started-cli.md b/docs/get-started-cli.md
index 93806c4..a1ffa4f 100644
--- a/docs/get-started-cli.md
+++ b/docs/get-started-cli.md
@@ -21,13 +21,23 @@ acms collection add restaurant <<'EOF'
 EOF
 ```
 
+Take note of the `$fileName` in the output. Note that it should be different for you.
+
+```json
+{
+    "$fileName": "9474f0eb-06d7-4fd8-b89e-0ce996962508.json",
+    "description": "Welcome to Biscotte restaurant! Restaurant Biscotte offers a cuisine based on fresh, quality products, often local, organic when possible, and always produced by passionate producers.",
+    "name": "Biscotte Restaurant"
+}
+```
+
 ## Create a category collection type
 
 ```console
 acms collection add category <<'EOF'
 {
   "name": "French Food",
-  "restaurant": "1.json"
+  "restaurant": { "$ref": "restaurant/9474f0eb-06d7-4fd8-b89e-0ce996962508.json" }
 }
 EOF
 ```
@@ -36,7 +46,7 @@ EOF
 acms collection add category <<'EOF'
 {
   "name": "Brunch",
-  "restaurant": "1.json"
+  "restaurant": { "$ref": "restaurant/9474f0eb-06d7-4fd8-b89e-0ce996962508.json" }
 }
 EOF
 ```
@@ -66,14 +76,7 @@ curl 'http://localhost:8081' --data '
 [
   {
     "category": {
-      "category": "French Food"
-    },
-    "description": "Welcome to Biscotte restaurant! Restaurant Biscotte offers a cuisine based on fresh, quality products, often local, organic when possible, and always produced by passionate producers.",
-    "name": "Biscotte Restaurant"
-  },
-  {
-    "category": {
-      "category": "Brunch"
+      "category": null
     },
     "description": "Welcome to Biscotte restaurant! Restaurant Biscotte offers a cuisine based on fresh, quality products, often local, organic when possible, and always produced by passionate producers.",
     "name": "Biscotte Restaurant"
diff --git a/frontend/app/Page/EditValue.hs b/frontend/app/Page/EditValue.hs
index 8c91955..feacd4a 100644
--- a/frontend/app/Page/EditValue.hs
+++ b/frontend/app/Page/EditValue.hs
@@ -45,7 +45,7 @@ update__formSubmitted :: A.Object -> Action
 update__formSubmitted output = Action $ \m ->
   (m <# do update__entityWritten <$> try (API.REST.Collection.update m.collection m.fileName output), [])
 
-update__entityWritten :: Either SomeException () -> Action
+update__entityWritten :: Either SomeException A.Object -> Action
 update__entityWritten _ = Action $ \m -> (noEff m, [])
 
 updateModel :: Action -> Model -> (Effect Action Model, [Eff])
diff --git a/pkgs/default.nix b/pkgs/default.nix
new file mode 100644
index 0000000..7dce871
--- /dev/null
+++ b/pkgs/default.nix
@@ -0,0 +1,17 @@
+{ sources ? import ../nix/sources.nix }:
+(self: super:
+  let pkgs = self; in
+  {
+    haskell = super.haskell // {
+      packageOverrides = self: super: {
+        astore = self.callCabal2nix "astore" sources.json2sql { };
+        autotypes = self.callCabal2nix "autotypes" ../autotypes { };
+        backend = self.callCabal2nix "backend" ../backend { };
+        cli = self.callCabal2nix "cli" ../cli { };
+        common = self.callCabal2nix "common" ../common { };
+        frontend = self.callCabal2nix "frontend" ../frontend { };
+        sh = pkgs.haskell.lib.dontCheck (self.callCabal2nix "sh" sources.sh { });
+        websockets = pkgs.haskell.lib.doJailbreak super.websockets;
+      };
+    };
+  })
diff --git a/tests.nix b/tests.nix
new file mode 100644
index 0000000..c7955fb
--- /dev/null
+++ b/tests.nix
@@ -0,0 +1,83 @@
+{ pkgs ? import sources.nixpkgs { overlays = [ (import ./pkgs { }) ]; }
+, sources ? import ./nix/sources.nix
+}:
+let
+  haskellPackages = pkgs.haskell.packages.ghc98;
+  makeDocTest = n: i: (import (sources.nixpkgs + "/nixos/lib") { }).runTest {
+    name = "doc-test-${n}";
+    imports = [{
+      nodes =
+        {
+          machine = { lib, pkgs, nodes, ... }: {
+            environment.systemPackages = [ ];
+            systemd.services.backend.wantedBy = [ "multi-user.target" ];
+            systemd.services.backend.preStart = ''
+              export HOME=$(mktemp -d)
+              ${pkgs.git}/bin/git config --global user.email "you@example.com"
+              ${pkgs.git}/bin/git config --global user.name "Your Name"
+              ${pkgs.git}/bin/git init
+              ${pkgs.git}/bin/git commit -m init --allow-empty
+            '';
+            systemd.services.backend.script = ''
+              UUID_SEED=0 ${haskellPackages.backend}/bin/backend serve .
+            '';
+          };
+        };
+      testScript = ''
+        start_all();
+        machine.wait_for_unit("backend");
+        machine.succeed("${pkgs.bash}/bin/bash ${makeDocTestScript n i}");
+      '';
+
+    }];
+    hostPkgs = pkgs;
+    defaults.networking.firewall.enable = false;
+  };
+  makeDocTestScript = n: i: pkgs.runCommand "doc-test-script-${n}" { } ''
+    set -efu
+    export PATH=${pkgs.lib.makeBinPath [
+      pkgs.coreutils
+      pkgs.glow
+      pkgs.jq
+      pkgs.pandoc
+    ]}
+    (
+      cat <<'EOF'
+    set -efux
+    readonly tmp=$(mktemp -d)
+    trap 'rm -rf "$tmp"' EXIT
+    cd "$tmp"
+    export ACMS_CONTENT=$PWD/content # TODO
+    export PATH=${pkgs.lib.makeBinPath [
+    haskellPackages.cli
+    pkgs.jq
+    ]}''${PATH+:$PATH}
+    EOF
+      cat ${i} | pandoc --to json | jq -c '
+        .blocks | map(select(.t == "CodeBlock") | .c |
+          {
+            t: .[0].[1].[0],
+            v: .[1]
+          }
+        ) | .[]
+      ' | while read -r l; do
+        t=$(echo "$l" | jq -r .t)
+        v=$(echo "$l" | jq -r .v)
+        if test "$t" = console; then
+          cat <<EOF
+    LASTOUT=\$(
+      $v
+      )
+    EOF
+        else
+          cat <<EOF
+    test "\$LASTOUT" = '$v'
+    EOF
+        fi
+      done
+    ) > $out
+  '';
+in
+{
+  get-started-cli = makeDocTest "get-started-cli" ./docs/get-started-cli.md;
+}