├── .Dockerignore ├── .github └── workflows │ └── push.yml ├── .gitignore ├── Dockerfile ├── Dockerfile.built ├── LICENSE ├── Makefile ├── README.md ├── built-snapshot.rkt ├── common.rkt ├── configs ├── Makefile ├── README.md ├── files │ ├── etc │ │ ├── cron.d │ │ │ ├── fix-cpu-scaling │ │ │ └── take-snapshot │ │ ├── nginx │ │ │ └── sites-enabled │ │ │ │ └── 50-racksnaps │ │ └── systemd │ │ │ └── system │ │ │ └── racksnaps-site.service │ └── usr │ │ └── local │ │ └── bin │ │ ├── fix-cpu-scaling.sh │ │ └── snapshot.sh └── script ├── deduplication.rkt ├── http.rkt ├── logging.rkt ├── site.rkt ├── snapshot.rkt ├── sugar.rkt ├── term.rkt └── test.sh /.Dockerignore: -------------------------------------------------------------------------------- 1 | * 2 | 3 | ! Dockerfile -------------------------------------------------------------------------------- /.github/workflows/push.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | pull_request: 6 | schedule: 7 | - cron: "0 8 * * MON" 8 | 9 | jobs: 10 | test: 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v1 14 | - name: test one package 15 | run: ./test.sh component-lib 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | built-snapshots 2 | cache 3 | snapshots 4 | store 5 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM racket/racket:8.7-full 2 | 3 | RUN apt-get update \ 4 | && apt-get install -y dumb-init 5 | 6 | RUN raco pkg config --set download-cache-max-files 1024000 \ 7 | && raco pkg config --set download-cache-max-bytes 107374182400 \ 8 | && raco pkg config --set trash-max-packages 0 \ 9 | && raco pkg config --set trash-max-seconds 0 10 | -------------------------------------------------------------------------------- /Dockerfile.built: -------------------------------------------------------------------------------- 1 | FROM racket/racket:8.7-full 2 | 3 | RUN apt-get update \ 4 | && apt-get install -y apt-transport-https ca-certificates curl gnupg-agent software-properties-common \ 5 | && curl -fsSL https://download.docker.com/linux/debian/gpg | apt-key add - \ 6 | && apt-key fingerprint 0EBFCD88 \ 7 | && add-apt-repository "deb [arch=amd64] https://download.docker.com/linux/debian $(lsb_release -cs) stable" \ 8 | && apt-get update \ 9 | && apt-get install -y docker-ce-cli dumb-init tzdata \ 10 | && apt-get remove -y apt-transport-https curl gnupg-agent software-properties-common \ 11 | && apt-get clean -y \ 12 | && rm -rf /var/lib/apt/lists/* 13 | 14 | RUN raco pkg config --set download-cache-max-files 1024000 \ 15 | && raco pkg config --set download-cache-max-bytes 107374182400 \ 16 | && raco pkg config --set trash-max-packages 0 \ 17 | && raco pkg config --set trash-max-seconds 0 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: docker-images 2 | docker-images: 3 | docker build -t bogdanp/racksnaps:8.7 -f Dockerfile . 4 | docker build -t bogdanp/racksnaps-built:8.7 -f Dockerfile.built . 5 | docker push bogdanp/racksnaps:8.7 6 | docker push bogdanp/racksnaps-built:8.7 7 | 8 | .PHONY: deploy 9 | deploy: 10 | rsync -avh --delete *.rkt racksnaps@racksnaps:/opt/racksnaps/ 11 | $(MAKE) -C configs/ 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # racksnaps 2 | 3 | [![CI](https://github.com/Bogdanp/racksnaps/actions/workflows/push.yml/badge.svg)](https://github.com/Bogdanp/racksnaps/actions/workflows/push.yml) 4 | 5 | This code builds daily snapshots of the official [Racket Package 6 | Catalog]. The intent is to allow application developers to depend on 7 | specific, unchanging sets of packages until they're ready to update 8 | their apps. 9 | 10 | The snapshots are currently available at https://racksnaps.defn.io/snapshots/ . 11 | 12 | To develop against the snapshot from November 16th, 2022, you might 13 | run the following command: 14 | 15 | raco pkg config --set catalogs \ 16 | https://download.racket-lang.org/releases/8.7/catalog/ \ 17 | https://racksnaps.defn.io/snapshots/2022/11/16/catalog/ \ 18 | https://pkgs.racket-lang.org \ 19 | https://planet-compats.racket-lang.org 20 | 21 | When building a web app in CI you might limit the catalog list to just 22 | the release catalog (for packages in the main distribution) and the 23 | snapshot: 24 | 25 | raco pkg config --set catalogs \ 26 | https://download.racket-lang.org/releases/8.7/catalog/ \ 27 | https://racksnaps.defn.io/snapshots/2022/11/16/catalog/ 28 | 29 | 30 | ## How it Works 31 | 32 | Every day at 12am UTC, the service queries all the packages on 33 | pkgs.racket-lang.org for metadata and source locations. It then 34 | creates a source package archive for each package whose sources are 35 | still valid. 36 | 37 | Snapshots are never modified once they succeed and a content 38 | addressing scheme is used for the individual packages to avoid using 39 | up too much disk space over time. 40 | 41 | The `snapshot.rkt` program creates the snapshots. 42 | 43 | ## Testing Changes 44 | 45 | The code relies on [Docker] so you'll need a system that supports it. 46 | 47 | To run a full build, you can invoke 48 | 49 | ./test.sh 50 | 51 | in the root of the repository. 52 | 53 | To run a build for a subset of packages, you can invoke `test.sh` with 54 | whichever packages you want to build: 55 | 56 | ./test.sh component component-lib component-doc 57 | 58 | 59 | ## License 60 | 61 | racksnaps is licensed under the 3-Clause BSD license. 62 | 63 | 64 | [Racket Package Catalog]: https://pkgs.racket-lang.org/ 65 | [Docker]: https://www.docker.com/ 66 | -------------------------------------------------------------------------------- /built-snapshot.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require net/url 4 | pkg/lib 5 | racket/file 6 | racket/format 7 | racket/match 8 | racket/port 9 | racket/system 10 | "common.rkt" 11 | "deduplication.rkt" 12 | "logging.rkt" 13 | "sugar.rkt") 14 | 15 | (define-logger build) 16 | (define-logger docker) 17 | (define-logger setup) 18 | (define stop-logger (start-logger '(build common deduper docker pkg setup))) 19 | 20 | (define docker 21 | (find-executable-path "docker")) 22 | 23 | (define BUILD_TIMEOUT 24 | (* 10 60 1000)) 25 | 26 | (define (build-package root-path snapshot-path built-snapshot-path name) 27 | (log-build-info "building package ~a" name) 28 | (match-define (list out _in _pid err control) 29 | (process* 30 | docker 31 | "run" 32 | "--rm" 33 | "--network" "none" 34 | "-e" "CI=1" 35 | "-e" "PLT_PKG_BUILD_SERVICE=1" 36 | (format "-v~a:~a" root-path root-path) 37 | "bogdanp/racksnaps-built:8.7" 38 | "dumb-init" 39 | "bash" "-c" 40 | @~a{ 41 | set -euo pipefail 42 | raco pkg config --set catalogs \ 43 | file://@|built-snapshot-path|/catalog/ \ 44 | file://@|snapshot-path|/catalog/ 45 | raco pkg install --batch --auto --fail-fast --no-docs @name 46 | raco pkg create --built --dest @|built-snapshot-path|/pkgs --from-install @name 47 | })) 48 | 49 | (define logger-thd 50 | (thread 51 | (lambda () 52 | (let loop () 53 | (with-handlers ([exn:fail? 54 | (lambda (e) 55 | (log-docker-warning "~a~nerror: ~a" name (exn-message e)))]) 56 | (sync 57 | (handle-evt 58 | (thread-receive-evt) 59 | void) 60 | (handle-evt 61 | (read-line-evt out) 62 | (lambda (line) 63 | (unless (eof-object? line) 64 | (log-docker-debug "~a: ~a" name line)) 65 | (loop))) 66 | (handle-evt 67 | (read-line-evt err) 68 | (lambda (line) 69 | (unless (eof-object? line) 70 | (log-docker-warning "~a: ~a" name line)) 71 | (loop))))))))) 72 | 73 | (sync 74 | (handle-evt 75 | (alarm-evt (+ (current-inexact-milliseconds) BUILD_TIMEOUT)) 76 | (lambda _ 77 | (control 'interrupt))) 78 | (thread 79 | (lambda () 80 | (control 'wait)))) 81 | 82 | (begin0 (eq? (control 'status) 'done-ok) 83 | (thread-send logger-thd 'stop))) 84 | 85 | (define (build-packages root-path snapshot-path built-snapshot-path names) 86 | (define built-catalog-path (build-path built-snapshot-path "catalog")) 87 | (define built-pkgs-path (build-path built-snapshot-path "pkgs")) 88 | (delete-directory/files built-snapshot-path #:must-exist? #f) 89 | (make-directory* (build-path built-catalog-path "pkg")) 90 | (make-directory* built-pkgs-path) 91 | 92 | (define total-pkgs (length names)) 93 | (define pkgs-all 94 | (for/fold ([pkgs-all (hash)]) 95 | ([name (in-list names)] 96 | [i (in-naturals 1)]) 97 | (with-handlers ([exn:fail? 98 | (lambda (e) 99 | (begin0 pkgs-all 100 | (log-build-error "failed to build ~a~n error: ~a" name (exn-message e))))]) 101 | (define built? 102 | (build-package root-path snapshot-path built-snapshot-path name)) 103 | (log-build-info "progress: [~a/~a]" i total-pkgs) 104 | (cond 105 | [built? 106 | (define info (call-with-input-file (build-path snapshot-path "catalog" "pkg" name) read)) 107 | (define new-checksum (file->string (build-path built-pkgs-path (format "~a.zip.CHECKSUM" name)))) 108 | (define new-info 109 | (~> info 110 | (hash-set 'checksum new-checksum) 111 | (hash-set 'versions (hasheq 'default (hasheq 'source ('source info) 112 | 'checksum new-checksum))))) 113 | (write/rktd (build-path built-catalog-path "pkg" name) new-info) 114 | (hash-set pkgs-all name new-info)] 115 | 116 | [else 117 | (begin0 pkgs-all 118 | (log-build-warning "failed to build ~a" name))])))) 119 | 120 | (write/rktd (build-path built-catalog-path "pkgs") (sort (hash-keys pkgs-all) stringstring 150 | (sort/topological 151 | (for/hasheq ([(name details) (get-all-pkg-details-from-catalogs)]) 152 | (values (string->symbol name) 153 | (for/list ([dep (in-list (hash-ref details 'dependencies null))]) 154 | (string->symbol 155 | (cond 156 | [(string? dep) dep] 157 | [(list? dep) (car dep)] 158 | [else (raise-argument-error 'get-all-pkg-names/topological "(or/c string? list?)" dep)])))))))) 159 | 160 | (module+ main 161 | (require racket/cmdline) 162 | (command-line 163 | #:args (root-path snapshot-path built-snapshot-path store-path . pkgs) 164 | (file-stream-buffer-mode (current-output-port) 'line) 165 | (parameterize ([current-pkg-catalogs (list (path->url (build-path snapshot-path "catalog")))]) 166 | (define packages-to-build (if (null? pkgs) (get-all-pkg-names/topological) pkgs)) 167 | (log-build-info "about to build ~a packages" (length packages-to-build)) 168 | (build-packages root-path snapshot-path built-snapshot-path packages-to-build) 169 | (dedupe-snapshot built-snapshot-path store-path) 170 | (fix-catalog-checksums built-snapshot-path) 171 | (make-done-cookie built-snapshot-path) 172 | (stop-logger)))) 173 | -------------------------------------------------------------------------------- /common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | make-done-cookie 5 | write/rktd) 6 | 7 | (define-logger common) 8 | 9 | (define (make-done-cookie snapshot-path) 10 | (define cookie-path (build-path snapshot-path "catalog" "done")) 11 | (log-common-debug "creating ~a" cookie-path) 12 | (call-with-output-file cookie-path 13 | #:exists 'truncate/replace 14 | (lambda (out) 15 | (write 'done out)))) 16 | 17 | (define (write/rktd path data) 18 | (log-common-debug "writing ~a" path) 19 | (call-with-output-file path 20 | #:exists 'truncate/replace 21 | (lambda (out) 22 | (write data out)))) 23 | -------------------------------------------------------------------------------- /configs/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: deploy 2 | deploy: 3 | drist root@racksnaps 4 | -------------------------------------------------------------------------------- /configs/README.md: -------------------------------------------------------------------------------- 1 | # configs 2 | 3 | All the various bits of configuration intended to run on the snapshot 4 | server. Deployed with [drist]. 5 | 6 | [drist]: https://github.com/bogdanp/drist 7 | -------------------------------------------------------------------------------- /configs/files/etc/cron.d/fix-cpu-scaling: -------------------------------------------------------------------------------- 1 | @reboot root /usr/local/bin/fix-cpu-scaling.sh 2 | -------------------------------------------------------------------------------- /configs/files/etc/cron.d/take-snapshot: -------------------------------------------------------------------------------- 1 | @daily root /usr/local/bin/snapshot.sh >/dev/null 2 | -------------------------------------------------------------------------------- /configs/files/etc/nginx/sites-enabled/50-racksnaps: -------------------------------------------------------------------------------- 1 | upstream racksnaps_site_backend { 2 | server 127.0.0.1:8000; 3 | 4 | keepalive 128; 5 | } 6 | 7 | server { 8 | listen 80; 9 | listen 443 ssl; 10 | server_name racksnaps.defn.io; 11 | 12 | ssl_certificate /var/certs/racksnaps.defn.io.crt; 13 | ssl_certificate_key /var/certs/racksnaps.defn.io.key; 14 | ssl_protocols TLSv1 TLSv1.1 TLSv1.2; 15 | ssl_ciphers HIGH:!aNULL:!MD5; 16 | 17 | sendfile on; 18 | tcp_nopush on; 19 | tcp_nodelay on; 20 | 21 | root /var/www; 22 | 23 | location / { 24 | proxy_pass http://racksnaps_site_backend; 25 | proxy_http_version 1.1; 26 | proxy_connect_timeout 60s; 27 | proxy_send_timeout 60s; 28 | proxy_read_timeout 60s; 29 | proxy_set_header Connection ""; 30 | proxy_set_header Host $host; 31 | proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for; 32 | proxy_set_header X-Real-IP $remote_addr; 33 | proxy_intercept_errors on; 34 | } 35 | 36 | location /snapshots { 37 | autoindex on; 38 | } 39 | 40 | # Kept for backwards-compatibility. Points to /snapshots. 41 | location /built-snapshots { 42 | autoindex on; 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /configs/files/etc/systemd/system/racksnaps-site.service: -------------------------------------------------------------------------------- 1 | [Unit] 2 | Description=racksnaps-site 3 | 4 | [Service] 5 | ExecStart= \ 6 | /usr/bin/docker run \ 7 | --rm \ 8 | -v /var/racksnaps:/var/racksnaps \ 9 | -v /opt/racksnaps:/opt/racksnaps \ 10 | -p 8000:8000 \ 11 | --workdir /var/racksnaps \ 12 | bogdanp/racksnaps:8.7 \ 13 | dumb-init \ 14 | racket /opt/racksnaps/site.rkt 15 | 16 | [Install] 17 | WantedBy=multi-user.target -------------------------------------------------------------------------------- /configs/files/usr/local/bin/fix-cpu-scaling.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | echo performance | tee /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor 6 | -------------------------------------------------------------------------------- /configs/files/usr/local/bin/snapshot.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | VERSION=8.7 6 | SNAPSHOT_IMAGE="bogdanp/racksnaps:$VERSION" 7 | SNAPSHOT="$(date +%Y)/$(date +%m)/$(date +%d)" 8 | ROOT_PATH="/var/racksnaps" 9 | CODE_PATH="/opt/racksnaps" 10 | CACHE_PATH="$ROOT_PATH/cache" 11 | SNAPSHOT_PATH="$ROOT_PATH/snapshots/$SNAPSHOT" 12 | SNAPSHOT_LOG_PATH="$SNAPSHOT_PATH.log" 13 | STORE_PATH="$ROOT_PATH/store" 14 | 15 | rm -rf "$SNAPSHOT_PATH" 16 | mkdir -p "$SNAPSHOT_PATH" 17 | 18 | docker run \ 19 | --rm \ 20 | -v"$ROOT_PATH":"$ROOT_PATH" \ 21 | -v"$CODE_PATH":/code \ 22 | -v"$CACHE_PATH":/root/.racket/download-cache \ 23 | "$SNAPSHOT_IMAGE" \ 24 | dumb-init \ 25 | racket \ 26 | /code/snapshot.rkt \ 27 | "$SNAPSHOT_PATH" \ 28 | "$STORE_PATH" | tee "$SNAPSHOT_LOG_PATH" 29 | -------------------------------------------------------------------------------- /configs/script: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -euo pipefail 4 | 5 | log() { 6 | printf "[%s] %s\n" "$(date)" "$@" 7 | } 8 | 9 | if [ ! -d /var/racksnaps ]; then 10 | log "Creating /var/racksnaps..." 11 | sudo mkdir -p /var/racksnaps/{cache,snapshots,built-snapshots,store} 12 | sudo chown -R racksnaps:racksnaps /var/racksnaps 13 | fi 14 | 15 | if [ ! -L /var/www/snapshots ]; then 16 | log "Linking snapshots to www..." 17 | ln -s /var/racksnaps/snapshots /var/www/snapshots 18 | fi 19 | 20 | # For backwards compatibility. Points to regular snapshots. 21 | if [ ! -L /var/www/built-snapshots ]; then 22 | log "Linking built-snapshots to www..." 23 | ln -s /var/racksnaps/built-snapshots /var/www/snapshots 24 | fi 25 | 26 | log "Reloading nginx config..." 27 | service nginx reload 28 | 29 | log "Pulling docker images..." 30 | docker pull bogdanp/racksnaps:8.7 31 | docker pull bogdanp/racksnaps-built:8.7 32 | 33 | log "Pruning docker containers & images..." 34 | docker container prune -f 35 | docker image prune -f 36 | 37 | log "Reloading systemd daemon..." 38 | systemctl daemon-reload 39 | 40 | log "Restarting site service..." 41 | service racksnaps-site restart 42 | -------------------------------------------------------------------------------- /deduplication.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require file/unzip 4 | openssl/sha1 5 | racket/file 6 | racket/format 7 | racket/match 8 | racket/path 9 | racket/port 10 | "common.rkt" 11 | "sugar.rkt") 12 | 13 | (provide 14 | dedupe-snapshot 15 | fix-catalog-checksums) 16 | 17 | (define-logger deduper) 18 | 19 | ;; Zip files record the modification times of each file contained 20 | ;; within them so hashing them does not produce deterministic values. 21 | ;; Instead, we must sort the files by name and then hash the contents 22 | ;; of the files within the zips themselves, which is what this 23 | ;; function does. 24 | (define (zip-digest path) 25 | (call-with-unzip path 26 | (lambda (temp-path) 27 | (define-values (in out) 28 | (make-pipe)) 29 | 30 | (define sorted-paths 31 | (sort (find-files 32 | file-exists? 33 | temp-path) 34 | pathstring)) 92 | (define updated-metadata 93 | (~> metadata 94 | (hash-set 'checksum checksum) 95 | (hash-set 'versions (hash 'default (hash 'checksum checksum 96 | 'source ('source metadata)))))) 97 | (write/rktd path updated-metadata) 98 | (values ('name metadata) updated-metadata))) 99 | 100 | (write/rktd (build-path snapshot-path "catalog" "pkgs-all") pkgs-all)) 101 | -------------------------------------------------------------------------------- /http.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require net/http-client 4 | racket/format 5 | racket/match 6 | racket/port 7 | racket/string) 8 | 9 | (provide get) 10 | 11 | (define conn 12 | (http-conn-open 13 | "pkgs.racket-lang.org" 14 | #:ssl? #t 15 | #:port 443 16 | #:auto-reconnect? #t)) 17 | 18 | (define (get . path) 19 | (define-values (status _headers in) 20 | (http-conn-sendrecv! conn (~a "/" (string-join path "/")))) 21 | 22 | (match status 23 | [(regexp #rx"HTTP.... 200 ") 24 | (read in)] 25 | 26 | [(regexp #rx"HTTP.... [345].. ") 27 | (error 'get "failed to get path:~n path: ~a~n response: ~a" path (port->bytes in))])) 28 | -------------------------------------------------------------------------------- /logging.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/date 4 | racket/format 5 | racket/list 6 | racket/match 7 | racket/port 8 | "term.rkt") 9 | 10 | (provide 11 | start-logger) 12 | 13 | (define (start-logger topics) 14 | (define stopped (make-semaphore)) 15 | (define receiver 16 | (apply make-log-receiver 17 | (current-logger) 18 | (flatten 19 | (for/list ([topic (in-list topics)]) 20 | (list 'debug topic))))) 21 | 22 | (define (receive-logs) 23 | (sync 24 | (choice-evt 25 | (handle-evt receiver 26 | (match-lambda 27 | [(vector level message _ _) 28 | (fprintf (current-output-port) 29 | "[~a] [~a] ~a\n" 30 | (pretty-date) 31 | (with-output-to-string 32 | (lambda _ 33 | (colorize 34 | (case level 35 | [(debug) `((fg ,(make-color 0 0 4)))] 36 | [(info) `((fg ,(make-color 0 3 0)))] 37 | [(warning) `((fg ,(make-color 3 1 0)))] 38 | [(error) `((fg ,(make-color 3 0 0)))] 39 | [else null]) 40 | (display (~a level #:align 'right #:width 7))))) 41 | message) 42 | (receive-logs)])) 43 | stopped))) 44 | 45 | (define thd 46 | (thread receive-logs)) 47 | 48 | (lambda () 49 | (sync (system-idle-evt)) 50 | (semaphore-post stopped) 51 | (void (sync thd)))) 52 | 53 | (define (pretty-date) 54 | (define d (current-date)) 55 | (define o (quotient (date-time-zone-offset d) 60)) 56 | (~a (date-year d) 57 | "-" 58 | (padded (date-month d)) 59 | "-" 60 | (padded (date-day d)) 61 | " " 62 | (padded (date-hour d)) 63 | ":" 64 | (padded (date-minute d)) 65 | ":" 66 | (padded (date-second d)) 67 | " UTC" 68 | (cond 69 | [(zero? o) ""] 70 | [(negative? o) o] 71 | [else (~a "+" o)]))) 72 | 73 | (define (padded n [w 2]) 74 | (~r n #:min-width w #:pad-string "0")) 75 | -------------------------------------------------------------------------------- /site.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require (for-syntax racket/base 4 | syntax/parse) 5 | racket/file 6 | racket/format 7 | racket/match 8 | racket/string 9 | web-server/dispatch 10 | web-server/http 11 | web-server/servlet-dispatch 12 | web-server/web-server 13 | "logging.rkt") 14 | 15 | 16 | ;; core ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (struct catalog-cache-entry (paths deadline) 19 | #:transparent) 20 | 21 | (define catalog-cache-entry-ttl 300) 22 | 23 | (define (make-catalog-cache-entry paths) 24 | (catalog-cache-entry paths (+ (current-seconds) catalog-cache-entry-ttl))) 25 | 26 | (define (deadline-passed? deadline) 27 | (>= (current-seconds) deadline)) 28 | 29 | (define catalog-cache (make-hash)) 30 | (define catalog-cache-mu (make-semaphore 1)) 31 | 32 | ;; TODO: There should eventually be a limit on these. 33 | (define (find-catalogs start) 34 | (call-with-semaphore catalog-cache-mu 35 | (lambda () 36 | (match (hash-ref catalog-cache start #f) 37 | [(or #f (catalog-cache-entry _ (? deadline-passed?))) 38 | (define all-paths 39 | (find-files 40 | #:skip-filtered-directory? #t 41 | (lambda (p) 42 | (define-values (_snapshot-path filename _) 43 | (split-path p)) 44 | 45 | (case (path->string filename) 46 | [("pkg" "pkgs") #f] 47 | [("catalog") (file-exists? (build-path p "done"))] 48 | [else (directory-exists? p)])) 49 | start)) 50 | 51 | (define catalog-paths 52 | (for/list ([p (in-list all-paths)] 53 | #:when (string-suffix? (path->string p) "/catalog")) 54 | (path->string p))) 55 | 56 | (define sorted-paths 57 | (sort catalog-paths string>?)) 58 | 59 | (begin0 sorted-paths 60 | (hash-set! catalog-cache start (make-catalog-cache-entry sorted-paths)))] 61 | 62 | [(catalog-cache-entry paths _) 63 | paths])))) 64 | 65 | 66 | ;; ui ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | (define STYLE #<