From f59cd4349c974c8ab7907b4852f5dc86ce4daeed Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Sat, 12 Oct 2024 16:29:05 +0200
Subject: add doc tests
---
backend/app/Main.hs | 65 +++++++++++++++++---------
backend/lib/ACMS/API/REST/Collection.hs | 3 +-
cli/app/Main.hs | 9 ++--
cli/cli.cabal | 2 +-
default.nix | 26 ++---------
docs/get-started-cli.md | 23 +++++----
frontend/app/Page/EditValue.hs | 2 +-
pkgs/default.nix | 17 +++++++
tests.nix | 83 +++++++++++++++++++++++++++++++++
9 files changed, 169 insertions(+), 61 deletions(-)
create mode 100644 pkgs/default.nix
create mode 100644 tests.nix
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;
+}
--
cgit v1.2.3