;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson
;;; Copyright © 2015, 2016 Ludovic Courtès
;;; Copyright © 2016 ng0
;;; Copyright © 2016 Julien Lepiller
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see .
(define-module (gnu services web)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system shadow)
#:use-module (gnu packages admin)
#:use-module (gnu packages web)
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (nginx-configuration
nginx-configuration?
nginx-block-server
nginx-access
nginx-option
nginx-listen
nginx-service
nginx-service-type))
;;; Commentary:
;;;
;;; Web services.
;;;
;;; Code:
(define-record-type*
nginx-configuration make-nginx-configuration
nginx-configuration?
(nginx nginx-configuration-nginx) ;
(log-directory nginx-configuration-log-directory) ;string
(run-directory nginx-configuration-run-directory) ;string
(http-configs nginx-configuration-http-configs)
(events-configs nginx-configuration-events-configs)
(blocks nginx-configuration-blocks)
(file nginx-configuration-file)) ;string | file-like
(define-record-type*
nginx-option make-nginx-option
nginx-option?
(type nginx-option-type)
(value nginx-option-value))
(define-record-type*
nginx-block-server make-nginx-block-server
nginx-block-server?
(blocks nginx-block-server-blocks)
(configs nginx-block-server-configs))
(define-record-type*
nginx-listen make-nginx-listen
nginx-listen?
(port nginx-listen-port
(default 80))
(address nginx-listen-address
(default #f))
(socket nginx-listen-socket
(default #f))
(ssl? nginx-listen-ssl?
(default #f))
(http2? nginx-listen-http2?
(default #f))
(spdy? nginx-listen-spdy?
(default #f))
(proxy? nginx-listen-proxy?
(default #f)))
(define-record-type*
nginx-error-page make-nginx-error-page
nginx-error-page?
(codes nginx-error-page-codes
(default (list 404)))
(response nginx-error-page-response
(default #f))
(uri nginx-error-page-uri
(default "/404.html")))
(define-record-type*
nginx-access make-nginx-access
nginx-access?
(deny? nginx-access-restriction
(default #t))
(to nginx-access-to
(default 'all))
(except nginx-access-except
(default '())))
(define (config-domain-strings names)
"Return a string denoting the nginx config representation of NAMES, a list
of domain names."
(string-concatenate
(map (match-lambda
('default "_ ")
((? string? str) (string-append str " ")))
names)))
(define (config-index-strings names)
"Return a string denoting the nginx config representation of NAMES, a list
of index files."
(string-concatenate
(map (match-lambda
((? string? str) (string-append str " ")))
names)))
(define (config-code-strings codes)
"Return a string denoting the nginx config representation of CODES, a list
of HTTP response code."
(string-concatenate
(map (match-lambda
((? number? n) (string-append (number->string n) " ")))
codes)))
(define (nginx-listen-config listen)
(match listen
(($ port address socket ssl? http2? spdy? proxy?)
#~(string-append "listen "
#$(if address
(if port
(string-append address ":" (number->string port))
address)
(if port
(number->string port)
(string-append "unix:" socket)))
#$(if ssl? "http2 " (if spdy? "spdy " " "))
#$(if proxy? "proxy_protocol" "")
";"))))
(define (nginx-error-page-config error)
(match error
(($ codes response uri)
#~(string-append "error_page " #$(config-code-strings codes)
#$(match response
(#f "")
('proxy "=")
((? number? n) (string-append "=" (number->string n))))
#$uri ";"))))
(define (nginx-access-config access)
(match access
(($ deny? to except)
#~(string-append
#$(let ((except-list
(map nginx-access-config except)))
(do ((except-list except-list (cdr except-list))
(block "" #~(string-append #$(car except-list) "\n" #$block )))
((null? except-list) block)))
#$(if deny? "deny " "allow ")
#$(match to
('all "all")
('unix "unix:")
(_ to))
";"))))
(define (authorized-option-type type)
(match type
('http (list 'access 'error_page 'etag 'index 'if_modified_since
'ignore_invalid_headers 'log_not_found 'log_subrequest
'merge_slashes 'port_in_redirect 'recursive_error_pages 'root
'server_name_in_redirect 'server_tokens))
('server (list 'access 'error_page 'etag 'index 'if_modified_since
'ignore_invalid_headers 'listen 'log_not_found 'log_subrequest
'merge_slashes 'port_in_redirect 'recursive_error_pages 'root
'server_name 'server_name_in_redirect 'server_tokens 'try_files))
('location (list 'access 'alias 'error_page 'etag 'if_modified_since 'index
'internal 'log_not_found 'log_subrequest 'port_in_redirect
'recursive_error_pages 'root 'server_name_in_redirect
'server_tokens 'try_files))
('if (list 'error_page 'root))
('limit_except (list 'access))
('events (list))))
(define (assert-good-type conf-type block-type)
(if (not (memq conf-type (authorized-option-type block-type)))
(throw 'bad-conf-type
(string-append (symbol->string conf-type)
" is not allowed in a "
(symbol->string block-type)
" block."))))
(define (default-nginx-option-config name value)
#~(string-append #$(symbol->string name) " " #$value ";"))
(define (nginx-option-config option parent-block-type)
(assert-good-type (nginx-option-type option) parent-block-type)
(match option
(($ type value)
(match type
('access (nginx-access-config value))
('error_page (nginx-error-page-config value))
('if_modified_since (match value
(#f "if_modified_since off;")
('exact "if_modified_since exact;")
('before "if_modified_since before;")))
('internal (if value "internal;" ""))
('listen (nginx-listen-config value))
('server_name #~(string-append "server_name "
#$(config-domain-strings value) ";"))
('index #~(string-append "index " #$(config-index-strings value) ";"))
('try_files #~(string-append "try_files "
#$(config-index-strings value)) ";")
(_ (match value
((? number? n) (default-nginx-option-config type (number->string n)))
(#t default-nginx-option-config type "on")
(#f default-nginx-option-config type "off")
(_ (default-nginx-option-config type value))))))))
(define (authorized-block-type type)
(match type
('http (list 'server 'types))
('location (list 'if 'limit_except 'location 'types))
('server (list 'location 'types))))
(define (assert-good-block-type block-type parent-type)
(if (not (memq block-type (authorized-block-type parent-type)))
(throw 'bad-block-type
(string-append (symbol->string block-type)
" is not allowed in a "
(symbol->string parent-type)
" block."))))
(define (nginx-block-server-config blocks options parent-type)
(assert-good-block-type 'server parent-type)
#~(string-append
" server {\n"
#$(let ((config-list
(map (lambda (option)
(nginx-option-config option 'server))
options)))
(do ((config-list config-list (cdr config-list))
(block "" #~(string-append #$(car config-list) "\n" #$block )))
((null? config-list) block)))
#$(let ((block-list
(map (lambda (block)
(nginx-block-config block 'server)) blocks)))
(do ((block-list block-list (cdr block-list))
(block "" #~(string-append #$(car block-list) "\n" #$block )))
((null? block-list) block)))
; #$(if (eq? options '())
; ""
; #~(string-concatenate
; #$(map (lambda (option)
; (nginx-option-config option 'server))
; options)))
; #$(if (eq? blocks '())
; ""
; (string-concatenate
; (map (lambda (block)
; (nginx-block-config block 'server))
; blocks)))
" }\n"))
(define (nginx-block-config block parent-type)
(match block
(($ blocks options)
(nginx-block-server-config blocks options parent-type))
(_ "")))
(define (default-nginx-config log-directory run-directory http-configs
events-configs blocks)
(computed-file "nginx.conf"
#~(call-with-output-file #$output
(lambda (port)
(format port
(string-append
"user nginx nginx;\n"
"pid " #$run-directory "/pid;\n"
"error_log " #$log-directory "/error.log info;\n"
"http {\n"
" client_body_temp_path " #$run-directory "/client_body_temp;\n"
" proxy_temp_path " #$run-directory "/proxy_temp;\n"
" fastcgi_temp_path " #$run-directory "/fastcgi_temp;\n"
" uwsgi_temp_path " #$run-directory "/uwsgi_temp;\n"
" scgi_temp_path " #$run-directory "/scgi_temp;\n"
" access_log " #$log-directory "/access.log;\n"
#$(let ((config-list
(map (lambda (option)
(nginx-option-config option 'http))
http-configs)))
(do ((config-list config-list (cdr config-list))
(block "" #~(string-append #$(car config-list) "\n" #$block )))
((null? config-list) block)))
#$(let ((block-list
(map (lambda (block)
(nginx-block-config block 'http)) blocks)))
(do ((block-list block-list (cdr block-list))
(block "" #~(string-append #$(car block-list) "\n" #$block )))
((null? block-list) block)))
"}\n"
"events {\n"
#$(let ((config-list
(map (lambda (option)
(nginx-option-config option 'http))
events-configs)))
(do ((config-list config-list (cdr config-list))
(block "" #~(string-append #$(car config-list) "\n" #$block )))
((null? config-list) block)))
"}\n"))))))
(define %nginx-accounts
(list (user-group (name "nginx") (system? #t))
(user-account
(name "nginx")
(group "nginx")
(system? #t)
(comment "nginx server user")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define nginx-activation
(match-lambda
(($ nginx log-directory run-directory http-configs
events-configs blocks file)
#~(begin
(use-modules (guix build utils))
(format #t "creating nginx log directory '~a'~%" #$log-directory)
(mkdir-p #$log-directory)
(format #t "creating nginx run directory '~a'~%" #$run-directory)
(mkdir-p #$run-directory)
(format #t "creating nginx temp directories '~a/{client_body,proxy,fastcgi,uwsgi,scgi}_temp'~%" #$run-directory)
(mkdir-p (string-append #$run-directory "/client_body_temp"))
(mkdir-p (string-append #$run-directory "/proxy_temp"))
(mkdir-p (string-append #$run-directory "/fastcgi_temp"))
(mkdir-p (string-append #$run-directory "/uwsgi_temp"))
(mkdir-p (string-append #$run-directory "/scgi_temp"))
;; Check configuration file syntax.
(system* (string-append #$nginx "/sbin/nginx")
"-t" "-c" #$(or file
(default-nginx-config log-directory run-directory
http-configs events-configs blocks)))))))
(define nginx-shepherd-service
(match-lambda
(($ nginx log-directory run-directory http-configs
events-configs blocks file)
(let* ((nginx-binary (file-append nginx "/sbin/nginx"))
(nginx-action
(lambda args
#~(lambda _
(zero?
(system* #$nginx-binary "-c"
#$(or file
(default-nginx-config log-directory run-directory
http-configs events-configs blocks))
address@hidden))))))
;; TODO: Add 'reload' action.
(list (shepherd-service
(provision '(nginx))
(documentation "Run the nginx daemon.")
(requirement '(user-processes loopback))
(start (nginx-action "-p" run-directory))
(stop (nginx-action "-s" "stop"))))))))
(define nginx-service-type
(service-type (name 'nginx)
(extensions
(list (service-extension shepherd-root-service-type
nginx-shepherd-service)
(service-extension activation-service-type
nginx-activation)
(service-extension account-service-type
(const %nginx-accounts))))
(compose concatenate)
(extend (lambda (config blocks)
(nginx-configuration
(inherit config)
(blocks (append (nginx-configuration-blocks config)
blocks)))))))
(define* (nginx-service #:key (nginx nginx)
(log-directory "/var/log/nginx")
(run-directory "/var/run/nginx")
(http-configs '())
(events-configs '())
(blocks '())
(config-file #f))
"Return a service that runs NGINX, the nginx web server.
The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log
files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
(service nginx-service-type
(nginx-configuration
(nginx nginx)
(log-directory log-directory)
(run-directory run-directory)
(http-configs http-configs)
(events-configs events-configs)
(blocks blocks)
(file config-file))))