root/gnu-social.scm

(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 (srfi srfi-11)       ;let-values
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)

  #: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)
            (loop
             (cons (vector-ref
                    alphabet
                    (floor (modulo (get-u8 port) alphabet-max)))
                   acc)
             (+ i 1))
            (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))
  (define tmp-file (string-append file ".tmp"))
  ;; touch file with limited permissions
  (call-with-output-file tmp-file (const #t))
  (chown tmp-file 0 0)
  (chmod tmp-file #o600)
  ;; write
  (call-with-output-file tmp-file
    (lambda (port)
      (write data-without-meta port)))
  ;; finalize
  (rename-file tmp-file 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
      (values (cdr found) secrets)
      (let ((new-password (random-string length alphabet)))
        (set! secrets (cons* (cons name new-password)
                             (cons 'meta:password-was-generated #t)
                             secrets))
        (values new-password secrets))))

;;; 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 ()
    ;; 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-values (((name new-secrets) (generatable-password! %secrets 'name length)))
       (binding new-secrets file (rest ...) body ...)))
    ((binding %secrets file ((generatable name length alphabet) rest ...) body ...)
     (let-values (((name new-secrets) (generatable-password! %secrets 'name length alphabet)))
       (binding new-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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; START OF sql stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define* (run-sql package sql #:key (bin "/bin/mysql") (user "root") (password #f) (host "127.0.0.1") (socket #f))
  (define process-prot
    (apply open-pipe* OPEN_BOTH (string-append package bin)
           "--execute"
           ;; TODO FIXME escape ' signs in username/password
           sql
           "--user" user
           (cond ((and host socket) (error "run-sql: both host and socket are both set, only one can be used.
Please set the unneeded to #f."))
                 (socket (list "--socket" socket))
                 (host (list "--host" host))
                 (#t (error "run-sql: either db-host or db-socket must be set")))
           ;; TODO FIXME SECURITY this will appear in the system's process list
           (if password
               (list (string-append "--password" password))
               '())))
  (when password
    (display password process-prot))
  (let ((exit-code (close-pipe process-port)))
    exit-code))

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; END OF sql stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; 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"))
  ;; writeable
  (avatar-dir      gnu-social-avatar-dir
                   (default "/srv/http/gnu-social/avatar"))
  ;; writable
  (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))
  ;; system user who owns the writable directories, the config file, and runs php-fpm
  (user            gnu-social-user
                   (default "php-fpm"))
  ;; packages
  (gnu-social      gnu-social-gnu-social
                   (default gnu-social))
  (php             gnu-social-php
                   (default php))
  (mysql           gnu-social-mysql
                   (default mariadb))
  ;; --- optional customizations ---
  (default-theme   gnu-social-default-theme
    (default "neo"))
  (logo            gnu-social-logo
                   (default #f))    ; url string
  (timezone        gnu-social-timezone
                   (default "UTC"))
  (language        gnu-social-language
                   (default "en"))
  (site-notice     gnu-social-site-notice
                   (default #f))
  ;; --- limits ---
  ;; 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))
  ;; transforms (((attachments file_quota) 800000000)
  ;;             ((attachments monthly_quota) 888800000000))
  ;; into:
  ;;       $config['attachments']['file_quota'] = 800000000;
  ;;       $config['attachments']['monthly_quota'] = 888800000000;
  (extra-fields    gnu-social-extra-fields
                   (default '()))
  (themes          gnu-social-themes
                   (default '()))
  (plugins         gnu-social-plugins
                   ;; list of plugins ((guix-package '((arg1 value1))
                   ;;                  '(build-in "Build-in-name" '((arg1 value1)))
                   (default (list (list gnu-social-plugin-sensitive-media '())
                                  ;; (list gnu-social-plugin-qvitter '())
                                  '(build-in "StoreRemoteMedia" ())))))

(define (letsencrypt-challenge-location dir)
  (nginx-location-configuration
   (uri "location ^~ /.well-known/acme-challenge/")
   (body (list
          "allow all;"
          (string-append "root " dir ";")
          "default_type \"text/plain\";"
          "try_files $uri =404;"))))

(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)
                                 (letsencrypt-dir #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
     (filter
      identity
      (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;"))))
       (if letsencrypt-dir
           (letsencrypt-challenge-location letsencrypt-dir)
           #f)
       (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 "/theme")
        (body (list (string-append "alias /etc/gnu-social-" site-domain "/theme;"))))
       (nginx-location-configuration
        (uri "/plugins")
        (body (list (string-append "alias /etc/gnu-social-" site-domain "/plugins;"))))
       (nginx-location-configuration
        (uri "/local/plugins")
        (body (list (string-append "alias /etc/gnu-social-" site-domain "/plugins;"))))
       (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 (var->php-source-string value)
  (cond ((number? value) (number->string value))
        ((boolean? value) (if value "true" "false"))
        ;; TODO escape
        ((string? value) (string-append "'" value "'"))
        ((symbol? value) (symbol->string value))
        (else (error "unknown type for extra-field value" value))))

(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 default-theme logo timezone language text-limit dupe-limit
              site-notice themes plugins extra-fields)

   (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"))
          (theme-dir (string-append "/etc/gnu-social-"
                                    site-domain "/theme"))
          (plugin-dir (string-append "/etc/gnu-social-"
                                     site-domain "/plugins"))
          (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'] = '" default-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"
      "$config['theme']['dir'] = '" theme-dir "';\n"
      "$config['plugins']['dir'] = '" plugin-dir "';\n"

      ;; TODO escape
      "$config['site']['notice'] = '" site-notice "';\n"

      ;; TODO, doesn't work with cli installation, yet. Core plugin tables are missing
      "// 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"

      (map (lambda (plugin)
             (define (make-plugin-arg-list args)
               ;; helper to create this php code:
               ;; 'param2' => 'value2'
               (string-join
                (map (lambda (arg)
                       (string-append "'" (symbol->string (car arg)) "'"
                                      " => "
                                      (var->php-source-string (cadr arg))))
                     args)
                ", \n    "))
             ;; handle the plugin list
             (cond ((or (not (list? plugin))
                        (null? plugin)) (warn "GNU Social: Ignoring invalid plugin" plugin) "")
                   ((eq? 'build-in (car plugin))
                    (match plugin
                      ((_ name args)
                       (string-append "addPlugin('" name "', array("
                                      (make-plugin-arg-list args)
                                      "));\n"))))
                   ((package? (car plugin))
                    (match plugin
                      ((package args)
                       (define name (assoc-ref (package-properties package) 'gnu-social-plugin-name))
                       (string-append "addPlugin('" name "', array("
                                      (make-plugin-arg-list args)
                                      "));\n"))))))
           plugins)

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

      (map (lambda (extra-field)
             (define head (car extra-field))
             (define value (cadr extra-field))
             (string-append "$config"
                            (string-join (map (lambda (h)
                                                (string-append
                                                 "['" (symbol->string h) "']"))
                                              head)
                                         "")
                            " = "
                            (var->php-source-string value)
                            ";\n"))
           extra-fields)))))

(define gnu-social
  (let ((commit "67a9c0415c395d92adeb784413bb9a88fba7347f"))
    (package
     (name "gnu-social")
     (version "1.2.0-beta4")
     (source (origin
              (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
                "0zdr91p8hjqdhnn1vahkav71rmyrk10nifz6inzxq2fiqrfg03b1"))))
     (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.
              ;; The file can not be in /etc because that might become readonly
              ;; and the config contians the mysql password
              (substitute* "lib/gnusocial.php"
                           (("\\$config_files\\[\\] = INSTALLDIR\\.'/config\\.php';")
                            "$config_files = array('/var/gnusocial/config.d/'.$_server.'.php');"))

              ;; load plugins from /etc
              (substitute* "lib/gnusocial.php"
                           (("\"local/plugins/\\{\\$pluginclass\\}\\.php\"")
                            "common_config('plugins', 'dir').\"/{$name}/{$pluginclass}.php\""))
              (substitute* "lib/gnusocial.php"
                           (("\\$fullpath = INSTALLDIR\\.'/'\\.\\$file;")
                            "$fullpath = $file;"))

              ;; fix paths plugin classes and actions loading
              (substitute* "lib/plugin.php"
                           (("INSTALLDIR ?\\. ?'/local/plugins")
                            "common_config('plugins', 'dir').'"))

              (substitute* "lib/plugin.php"
                           (("INSTALLDIR ?\\. ?\"/local/plugins")
                            "common_config('plugins', 'dir').\""))

              ;; set the domain (server) before config init, so the domain specific config can be found
              (substitute* "lib/installer.php"
                           (("require_once INSTALLDIR . '/lib/common.php';")
                            "$server = $this->server; require_once INSTALLDIR . '/lib/common.php'; "))



              (substitute* "scripts/checkschema.php"
                           (("require_once INSTALLDIR.'/scripts/commandline.inc';")
                            "
$shortoptions = 's:x::';
$longoptions = array('server=', 'extensions=');

for ($i=0; $i< count($argv); $i++) {
   if ($argv[$i] == '--server' || $argv[$i] == '-s') {
       $server = $argv[$i+1];
   }
}
require_once INSTALLDIR . '/scripts/commandline.inc';"))

              ;; hide the Admin panel, since configuration is done through guix
              (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-public gnu-social-plugin-sensitive-media
  (let ((commit "a096bbe0cfae9a9b177682920ffb58d32a48e136")
        (plugin-name "SensitiveContent"))
    (package
     (name "gnu-social-plugin-sensitive-media")
     (version commit)
     (source (origin
              (method git-fetch)    ; no tarball available
              (uri (git-reference
                    (url "https://gitgud.io/ShitposterClub/SensitiveContent.git")
                    (commit commit)))   ; using the latest version
              (sha256
               (base32
                "0rp6zvyn47v527clqjnq2ckjkv7xyhg8d85pfs6k1pmdi6jfmqrj"))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases
        (modify-phases
         %standard-phases
         (delete 'configure)
         (delete 'check)
         (delete 'build)
         (replace
          'install
          (lambda* (#:key outputs #:allow-other-keys)
            (let ((out (string-append (assoc-ref %outputs "out")
                                      "/share/gnu-social/plugins/"
                                      ,plugin-name)))
              (mkdir-p out)
              (copy-recursively "." out)
              #t))))))
     (home-page "https://gitgud.io/ShitposterClub/SensitiveContent")
     (synopsis "nsfw plugin for gnu social")
     (properties `((gnu-social-plugin-name . ,plugin-name)))
     (description
      "SensitiveContent gives GNU Social users the option to hide
 sensitive media when it was tagged with #nsfw.")
     (license license:agpl3+))))

(define-public gnu-social-plugin-qvitter
  (let ((commit "7f41ca572978372a8dd7f8875728f41b4e63f561")
        (plugin-name "Qvitter"))
    (package
     (name "gnu-social-plugin-qvitter")
     (version commit)
     (source (origin
              (method git-fetch)    ; no tarball available
              (uri (git-reference
                    (url "https://git.gnu.io/h2p/Qvitter.git")
                    (commit commit)))   ; using the latest version
              (sha256
               (base32
                "1qfrvjbm3d25yyyd939fh8rmaaf1chzg6d6bchpv5lziqdcpc0z6"))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases
        (modify-phases
         %standard-phases
         (delete 'configure)
         (delete 'check)
         (delete 'build)
         (replace
          'install
          (lambda*
              (#:key outputs properties #:allow-other-keys)
            (let ((out (string-append (assoc-ref %outputs "out")
                                      "/share/gnu-social/plugins/"
                                      ,plugin-name)))
              (mkdir-p out)
              (copy-recursively "." out)
              #t))))))
     (home-page "https://git.gnu.io/h2p/Qvitter")
     (synopsis "gnusocial javascript ui")
     (properties `((gnu-social-plugin-name . ,plugin-name)))
     (description
      "Qvitter is plugin for gnu-social that provides
a modern javascript user interface.")
     (license license:agpl3+))))

(define-public gnu-social-theme-hidamari-blue
  (let ((commit "8e4287fbe945b7b4239d6e097696a0d70938adbf")
        (theme-name "hidamari-blue"))
    (package
     (name "gnu-social-theme-hidamari-blue")
     (version commit)
     (source (origin
              (method git-fetch)    ; no tarball available
              (uri (git-reference
                    (url "https://hidamari.blue/git/gs-theme-hidamari-blue")
                    (commit commit)))   ; using the latest version
              (sha256
               (base32
                "1xihx6aflpvps4iiv1wkxmwdm6rwjvnnw3gygxbxkdm7ljmzxlf5"))))
     (build-system gnu-build-system)
     (arguments
      `(#:phases
        (modify-phases
         %standard-phases
         (delete 'configure)
         (delete 'check)
         (delete 'build)
         (replace
          'install
          (lambda*
              (#:key outputs properties #:allow-other-keys)
            (let ((out (string-append (assoc-ref %outputs "out")
                                      "/share/gnu-social/theme/"
                                      ,theme-name)))
              (mkdir-p out)
              (copy-recursively "." out)
              #t))))))
     (home-page "https://hidamari.blue/git/gnu-social-theme")
     (synopsis "blue gnu social theme")
     (properties `((gnu-social-theme-name . ,theme-name)))
     (description "hidamari-blue is a blueish gnu social theme.")
     (license license:agpl3+))))



(define (gnu-social-plugins-etc-service config)
  (match-record config <gnu-social-config>
                (site-domain plugins themes gnu-social)
                (let ((package-plugins
                       (filter (lambda (plugin)
                                 (cond ((or (not (list? plugin))
                                            (null? plugin)) #f)
                                       ((eq? 'build-in (car plugin)) #f)
                                       ((package? (car plugin)) #t)))
                               plugins)))

                  ;; setup /etc/gnu-social-<domain>/plugins and themes
                  `((,(string-append "gnu-social-" site-domain)
                     ,(file-union
                       (string-append "gnu-social-plugins-and-themes-" site-domain)
                       `(("theme"
                          ,(directory-union
                            (string-append "gnu-social-themes-" site-domain)
                            (cons
                             ;; the default installation's build-in themes
                             (file-append gnu-social "/share/gnu-social/theme")
                             ;; additional custom themes
                             (map (lambda (theme)
                                    (file-append theme "/share/gnu-social/theme"))
                                  themes))))
                         ("plugins"
                          ,(directory-union
                            (string-append "gnu-social-plugins-" site-domain)
                            (cons
                             ;; the default installation's build-in plugins
                             (file-append gnu-social "/share/gnu-social/plugins")
                             ;; plugins from additional packages
                             (map (lambda (plugin)
                                    (file-append (car plugin) "/share/gnu-social/plugins"))
                                  package-plugins)))))))))))

;;; core and default plugin list taken from lib/default.php
(define %gnu-social-core-plugins
  (list "ActivityVerb" "ActivityVerbPost" "ActivityModeration" "AuthCrypt"
        "Cronish" "Favorite" "HTMLPurifierSchemes" "Share" "LRDD"))

;; default plugins, can be deactivated.
(define %gnu-social-default-plugins
  (list "Activity" "AntiBrute" "Bookmark" "ClientSideShorten" "DefaultLayout"
        "Directory" "DirectMessage" "EmailAuthentication" "Event" "Oembed"
        "OpenID"  "OpportunisticQM" "OStatus" "Poll" "SearchSub" "SimpleCaptcha"
        "TagSub" "WebFinger"))

(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 logo timezone language text-limit dupe-limit site-notice plugins)

   (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))
          (plugin-names (append %gnu-social-core-plugins
                                %gnu-social-default-plugins
                                (map (match-lambda
                                      (('build-in name _args)
                                       name)
                                      ((package _args)
                                       (assoc-ref (package-properties package)
                                                  'gnu-social-plugin-name)))
                                     plugins))))
     (with-passwords
      password-file
      ((optional mysql-root-password)
       (generatable gnu-social-db-password 32 alphanumeric)
       (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)

            ;; install/upgrade && check-addon-changes
            (and (cond ((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"
                                           (append
                                            (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)))
                       ;; Upgrade case
                       ((not (equal? #$installed-version #$gnu-social-version))
                        ;; upgrade existing installation
                        (format #t "Upgrading gnu-social database ~a from ~a to ~a."
                                #$db-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)))
                       ;; same version already installed, do nothing
                       (else #t))
                 ;; run checkschema script to do db migrations for any changed addons
                 ;; (zero? (system* (warn php) (warn (string-append #$gnu-social "/share/gnu-social/scripts/checkschema.php"))
                 ;;          "-x" (warn
                 ;;                (string-join
                 ;;             ;; for some reason lists have to be quoted when they are expanded with #$
                 ;;             (warn (quote #$plugin-names))
                 ;;             ","))
                 ;;          "--server" #$site-domain))
                 )))))))

(define (gnu-social-shepherd-service _config)
  ;; only used to assure that mysql and php-fpm are started before running the activation
  (list
   (shepherd-service (provision '(gnu-social))
                     (requirement '(mysql php-fpm))
                     (respawn? #f)
                     (start #~(const #t))
                     (documentation "GNU Social init/upgrade service"))))

(define gnu-social-service-type
  ;; TODO add requirement, otherwise activation can fail if mysql and php-fpm aren't running
  ;; (requirement '(php-fpm mysql))
  (service-type (name 'gnu-social)
                (extensions
                 (list (service-extension activation-service-type
                                          gnu-social-activation)
                       (service-extension etc-service-type
                                          gnu-social-plugins-etc-service)
                       (service-extension shepherd-root-service-type
                                          gnu-social-shepherd-service)))))