Hello, I fixed a bunch of problems I had and now I've been adding
database migrations when the package version changes.
This is very insufficiently tested right now.
I only tested this with one pre-existing installation so far, but it
seems to work fine there. I want write system tests to cover each case.
After this is done a qvitter package could be added (I never installed
it before) and maybe the plugins code could be altered to load plugins
from guix packages.

I'm appending the patches from my package path, since my website only
ever displays the latest version.

Am 25.09.2017 um 23:14 schrieb nee:
> - Setting up the database requires the sql root password, the new
>   social_db_user password, and a password for the first admin user to
>   create in gnu social.
>   Having plaintext passwords in /etc/config.scm sounds pretty bad.
>   I'm not sure what the solution here is.
>   - Could we add a password store to guix? It could automatically
>     generate passwords and pass them to services.
>   - Should I generate a script that must be run manually and asks for
>     password input through stdin?
>   - Something else?
> 
I'm experimenting with the password generator approach right now.
Current downsides:
- there is a plaintext file with all the service passwords in /root/
Positives:
- It requires no user input for a new installation.
- It's simple to move with a backup.

Gnu social needs the password for it's mysql-user to generate the config
file, so at least this one has to be saved somewhere or entered every
time you reconfigure.

I also wrote a new macro 'with-passwords. I'm not very experienced with
writing macros so it would be nice to get some feedback on it.

> - The password of the database-user ends up in the config.php which is
>   generated by mixed-text-file. This file can be read by everyone. Can I
>   somehow set the owner on it and remove the reading rights from other
>   users?
> 
I moved the config.php file to /var for now, so I can use basic guile
file writing operations. I have to read up on etc-service-types some day.
Can these files be created to be not publicly readable by everyone?

> Here are some other open problems with the packages:
> 
> - I build php with --enable-intl now, causes a new broken tests to
>   appear.
>   I on a quick look I couldn't figure out what was wrong, and I'm not
>   familiar with php, so I disabled the failing tests.
>   Setting the language in gnu social does not seem to work. Nothing
>   happens, but the installation phase does no longer complain about the
>   missing php module.
> 
Not sure if I tested this wrong, or this was fixed by the php version
upgrade that happened meanwhile, but now setting the language works.
Before I log in GNU Social presents itself in the language of my browser.
After logging in the language from the config.php is used.

> - A bunch of plugins that are shipped with gs seem to rely on writeable
>   cache directories in their working directory.
>   Those can not be changed through the config file.
>   It will take me some time to find and patch them all.
> 
I added a setting to change the cache directory for extlib/HTMLPurifier/
upstream patch: https://git.gnu.io/gnu/gnu-social/merge_requests/156 (it
got merged)

I don't know of any other functions trying to write in the current
directory right now.

> - The admin area must be patched out and all configuration options must
>   be represented by the service.
> 
I patched out the link to the Admin menu in the package.

> - The following plugins throw warnings: Poll, OpenId, Favorite,
>   Bookmark, DirectMessage those warnings might be related to the
>   php/mariadb versions used with gnu social
> 
> - common warnings that appear:
>  Warning: Declaration of InviteAction::handle($args) should be
> compatible with Action::handle() in
> /gnu/store/qfzqxlfkrzri73jrphlqccsd35s0kcy3-gnu-social-1.2.0-beta4/actions/invite.php
> on line 298
> 
>   Warning: Cannot modify header information - headers already sent by
> (output started at
> /gnu/store/qfzqxlfkrzri73jrphlqccsd35s0kcy3-gnu-social-1.2.0-beta4/actions/invite.php:298)
> in
> /gnu/store/qfzqxlfkrzri73jrphlqccsd35s0kcy3-gnu-social-1.2.0-beta4/lib/action.php
> on line 1277
> 
> The /settings/poll url completely breaks.
> 
These warnings seems to be a general GNU Social problem unrelated to
guix. When php-fpm is set to not send warnings to the browser it looks
like any other installation.
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Julien Lepiller <jul...@lepiller.eu>
;;; Copyright © 2016 Marius Bakke <mba...@fastmail.com>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(define-module (hidamari-blue php)
  #:use-module (gnu packages)
  #:use-module (gnu packages algebra)
  #:use-module (gnu packages aspell)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bison)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages curl)
  #:use-module (gnu packages cyrus-sasl)
  #:use-module (gnu packages databases)
  #:use-module (gnu packages fontutils)
  #:use-module (gnu packages gd)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages image)
  #:use-module (gnu packages icu4c)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages multiprecision)
  #:use-module (gnu packages openldap)
  #:use-module (gnu packages pcre)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages readline)
  #:use-module (gnu packages textutils)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages web)
  #:use-module (gnu packages xml)
  #:use-module (gnu packages xorg)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system gnu)
  #:use-module ((guix licenses) #:prefix license:))

(define-public php
  (package
    (name "php")
    (version "7.1.9")
    (home-page "https://secure.php.net/";)
    (source (origin
              (method url-fetch)
              (uri (string-append home-page "distributions/"
                                  name "-" version ".tar.xz"))
              (sha256
               (base32
                "130y50nawipd12nbs10661vzk8gvy7zsqcsxvj29mwaivm4a777c"))
              (modules '((guix build utils)))
              (snippet
               '(with-directory-excursion "ext"
                  (for-each delete-file-recursively
                            ;; Some of the bundled libraries have no proper upstream.
                            ;; Ideally we'd extract these out as separate packages:
                            ;;"mbstring/libmbfl"
                            ;;"date/lib"
                            ;;"bcmath/libbcmath"
                            ;;"fileinfo/libmagic" ; This is a patched version of libmagic.
                            '("gd/libgd"
                              "mbstring/oniguruma"
                              "pcre/pcrelib"
                              "sqlite3/libsqlite"
                              "xmlrpc/libxmlrpc"
                              "zip/lib"))))))
    (build-system gnu-build-system)
    (arguments
     '(#:configure-flags
       (let-syntax ((with (syntax-rules ()
                            ((_ option input)
                             (string-append option "="
                                            (assoc-ref %build-inputs input))))))
         (list (with "--with-bz2" "bzip2")
               (with "--with-curl" "curl")
               (with "--with-freetype-dir" "freetype")
               (with "--with-gd" "gd")
               (with "--with-gdbm" "gdbm")
               (with "--with-gettext" "glibc") ; libintl.h
               (with "--with-gmp" "gmp")
	       (with "--with-icu-dir" "icu4c")
               (with "--with-jpeg-dir" "libjpeg")
               (with "--with-ldap" "openldap")
               (with "--with-ldap-sasl" "cyrus-sasl")
               (with "--with-libzip" "zip")
               (with "--with-libxml-dir" "libxml2")
               (with "--with-onig" "oniguruma")
               (with "--with-pcre-dir" "pcre")
               (with "--with-pcre-regex" "pcre")
               (with "--with-pdo-pgsql" "postgresql")
               (with "--with-pdo-sqlite" "sqlite")
               (with "--with-pgsql" "postgresql")
               (with "--with-png-dir" "libpng")
               ;; PHP’s Pspell extension, while retaining its current name,
               ;; now uses the Aspell library.
               (with "--with-pspell" "aspell")
               (with "--with-readline" "readline")
               (with "--with-sqlite3" "sqlite")
               (with "--with-tidy" "tidy")
               (with "--with-webp-dir" "libwebp")
               (with "--with-xpm-dir" "libxpm")
               (with "--with-xsl" "libxslt")
               (with "--with-zlib-dir" "zlib")
               ;; We could add "--with-snmp", but it requires netsnmp that
               ;; we don't have a package for. It is used to build the snmp
               ;; extension of php.
               "--with-iconv"
               "--with-openssl"
               "--with-mysqli"          ; Required for, e.g. wordpress
               "--with-pdo-mysql"
               "--with-zlib"
               "--enable-calendar"
               "--enable-dba=shared"
               "--enable-exif"
               "--enable-flatfile"
               "--enable-fpm"
               "--enable-ftp"
               "--enable-inifile"
	       "--enable-intl"	; uses icu4c. Required for, e.g. GNU Social
               "--enable-mbstring"
               "--enable-pcntl"
               "--enable-sockets"))
       #:phases
       (modify-phases %standard-phases
         (add-after 'unpack 'do-not-record-build-flags
           (lambda _
             ;; Prevent configure flags from being stored and causing
             ;; unnecessary runtime dependencies.
             (substitute* "scripts/php-config.in"
               (("@CONFIGURE_OPTIONS@") "")
               (("@PHP_LDFLAGS@") ""))
             ;; This file has ISO-8859-1 encoding.
             (with-fluids ((%default-port-encoding "ISO-8859-1"))
               (substitute* "main/build-defs.h.in"
                 (("@CONFIGURE_COMMAND@") "(omitted)")))
             #t))
         (add-before 'build 'patch-/bin/sh
           (lambda _
             (substitute* '("run-tests.php" "ext/standard/proc_open.c")
               (("/bin/sh") (which "sh")))
             #t))
         (add-before 'check 'prepare-tests
           (lambda _
             ;; Some of these files have ISO-8859-1 encoding, whereas others
             ;; use ASCII, so we can't use a "catch-all" find-files here.
             (with-fluids ((%default-port-encoding "ISO-8859-1"))
               (substitute* '("ext/mbstring/tests/mb_send_mail02.phpt"
                              "ext/mbstring/tests/mb_send_mail04.phpt"
                              "ext/mbstring/tests/mb_send_mail05.phpt"
                              "ext/mbstring/tests/mb_send_mail06.phpt")
                 (("/bin/cat") (which "cat"))))
             (substitute* '("ext/mbstring/tests/mb_send_mail01.phpt"
                            "ext/mbstring/tests/mb_send_mail03.phpt"
                            "ext/mbstring/tests/bug52861.phpt"
                            "ext/standard/tests/general_functions/bug34794.phpt"
                            "ext/standard/tests/general_functions/bug44667.phpt"
                            "ext/standard/tests/general_functions/proc_open.phpt")
               (("/bin/cat") (which "cat")))

             ;; The encoding of this file is not recognized, so we simply drop it.
             (delete-file "ext/mbstring/tests/mb_send_mail07.phpt")

             (substitute* "ext/standard/tests/streams/bug60602.phpt"
               (("'ls'") (string-append "'" (which "ls") "'")))

             ;; Drop tests that are known to fail.
             (for-each delete-file
                       '("ext/posix/tests/posix_getgrgid.phpt"    ; Requires /etc/group.
                         "ext/sockets/tests/bug63000.phpt"        ; Fails to detect OS.
                         "ext/sockets/tests/socket_shutdown.phpt" ; Requires DNS.
                         "ext/sockets/tests/socket_send.phpt"     ; Likewise.
                         "ext/sockets/tests/mcast_ipv4_recv.phpt" ; Requires multicast.
                         ;; These needs /etc/services.
                         "ext/standard/tests/general_functions/getservbyname_basic.phpt"
                         "ext/standard/tests/general_functions/getservbyport_basic.phpt"
                         "ext/standard/tests/general_functions/getservbyport_variation1.phpt"
                         ;; And /etc/protocols.
                         "ext/standard/tests/network/getprotobyname_basic.phpt"
                         "ext/standard/tests/network/getprotobynumber_basic.phpt"
                         ;; And exotic locales.
                         "ext/standard/tests/strings/setlocale_basic1.phpt"
                         "ext/standard/tests/strings/setlocale_basic2.phpt"
                         "ext/standard/tests/strings/setlocale_basic3.phpt"
                         "ext/standard/tests/strings/setlocale_variation1.phpt"

			 ;; --enable-intl tests that fail, maybe also because of exotic locales?
			 "ext/intl/tests/bug74230.phpt"
			 "ext/intl/tests/spoofchecker_001.phpt"
			 "ext/intl/tests/timezone_IDforWindowsID_basic.phpt"
			 "ext/intl/tests/timezone_windowsID_basic.phpt"


                         ;; XXX: These gd tests fails.  Likely because our version
                         ;; is different from the (patched) bundled one.
                         ;; Here, gd quits immediately after "fatal libpng error"; while the
                         ;; test expects it to additionally return a "setjmp" error and warning.
                         "ext/gd/tests/bug39780_extern.phpt"
                         "ext/gd/tests/libgd00086_extern.phpt"
                         ;; Extra newline in gd-png output.
                         "ext/gd/tests/bug45799.phpt"
                         ;; Different error message than expected from imagecrop().
                         "ext/gd/tests/bug66356.phpt"
                         ;; Similarly for imagecreatefromgd2().
                         "ext/gd/tests/bug72339.phpt"
                         ;; Call to undefined function imageantialias().  They are
                         ;; supposed to fail anyway.
                         "ext/gd/tests/bug72482.phpt"
                         "ext/gd/tests/bug72482_2.phpt"
                         "ext/gd/tests/bug73213.phpt"
                         ;; Test expects generic "gd warning" but gets the actual function name.
                         "ext/gd/tests/createfromwbmp2_extern.phpt"
                         ;; TODO: Enable these when libgd is built with xpm support.
                         "ext/gd/tests/xpm2gd.phpt"
                         "ext/gd/tests/xpm2jpg.phpt"
                         "ext/gd/tests/xpm2png.phpt"

                         ;; XXX: These iconv tests have the expected outcome,
                         ;; but with different error messages.
                         ;; Expects "illegal character", instead gets "unknown error (84)".
                         "ext/iconv/tests/bug52211.phpt"
                         ;; Expects "wrong charset", gets unknown error (22).
                         "ext/iconv/tests/iconv_mime_decode_variation3.phpt"
                         "ext/iconv/tests/iconv_strlen_error2.phpt"
                         "ext/iconv/tests/iconv_strlen_variation2.phpt"
                         "ext/iconv/tests/iconv_substr_error2.phpt"
                         ;; Expects conversion error, gets "error condition Termsig=11".
                         "ext/iconv/tests/iconv_strpos_error2.phpt"
                         "ext/iconv/tests/iconv_strrpos_error2.phpt"
                         ;; Similar, but iterating over multiple values.
                         ;; iconv breaks the loop after the first error with Termsig=11.
                         "ext/iconv/tests/iconv_strpos_variation4.phpt"
                         "ext/iconv/tests/iconv_strrpos_variation3.phpt"

                         ;; XXX: These test failures appear legitimate, needs investigation.
                         ;; open_basedir() restriction failure.
                         "ext/curl/tests/bug61948.phpt"
                         ;; Expects a false boolean, gets empty array from glob().
                         "ext/standard/tests/file/bug41655_1.phpt"
                         "ext/standard/tests/file/glob_variation5.phpt"
                         ;; Test output is correct, but in wrong order.
                         "ext/standard/tests/streams/proc_open_bug64438.phpt"
                         ;; The test expects an Array, but instead get the contents(?).
                         "ext/gd/tests/bug43073.phpt"
                         ;; imagettftext() returns wrong coordinates.
                         "ext/gd/tests/bug48732-mb.phpt"
                         "ext/gd/tests/bug48732.phpt"
                         ;; Similarly for imageftbbox().
                         "ext/gd/tests/bug48801-mb.phpt"
                         "ext/gd/tests/bug48801.phpt"
                         ;; Different expected output from imagecolorallocate().
                         "ext/gd/tests/bug53504.phpt"
                         ;; Wrong image size after scaling an image.
                         "ext/gd/tests/bug73272.phpt"
                         ;; Expects iconv to detect illegal characters, instead gets
                         ;; "unknown error (84)" and heap corruption(!).
                         "ext/iconv/tests/bug48147.phpt"
                         ;; Expects illegal character ".", gets "=?utf-8?Q?."
                         "ext/iconv/tests/bug51250.phpt"
                         ;; @iconv() does not return expected output.
                         "ext/iconv/tests/iconv003.phpt"
                         ;; iconv throws "buffer length exceeded" on some string checks.
                         "ext/iconv/tests/iconv_mime_encode.phpt"
                         ;; file_get_contents(): iconv stream filter
                         ;; ("ISO-8859-1"=>"UTF-8") unknown error.
                         "ext/standard/tests/file/bug43008.phpt"
                         ;; Table data not created in sqlite(?).
                         "ext/pdo_sqlite/tests/bug_42589.phpt"))

             ;; Skip tests requiring network access.
             (setenv "SKIP_ONLINE_TESTS" "1")
             ;; Without this variable, 'make test' passes regardless of failures.
             (setenv "REPORT_EXIT_STATUS" "1")
             #t)))
       #:test-target "test"))
    (inputs
     `(("aspell" ,aspell)
       ("bzip2" ,bzip2)
       ("curl" ,curl)
       ("cyrus-sasl" ,cyrus-sasl)
       ("freetype" ,freetype)
       ("gd" ,gd)
       ("gdbm" ,gdbm)
       ("glibc" ,glibc)
       ("gmp" ,gmp)
       ("gnutls" ,gnutls)
       ("icu4c" ,icu4c)
       ("libgcrypt" ,libgcrypt)
       ("libjpeg" ,libjpeg)
       ("libpng" ,libpng)
       ("libwebp" ,libwebp)
       ("libxml2" ,libxml2)
       ("libxpm" ,libxpm)
       ("libxslt" ,libxslt)
       ("libx11" ,libx11)
       ("oniguruma" ,oniguruma)
       ("openldap" ,openldap)
       ("openssl" ,openssl)
       ("pcre" ,pcre)
       ("postgresql" ,postgresql)
       ("readline" ,readline)
       ("sqlite" ,sqlite)
       ("tidy" ,tidy)
       ("zip" ,zip)
       ("zlib" ,zlib)))
    (native-inputs
     `(("pkg-config" ,pkg-config)
       ("bison" ,bison)
       ("intltool" ,intltool)
       ("procps" ,procps)))         ; For tests.
    (synopsis "PHP programming language")
    (description
      "PHP (PHP Hypertext Processor) is a server-side (CGI) scripting
language designed primarily for web development but is also used as
a general-purpose programming language.  PHP code may be embedded into
HTML code, or it can be used in combination with various web template
systems, web content management systems and web frameworks." )
    (license (list
              (license:non-copyleft "file://LICENSE")       ; The PHP license.
              (license:non-copyleft "file://Zend/LICENSE")  ; The Zend license.
              license:lgpl2.1                               ; ext/mbstring/libmbfl
              license:lgpl2.1+                              ; ext/bcmath/libbcmath
              license:bsd-2                                 ; ext/fileinfo/libmagic
              license:expat))))                             ; ext/date/lib
(define-module (hidamari-blue gnu-social)
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (gnu packages web)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages gettext)
  #:use-module (hidamari-blue php)
  #:use-module (gnu packages databases)
  #:use-module (guix build-system gnu)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)

  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services web)
  #:use-module (gnu system shadow)

  #:export (gnu-social-service-type
            gnu-social-nginx-block
            gnu-social

            <gnu-social-config>
            gnu-social-config
            make-gnu-social-config
            gnu-social-config?

            gnu-social-site-name
            gnu-social-site-domain
            gnu-social-site-type
            gnu-social-avatar-dir
            gnu-social-attachments-dir
            gnu-social-pid-dir
            gnu-social-logfile
            gnu-social-ssl?
            gnu-social-db-user
            gnu-social-password-file
            gnu-social-db-host
            gnu-social-db-socket
            gnu-social-db-database
            gnu-social-admin-handle
            gnu-social-admin-email
            gnu-social-user
            gnu-social-gnu-social
            gnu-social-php
            gnu-social-mysql
            gnu-social-theme
            gnu-social-logo
            gnu-social-timezone
            gnu-social-language
            gnu-social-text-limit
            gnu-social-dupe-limit
            gnu-social-site-notice))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; START OF password stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define alphanumeric-str "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890")
(define ascii-special-str "!\"#$%&'()*+,-./:;<=>?[\\]^_`{|}~  ")
(define (string->vector str) (list->vector (string->list str)))
(define alphanumeric (string->vector alphanumeric-str))
(define ascii (string->vector (string-append alphanumeric-str ascii-special-str)))

(define* (random-string str-length #:optional (alphabet ascii))
  (call-with-input-file "/dev/urandom"
    (lambda (port)
      (define alphabet-max (vector-length alphabet))
      (define (loop acc i)
	(if (< i str-length)
	  (cons (floor (/ (get-u8 port) alphabet-max))
	   acc)
	  (list->string acc)))
      (loop '() 0))))

(define (read-password-file file)
  (if (file-exists? file)
      (call-with-input-file file
        (lambda (port)
          (read port)))
      (error "Passoword file" file " does not exist.")))

(define (write-password-file file data)
  (define data-without-meta
    (filter (match-lambda 
	      (('meta:password-was-generated . x) #f)
	      (_ #t))
	    data))
  ;; touch file with limited permissions
  (call-with-output-file (string-append file ".tmp") (const #t))
  (chown file 0 0)
  (chmod file #o600)
  ;; write
  (call-with-output-file (string-append file ".tmp")
    (lambda (port)
      (write data-without-meta port)))
  ;; finalize
  (rename-file (string-append file ".tmp") file))

(define (optional-password secrets name)
  (assoc-ref secrets name))

(define (required-password secrets name)
  (define found (assoc name secrets))
  (if found
      (cdr found)
      (error "No secret named: " name " in password file.")))

(define* (generatable-password! secrets name length #:optional (alphabet ascii))
 (define found (assoc name secrets))
 (if found
     (cdr found)
     (let ((new-password (random-string alphabet)))
       (set! secrets (cons* (cons name new-password)
			    (cons 'meta:password-was-generated #t)
			    secrets))
       new-password)))

;;; Example:
;; (with-passwords
;;  "/root/guix.passwords-store"		; where it will be stored
;;  ((optional mysql-root-password)	; will be #f if it is not in the file
;;   ;; will be generated for 23 alphanumeric characters
;;   ;; and written to the file after the body is run.
;;   (generatable gnu-social-mysql-password 23 alphanumeric)
;;   ;; will throw an error if it is not in the file
;;   (required gnu-social-admin-password))	
;;  (init-gnu-social config
;; 		  mysql-root-password
;; 		  gnu-social-mysql-password
;; 		  gnu-social-admin-password))

(define-syntax with-passwords
  (syntax-rules (optional)
    ;; entry point
    ((_ file (bindings ...) body ...)
     ((lambda (%secrets)
	(binding %secrets file (bindings ...) body ...))
      (read-password-file file)))))
(define-syntax binding
  (syntax-rules (optional required generatable)
    ;; bindings
    ((binding %secrets file ((optional name) rest ...) body ...)
     (let ((name (optional-password %secrets 'name)))
       (binding %secrets file (rest ...) body ...)))
    ((binding %secrets file ((required name) rest ...)  body ...)
     (let ((name (required-password %secrets 'name)))
       (binding %secrets file (rest ...) body ...)))
    ((binding %secrets file ((generatable name length) rest ...) body ...)
     (let ((name (generatable-password! %secrets 'name length)))
       (binding %secrets file (rest ...) body ...)))
    ((binding %secrets file ((generatable name length alphabet) rest ...) body ...)
     (let ((name (generatable-password! %secrets 'name length alphabet)))
       (binding %secrets file(rest ...) body ...)))
    ;; final body
    ((binding %secrets file () body ...)
     (let ((result (begin body ...)))
       ;; write generated passwords before returning the result
       (when (assoc-ref %secrets 'meta:password-was-generated)
	 (write-password-file file %secrets))
       result))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; END OF password stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (mysql-database-exists? database)
  ;;; TODO take mysql service settings
  (file-exists? (string-append "/var/lib/mysql/" database)))

;;; 

;;; TODO test profilesettings -> openID
;;; TODO config for optional different domains for static files
(define-record-type* <gnu-social-config>
  gnu-social-config make-gnu-social-config
  gnu-social-config?
  ;; --- mandetory during init ---
  (site-name       gnu-social-site-name
                   (default "gnu social"))
  (site-domain     gnu-social-site-domain
                   (default "localhost"))
  ;; can be set to single user to change the start page and menues
  (site-type       gnu-social-site-type
                   (default "community"))
  (avatar-dir      gnu-social-avatar-dir
                   (default "/srv/http/gnu-social/avatar"))
  (attachments-dir gnu-social-attachments-dir
                   (default "/srv/http/gnu-social/file"))
  (pid-dir         gnu-social-pid-dir
                   (default "/var/gnusocial/pid"))
  (logfile         gnu-social-logfile
                   (default #f))
  (ssl?            gnu-social-ssl?
                   (default #f))
  (db-user         gnu-social-db-user
                   (default "gnusocial"))
  (password-file   gnu-social-password-file
		   (default "/root/guix.password-store"))
  ;; "localhost" won't work because of mysql.default_socket is incorrectly defined in the php.ini
  ;; https://stackoverflow.com/questions/1676688/php-mysql-connection-not-working-2002-no-such-file-or-directory#comment48706064_6959675
  (db-host         gnu-social-db-host
                   (default "127.0.0.1"))
  (db-socket       gnu-social-db-socket
                   (default #f))
  (db-database     gnu-social-db-database
                   (default "gnusocial"))
  (admin-handle    gnu-social-admin-handle
                   (default "admin"))
  (admin-email     admin-email
                   (default "#f"))
  ;; TODO need a new user for the config file, since that is read by php-fpm
  (user            gnu-social-user ; system user who owns the writable directories
                   (default "nginx"))
  ;; packages
  (gnu-social      gnu-social-gnu-social
                   (default gnu-social))
  (php             gnu-social-php
                   (default php))
  (mysql           gnu-social-mysql
                   (default mariadb))
  ;; --- optional customizations ---
  (theme           gnu-social-theme
                   (default "neo-gnu"))
  (logo            gnu-social-logo
                   (default #f))    ; url string
  (timezone        gnu-social-timezone
                   (default "UTC"))
  (language        gnu-social-language
                   (default "en"))
  ;; How long notices can be. Set to 0 for unlimited.
  (text-limit      gnu-social-text-limit
                   (default 1000))
  ;; How long users must wait (in seconds) to post the same thing again.
  (dupe-limit      gnu-social-dupe-limit
                   (default 60))
  ;; String to be displayed in the header (max 255 characters).
  (site-notice     gnu-social-site-notice
                   (default #f)))

(define* (gnu-social-nginx-block nginx
                                 gnu-social
                                 gnu-social-config
                                 #:key
                                 (fastcgi-php-socket "/var/run/php7-fpm.sock")
				 (listen '("80" "443 ssl"))
                                 ;; (https-port #f)
                                 (ssl-certificate #f)
                                 (ssl-certificate-key #f)
                                 (server-tokens? #f))
  (match-record
   gnu-social-config
   <gnu-social-config>
   (site-domain avatar-dir attachments-dir)

   (nginx-server-configuration
    (index (list "index.php"))
    (server-name (list site-domain))
    (root (file-append gnu-social "/share/gnu-social"))
    ;; (http-port http-port)
    ;; (https-port https-port)
    (listen listen)
    (ssl-certificate ssl-certificate)
    (ssl-certificate-key ssl-certificate-key)
    (server-tokens? server-tokens?)
    (locations
     (list
      (nginx-location-configuration
       (uri "~ \\.php$")
       (body (list
              "fastcgi_split_path_info ^(.+\\.php)(/.+)$;"
              (string-append "fastcgi_pass unix:" fastcgi-php-socket ";")
              "fastcgi_index index.php;"
              (list "include " nginx "/share/nginx/conf/fastcgi.conf;"))))
      (nginx-location-configuration
       (uri "/avatar")
       (body (list (string-append "alias " avatar-dir ";"))))
      (nginx-location-configuration
       (uri "/file")
       (body (list (string-append "alias " attachments-dir ";"))))
      (nginx-location-configuration
       (uri "/scripts")
       (body (list "deny all;")))
      ;; not really required, but for my own legacy redirect
      ;; (nginx-location-configuration
      ;;  (uri "/index.php/")
      ;;  (body (list "rewrite ^/index.php/(.*)$ /index.php?p=$1 last")))
      (nginx-location-configuration
       (uri "/")
       (body (list "try_files $uri $uri/ @gnusocial;")))
      (nginx-named-location-configuration
       (name "gnusocial")
       ;; TODO optimize to not use regex
       ;; (body (list "rewrite ^ /index.php?p=$1 last;"))
       (body (list "rewrite ^(.*)$ /index.php?p=$1 last;"))))))))

;;; TODO defined multiple times (web.scm, telephony.scm)
(define flatten
  (lambda (. lst)
    (define (flatten1 head out)
      (if (list? head)
      (fold-right flatten1 out head)
      (cons head out)))
    (fold-right flatten1 '() lst)))

(define-syntax-rule (write-text-file name args ...)
  (begin
    (call-with-output-file name
     (lambda (port)
       (display (apply string-append (flatten (list args ...))) port)))
    name))

(define (write-gnu-social-config-file config db-password)
  (mkdir-p "/var/gnusocial/config.d/")
  (match-record
   config
   <gnu-social-config>
   (site-name site-domain site-type avatar-dir attachments-dir pid-dir logfile ssl?
              db-user db-host db-socket db-database admin-handle admin-email user
              gnu-social php mysql theme logo timezone language text-limit dupe-limit site-notice)

   (let* ((mysqli (string-append "mysqli://"
                                 db-user
                                 (if db-password
                                     (string-append ":" db-password)
                                     "")
                                 "@" (if db-socket
                                         (string-append "@unix(" db-socket ")")
                                         db-host)
                                 "/" db-database))
	  ;; TODO use config variable for php-fpm user
	  (gnu-social-user (getpwnam "php-fpm"))
	  (config-file (string-append "/var/gnusocial/config.d/"
				      site-domain ".php"))
          (optional (lambda (prefix value suffix)
                      (if value (string-append prefix value suffix) "")))
	  ;; TODO function defined multiple times
	  (touch (lambda (file-name)
                        (call-with-output-file file-name (const #t)))))

     ;; limit permissions to the config, since it contains the db password
     ;; owned by root (0), readable by gnu-social's user group
     (touch config-file)
     (chown config-file 0 (passwd:gid gnu-social-user))	
     (chmod config-file #o640)
     (write-text-file
      config-file
      "<?php\n"
      "if (!defined('GNUSOCIAL')) { exit(1); }\n"
      "$config['site']['name'] = '" site-name "';\n"
      "$config['site']['server'] = '" site-domain "';\n"
      "$config['site']['path'] = false;\n"
      "$config['site']['fancy'] = true;\n"
      "$config['site']['ssl'] = '" (if ssl? "always" "never") "';\n"
      "$config['site']['theme'] = '" theme "';\n"

      "$config['site']['profile'] = '" site-type "';\n"
      (optional "$config['site']['logo'] ='" logo "';\n")
      (optional "$config['site']['timezone'] ='" timezone "';\n")
      (optional "$config['site']['language'] ='" language "';\n")
      "$config['site']['textlimit'] =" (number->string text-limit) ";\n"
      "$config['site']['dupelimit'] =" (number->string dupe-limit) ";\n"

      "$config['db']['database'] = '" mysqli "';\n"
      "$config['db']['type'] = 'mysql';\n"

      "$config['avatar']['dir'] = '" avatar-dir "';\n"
      "$config['attachments']['dir'] = '" attachments-dir "';\n"
      "$config['cache']['dir'] = '" "/tmp/" "';\n"
      "$config['daemon']['piddir'] = '" pid-dir "';\n"


      "// Uncomment below for better performance. Just remember you must run\n"
      "// php scripts/checkschema.php whenever your enabled plugins change!\n"
      "$config['db']['schemacheck'] = 'script';\n"

      (if logfile
	  (string-append "$config['site']['logfile'] = '" logfile "';\n")
	  "")))))

(define gnu-social
  (let ((commit "50f9f23ff19a4f577c429d80411378d6a1747725"))
    (package
     (name "gnu-social")
     (version "1.2.0-beta4")
     (source (origin
              ;; I made some cli-installer patches
              ;; waiting for them to get accepted into master:
              ;; https://git.gnu.io/gnu/gnu-social/merge_requests/155
              (method url-fetch)
              (uri "https://hidamari.blue/gnu-social.tar.bz2";)
              (sha256
               (base32
                "0l9vh9lxn6d42yh1nfd4ydsrizp7qa018wz9da41a14fd44bwqwi"))
              ;; (method git-fetch)    ; no tarball available
              ;; (uri (git-reference
              ;;       (url "https://git.gnu.io/gnu/gnu-social.git";)
              ;;       (commit commit)))   ; using the latest version
              ;; (sha256
              ;;  (base32
              ;;   "1xja9pbw8dy8jqc44f7z4vd8mrkpcirq1yxxvf4w0lf778z4xasr"))
              ))
     (build-system gnu-build-system)
     (arguments
      `(#:phases
        (modify-phases
         %standard-phases
         (delete 'configure)
         (delete 'check)
         (replace
          'install
          (lambda*
              (#:key outputs #:allow-other-keys)
            (let ((out (string-append (assoc-ref %outputs "out") "/share/gnu-social/"))
                  (php-bin (string-append (assoc-ref %build-inputs "php") "/bin/php"))
                  (bash (string-append (assoc-ref %build-inputs "bash") "/bin/bash")))

              ;; overwrite the config_files array to only try one config file.
              (substitute* "lib/gnusocial.php"
                           (("\\$config_files\\[\\] = INSTALLDIR\\.'/config\\.php';")
                            "$config_files = array('/var/gnusocial/config.d/'.$_server.'.php');"))

              (substitute* "lib/installer.php"
                           (("require_once INSTALLDIR . '/lib/common.php';")
                            "$server = $this->server; require_once INSTALLDIR . '/lib/common.php'; "))

	      (substitute* "lib/primarynav.php"
                           (("\\$user->hasRight\\(Right::CONFIGURESITE\\)")
                            "false"))
	      
              (delete-file "install.php")
              (mkdir-p out)
              (copy-recursively "." out)
              #t))))))

     ;; TODO replace the bundled jquery if someone ever manages to package that juggernaut
     (inputs `(("php" ,php)
               ("bash" ,bash)))
     (native-inputs `(("gettext" ,gnu-gettext)))
     (home-page "https://gnu.io/social";)
     (synopsis "Federated microblogging platform for the web")
     (description
      "GNU Social is a federated microblogging platform.")
     (license license:agpl3+))))

(define (gnu-social-activation config)
  (match-record
   config
   <gnu-social-config>
   (site-name site-domain site-type avatar-dir attachments-dir pid-dir logfile ssl?
              db-user password-file db-host db-socket db-database admin-handle admin-email user
              gnu-social php mysql theme logo timezone language text-limit dupe-limit site-notice)
   
   (let* ((gnu-social-version (package-version gnu-social))
	  ;; TODO put into config
	  (installed-version-filepath "/var/gnusocial/version")
	  (installed-version (if (file-exists? installed-version-filepath)
				 (call-with-input-file installed-version-filepath
				   (lambda (port)
				     (read port)))
				 #f)))
     (with-passwords
      password-file
      ((optional mysql-root-password)
       (generatable gnu-social-db-password 32)
       (generatable gnu-social-admin-password 32))
      #~(begin
	  (use-modules (guix build utils)
		       (ice-9 match)
		       (srfi srfi-1))
	  (let ((user (getpwnam #$user))
		(sh (string-append #$bash "/bin/sh"))
		(php (string-append #$php "/bin/php"))
		(mysql (string-append #$mysql "/bin/mysql"))
		(install-script (string-append #$gnu-social "/share/gnu-social/scripts/install_cli.php"))
		(config-file #$(write-gnu-social-config-file config gnu-social-db-password))
		;; TODO remove, since it's already in web.scm, might move to guix utils
		(flatten (lambda (. lst)
			   (define (flatten1 head out)
			     (if (list? head)
				 (fold-right flatten1 out head)
				 (cons head out)))
			   (fold-right flatten1 '() lst)))
		(touch (lambda (file-name)
			 (call-with-output-file file-name (const #t))))
		(write-installed-version
		 (lambda ()
		   ;; create proof of successful version installation as .tmp
		   (call-with-output-file (string-append #$installed-version-filepath ".tmp")
		     (lambda (port)
		       (write #$gnu-social-version port)))
		   ;; rename to actual name
		   (rename-file (string-append #$installed-version-filepath ".tmp")
				#$installed-version-filepath)
		   #t)))
	    ;; prepare writable directories
	    (mkdir-p #$avatar-dir)
	    (mkdir-p #$attachments-dir)
	    (chown #$avatar-dir (passwd:uid user) (passwd:gid user))
	    (chown #$attachments-dir (passwd:uid user) (passwd:gid user))

	    ;; prepare logfile
	    (touch #$logfile)
	    (chown #$logfile (passwd:uid user) (passwd:gid user))

	    (display "wrote gnu-social config ") (display config-file) (newline)

	    ;; upgrade/install && check-addon-changes
	    (and (cond ((not (equal? #$installed-version #$gnu-social-version))
			;; upgrade existing installation
			(fromat #t "Upgrading gnu-social database ~a from ~a to ~a."
				#$database
				#$installed-version #$gnu-social-version)
			(and (zero? (system* php (string-append #$gnu-social "/share/gnu-social/scripts/stopdaemons.sh")))
			     (zero? (system* php (string-append #$gnu-social "/share/gnu-social/scripts/upgrade.php")
					     "--server" #$site-domain))
			     (zero? (system* php (string-append #$gnu-social "/share/gnu-social/scripts/startdaemons.sh")))
			     (write-installed-version)))
		       ((not #$installed-version)
			;; inital install
			;; create database if it's the default setup
			(format "Installing database for gnu social version ~a." #$gnu-social-version)
			;; create mysql database and user
			(and (zero? (apply system* mysql
					   "--execute"
					   ;; TODO FIXME escape ' signs in username/password
					   (string-append "
CREATE DATABASE IF NOT EXISTS " #$db-database ";
CREATE USER IF NOT EXISTS '" #$db-user "'@'localhost' identified by '" #$gnu-social-db-password "';
GRANT ALL PRIVILEGES ON " #$db-database ".* TO '" #$db-user "'@'localhost';")
					   
					   "--user" "root"
					   (cond (#$db-host (list "--host" #$db-host))
						 (#$db-socket (list "--socket" #$db-socket))
						 (#t (error "gnu-social-service: "
							    "either db-host or db-socket must be set")))
					   ;; TODO FIXME SECURITY this will appear in the system's process list
					   (if #$mysql-root-password
					       (list (string-append "--password=" #$mysql-root-password))
					       '())))
			     ;; call the install script
			     (zero? (apply system* php install-script
					   (filter (lambda (x) (or (not (list? x))
								   (not (null? x))))
						   (flatten
						    "--skip-config"
						    "--sitename"     #$site-name
						    "--server"       #$site-domain
						    "--site-profile" #$site-type

						    "--dbtype"   "mysql"
						    "--host"     #$db-host
						    "--database" #$db-database
						    "--username" #$db-user
						    (if #$gnu-social-db-password
							(list "--password" #$gnu-social-db-password)
							'())

						    "--admin-nick" #$admin-handle
						    "--admin-pass" #$gnu-social-admin-password
						    (if #$admin-email
							(list "--admin-email" #$admin-email)
							'())))))
			     (write-installed-version)))
		       ;; same version already installed, do nothing
		       (else #t))
		 ;; call the routing update script, in case any new addons were installed
		 (zero? (system* php (string-append #$gnu-social "/share/gnu-social/scripts/checkschema.php")
				 "--server" #$site-domain)))))))))

(define gnu-social-service-type
  (service-type (name 'gnu-social)
                (extensions
                 (list (service-extension activation-service-type
                                          gnu-social-activation)))))

Reply via email to