Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
231 lines (205 sloc) 9.44 KB
#|
This file is a part of Radiance
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.radiance.core)
;; Sets up a default trigger for pages
(define-option page :hook (name body uri &optional (value T))
(declare (ignore uri))
(assert (symbolp value))
(if value
(let ((name (if (eql value T) name value)))
(values
`((trigger '(,name ,(package-name *package*)))
,@body)
`(define-hook (,name ,(package-name *package*)) ())))
body))
(define-option page :uri-groups (name body uri &optional uri-groups)
(declare (ignore name))
(if uri-groups
`((cl-ppcre:register-groups-bind ,uri-groups (,(path uri) (path (uri *request*)))
,@body))
body))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun transform-access-body (body branch type)
(if (not (eql branch T))
`((unless (and (auth:current)
,@(when branch `((user:check (auth:current) ,branch))))
(error ',type :message (format NIL "~a does not have access~@[ to ~s~]"
(user:username (or (auth:current) (user:get "anonymous"))) ,branch)))
,@body)
body)))
(define-option page :access (name body uri &optional (branch T))
(declare (ignore name uri))
(transform-access-body body branch 'request-denied))
(define-option api :access (name body args &optional (branch T))
(declare (ignore name args))
(transform-access-body body branch 'api-auth-error))
(define-option admin:panel :access (name body category &optional (branch T))
(declare (ignore name category))
(transform-access-body body branch 'request-denied))
(define-option profile:panel :access (name body &optional (branch T))
(declare (ignore name))
(transform-access-body body branch 'request-denied))
;; Standard serialisations
(defmethod api-serialize ((error radiance-condition))
(let ((table (make-hash-table)))
(flet ((s (k v) (setf (gethash (string-downcase k) table) v)))
(s :error-type (type-of error))
(s :message (message error))
(when (typep error 'request-error)
(s :uri (uri-to-url (uri (slot-value error 'request)) :representation :external)))
(when (typep error '(or api-argument-missing
api-argument-invalid))
(s :argument (slot-value error 'argument)))
(when (typep error 'api-unknown-format)
(s :format (slot-value error 'format))))
table))
;; Api catchall page
(define-api || () ()
(error 'api-call-not-found))
;; Api standard format
(define-api-format lisp (object)
(when (boundp '*response*)
(setf (content-type *response*) "text/x-sexpr"))
(with-output-to-string (stream)
(macrolet ((w (&rest args)
`(progn ,@(loop for arg in args
collect (etypecase arg
(string `(write-string ,arg stream))
(character `(write-char ,arg stream))
(list arg))))))
(labels ((output (object)
(typecase object
((or string symbol number)
(write object :stream stream))
(list
(w "("
(loop (typecase (cdr object)
(cons
(w (output (car object)) " ")
(setf object (cdr object)))
(null
(w (output (car object)))
(return))
(T (w (output (car object)) " . " (output (cdr object)))
(return))))
")"))
(vector
(w "#("
(when (< 0 (length object))
(output (aref object 0))
(loop for i from 1 below (length object)
do (w " " (output (aref object i)))))
")"))
(hash-table
(w "#{"
(loop for i downfrom (hash-table-count object)
for k being the hash-keys of object
for v being the hash-values of object
do (w (output k) ": " (output v))
(unless (= i 1) (w ", ")))
"}"))
(T (output (api-serialize object))))))
(output object)))))
(setf *default-api-format* "lisp")
;; Default urls
(define-page favicon ("/^favicon.ico$" 10) ()
(serve-file (static-file "favicon.ico" :radiance-core)))
(define-page robots ("/^robots.txt$" 10) ()
(serve-file (static-file "robots.txt" :radiance-core)))
(define-page static ("/^static/.*" 1000) ()
(let* ((path (path (uri *request*)))
(slashpos (position #\/ path :start (length "static/")))
(file (if slashpos
(ignore-errors
(static-file (parse-path-safely (subseq path (1+ slashpos))) (string-upcase (subseq path (length "static/") slashpos))))
(static-file (parse-path-safely (subseq path (length "static/"))) :radiance-core))))
(if (and file (uiop:file-exists-p file))
(serve-file file)
(error 'request-not-found))))
(defvar *config-routes* ())
(define-trigger (environment-change 'compile-config-routes) ()
(loop for (name direction) in *config-routes*
do (remove-route name direction))
(setf *config-routes* NIL)
(loop for (name direction from to priority) in (config :routes)
do (with-simple-restart (continue "Ignore the route definition.")
(funcall (ecompile NIL `(lambda () (define-string-route ,name (,direction ,(or priority 0)) ,from ,to))))
(push (list name direction) *config-routes*))))
;; Default routing to cut domains.
(defvar *domain-internalizers* ())
(defun add-domain (domain)
(pushnew domain (config :domains) :test #'string-equal)
(setf *domain-internalizers* (compile-domain-internalizers))
(config :domains))
(defun remove-domain (domain)
(setf (config :domains) (remove domain (config :domains) :test #'string-equal))
(setf *domain-internalizers* (compile-domain-internalizers))
(config :domains))
(defun compile-domain-internalizers (&optional (domains (config :domains)))
(loop for domain in domains
collect (let ((parts (nreverse (cl-ppcre:split "\\." domain)))
(domain domain))
(lambda (uri)
(loop for subdomains = (domains uri) then (cdr subdomains)
for a = (car subdomains)
for b in parts
when (or (not subdomains) (not (string-equal a b)))
do (return NIL)
finally (return (values domain subdomains)))))))
(define-trigger (environment-change 'compile-domain-internalizers) ()
(setf *domain-internalizers* (compile-domain-internalizers)))
(define-route domain (:mapping most-positive-fixnum) (uri)
(loop for internalizer in *domain-internalizers*
until (multiple-value-bind (domain subdomains) (funcall internalizer uri)
(when domain
(when (boundp '*request*)
(setf (domain *request*) domain))
(setf (domains uri) subdomains)
T))))
(define-route domain (:reversal most-negative-fixnum) (uri)
(cond
((boundp '*request*)
(push (domain *request*) (domains uri))
(unless (port uri)
(setf (port uri) (port (uri *request*)))))
;; KLUDGE! Find a better way to do this...
(T
(push (first (config :domains)) (domains uri))
(unless (port uri)
(setf (port uri) (config :port))))))
(define-route virtual-module (:mapping 100000) (uri)
(when (and (< 1 (length (path uri)))
(string= "!/" (path uri) :end2 2))
(let ((slashpos (position #\/ (path uri) :start 2)))
(let ((module (subseq (path uri) 2 slashpos))
(path (if slashpos
(subseq (path uri) (1+ slashpos))
"")))
(when (boundp '*request*)
(setf (gethash 'virtual-module (data *request*)) module))
(setf (path uri) path)
(setf (domains uri) (append (domains uri) (list module)))))))
(define-route virtual-module (:reversal -100000) (uri)
(when (boundp '*request*)
(let ((virtual (gethash 'virtual-module (data *request*)))
(last (car (last (domains uri)))))
(when virtual
;; Check if we are operating on the requested virtual domain
(cond ((string-equal virtual last)
(setf (path uri) (format NIL "!/~a/~a" virtual (path uri))
(domains uri) (butlast (domains uri))))
(last
;; Otherwise we need to use the specified subdomain as virtual
;; since we're trying to cross-reference a resource.
(setf (path uri) (format NIL "!/~a/~a" last (path uri))
(domains uri) (butlast (domains uri))))
((starts-with "api/" (path uri))
;; API requests need to retain the virtual module in case of
;; redirects back.
(setf (path uri) (format NIL "!/~a/~a" virtual (path uri))))
(T
;; Other refer, no change.
))))))