Replace define-runtime-path with custom anytime-path function

This commit is contained in:
Cadence Ember 2023-03-08 22:56:04 +13:00
parent e0fec5fa9c
commit 453570bdc9
Signed by untrusted user: cadence
GPG key ID: BC1C2C61CF521B17
6 changed files with 50 additions and 11 deletions

View file

@ -1,5 +1,6 @@
text/html html text/html html
text/css css text/css css
application/xml xml
text/xml xml text/xml xml
image/gif gif image/gif gif
image/jpeg jpeg image/jpeg jpeg
@ -25,6 +26,7 @@ application/font-woff2 woff2
application/acad woff2 application/acad woff2
font/woff2 woff2 font/woff2 woff2
application/font-woff woff application/font-woff woff
font/woff woff
application/x-font-ttf ttf application/x-font-ttf ttf
application/x-font-truetype ttf application/x-font-truetype ttf
application/x-truetype-font ttf application/x-truetype-font ttf

View file

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base syntax/location))
(provide (provide
; help make a nested if. if/in will gain the same false form of its containing if/out. ; help make a nested if. if/in will gain the same false form of its containing if/out.
@ -7,7 +7,12 @@
; cond, but values can be defined between conditions ; cond, but values can be defined between conditions
cond/var cond/var
; wrap sql statements into lambdas so they can be executed during migration ; wrap sql statements into lambdas so they can be executed during migration
wrap-sql) wrap-sql
; get the name of the file that contains the currently evaluating form
this-directory
this-file
; replacement for define-runtime-path
anytime-path)
(module+ test (module+ test
(require rackunit) (require rackunit)
@ -96,6 +101,16 @@
(check-equal? (if/out #t (if/in #f 'yes) 'no) 'no) (check-equal? (if/out #t (if/in #f 'yes) 'no) 'no)
(check-equal? (if/out #f (if/in #f 'yes) 'no) 'no)) (check-equal? (if/out #f (if/in #f 'yes) 'no) 'no))
(define-syntax (this-directory stx)
(datum->syntax stx (syntax-source-directory stx)))
(define-syntax (this-file stx)
(datum->syntax stx (build-path (or (syntax-source-directory stx) 'same) (syntax-source-file-name stx))))
(module+ test
(require racket/path)
(check-equal? (file-name-from-path (this-file)) (build-path "syntax.rkt")))
(define-syntax (cond/var stx) (define-syntax (cond/var stx)
(transform/out-cond/var stx)) (transform/out-cond/var stx))
(module+ test (module+ test
@ -103,7 +118,28 @@
#'(cond #'(cond
[#f 0] [#f 0]
[#t [#t
(let ([d (* a 2)]) (let* ([d (* a 2)])
(cond (cond
[(eq? d 8) d] [(eq? d 8) d]
[#t "not 4"]))]))) [#t "not 4"]))])))
;;; Replacement for define-runtime-path that usually works well and doesn't include the files/folder contents into the distribution.
;;; When running from source, should always work appropriately.
;;; When running from a distribution, (current-directory) is treated as the root.
;;; Usage:
;;; * to-root : Path-String * relative path from the source file to the project root
;;; * to-dest : Path-String * relative path from the root to the desired file/folder
(define-syntax (anytime-path stx)
(define-values (_ to-root to-dest) (apply values (syntax->list stx)))
(define source (syntax-source stx))
(unless (complete-path? source)
(error 'anytime-path "syntax source has no directory: ~v" stx))
(datum->syntax
stx
`(let* ([syntax-to-root (build-path (path-only ,source) ,to-root)]
[root (if (directory-exists? syntax-to-root)
;; running on the same filesystem it was compiled on, i.e. it's running the source code out of a directory, and the complication is the intermediate compilation
syntax-to-root
;; not running on the same filesystem, i.e. it's a distribution. we assume that the current working directory is where the executable is, and treat this as the root.
(current-directory))])
(simple-form-path (build-path root ,to-dest)))))

View file

@ -8,8 +8,8 @@
db db
memo memo
"static-data.rkt" "static-data.rkt"
"../lib/url-utils.rkt"
"whole-utils.rkt" "whole-utils.rkt"
"../lib/url-utils.rkt"
"../lib/xexpr-utils.rkt" "../lib/xexpr-utils.rkt"
"../archiver/archiver-database.rkt" "../archiver/archiver-database.rkt"
"config.rkt") "config.rkt")
@ -42,8 +42,8 @@
[(config-true? 'feature_offline::only) [(config-true? 'feature_offline::only)
(when (config-true? 'debug) (when (config-true? 'debug)
(printf "using offline mode for siteinfo ~a~n" wikiname)) (printf "using offline mode for siteinfo ~a~n" wikiname))
(define row (query-maybe-row slc "select sitename, basepage, license_text, license_url from wiki where wikiname = ?" (define row (query-maybe-row* "select sitename, basepage, license_text, license_url from wiki where wikiname = ?"
wikiname)) wikiname))
(if row (if row
(siteinfo^ (vector-ref row 0) (siteinfo^ (vector-ref row 0)
(vector-ref row 1) (vector-ref row 1)

View file

@ -2,7 +2,6 @@
(require racket/file (require racket/file
racket/path racket/path
racket/port racket/port
racket/runtime-path
racket/string racket/string
net/url net/url
web-server/http web-server/http
@ -11,6 +10,7 @@
(only-in web-server/dispatchers/dispatch next-dispatcher) (only-in web-server/dispatchers/dispatch next-dispatcher)
"../archiver/archiver.rkt" "../archiver/archiver.rkt"
"../lib/mime-types.rkt" "../lib/mime-types.rkt"
"../lib/syntax.rkt"
"../lib/xexpr-utils.rkt" "../lib/xexpr-utils.rkt"
"config.rkt" "config.rkt"
"log.rkt") "log.rkt")
@ -18,7 +18,7 @@
(provide (provide
page-static-archive) page-static-archive)
(define-runtime-path path-archive "../storage/archive") (define path-archive (anytime-path ".." "storage/archive"))
(define ((replacer wikiname) whole url) (define ((replacer wikiname) whole url)
(format (format

View file

@ -8,6 +8,7 @@
(only-in web-server/dispatchers/dispatch next-dispatcher) (only-in web-server/dispatchers/dispatch next-dispatcher)
(prefix-in files: web-server/dispatchers/dispatch-files) (prefix-in files: web-server/dispatchers/dispatch-files)
"../lib/mime-types.rkt" "../lib/mime-types.rkt"
"../lib/syntax.rkt"
"config.rkt") "config.rkt")
(provide (provide
@ -17,7 +18,7 @@
(require rackunit)) (require rackunit))
(define-runtime-path path-static "../static") (define-runtime-path path-static "../static")
(define-runtime-path path-archive "../storage/archive") (define path-archive (anytime-path ".." "storage/archive"))
(define hash-ext-mime-type (define hash-ext-mime-type
(hash #".css" #"text/css" (hash #".css" #"text/css"

View file

@ -4,7 +4,7 @@
racket/function racket/function
racket/list racket/list
racket/match racket/match
racket/runtime-path racket/path
racket/string racket/string
; libs ; libs
(prefix-in easy: net/http-easy) (prefix-in easy: net/http-easy)
@ -38,7 +38,7 @@
(module+ test (module+ test
(require rackunit)) (require rackunit))
(define-runtime-path path-archive "../storage/archive") (define path-archive (anytime-path ".." "storage/archive"))
(define (page-wiki-offline req) (define (page-wiki-offline req)
(response-handler (response-handler