Subject: [bug#29741] [PATCH 2/2] gnu: services: web: Add service for apache-httpd.

From: Christopher Baines <[email-masked]>
Date: Sat, 16 Dec 2017 20:17:00 +0000

* gnu/services/web.scm (<apache-httpd-load-module>,
  <apache-httpd-config-file>, <apache-httpd-virtualhost>
  <apache-httpd-configuration>): New record types.
  (%default-apache-httpd-modules, %apache-httpd-accounts,
  apache-httpd-service-type): New variables.
  (apache-httpd-shepherd-services, apache-httpd-activation,
  apache-httpd-process-extensions): New procedures.
* gnu/tests/web.scm (run-apache-httpd-test): New procedure.
  (%apache-httpd-os, %tests-apache-httpd): New variables.
---
 gnu/services/web.scm | 227 ++++++++++++++++++++++++++++++++++++++++++++++++++-
 gnu/tests/web.scm    |  82 ++++++++++++++++++-
 2 files changed, 307 insertions(+), 2 deletions(-)

diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 582cf535c..8bfa1bc9b 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -33,8 +33,36 @@
   #:use-module ((guix utils) #:select (version-major))
   #:use-module ((guix packages) #:select (package-version))
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
-  #:export (<nginx-configuration>
+  #:export (<apache-httpd-configuration>
+            apache-httpd-configuration
+            apache-httpd-configuration?
+            apache-httpd-configuration-package
+            apache-httpd-configuration-pid-file
+            apache-httpd-configuration-config
+
+            <apache-httpd-virtualhost>
+            apache-httpd-virtualhost
+            apache-httpd-virtualhost?
+            apache-httpd-virtualhost-addresses-and-ports
+            apache-httpd-virtualhost-contents
+
+            <apache-httpd-config-file>
+            apache-httpd-config-file
+            apache-httpd-config-file?
+            apache-httpd-config-file-load-modules
+            apache-httpd-config-file-server-root
+            apache-httpd-config-file-server-name
+            apache-httpd-config-file-listen
+            apache-httpd-config-file-pid-file
+            apache-httpd-config-file-error-log
+            apache-httpd-config-file-user
+            apache-httpd-config-file-group
+
+            apache-httpd-service-type
+
+            <nginx-configuration>
             nginx-configuration
             nginx-configuration?
             nginx-configuartion-nginx
@@ -132,6 +160,203 @@
 ;;;
 ;;; Code:
 
+(define-record-type* <apache-httpd-load-module>
+  apache-httpd-load-module make-apache-httpd-load-module
+  apache-httpd-load-module?
+  (name apache-httpd-load-module-name)
+  (file apache-httpd-load-module-file))
+
+(define %default-apache-httpd-modules
+  (map (match-lambda
+         ((name file)
+          (apache-httpd-load-module
+           (name name)
+           (file file))))
+       '(("authn_file_module" "modules/mod_authn_file.so")
+         ("authn_core_module" "modules/mod_authn_core.so")
+         ("authz_host_module" "modules/mod_authz_host.so")
+         ("authz_groupfile_module" "modules/mod_authz_groupfile.so")
+         ("authz_user_module" "modules/mod_authz_user.so")
+         ("authz_core_module" "modules/mod_authz_core.so")
+         ("access_compat_module" "modules/mod_access_compat.so")
+         ("auth_basic_module" "modules/mod_auth_basic.so")
+         ("reqtimeout_module" "modules/mod_reqtimeout.so")
+         ("filter_module" "modules/mod_filter.so")
+         ("mime_module" "modules/mod_mime.so")
+         ("log_config_module" "modules/mod_log_config.so")
+         ("env_module" "modules/mod_env.so")
+         ("headers_module" "modules/mod_headers.so")
+         ("setenvif_module" "modules/mod_setenvif.so")
+         ("version_module" "modules/mod_version.so")
+         ("unixd_module" "modules/mod_unixd.so")
+         ("status_module" "modules/mod_status.so")
+         ("autoindex_module" "modules/mod_autoindex.so")
+         ("dir_module" "modules/mod_dir.so")
+         ("alias_module" "modules/mod_alias.so"))))
+
+(define-record-type* <apache-httpd-config-file>
+  apache-httpd-config-file make-apache-httpd-config-file
+  apache-httpd-config-file?
+  (load-modules   apache-httpd-config-file-load-modules
+                  (default %default-apache-httpd-modules))
+  (server-root    apache-httpd-config-file-server-root
+                  (default httpd))
+  (server-name    apache-httpd-config-file-server-name
+                  (default #f))
+  (document-root  apache-httpd-config-file-document-root
+                  (default "/srv/http"))
+  (listen         apache-httpd-config-file-listen
+                  (default '("80")))
+  (pid-file       apache-httpd-config-file-pid-file
+                  (default "/var/run/apache-httpd"))
+  (error-log      apache-httpd-config-file-error-log
+                  (default "/var/log/apache-httpd/error_log"))
+  (user           apache-httpd-config-file-user
+                  (default "apache-httpd"))
+  (group          apache-httpd-config-file-group
+                  (default "apache-httpd"))
+  (extra-config   apache-httpd-config-file-extra-config
+                  (default
+                    `("TypesConfig " ,(file-append httpd "/etc/httpd/mime.types") "\n"))))
+
+(define-gexp-compiler (apache-httpd-config-file-compiler
+                       (file <apache-httpd-config-file>) system target)
+  (match file
+    (($ <apache-httpd-config-file> load-modules server-root server-name
+                                   document-root listen pid-file error-log
+                                   user group extra-config)
+     (gexp->derivation
+      "httpd.conf"
+      #~(call-with-output-file (ungexp output "out")
+          (lambda (port)
+            (display
+             (string-append
+              (ungexp-splicing
+               `(,@(append-map
+                    (match-lambda
+                      (($ <apache-httpd-load-module> name module)
+                       `("LoadModule " ,name " " ,module "\n")))
+                    load-modules)
+                 ,@`("ServerRoot " ,server-root "\n")
+                 ,@(if server-name
+                       `("ServerName " ,server-name "\n")
+                       '())
+                 ,@`("DocumentRoot " ,document-root "\n")
+                 ,@(append-map
+                    (lambda (listen-value)
+                      `("Listen " ,listen-value "\n"))
+                    listen)
+                 ,@(if pid-file
+                       `("Pidfile " ,pid-file "\n")
+                       '())
+                 ,@(if error-log
+                       `("ErrorLog " ,error-log "\n")
+                       '())
+                 ,@(if user
+                       `("User " ,user "\n")
+                       '())
+                 ,@(if group
+                       `("Group " ,group "\n")
+                       '())
+                 "\n\n"
+                 ,@extra-config)))
+             port)))
+      #:local-build? #t))))
+
+(define-record-type <apache-httpd-virtualhost>
+  (apache-httpd-virtualhost addresses-and-ports contents)
+  apache-httpd-virtualhost?
+  (addresses-and-ports apache-httpd-virtualhost-addresses-and-ports)
+  (contents            apache-httpd-virtualhost-contents))
+
+(define-record-type* <apache-httpd-configuration>
+  apache-httpd-configuration make-apache-httpd-configuration
+  apache-httpd-configuration?
+  (package  apache-httpd-configuration-package
+            (default httpd))
+  (pid-file apache-httpd-configuration-pid-file
+            (default "/var/run/apache-httpd"))
+  (config   apache-httpd-configuration-config
+            (default (apache-httpd-config-file))))
+
+(define %apache-httpd-accounts
+  (list (user-group (name "apache-httpd") (system? #t))
+        (user-account
+         (name "apache-httpd")
+         (group "apache-httpd")
+         (system? #t)
+         (comment "Apache HTTPD server user")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define apache-httpd-shepherd-services
+  (match-lambda
+    (($ <apache-httpd-configuration> package pid-file config)
+     (list (shepherd-service
+            (provision '(apache-httpd))
+            (documentation "The Apache HTTP Server")
+            (requirement '(networking))
+            (start #~(make-forkexec-constructor
+                      `(#$(file-append package "/bin/httpd")
+                        #$@(if config
+                               (list "-f" config)
+                               '()))
+                      #:pid-file #$pid-file))
+            (stop #~(make-kill-destructor)))))))
+
+(define apache-httpd-activation
+  (match-lambda
+    (($ <apache-httpd-configuration> package pid-file config)
+     (match-record
+      config
+      <apache-httpd-config-file>
+      (error-log document-root)
+      #~(begin
+          (use-modules (guix build utils))
+
+          (mkdir-p #$(dirname error-log))
+          (mkdir-p #$document-root))))))
+
+(define (apache-httpd-process-extensions original-config extension-configs)
+  (let ((config (apache-httpd-configuration-config
+                 original-config)))
+    (if (apache-httpd-config-file? config)
+        (apache-httpd-configuration
+         (inherit original-config)
+         (config
+          (apache-httpd-config-file
+           (inherit config)
+           (extra-config
+            (append (apache-httpd-config-file-extra-config config)
+                    (append-map
+                     (match-lambda
+                       (($ <apache-httpd-virtualhost>
+                           addresses-and-ports
+                           contents)
+                        `(,(string-append
+                            "<VirtualHost " addresses-and-ports ">\n")
+                          ,@contents
+                          "\n</VirtualHost>\n"))
+                       ((? string? x)
+                        `("\n" ,x "\n"))
+                       ((? list? x)
+                        `("\n" ,@x "\n")))
+                     extension-configs)))))))))
+
+(define apache-httpd-service-type
+  (service-type (name 'apache-httpd)
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          apache-httpd-shepherd-services)
+                       (service-extension activation-service-type
+                                          apache-httpd-activation)
+                       (service-extension account-service-type
+                                          (const %apache-httpd-accounts))))
+                (compose concatenate)
+                (extend apache-httpd-process-extensions)
+                (default-value
+                  (apache-httpd-configuration))))
+
 (define-record-type* <nginx-server-configuration>
   nginx-server-configuration make-nginx-server-configuration
   nginx-server-configuration?
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index b84f072ac..1f4ab697c 100644
--- a/gnu/tests/web.scm
+++ b/gnu/tests/web.scm
@@ -28,7 +28,8 @@
   #:use-module (gnu services networking)
   #:use-module (guix gexp)
   #:use-module (guix store)
-  #:export (%test-nginx
+  #:export (%test-apache-httpd
+            %test-nginx
             %test-php-fpm))
 
 (define %index.html-contents
@@ -44,6 +45,85 @@
         (lambda (port)
           (display #$%index.html-contents port)))))
 
+(define %apache-httpd-os
+  ;; Operating system under test.
+  (simple-operating-system
+   (dhcp-client-service)
+   (service apache-httpd-service-type
+            (apache-httpd-configuration
+             (config (apache-httpd-config-file
+                      (listen '("8080"))))))
+   (simple-service 'make-http-root activation-service-type
+                   %make-http-root)))
+
+(define* (run-apache-httpd-test #:optional (http-port 8080))
+  "Run tests in %APACHE-HTTPD-OS, which has apache-httpd running and listening on
+HTTP-PORT."
+  (define os
+    (marionette-operating-system
+     %apache-httpd-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings `((,http-port . 8080)))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette)
+                       (web uri)
+                       (web client)
+                       (web response))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "apache-httpd")
+
+          ;; Wait for apache-httpd to be up and running.
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'apache-httpd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          ;; Retrieve the index.html file we put in /srv.
+          (test-equal "http-get"
+            '(200 #$%index.html-contents)
+            (let-values (((response text)
+                          (http-get "http://localhost:8080/index.html"
+                                    #:decode-body? #t)))
+              (list (response-code response) text)))
+
+          ;; There should be a log file in here.
+          (test-assert "log file"
+            (marionette-eval
+             '(file-exists? "/var/log/apache-httpd/error_log")
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "apache-httpd-test" test))
+
+(define %test-apache-httpd
+  (system-test
+   (name "apache-httpd")
+   (description "Connect to a running APACHE-HTTPD server.")
+   (value (run-apache-httpd-test))))
+
 (define %nginx-servers
   ;; Server blocks.
   (list (nginx-server-configuration
-- 
2.14.1