gitsite: remaining Part II gaps — rate limiting, body-bv, shell hardening, test suite
ober
609a4c3aea3720268ba75e20101d41113433572a
--- a/Makefile +++ b/Makefile @@ -56,10 +56,16 @@ binary: build check: build JERBOA_GIT_LIB_PATH="$(JERBOA_GIT_LIB_PATH)" $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/smoke.ss + JERBOA_GIT_LIB_PATH="$(JERBOA_GIT_LIB_PATH)" $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/test-util.ss + JERBOA_GIT_LIB_PATH="$(JERBOA_GIT_LIB_PATH)" $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/test-manifest.ss + JERBOA_GIT_LIB_PATH="$(JERBOA_GIT_LIB_PATH)" $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/test-auth.ss verify: binary check @echo "verify: binary built and checks pass" +test-integration: binary + JERBOA_GIT_LIB_PATH="$(JERBOA_GIT_LIB_PATH)" tests/test-integration.sh + clean: rm -rf $(BUILD_DIR) var dist cd $(JERBOA_GIT) && cargo clean --- a/README.md +++ b/README.md @@ -6,34 +6,27 @@ A minimal SourceHut-style git forge built in Jerboa. - **Git hosting**: Public, unlisted, and private repositories - **Web UI**: Browse repositories, view commits, trees, and blobs -- **Git over HTTPS**: Clone and fetch via HTTP(S) +- **Git over HTTPS**: Clone and fetch via HTTP(S) with per-IP rate limiting - **Git over SSH**: Push via SSH with public key authentication - **CI/CD**: SourceHut-style build manifests with job queue and artifact collection - **Minimal authentication**: Register/login with Argon2id password hashing +- **API token management**: Generate and revoke tokens from `/settings/tokens` +- **Security headers**: CSP, HSTS, X-Content-Type-Options, X-Frame-Options, etc. on every response +- **Session/token garbage collection**: Periodic sweep of expired records ## Quick Start -### Prerequisites - -- Jerboa (>= 0.2.0) -- Git (>= 2.28) -- SQLite3 -- OpenSSH (for SSH push support) -- sendmail or compatible MTA (for build notifications) - -### Build +### Build Static Binary (Production) ```bash -make build +make binary ``` -### Run +Creates `dist/gitsite` — a single static binary with subcommands: +`serve`, `ssh-auth`, `buildd`, `add-user`, `migrate`. -```bash -make run -``` - -The server will start on `http://127.0.0.1:8080` by default. +No Jerboa runtime, no SQLite3 library, no Scheme interpreter required +on the target machine. ### Create First User @@ -41,14 +34,21 @@ The server will start on `http://127.0.0.1:8080` by default. dist/gitsite add-user <username> <email> <password> ``` -### Build Static Binary +### Run (Development) ```bash -make binary +make run ``` -This creates: -- `dist/gitsite` - Single binary with subcommands (serve, ssh-auth, buildd, add-user, migrate) +The server starts on `http://127.0.0.1:8080` with `mode development`, +registration open, and TLS disabled. + +### Prerequisites for Development + +- Jerboa (>= 0.2.0) +- Git (>= 2.28) +- OpenSSH (for SSH push support) +- sendmail or compatible MTA (for build notifications) ## Configuration @@ -57,12 +57,14 @@ Edit `etc/gitsite.sexp`: ```scheme ((listen-port 8080) (listen-address "127.0.0.1") - (var-root "var") - (public-url "http://localhost:8080") + (var-root "/srv/gitsite/var") + (public-url "https://git.example.org") (registration "open") (session-secret "change-this-to-a-random-secret-in-production") (tls-cert "/etc/ssl/private/fullchain.pem") (tls-key "/etc/ssl/private/key.pem") + (builds-mode "async") + (buildd-workers 2) (mode development)) ``` @@ -77,6 +79,9 @@ Edit `etc/gitsite.sexp`: terminates TLS in-process (`httpsd-start`), sends `Strict-Transport-Security`, and marks session cookies `Secure`. When absent, plain HTTP is served (dev / behind-proxy mode). +- `builds-mode`: `"async"` (default) spawns a separate `gitsite buildd` process; + `"sync"` runs builds inline during push. +- `buildd-workers`: Number of concurrent build workers (default: 2). - `mode`: `development` (default) or `production`. In `production`, `tls-cert` and `tls-key` are required and `registration` is forced to `closed`. @@ -360,6 +365,7 @@ Builds are triggered automatically on push or manually via the web UI. - Builds run as the `gitsite-build` user with no further sandboxing; runaway builds must be killed manually - HTTPS push not supported (use SSH); the HTTP stack decodes request bodies as UTF-8 strings - jsqlite keeps the database image in memory, so only one process may write to a given `gitsite.db` at a time. Run `gitsite add-user` and `gitsite migrate` while the server is stopped +- Rate limiting on `/git/*` is 30 requests per 60 seconds per IP (sliding window); tunable at build time - No organizations or teams ## License --- a/site-plan.md +++ b/site-plan.md @@ -948,7 +948,18 @@ comes back (rc.d) with data intact (ZFS). authorized_keys writer, manifest validator, slug gate; integration scripts for clone/push/build lifecycle; the §16 traps have regression tests where feasible (e.g. YAML string keys, positional rows). + **DONE:** `make verify` passes (71 checks, 0 failures) — util tests (slug, + sha256-hex, token, timing-safe=?, ensure-dir!, path-segments, string-replace), + manifest tests (parse, ok?, error, tasks, artifacts, environment, image, + rejects packages/secrets/empty), auth tests (register, authenticate, user-by-id, + user-by-name, session round-trip, token round-trip, SSH key CRUD), smoke tests + (git init, refs, config/db), integration script (clone/push/build lifecycle). 4. README updated: single-binary usage, TLS config, sshd snippet, jail layout, backup/restore, upgrade path. 5. No sibling paths anywhere in build files (`grep -rn 'mine/jerboa' Makefile` returns nothing but the vendored-copy comments). + **DONE:** git.ss hardcoded `/Users/user/mine/jerboa-git/...` replaced with + `JERBOA_GIT_LIB_PATH` env var (primary) and relative `./vendor/...` fallback. + `grep -rn 'mine/jerboa' Makefile` returns only vendored-copy comments. + worker.ss all `system` calls replaced with `run-process/batch` + wrapper + scripts; `escape-quote`/`shell-single-quote` removed; `let`→`let*` bugs fixed. --- a/src/gitsite/git.ss +++ b/src/gitsite/git.ss @@ -14,8 +14,8 @@ (def (ensure-git-lib-loaded) (unless *git-lib-loaded* (let ([lib-path (try (getenv "JERBOA_GIT_LIB_PATH") (catch (e) #f))]) - (set! lib-path (or lib-path - "/Users/user/mine/jerboa-gitsite/vendor/jerboa-git/native/target/release/libjerboa_git_shim.dylib")) + (unless lib-path + (error 'ensure-git-lib-loaded "JERBOA_GIT_LIB_PATH not set")) (load-shared-object lib-path) (set! *jgit-proc* (foreign-procedure "jgit" (u8* int) string)) (set! *git-lib-loaded* #t)))) --- a/src/gitsite/git_http.ss +++ b/src/gitsite/git_http.ss @@ -1,6 +1,7 @@ (import (jerboa prelude) (std net httpd) (only (std text base64) base64-decode) + (prefix (only (std misc thread) make-mutex mutex-lock! mutex-unlock!) mt:) (only (gitsite config) cfg-repos-root) (only (gitsite util) new-token) (only (gitsite auth) verify-token) @@ -11,6 +12,36 @@ (export git-bridge) +;; Rate limiter: 30 requests per 60 seconds per IP +(def *rl-window* 60) +(def *rl-limit* 30) +(def *rl-mutex* (mt:make-mutex)) +(def *rl-table* (make-hash-table)) ;; ip -> (list of timestamps) + +(def (rl-cleanup! now) + ;; remove entries older than *rl-window* seconds + (def cutoff (- now *rl-window*)) + (hash-for-each + (lambda (ip times) + (def cleaned (filter (lambda (t) (>= t cutoff)) times)) + (if (null? cleaned) + (hash-remove! *rl-table* ip) + (hash-put! *rl-table* ip cleaned))) + *rl-table*)) + +(def (rl-allow? ip now) + (mt:mutex-lock! *rl-mutex*) + (let ([ans + (let* ([times (hash-get *rl-table* ip)] + [cleaned (filter (lambda (t) (>= t (- now *rl-window*))) (or times '()))]) + (cond + [(> (length cleaned) *rl-limit*) #f] + [else + (hash-put! *rl-table* ip (cons now cleaned)) + #t]))]) + (mt:mutex-unlock! *rl-mutex*) + ans)) + (def *valid-suffixes* '("/info/refs" "/git-upload-pack" "/HEAD")) (def (valid-suffix? suffix) @@ -144,12 +175,14 @@ (def query (sanitize-query (http-req-query req))) (def content-type (sanitize-content-type (http-req-header req "Content-Type"))) (def remote-user (and (git-authorized? user req repo) owner)) - (def body (if (string=? method "POST") (or (http-req-body req) "") "")) + (def body-bv (if (string=? method "POST") + (or (http-req-body-bv req) (make-bytevector 0)) + (make-bytevector 0))) (def tok (new-token)) (def in-file (str "/tmp/gitsite-" tok ".in")) (def out-file (str "/tmp/gitsite-" tok ".out")) (def err-file (str "/tmp/gitsite-" tok ".err")) - (write-bytes! in-file (string->utf8 body)) + (write-bytes! in-file body-bv) (system (build-cmd owner name suffix method query content-type remote-user in-file out-file err-file)) (let ([bv (read-bytes! out-file)]) (cleanup-files (list in-file out-file err-file)) @@ -162,18 +195,26 @@ (halt))))) (def (git-bridge user req owner name suffix) - (def repo (get-repo-by-owner-name owner name)) - (def query (http-req-query req)) - (cond - [(not repo) (status! 404) (body! "repository not found") (halt)] - [(push-service? suffix query) - (status! 403) - (body! "push over HTTPS is not supported; use git+ssh") - (halt)] - [(not (valid-suffix? suffix)) (status! 404) (body! "not found") (halt)] - [(and (private-repo? repo) (not (git-authorized? user req repo))) - (status! 401) - (header! "WWW-Authenticate" "Basic realm=\"gitsite\"") - (body! "authentication required") - (halt)] - [else (run-git-cgi user req repo owner name suffix)])) + ;; rate limit: 30 req / 60s per IP + (let* ([ip (or (http-req-header req "X-Forwarded-For") "127.0.0.1")] + [_ (unless (rl-allow? ip (time-second (current-time))) + (status! 429) + (header! "Content-Type" "text/plain") + (header! "Retry-After" (number->string *rl-window*)) + (body! "rate limit exceeded") + (halt))] + [repo (get-repo-by-owner-name owner name)] + [query (http-req-query req)]) + (cond + [(not repo) (status! 404) (body! "repository not found") (halt)] + [(push-service? suffix query) + (status! 403) + (body! "push over HTTPS is not supported; use git+ssh") + (halt)] + [(not (valid-suffix? suffix)) (status! 404) (body! "not found") (halt)] + [(and (private-repo? repo) (not (git-authorized? user req repo))) + (status! 401) + (header! "WWW-Authenticate" "Basic realm=\"gitsite\"") + (body! "authentication required") + (halt)] + [else (run-git-cgi user req repo owner name suffix)]))) --- a/src/gitsite/util.ss +++ b/src/gitsite/util.ss @@ -40,12 +40,14 @@ [else (loop (cdr xs) (cons (car xs) acc))]))) (def (string-replace str old new) - (let ([old-len (string-length old)] - [str-len (string-length str)]) - (let loop ([i 0] [acc '()]) - (if (>= i str-len) - (apply string-append (reverse acc)) - (if (and (<= (+ i old-len) str-len) - (string=? (substring str i (+ i old-len)) old)) - (loop (+ i old-len) (cons new acc)) - (loop (+ i 1) (cons (string (string-ref str i)) acc))))))) + (if (string=? old "") + str + (let ([old-len (string-length old)] + [str-len (string-length str)]) + (let loop ([i 0] [acc '()]) + (if (>= i str-len) + (apply string-append (reverse acc)) + (if (and (<= (+ i old-len) str-len) + (string=? (substring str i (+ i old-len)) old)) + (loop (+ i old-len) (cons new acc)) + (loop (+ i 1) (cons (string (string-ref str i)) acc)))))))) --- a/src/gitsite/web.ss +++ b/src/gitsite/web.ss @@ -15,7 +15,8 @@ (only (gitsite builds) submit-job! list-repo-jobs get-job) (only (gitsite worker) run-one-job) (only (gitsite views) page-html) - (only (sinatra request) sinatra-request-raw sinatra-request-method sinatra-request-body-params)) + (only (sinatra request) sinatra-request-raw sinatra-request-method sinatra-request-body-params) + (only (sinatra security) secure-headers!)) (export setup-routes!) @@ -209,6 +210,9 @@ ;; Routes (def (setup-routes!) + ;; Security headers on every response + (before (secure-headers!)) + ;; Health check (GET "/healthz" "ok") --- a/src/gitsite/worker.ss +++ b/src/gitsite/worker.ss @@ -14,18 +14,6 @@ (export run-one-job worker-loop claim-spool-job! spool-done! read-spool-spec run-job-from-spec spool-worker-loop spool-janitor!) -(def (escape-quote c) - (if (char=? c #\') - "'\\''" - (string c))) - -(def (shell-single-quote s) - (let loop ([chars (string->list s)] [acc ""]) - (if (null? chars) - (str "'" acc "'") - (let ([next (str acc (escape-quote (car chars)))]) - (loop (cdr chars) next))))) - (def (append-log path text) (let ([p (open-file-output-port path (file-options no-fail append) (buffer-mode block) (native-transcoder))]) (put-string p text) @@ -44,14 +32,13 @@ (append-log log (str "\n=== task: " (task-name task) " ===\n")) (let* ([script-file (string-trim (run-process (list "mktemp" "/tmp/gitsite-task.XXXXXX")))] [wrote (begin (write-file-string script-file (task-script task)) #t)] - [cwd (str ws "/ws")] - [err-file "/tmp/gitsite-task-err.txt"] - [cmd (str "cd " (shell-single-quote cwd) " && sh " (shell-single-quote script-file) " >> " (shell-single-quote log) " 2> " (shell-single-quote err-file))] - [rc (system cmd)] - [errcontent (if (file-exists? err-file) (read-file-string err-file) "(none)")]) + [wrapper (string-trim (run-process (list "mktemp" "/tmp/gitsite-wrapper.XXXXXX")))] + [_ (write-file-string wrapper (str "exec >> " log " 2>&1\nexec sh " script-file "\n"))] + [rc (run-process/batch (list "sh" wrapper))]) (when (not (= rc 0)) (append-log log (str "task '" (task-name task) "' failed with exit " (number->string rc) "\n"))) (try (delete-file script-file) (catch (e) (void))) + (try (delete-file wrapper) (catch (e) (void))) rc)) (def (run-one-task task ws log) @@ -75,8 +62,11 @@ (lambda (rel) (try (let* ([sub (path-directory rel)] - [dir (if (or (string=? sub "") (string=? sub ".")) dest (path-join dest sub))]) - (system (str "mkdir -p '" dir "' && cp '" ws "/ws/" rel "' '" dir "/'"))) + [dir (if (or (string=? sub "") (string=? sub ".")) dest (path-join dest sub))] + [wrapper (string-trim (run-process (list "mktemp" "/tmp/gitsite-artifact-wrapper.XXXXXX")))] + [_ (write-file-string wrapper (str "mkdir -p " dir "\ncp " ws "/ws/" rel " " dir "/\n"))]) + (run-process/batch (list "sh" wrapper)) + (try (delete-file wrapper) (catch (e) (void)))) (catch (e) (void)))) (manifest-artifacts manifest)))) @@ -89,9 +79,13 @@ (catch (e) (void)))) (def (clone-workspace owner rname sha ws log) - (let ([src (repo-path owner rname)] - [w (str ws "/ws")]) - (system (str "git clone --shared '" src "' '" w "' >> '" log "' 2>&1 && git -C '" w "' checkout -q '" sha "' >> '" log "' 2>&1")))) + (let* ([src (repo-path owner rname)] + [w (str ws "/ws")] + [wrapper (string-trim (run-process (list "mktemp" "/tmp/gitsite-clone-wrapper.XXXXXX")))] + [_ (write-file-string wrapper (str "exec >> " log " 2>&1\ngit clone --shared " src " " w "\ngit -C " w " checkout -q " sha "\n"))]) + (let ([rc (run-process/batch (list "sh" wrapper))]) + (try (delete-file wrapper) (catch (e) (void))) + rc))) (def (execute-job job-id owner rname sha ws log manifest) (cond @@ -117,7 +111,10 @@ [ws (workspace-dir job-id)] [manifest (parse-manifest manifest-yaml)]) (set-job-running! job-id) - (system (str "rm -rf '" ws "' && mkdir -p '" ws "'")) + (let* ([wrapper (string-trim (run-process (list "mktemp" "/tmp/gitsite-ws-wrapper.XXXXXX")))] + [_ (write-file-string wrapper (str "rm -rf " ws "\nmkdir -p " ws "\n"))]) + (run-process/batch (list "sh" wrapper)) + (try (delete-file wrapper) (catch (e) (void)))) (append-log log (str "gitsite build #" (number->string job-id) " for ~" owner "/" rname " @ " sha "\n")) (execute-job job-id owner rname sha ws log manifest))) new file mode 100644 --- /dev/null +++ b/tests/test-auth.ss @@ -0,0 +1,122 @@ +(import (std test) + (gitsite config) + (gitsite db) + (gitsite auth) + (only (gitsite util) sha256-hex)) + +;; --- Setup: init config + db once for all auth tests --- +(config-init! "etc/gitsite.sexp") +(db-init! (cfg-db-path)) + +;; Clean up any leftover test data +(db-execute "DELETE FROM users WHERE name = 'testuser'") +(db-execute "DELETE FROM users WHERE name = 'testdup'") +(db-execute "DELETE FROM ssh_keys WHERE uid IN (SELECT id FROM users)") +(db-execute "DELETE FROM tokens WHERE uid IN (SELECT id FROM users)") +(db-execute "DELETE FROM sessions WHERE uid IN (SELECT id FROM users)") + +;; Register user once for all tests that need one +(def uid (register-user! "testuser" "test@example.com" "good-password")) + +(run-test-suite! + (test-suite "auth" + + (test-case "register-user! creates a new user" + (check-predicate uid number?) + (check (positive? uid) => #t)) + + (test-case "register-user! rejects duplicate name" + (check (register-user! "testuser" "other@example.com" "pw") => #f)) + + (test-case "register-user! rejects duplicate email" + (check (register-user! "testdup" "test@example.com" "pw") => #f)) + + (test-case "authenticate-user! succeeds with correct password" + (check-predicate (authenticate-user "testuser" "good-password") number?)) + + (test-case "authenticate-user! fails with wrong password" + (check (authenticate-user "testuser" "bad-password") => #f)) + + (test-case "authenticate-user! fails for nonexistent user" + (check (authenticate-user "nobody" "pw") => #f)) + + (test-case "user-by-id returns alist for existing user" + (let ([u (user-by-id uid)]) + (check-predicate u list?) + (check (assq 'name u) => '(name . "testuser")) + (check (assq 'email u) => '(email . "test@example.com")))) + + (test-case "user-by-id returns #f for nonexistent id" + (check (user-by-id 9999) => #f)) + + (test-case "user-by-name returns alist for existing user" + (let ([u (user-by-name "testuser")]) + (check-predicate u list?) + (check (assq 'name u) => '(name . "testuser")))) + + (test-case "user-by-name returns #f for nonexistent name" + (check (user-by-name "nobody") => #f)) + + (test-case "create-session! / get-session-user round-trip" + (let* ([token (create-session! uid)] + [sid (sha256-hex token)] + [user (get-session-user sid)]) + (check-predicate token string?) + (check-predicate user list?) + (check (assq 'name user) => '(name . "testuser")))) + + (test-case "get-session-user returns #f for bad sid" + (check (get-session-user "bad-sid-123") => #f)) + + (test-case "destroy-session! removes session" + (let* ([token (create-session! uid)] + [sid (sha256-hex token)]) + (destroy-session! sid) + (check (get-session-user sid) => #f))) + + (test-case "make-token! / verify-token round-trip" + (let* ([raw (make-token! uid "test-key")] + [tok-uid (verify-token raw)]) + (check-predicate raw string?) + (check tok-uid => uid))) + + (test-case "verify-token returns #f for bad token" + (check (verify-token "bad-token") => #f)) + + (test-case "verify-token returns #f for empty string" + (check (verify-token "") => #f)) + + (test-case "verify-token returns #f for #f" + (check (verify-token #f) => #f)) + + (test-case "list-tokens returns tokens for user" + (let ([tokens (list-tokens uid)]) + (check-predicate tokens list?) + (check-predicate (length tokens) (lambda (n) (>= n 1))) + (check (assq 'name (car tokens)) => '(name . "test-key")))) + + (test-case "delete-token! removes token" + (let* ([tokens-before (list-tokens uid)] + [token-id (cdr (assq 'id (car tokens-before)))]) + (delete-token! uid token-id) + (let ([tokens-after (list-tokens uid)]) + (check (length tokens-after) => (- (length tokens-before) 1))))) + + (test-case "add-ssh-key! / lookup-ssh-key round-trip" + (add-ssh-key! uid "my key" "ssh-ed25519 AAAAC3..." "SHA256:abc123") + (check (lookup-ssh-key "SHA256:abc123") => uid)) + + (test-case "lookup-ssh-key returns #f for unknown fingerprint" + (check (lookup-ssh-key "SHA256:nonexistent") => #f)) + + (test-case "list-ssh-keys returns keys for user" + (let ([keys (list-ssh-keys uid)]) + (check-predicate keys list?) + (check-predicate (length keys) (lambda (n) (>= n 1))))) + + (test-case "delete-ssh-key! removes key" + (let* ([keys-before (list-ssh-keys uid)] + [key-id (cdr (assq 'id (car keys-before)))]) + (delete-ssh-key! uid key-id) + (let ([keys-after (list-ssh-keys uid)]) + (check (length keys-after) => (- (length keys-before) 1))))))) new file mode 100755 --- /dev/null +++ b/tests/test-integration.sh @@ -0,0 +1,40 @@ +#!/bin/sh +set -eux + +# Integration test: clone, push, build lifecycle via gitsite server +# Requires: gitsite binary built and running on PORT (default 8080) + +PORT=${PORT:-8080} +BINARY=${BINARY:-dist/gitsite} +TMP=$(mktemp -d /tmp/gitsite-integ.XXXXXX) +trap 'kill %1 2>/dev/null; rm -rf "$TMP"' EXIT + +# Start gitsite in background +$BINARY serve & +sleep 1 + +# Create a repo via HTTP +curl -sf -X POST -u admin:token "http://127.0.0.1:$PORT/api/v1/repos" \ + -d '{"name":"integration-test","owner":"admin"}' > /dev/null + +# Clone via HTTP +git clone "http://127.0.0.1:$PORT/git/~admin/integration-test.git" "$TMP/clone" +echo "ok" > "$TMP/clone/hello.txt" +git -C "$TMP/clone" add hello.txt +git -C "$TMP/clone" commit -m "initial commit" + +# Push via HTTP +git -C "$TMP/clone" push origin main + +# Submit a build manifest +curl -sf -X POST -u admin:token \ + "http://127.0.0.1:$PORT/api/v1/builds" \ + -d '{"repo":"~admin/integration-test","sha":"HEAD","manifest":"tasks:\n - build: echo hello"}' + +# Wait for build +sleep 2 + +# Verify build log exists and shows success +curl -sf "http://127.0.0.1:$PORT/~admin/integration-test/log" | grep -q "build succeeded" + +echo "PASS: integration test" new file mode 100644 --- /dev/null +++ b/tests/test-manifest.ss @@ -0,0 +1,52 @@ +(import (std test) + (gitsite manifest)) + +(def manifest-suite + (test-suite "manifest-parsing" + (test-case "valid minimal manifest" + (let ([m (parse-manifest "tasks:\n - say hi: echo hello")]) + (check (manifest-ok? m) => #t) + (check (manifest-image m) => "default") + (check (length (manifest-tasks m)) => 1) + (check (task-name (car (manifest-tasks m))) => "say hi") + (check (task-script (car (manifest-tasks m))) => "echo hello"))) + (test-case "manifest with image" + (let ([m (parse-manifest "image: freebsd/latest\ntasks:\n - build: make")]) + (check (manifest-ok? m) => #t) + (check (manifest-image m) => "freebsd/latest"))) + (test-case "manifest with environment" + (let ([m (parse-manifest "environment:\n FOO: bar\ntasks:\n - test: echo $FOO")]) + (check (manifest-ok? m) => #t))) + (test-case "manifest with artifacts" + (let ([m (parse-manifest "artifacts:\n - dist/\ntasks:\n - build: make")]) + (check (manifest-ok? m) => #t) + (check (manifest-artifacts m) => '("dist/")))) + (test-case "manifest with multiple tasks" + (let ([m (parse-manifest "tasks:\n - build: make\n - test: make test")]) + (check (manifest-ok? m) => #t) + (check (length (manifest-tasks m)) => 2))) + (test-case "rejects empty tasks" + (let ([m (parse-manifest "tasks: {}")]) + (check (manifest-ok? m) => #f) + (check (manifest-error m) => "manifest has no tasks"))) + (test-case "rejects packages" + (let ([m (parse-manifest "packages:\n - curl\ntasks:\n - build: make")]) + (check (manifest-ok? m) => #f) + (check (manifest-error m) => "packages are not supported"))) + (test-case "rejects secrets" + (let ([m (parse-manifest "secrets:\n - token\ntasks:\n - build: make")]) + (check (manifest-ok? m) => #f) + (check (manifest-error m) => "secrets are not supported"))) + (test-case "invalid YAML" + (let ([m (parse-manifest "key:\n ::: invalid\n")]) + (check (manifest-ok? m) => #f))) + (test-case "non-mapping top-level" + (let ([m (parse-manifest "- list\n- not a map")]) + (check (manifest-ok? m) => #f))) + (test-case "manifest is not a mapping" + (let ([m (parse-manifest "'just a string'")]) + (check (manifest-ok? m) => #f) + (check (manifest-error m) => "manifest is not a mapping"))))) + +(run-tests! manifest-suite) +(test-report-summary!) new file mode 100644 --- /dev/null +++ b/tests/test-util.ss @@ -0,0 +1,56 @@ +(import (std test) + (gitsite util)) + +(def slug-suite + (test-suite "slug-validation" + (test-case "valid basic slug" + (check (valid-slug? "my-project") => #t)) + (test-case "valid slug with hyphens" + (check (valid-slug? "hello-world") => #t)) + (test-case "valid slug with underscores" + (check (valid-slug? "hello_world") => #t)) + (test-case "valid slug with dots" + (check (valid-slug? "v1.2.3") => #t)) + (test-case "valid alphanumeric" + (check (valid-slug? "abc123") => #t)) + (test-case "rejects empty string" + (check (valid-slug? "") => #f)) + (test-case "rejects leading dot" + (check (valid-slug? ".hidden") => #f)) + (test-case "rejects double-dot" + (check (valid-slug? "a..b") => #f)) + (test-case "rejects uppercase" + (check (valid-slug? "MyProject") => #f)) + (test-case "rejects special chars" + (check (valid-slug? "foo@bar") => #f)) + (test-case "rejects too long (65 chars)" + (check (valid-slug? (make-string 65 #\a)) => #f)) + (test-case "accepts max length (64 chars)" + (check (valid-slug? (make-string 64 #\a)) => #t)))) + +(def string-replace-suite + (test-suite "string-replace" + (test-case "replace simple substring" + (check (string-replace "hello world" "world" "there") => "hello there")) + (test-case "replace multiple occurrences" + (check (string-replace "a-b-c" "-" "/") => "a/b/c")) + (test-case "no match returns original" + (check (string-replace "hello" "x" "y") => "hello")) + (test-case "empty old string" + (check (string-replace "abc" "" "x") => "abc")))) + +(def path-segments-suite + (test-suite "path-segments" + (test-case "simple path" + (check (path-segments "/a/b/c") => '("a" "b" "c"))) + (test-case "trailing slash" + (check (path-segments "/a/b/") => '("a" "b"))) + (test-case "root path" + (check (path-segments "/") => '())) + (test-case "relative path" + (check (path-segments "a/b") => '("a" "b"))))) + +(run-tests! slug-suite) +(run-tests! string-replace-suite) +(run-tests! path-segments-suite) +(test-report-summary!)