gitsite: complete Part II backlog
ober
e731ca8a5aa0d51837eeb481b1c89063fe9105d6
--- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ PORT ?= 8080 BINARY_OUTPUT ?= dist/gitsite -.PHONY: build run run-builds check clean binary jerboa-git vendor vendor-jsqlite vendor-sinatra +.PHONY: build run run-builds check verify clean binary jerboa-git vendor vendor-jsqlite vendor-sinatra vendor: vendor-jsqlite vendor-sinatra vendor-git @@ -57,6 +57,9 @@ binary: build check: build JERBOA_GIT_LIB_PATH="$(JERBOA_GIT_LIB_PATH)" $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/smoke.ss +verify: binary check + @echo "verify: binary built and checks pass" + clean: rm -rf $(BUILD_DIR) var dist cd $(JERBOA_GIT) && cargo clean --- a/README.md +++ b/README.md @@ -87,6 +87,7 @@ Edit `etc/gitsite.sexp`: 1. **Create dedicated user**: ```bash sudo useradd -r -m -d /srv/gitsite -s /bin/bash gitsite + sudo useradd -r -m -d /srv/gitsite-build -s /bin/bash gitsite-build ``` 2. **Install binary**: @@ -98,6 +99,7 @@ Edit `etc/gitsite.sexp`: ```bash sudo mkdir -p /srv/gitsite/{var,etc} sudo chown -R gitsite:gitsite /srv/gitsite + sudo chown gitsite-build:gitsite-build /srv/gitsite-build ``` 4. **Configure**: @@ -106,6 +108,7 @@ Edit `etc/gitsite.sexp`: # Edit /srv/gitsite/etc/gitsite.sexp for production # Set tls-cert/tls-key + (mode production) to terminate TLS in-process, # or leave TLS unset and terminate at a reverse proxy. + # Set session-secret to a long random string. ``` 5. **Reverse proxy** (nginx example, only if not using in-process TLS): @@ -195,20 +198,98 @@ Restart=on-failure WantedBy=multi-user.target ``` -### FreeBSD +### FreeBSD Jail Setup -Ship the included service files: +Recommended layout on FreeBSD 14+ with a dedicated jail: -- `files/rc.d/gitsite` → `/usr/local/etc/rc.d/gitsite` -- `files/newsyslog.d/gitsite` → `/usr/local/etc/newsyslog.conf.d/gitsite` +1. **Create the jail and ZFS dataset**: + ```bash + sudo zfs create -o mountpoint=/jails/gitsite tank/jails/gitsite + # use bsdinstall or a template to populate the jail + ``` + +2. **Install runtime dependencies inside the jail**: + ```bash + pkg install git + ``` + +3. **Create users**: + ```bash + pw useradd -n gitsite -d /srv/gitsite -s /bin/sh -m + pw useradd -n gitsite-build -d /srv/gitsite-build -s /bin/sh -m + ``` + +4. **Deploy the binary and service files**: + ```bash + install -m 755 dist/gitsite /usr/local/bin/gitsite + install -m 555 files/rc.d/gitsite /usr/local/etc/rc.d/gitsite + install -m 644 files/newsyslog.d/gitsite /usr/local/etc/newsyslog.conf.d/gitsite + mkdir -p /srv/gitsite/{var,etc} + chown -R gitsite:gitsite /srv/gitsite + chown gitsite-build:gitsite-build /srv/gitsite-build + cp etc/gitsite.sexp /srv/gitsite/etc/ + # edit /srv/gitsite/etc/gitsite.sexp: set session-secret, tls-cert/tls-key, mode production + ``` + +5. **Configure sshd for SSH push** (add to `/etc/ssh/sshd_config` inside the jail): + ``` + Match User git + AuthorizedKeysFile /srv/gitsite/var/ssh/authorized_keys + ForceCommand /usr/local/bin/gitsite ssh-auth + PermitTTY no + AllowAgentForwarding no + AllowTcpForwarding no + X11Forwarding no + ``` + +6. **Enable and start services**: + ```bash + sysrc gitsite_enable=YES + service gitsite start + service sshd restart + ``` + +7. **Log rotation**: + The included `files/newsyslog.d/gitsite` rotates `/srv/gitsite/var/gitsite.log`. + +### Backup and Restore + +All persistent state lives under `var-root` (`/srv/gitsite/var` by default): + +- `gitsite.db` — SQLite database (users, repos, sessions, tokens, jobs) +- `repos/` — bare git repositories +- `builds/` — build logs +- `artifacts/` — build artifacts +- `spool/` — async build queue + +Back up the entire `var` directory while the server and buildd are stopped: + +```bash +service gitsite stop +service gitsite_buildd stop 2>/dev/null || true +tar czf gitsite-var-$(date +%Y%m%d).tar.gz -C /srv/gitsite var +service gitsite start +``` + +Restore by stopping services, extracting the archive, and fixing ownership: ```bash -sudo install -m 555 files/rc.d/gitsite /usr/local/etc/rc.d/gitsite -sudo install -m 644 files/newsyslog.d/gitsite /usr/local/etc/newsyslog.conf.d/gitsite -sudo sysrc gitsite_enable=YES -sudo service gitsite start +service gitsite stop +tar xzf gitsite-var-YYYYMMDD.tar.gz -C /srv/gitsite +chown -R gitsite:gitsite /srv/gitsite/var +service gitsite start ``` +### Upgrade Path + +1. Build the new binary: `make binary` +2. Stop `gitsite serve` and `gitsite buildd` +3. Run migrations if the release notes require it: `gitsite migrate` +4. Install the new binary: `install -m 755 dist/gitsite /usr/local/bin/gitsite` +5. Start services again + +Database migrations are idempotent; `gitsite migrate` only creates tables that do not already exist. + ## Usage ### Create Repository @@ -265,9 +346,9 @@ Builds are triggered automatically on push or manually via the web UI. - **Database**: SQLite via `(std db sqlite)` (jsqlite pure-Scheme implementation) - **Authentication**: Argon2id password hashing, server-side session records - **Git operations**: System `git` binary for wire protocol, libgit2 for browsing (via jerboa-git Rust shim) -- **Builds**: Synchronous execution in web thread (Phase 3), with job queue +- **Builds**: Async file-spool queue; `gitsite buildd` workers claim and run jobs out-of-process - **SSH**: System OpenSSH with forced-command binary (`gitsite ssh-auth`) -- **TLS**: In-process termination via `httpd-start-https` (optional, config-driven) +- **TLS**: In-process termination via `httpsd-start` (optional, config-driven) ## Limitations @@ -276,9 +357,9 @@ Builds are triggered automatically on push or manually via the web UI. - No webhooks - No LFS support - No syntax highlighting -- Builds execute synchronously (web request blocks) — async worker queue planned -- No process-group isolation for builds (runaway builds must be killed manually) -- HTTPS push not supported (use SSH) — binary-body support planned +- 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 - No organizations or teams ## License --- a/src/gitsite.ss +++ b/src/gitsite.ss @@ -7,6 +7,7 @@ (gitsite auth) (gitsite sshcmd) (gitsite worker) + (gitsite gc) (sinatra handler) (only (std net httpsd) httpsd-start)) @@ -24,6 +25,9 @@ (config-init! "etc/gitsite.sexp") (db-init! (cfg-db-path)) + ;; Background session/token GC + (spawn (lambda () (gc-loop!))) + ;; Setup sinatra routes (setup-routes!) @@ -70,17 +74,31 @@ (config-init! "etc/gitsite.sexp") (db-init! (cfg-db-path)) - (let ([num-workers 2]) - (let spawn-workers ([i 0]) - (when (< i num-workers) - (spawn (lambda () (worker-loop (str "worker-" (number->string i))))) - (spawn-workers (+ i 1)))) - - (displayln "buildsd started with " num-workers " workers") - - (let loop () - (thread-sleep! 3600) - (loop)))) + (if (string=? (cfg-builds-mode) "sync") + (begin + ;; Sync mode: the web thread runs builds inline (legacy behavior), so + ;; the daemon only keeps DB-polling workers for historical compat. + (let ([num-workers 2]) + (let spawn-workers ([i 0]) + (when (< i num-workers) + (spawn (lambda () (worker-loop (str "worker-" (number->string i))))) + (spawn-workers (+ i 1)))) + (displayln "buildsd started with " num-workers " sync workers"))) + (begin + ;; Async mode (default): builds run via the file-spool queue. The web + ;; process writes job specs into var/spool/new; these workers claim them + ;; atomically with rename(2) and run them out-of-process. + (spool-janitor!) + (let ([num-workers (cfg-buildd-workers)]) + (let spawn-workers ([i 0]) + (when (< i num-workers) + (spawn (lambda () (spool-worker-loop (str "spool-worker-" (number->string i))))) + (spawn-workers (+ i 1)))) + (displayln "buildsd started with " num-workers " async spool workers")))) + + (let loop () + (thread-sleep! 3600) + (loop))) (def (cmd-add-user args) (when (< (length args) 3) --- a/src/gitsite/auth.ss +++ b/src/gitsite/auth.ss @@ -5,7 +5,7 @@ (export register-user! authenticate-user user-by-id user-by-name create-session! get-session-user destroy-session! - make-token! verify-token + make-token! verify-token list-tokens delete-token! add-ssh-key! list-ssh-keys delete-ssh-key! lookup-ssh-key) (def (row->alist r) @@ -84,9 +84,19 @@ (if (or (not raw) (string=? raw "")) #f (lookup-token (sha256-hex raw)))) +(def (list-tokens uid) + (map (lambda (r) + (list (cons 'id (car r)) + (cons 'name (cadr r)) + (cons 'created_at (caddr r)) + (cons 'last_used_at (cadddr r)))) + (db-query "SELECT id, name, created_at, last_used_at FROM tokens WHERE uid = ? ORDER BY created_at DESC" uid))) + +(def (delete-token! uid token-id) + (db-execute "DELETE FROM tokens WHERE id = ? AND uid = ?" token-id uid)) (def (add-ssh-key! uid title key fingerprint) - (db-insert "INSERT INTO ssh_keys (uid, title, key, fingerprint, created_at) VALUES (?, ?, ?, ?, ?)" + (db-insert "INSERT INTO ssh_keys (uid, title, \"key\", fingerprint, created_at) VALUES (?, ?, ?, ?, ?)" uid title key fingerprint (now-iso))) (def (list-ssh-keys uid) --- a/src/gitsite/builds.ss +++ b/src/gitsite/builds.ss @@ -1,6 +1,7 @@ (import (jerboa prelude) + (only (chezscheme) rename-file) (only (gitsite db) db-query db-execute db-insert db-changes) - (only (gitsite config) cfg-builds-dir) + (only (gitsite config) cfg-builds-dir cfg-spool-new cfg-builds-mode) (only (gitsite util) now-iso) (only (gitsite manifest) parse-manifest manifest-ok?)) @@ -9,6 +10,30 @@ (def (job-log-path id) (str (cfg-builds-dir) "/" (number->string id) ".log")) +(def (async-builds?) + (string=? (cfg-builds-mode) "async")) + +(def (job-spec repo-id commit-sha manifest-yaml id) + (let ([rows (db-query "SELECT u.name, r.name FROM repos r JOIN users u ON u.id = r.owner_id WHERE r.id = ?" repo-id)]) + (if (null? rows) + #f + (let ([r (car rows)]) + (list (cons 'id id) + (cons 'owner (car r)) + (cons 'repo (cadr r)) + (cons 'commit_sha commit-sha) + (cons 'manifest manifest-yaml)))))) + +(def (spool-enqueue! id repo-id commit-sha manifest-yaml) + (let ([spec (job-spec repo-id commit-sha manifest-yaml id)]) + (when spec + (let* ([dir (cfg-spool-new)] + [name (str (number->string id) ".sexp")] + [tmp (path-join dir (str name ".tmp"))] + [final (path-join dir name)]) + (try (delete-file tmp) (catch (e) (void))) + (call-with-output-file tmp (lambda (p) (write spec p))) + (rename-file tmp final))))) (def (submit-job! repo-id commit-sha manifest-yaml) (def m (parse-manifest manifest-yaml)) @@ -17,6 +42,8 @@ (let ([id (db-insert "INSERT INTO jobs (repo_id, commit_sha, manifest, status, queued_at) VALUES (?, ?, ?, 'queued', ?)" repo-id commit-sha manifest-yaml (now-iso))]) (db-execute "UPDATE jobs SET log_path = ? WHERE id = ?" (job-log-path id) id) + (when (async-builds?) + (spool-enqueue! id repo-id commit-sha manifest-yaml)) id))) (def (get-job id) --- a/src/gitsite/config.ss +++ b/src/gitsite/config.ss @@ -3,7 +3,9 @@ (export config-init! cfg-port cfg-address cfg-var-root cfg-repos-root cfg-db-path cfg-builds-dir cfg-artifacts-dir cfg-public-url cfg-registration-open? - cfg-session-secret cfg-tls-cert cfg-tls-key cfg-mode-production?) + cfg-session-secret cfg-tls-cert cfg-tls-key cfg-mode-production? + cfg-spool-dir cfg-spool-new cfg-spool-run cfg-spool-done + cfg-builds-mode cfg-buildd-workers) (def *config* (make-hash-table)) @@ -20,7 +22,11 @@ (ensure-dir! (cfg-var-root)) (ensure-dir! (cfg-repos-root)) (ensure-dir! (cfg-builds-dir)) - (ensure-dir! (cfg-artifacts-dir))) + (ensure-dir! (cfg-artifacts-dir)) + (ensure-dir! (cfg-spool-dir)) + (ensure-dir! (cfg-spool-new)) + (ensure-dir! (cfg-spool-run)) + (ensure-dir! (cfg-spool-done))) (def (cfg-get key default) (hash-ref *config* key default)) @@ -41,6 +47,17 @@ (def (cfg-builds-dir) (path-join (cfg-var-root) "builds")) (def (cfg-artifacts-dir) (path-join (cfg-var-root) "artifacts")) +(def (cfg-spool-dir) (path-join (cfg-var-root) "spool")) + +(def (cfg-spool-new) (path-join (cfg-spool-dir) "new")) + +(def (cfg-spool-run) (path-join (cfg-spool-dir) "run")) + +(def (cfg-spool-done) (path-join (cfg-spool-dir) "done")) + +(def (cfg-builds-mode) (cfg-get 'builds-mode "async")) + +(def (cfg-buildd-workers) (cfg-get 'buildd-workers 2)) (def (cfg-public-url) (cfg-get 'public-url "http://localhost:8080")) new file mode 100644 --- /dev/null +++ b/src/gitsite/gc.ss @@ -0,0 +1,21 @@ +(import (jerboa prelude) + (only (std misc thread) thread-sleep!) + (only (gitsite db) db-execute)) + +(export gc-sweep! gc-loop!) + +;; Delete expired sessions and stale, unused tokens. +;; sessions.expires_at is a decimal string of epoch seconds (see create-session!); +;; tokens.last_used_at is an ISO-8601 string or NULL. +(def (gc-sweep!) + (def now (time-second (current-time))) + (def cutoff (datetime->iso8601 (datetime-add (datetime-utc-now) (* -90 24 3600)))) + (db-execute "DELETE FROM sessions WHERE CAST(expires_at AS INTEGER) < ?" now) + (db-execute "DELETE FROM tokens WHERE last_used_at IS NOT NULL AND last_used_at < ?" cutoff) + (void)) + +(def (gc-loop!) + (let loop () + (gc-sweep!) + (thread-sleep! 3600) + (loop))) --- a/src/gitsite/git.ss +++ b/src/gitsite/git.ss @@ -80,16 +80,16 @@ (def (git-readme repo-path rev) ;; Try README.md, then README (let ([content (try - (git-cat-file repo-path (str rev ":README.md")) + (hash-ref (git-cat-file repo-path (str rev ":README.md")) "content") (catch (e) #f))]) (or content (try - (git-cat-file repo-path (str rev ":README")) + (hash-ref (git-cat-file repo-path (str rev ":README")) "content") (catch (e) #f))))) (def (git-blob repo-path rev path) (try - (git-cat-file repo-path (str rev ":" path)) + (hash-ref (git-cat-file repo-path (str rev ":" path)) "content") (catch (e) #f))) (def (git-commit repo-path sha) --- a/src/gitsite/req.ss +++ b/src/gitsite/req.ss @@ -55,7 +55,10 @@ (string-split body #\&)))) (def (form-ref form name) - (cond [(assoc name form) => cdr] [else ""])) + (cond + [(hash-table? form) (or (hash-get form name) "")] + [(assoc name form) => cdr] + [else ""])) (def (csrf-token sid) (sha256-hex (str sid "csrf"))) --- a/src/gitsite/sshcmd.ss +++ b/src/gitsite/sshcmd.ss @@ -1,38 +1,73 @@ (import (jerboa prelude) - (std misc process) + (std os fd) (gitsite config) (gitsite db) - (only (gitsite auth) lookup-ssh-key) - (only (gitsite repo) repo-path get-repo-by-owner-name) - (only (gitsite util) string-replace)) + (only (gitsite sshkeys) lookup-ssh-key-by-id) + (only (gitsite repo) repo-path get-repo-by-owner-name)) (export ssh-auth-main) +(def *allowed-ops* '("git-upload-pack" "git-receive-pack")) + +(def (auth-error msg) + (displayln msg) + (exit 1)) + +(def (slug-char? ch) + (or (and (char<=? #\a ch) (char<=? ch #\z)) + (and (char<=? #\0 ch) (char<=? ch #\9)) + (char=? ch #\_) + (char=? ch #\.) + (char=? ch #\-))) + +(def (all-slug-chars? part i) + (if (>= i (string-length part)) + #t + (if (slug-char? (string-ref part i)) + (all-slug-chars? part (+ i 1)) + #f))) + +(def (slug-ok? part) + (and (> (string-length part) 0) + (not (string-contains part "..")) + (all-slug-chars? part 0))) + +(def (strip-git-suffix name) + (if (string-suffix? ".git" name) + (substring name 0 (- (string-length name) 4)) + name)) + (def (parse-git-command cmd) (def parts (string-split cmd #\space)) - (if (< (length parts) 2) - #f - (let ([op (car parts)] - [path (cadr parts)]) - (cond - [(or (string=? op "git-upload-pack") (string=? op "git-receive-pack")) - (cons op path)] - [else #f])))) - -(def (extract-repo-info git-path) - (def cleaned (if (and (>= (string-length git-path) 2) - (string=? (substring git-path 0 1) "'") - (string=? (substring git-path (- (string-length git-path) 1) (string-length git-path)) "'")) - (substring git-path 1 (- (string-length git-path) 1)) - git-path)) - (def parts (string-split cleaned #\/)) - (if (< (length parts) 3) - #f - (let ([owner (list-ref parts (- (length parts) 3))] - [name (list-ref parts (- (length parts) 2))]) - (cons owner (if (string-suffix? ".git" name) - (substring name 0 (- (string-length name) 4)) - name))))) + (def two? (= (length parts) 2)) + (def op (and two? (car parts))) + (def arg (and two? (cadr parts))) + (def ok-op (and op (member op *allowed-ops*))) + (def quote-char (string-ref "'" 0)) + (def n (if (string? arg) (string-length arg) 0)) + (def quoted? + (and (string? arg) + (>= n 2) + (char=? (string-ref arg 0) quote-char) + (char=? (string-ref arg (- n 1)) quote-char))) + (def path (and quoted? (substring arg 1 (- n 1)))) + (def path-len (if (string? path) (string-length path) 0)) + (def has-tilde? + (and (string? path) + (> path-len 0) + (char=? (string-ref path 0) #\~))) + (def repo-path-str (if has-tilde? (substring path 1 path-len) path)) + (def segs (if (string? repo-path-str) + (string-split repo-path-str #\/) + '())) + (def ok-segs + (and (string? repo-path-str) + (= (length segs) 2) + (slug-ok? (car segs)) + (slug-ok? (cadr segs)))) + (if (and ok-op ok-segs) + (list op (car segs) (strip-git-suffix (cadr segs))) + #f)) (def (check-permission uid owner name op) (def repo (get-repo-by-owner-name owner name)) @@ -49,45 +84,54 @@ (= uid owner-id)] [else #f])))) -(def (shell-quote s) - (str "'" (string-replace s "'" "'\\''") "'")) +(def (find-keyid) + (def args (command-line)) + (let loop ([i 0]) + (cond + [(>= i (length args)) #f] + [(string=? (list-ref args i) "ssh-auth") + (if (< (+ i 1) (length args)) + (list-ref args (+ i 1)) + #f)] + [else (loop (+ i 1))]))) + +(def (run-git-service op rp) + (def proc (spawn-process (list op rp))) + (process-wait proc) + (exit (or (process-exit-code proc) 1))) + +(def (exec-git op owner name) + (def rp (repo-path owner name)) + (if (not (file-exists? rp)) + (auth-error "error: repository not found") + (run-git-service op rp))) + +(def (run-if-permitted uid parsed) + (def op (car parsed)) + (def owner (cadr parsed)) + (def name (caddr parsed)) + (if (not (check-permission uid owner name op)) + (auth-error "error: permission denied") + (exec-git op owner name))) + +(def (run-checked-command uid ssh-cmd) + (def parsed (parse-git-command ssh-cmd)) + (if (not parsed) + (auth-error "error: invalid command") + (run-if-permitted uid parsed))) + +(def (run-authed-command ssh-cmd keyid) + (def uid (lookup-ssh-key-by-id keyid)) + (if (not uid) + (auth-error "error: unknown ssh key") + (run-checked-command uid ssh-cmd))) (def (ssh-auth-main) + (def keyid (find-keyid)) (def ssh-cmd (getenv "SSH_ORIGINAL_COMMAND")) - (if (not ssh-cmd) - (begin - (displayln "error: no command") - (exit 1)) - (let ([parsed (parse-git-command ssh-cmd)]) - (if (not parsed) - (begin - (displayln "error: invalid command") - (exit 1)) - (let* ([op (car parsed)] - [git-path (cdr parsed)] - [repo-info (extract-repo-info git-path)]) - (if (not repo-info) - (begin - (displayln "error: invalid repository path") - (exit 1)) - (let* ([owner (car repo-info)] - [name (cdr repo-info)] - [fingerprint (getenv "SSH_KEY_FINGERPRINT")]) - (if (not fingerprint) - (begin - (displayln "error: no ssh key fingerprint") - (exit 1)) - (let ([uid (lookup-ssh-key fingerprint)]) - (if (not uid) - (begin - (displayln "error: unknown ssh key") - (exit 1)) - (if (not (check-permission uid owner name op)) - (begin - (displayln "error: permission denied") - (exit 1)) - (let ([repo-path (repo-path owner name)]) - (config-init! "etc/gitsite.sexp") - (db-init! (cfg-db-path)) - (let ([cmd (str op " " (shell-quote repo-path))]) - (exit (system cmd))))))))))))))) + (config-init! "etc/gitsite.sexp") + (db-init! (cfg-db-path)) + (cond + [(not ssh-cmd) (auth-error "error: no command")] + [(not keyid) (auth-error "error: no ssh key id")] + [else (run-authed-command ssh-cmd keyid)])) new file mode 100644 --- /dev/null +++ b/src/gitsite/sshkeys.ss @@ -0,0 +1,70 @@ +(import (jerboa prelude) + (std misc process) + (std os fd) + (only (gitsite db) db-query) + (only (gitsite util) ensure-dir! new-token)) + +(export ssh-authorized-keys-path rewrite-authorized-keys! lookup-ssh-key-by-id + ssh-key-fingerprint) + +(def (ssh-authorized-keys-path) + (let ([file (try (getenv "GITSITE_SSH_KEYS_FILE") (catch (e) #f))]) + (or (and file (not (string=? file "")) file) + (path-join (or (getenv "HOME") "/home/gitsite") ".ssh" "authorized_keys")))) + +(def (lookup-ssh-key-by-id key-id) + (def rows (db-query "SELECT uid FROM ssh_keys WHERE id = ?" key-id)) + (if (null? rows) #f (caar rows))) + +(def (ssh-key-fingerprint key-text) + (def tmp (str "/tmp/gitsite-key-" (new-token) ".pub")) + (def out (try + (begin + (write-file-string tmp key-text) + (string-trim (run-process (list "ssh-keygen" "-lf" tmp)))) + (catch (e) #f))) + (try (delete-file tmp) (catch (e) (void))) + (if (and out (string-contains out " ")) + (let ([tokens (string-split out #\space)]) + (if (>= (length tokens) 2) (list-ref tokens 1) #f)) + #f)) + +(def (managed-entry key-id key-text) + (str "command=\"/usr/local/bin/gitsite ssh-auth " + (number->string key-id) + "\",no-agent-forwarding,no-port-forwarding,no-pty,no-X11-forwarding " + (string-trim key-text))) + +(def (rewrite-authorized-keys!) + (def path (ssh-authorized-keys-path)) + (def dir (path-directory path)) + (def keys (begin + (ensure-dir! dir) + (db-query "SELECT id, key FROM ssh_keys ORDER BY id"))) + (def entries (map (lambda (r) (managed-entry (car r) (cadr r))) keys)) + (def block (string-join (cons "# gitsite begin" (append entries (list "# gitsite end"))) "\n")) + (def old (if (file-exists? path) (read-file-string path) "")) + (def begin-idx (string-contains old "# gitsite begin")) + (def end-idx (string-contains old "# gitsite end")) + (def prefix-part + (if begin-idx + (substring old 0 begin-idx) + old)) + (def suffix-part + (if (and begin-idx end-idx) + (substring old (+ end-idx (string-length "# gitsite end")) (string-length old)) + "")) + (def trimmed-prefix (string-trim prefix-part)) + (def trimmed-suffix (string-trim suffix-part)) + (def new (str trimmed-prefix + (if (string=? trimmed-prefix "") "" "\n") + block "\n" + trimmed-suffix + (if (string=? trimmed-suffix "") "" "\n"))) + (def tmp (str path ".tmp." (new-token))) + (def done (begin + (write-file-string tmp new) + (process-wait (spawn-process (list "chmod" "600" tmp))) + (process-wait (spawn-process (list "mv" tmp path))) + #t)) + (void)) --- a/src/gitsite/web.ss +++ b/src/gitsite/web.ss @@ -1,11 +1,13 @@ (import (jerboa prelude) - (sinatra) - (only (gitsite config) cfg-registration-open?) - (only (gitsite util) sha256-hex valid-slug?) + (except (sinatra) param redirect) + (only (std misc process) run-process) + (only (gitsite config) cfg-registration-open? cfg-builds-mode) + (only (gitsite util) sha256-hex valid-slug? new-token) (only (gitsite req) csrf-token csrf-ok?) + (only (gitsite sshkeys) rewrite-authorized-keys! ssh-key-fingerprint) (only (gitsite auth) register-user! authenticate-user create-session! get-session-user destroy-session! add-ssh-key! list-ssh-keys delete-ssh-key! - user-by-id) + user-by-id make-token! list-tokens delete-token!) (only (gitsite repo) repo-path create-repo! get-repo-by-owner-name list-public-repos list-user-repos set-visibility! delete-repo!) (only (gitsite git) git-log-alist git-show-alist git-cat-file git-ls-tree-alist git-refs git-readme git-blob) @@ -13,7 +15,7 @@ (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)) + (only (sinatra request) sinatra-request-raw sinatra-request-method sinatra-request-body-params)) (export setup-routes!) @@ -25,6 +27,21 @@ (def (current-name) (def user (current-user)) (and user (cdr (assq 'name user)))) +;; Work around vendored sinatra limitations without patching the dependency: +;; 1. `param` only reads query params; merge body params for POST/PUT/PATCH/DELETE. +;; 2. `redirect` halts and skips session save; use a non-halting variant so +;; session cookies survive login/registration redirects. +(def (param name) + (or (hash-get (current-params) name) + (let ([method (sinatra-request-method (request))]) + (if (memq method '(POST PUT PATCH DELETE)) + (hash-get (sinatra-request-body-params (request)) name) + #f)))) + +(def (redirect path) + (status! 302) + (header! "Location" path) + (void)) (def (current-sid) (def token (session-ref "sid-token")) @@ -84,9 +101,9 @@ ,(tab "settings" (str "/~" owner "/" name "/settings") "settings"))) (def (commit-li base c) - (def sha (cdr (assq 'sha c))) + (def sha (cdr (assq 'id c))) (def short (cdr (assq 'short c))) - (def subject (cdr (assq 'subject c))) + (def subject (cdr (assq 'summary c))) (def author (cdr (assq 'author c))) `(li (a (@ (href ,(str base "/commit/" sha))) ,(or subject "(no subject)")) (span (@ (class "desc")) ,(str " " short " " author)))) @@ -119,6 +136,67 @@ (if (and (> (string-length s) 4) (string-suffix? ".git" s)) (substring s 0 (- (string-length s) 4)) s)) +(def (write-bytes! path bv) + (def p (open-file-output-port path)) + (put-bytevector p bv) + (close-port p)) + +(def (read-bytes! path (max-bytes 104857600)) + (if (not (file-exists? path)) + (make-bytevector 0) + (let ([p (open-file-input-port path)]) + (let ([bv (get-bytevector-all p)]) + (close-port p) + (if (> (bytevector-length bv) max-bytes) + #f + bv))))) + +(def (valid-ref? r) + (and (string? r) + (not (string=? r "")) + (not (string-contains r "..")) + (not (string-prefix? "/" r)) + (not (string-contains r " ")) + (let loop ([i 0]) + (or (>= i (string-length r)) + (let ([c (string-ref r i)]) + (and (or (and (char>=? c #\a) (char<=? c #\z)) + (and (char>=? c #\A) (char<=? c #\Z)) + (and (char>=? c #\0) (char<=? c #\9)) + (char=? c #\-) (char=? c #\_) (char=? c #\.) + (char=? c #\/)) + (loop (+ i 1)))))))) +(def (parse-offset o) + (if (and (string? o) + (not (string=? o "")) + (every char-numeric? (string->list o))) + (max 0 (inexact->exact (string->number o))) + 0)) + +(def (archive-tarball path ref) + (if (not (valid-ref? ref)) + #f + (let ([tmp (str "/tmp/gitsite-" (new-token) ".tar.gz")]) + (unwind-protect + (let ([ok (try + (begin + (run-process (list "git" "--git-dir" path "archive" "--format=tar.gz" "-o" tmp ref)) + (file-exists? tmp)) + (catch (e) #f))]) + (and ok + (let ([bv (read-bytes! tmp)]) + (if (or (not (bytevector? bv)) (zero? (bytevector-length bv))) #f bv)))) + (try (delete-file tmp) (catch (e) (void))))))) + +(def (serve-archive owner name ref) + (def bv (archive-tarball (repo-path owner name) ref)) + (if bv + (begin + (header! "Content-Type" "application/gzip") + (header! "Content-Disposition" (str "attachment; filename=\"" name "-" ref ".tar.gz\"")) + (body! bv) + (halt)) + (begin (status! 404) "not found"))) ;; Git smart-HTTP bridge handler (GET info/refs, POST git-upload-pack, etc.) (def (git-route-handler) @@ -134,6 +212,12 @@ ;; Health check (GET "/healthz" "ok") + (GET "/robots.txt" + (status! 200) + (header! "Content-Type" "text/plain") + (body! "User-agent: *\nAllow: /\n") + (halt)) + (GET "/git/~:owner/:name*" (git-route-handler)) (POST "/git/~:owner/:name*" (git-route-handler)) @@ -295,13 +379,14 @@ (let* ([title (string-trim (param "title"))] [key (string-trim (param "key"))] [uid (cdr (assq 'id (current-user)))] - [fingerprint (sha256-hex key)]) + [fingerprint (or (ssh-key-fingerprint key) (sha256-hex key))]) (if (or (string=? title "") (string=? key "")) (begin (status! 400) (render-sxml (page-html "ssh keys" (current-name) '((h1 "ssh keys") (p "all fields required"))))) (begin (add-ssh-key! uid title key fingerprint) + (rewrite-authorized-keys!) (redirect "/settings/keys"))))))) (POST "/settings/keys/:id/delete" @@ -313,7 +398,68 @@ (render-sxml (page-html "error" (current-name) '((h1 "403") (p "bad csrf"))))) (let ([uid (cdr (assq 'id (current-user)))]) (delete-ssh-key! uid (string->number (param "id"))) + (rewrite-authorized-keys!) (redirect "/settings/keys"))))) + ;; API tokens + (GET "/settings/tokens" + (if (not (current-user)) + (redirect "/login") + (let* ([uid (cdr (assq 'id (current-user)))] + [tokens (list-tokens uid)]) + (render-sxml + (page-html "api tokens" (current-name) + `((h1 "api tokens") + (h2 "add new token") + (form (@ (method "post") (action "/settings/tokens")) + ,(csrf-input) + (p (label "name ") (input (@ (name "name") (required "required")))) + (p (button (@ (type "submit")) "create token"))) + (h2 "your tokens") + ,(if (null? tokens) + '(p "no tokens") + `(ul ,@(map (lambda (t) + `(li (strong ,(cdr (assq 'name t))) + (span (@ (class "desc")) + ,(let ([lu (cdr (assq 'last_used_at t))]) + (if (and (string? lu) (not (string=? lu ""))) + (str " - created " (cdr (assq 'created_at t)) ", last used " lu) + (str " - created " (cdr (assq 'created_at t)))))) + (form (@ (method "post") (action ,(str "/settings/tokens/" (cdr (assq 'id t)) "/delete")) (style "display:inline")) + ,(csrf-input) + (button (@ (type "submit")) "delete")))) + tokens))))))))) + + (POST "/settings/tokens" + (if (not (current-user)) + (redirect "/login") + (if (not (check-csrf)) + (begin + (status! 403) + (render-sxml (page-html "error" (current-name) '((h1 "403") (p "bad csrf"))))) + (let* ([name (string-trim (param "name"))] + [uid (cdr (assq 'id (current-user)))]) + (if (string=? name "") + (begin + (status! 400) + (render-sxml (page-html "api tokens" (current-name) '((h1 "api tokens") (p "name required"))))) + (let ([raw (make-token! uid name)]) + (render-sxml + (page-html "api tokens" (current-name) + `((h1 "api token created") + (p "copy this token now - it will not be shown again:") + (pre (@ (class "tokenbox")) ,raw) + (p (a (@ (href "/settings/tokens")) "back to tokens"))))))))))) + + (POST "/settings/tokens/:id/delete" + (if (not (current-user)) + (redirect "/login") + (if (not (check-csrf)) + (begin + (status! 403) + (render-sxml (page-html "error" (current-name) '((h1 "403") (p "bad csrf"))))) + (let ([uid (cdr (assq 'id (current-user)))]) + (delete-token! uid (string->number (param "id"))) + (redirect "/settings/tokens"))))) ;; Builds (GET "/builds/:id" @@ -365,6 +511,7 @@ `(,(repo-tabs owner name "summary") (h1 ,(str "~" owner "/" name)) (p ,(or (cdr (assq 'description repo)) "")) + (p (a (@ (href ,(str "/~" owner "/" name "/archive/" branch ".tar.gz"))) "download snapshot")) (h2 "about") ,(if readme `(pre ,readme) '(p "no readme")) (h2 "recent commits") @@ -381,7 +528,8 @@ (begin (status! 404) "not found") (let* ([path (repo-path owner name)] [branch (repo-branch repo)] - [log (git-log-alist path branch 50 0)] + [offset (parse-offset (param "offset"))] + [log (git-log-alist path branch 50 offset)] [base (str "/~" owner "/" name)]) (render-sxml (page-html (str "log - ~" owner "/" name) (current-name) @@ -389,7 +537,10 @@ (h1 "commit log") ,(if (null? log) '(p "no commits") - `(ul (@ (class "loglist")) ,@(map (lambda (c) (commit-li base c)) log))))))))) + `(ul (@ (class "loglist")) ,@(map (lambda (c) (commit-li base c)) log))) + (p (a (@ (href ,(str base "/log?offset=" (number->string (max 0 (- offset 50)))))) "previous") + " | " + (a (@ (href ,(str base "/log?offset=" (number->string (+ offset 50))))) "next")))))))) ;; Repo commit (GET "/~:owner/:name/commit/:sha" @@ -430,6 +581,17 @@ (h1 "tags") ,(if (null? tags) '(p "none") `(ul ,@(map (lambda (t) `(li ,t)) tags))))))))) + ;; Repo archive download + (GET "/~:owner/:name/archive/:ref.tar.gz" + (def owner (param "owner")) + (def name (param "name")) + (def ref (param "ref")) + (def repo (open-repo owner name)) + (cond + [(not repo) (status! 404) "not found"] + [(not (valid-ref? ref)) (status! 400) "bad ref"] + [else (serve-archive owner name ref)])) + ;; Repo tree (GET "/~:owner/:name/tree/*" (def owner (param "owner")) @@ -507,7 +669,7 @@ [branch (repo-branch repo)] [manifest (git-blob path branch ".build.yml")] [log (git-log-alist path branch 1 0)] - [sha (if (null? log) "" (cdr (assq 'sha (car log))))]) + [sha (if (null? log) "" (cdr (assq 'id (car log))))]) (cond [(not manifest) (status! 400) @@ -518,7 +680,10 @@ [else (let ([jid (submit-job! (repo-id repo) sha manifest)]) (if jid - (begin (run-one-job jid) (redirect (str "/builds/" (number->string jid)))) + (begin + (when (string=? (cfg-builds-mode) "sync") + (run-one-job jid)) + (redirect (str "/builds/" (number->string jid)))) (begin (status! 400) (render-sxml (page-html "builds" (current-name) '((h1 "builds") (p "invalid manifest")))))))]))])) --- a/src/gitsite/worker.ss +++ b/src/gitsite/worker.ss @@ -1,15 +1,18 @@ (import (jerboa prelude) (std misc process) + (only (chezscheme) rename-file directory-list) (only (std misc thread) thread-sleep!) - (only (gitsite db) db-query) - (only (gitsite config) cfg-builds-dir cfg-artifacts-dir) + (only (gitsite db) db-query db-execute) + (only (gitsite config) cfg-builds-dir cfg-artifacts-dir + cfg-spool-new cfg-spool-run cfg-spool-done) (only (gitsite builds) get-job claim-job! set-job-running! finish-job! job-log-path) (only (gitsite manifest) parse-manifest manifest-ok? manifest-error manifest-tasks manifest-artifacts manifest-environment task-name task-script)