(define-module (org euandre packages)
  #:use-module ((guix licenses) #:prefix licenses:)
  #:use-module ((ice-9 match) #:prefix m:)
  #:use-module ((ice-9 textual-ports) #:prefix textual-ports:)
  #:use-module ((org euandre queue) #:prefix q:)
  #:use-module ((srfi srfi-1) #:prefix s1:)
  #:use-module (gnu)
  #:use-module (gnu packages)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages texinfo)
  #:use-module (guix build utils)
  #:use-module (guix build-system gnu)
  #:use-module (guix download)
  #:use-module (guix gexp)
  #:use-module (guix least-authority)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:export (<syskeep-configuration>
             syskeep-configuration
        make-syskeep-configuration
             syskeep-configuration?
             syskeep-configuration-package
             syskeep-configuration-log-file

	    <binder-configuration>
             binder-configuration
        make-binder-configuration
             binder-configuration?
             binder-configuration-name
             binder-configuration-package
             binder-configuration-user
             binder-configuration-group
             binder-configuration-log-file
             binder-configuration-data-directory
             binder-configuration-run-directory
             binder-configuration-run-in-container?
             binder-configuration-container-name
             binder-configuration-extra-mappings
             binder-configuration-options
             binder-configuration-listen-socket
             binder-configuration-upstream-socket

            <glaze-configuration>
             glaze-configuration
        make-glaze-configuration
             glaze-configuration?
             glaze-configuration-name
             glaze-configuration-package
             glaze-configuration-user
             glaze-configuration-group
             glaze-configuration-log-file
             glaze-configuration-data-directory
             glaze-configuration-run-directory
             glaze-configuration-run-in-container?
             glaze-configuration-container-name
             glaze-configuration-extra-mappings
             glaze-configuration-options
             glaze-configuration-listen-socket
             glaze-configuration-upstream-socket

            <untls-configuration>
             untls-configuration
        make-untls-configuration
             untls-configuration?
             untls-configuration-name
             untls-configuration-package
             untls-configuration-user
             untls-configuration-group
             untls-configuration-log-file
             untls-configuration-data-directory
             untls-configuration-run-directory
             untls-configuration-run-in-container?
             untls-configuration-container-name
             untls-configuration-extra-mappings
             untls-configuration-options
             untls-configuration-listen-socket
             untls-configuration-upstream-socket

            <wscat-configuration>
             wscat-configuration
        make-wscat-configuration
             wscat-configuration?
             wscat-configuration-name
             wscat-configuration-package
             wscat-configuration-user
             wscat-configuration-group
             wscat-configuration-log-file
             wscat-configuration-data-directory
             wscat-configuration-run-directory
             wscat-configuration-run-in-container?
             wscat-configuration-container-name
             wscat-configuration-extra-mappings
             wscat-configuration-options
             wscat-configuration-listen-socket
             wscat-configuration-upstream-socket

            <papod-configuration>
             papod-configuration
        make-papod-configuration
             papod-configuration?
             papod-configuration-name
             papod-configuration-package
             papod-configuration-user
             papod-configuration-group
             papod-configuration-log-file
             papod-configuration-data-directory
             papod-configuration-run-directory
             papod-configuration-run-in-container?
             papod-configuration-container-name
             papod-configuration-extra-mappings
             papod-configuration-options
             papod-configuration-listen-socket
             papod-configuration-upstream-socket))
(use-package-modules
  admin
  version-control)
(use-service-modules
  admin
  mcron
  shepherd)



(define-public (pkg name version checksum)
  (package
    (name name)
    (version version)
    (source
      (origin
        (method url-fetch)
        (uri
          (string-append
           "https://euandre.org/git/" name "/snapshot/" name "-" version ".tar.xz"))
        (sha256
          (base32 checksum))))
    (build-system gnu-build-system)
    (arguments
      (list
       #:make-flags #~(list (string-append "PREFIX=" #$output))
       #:phases
       #~(modify-phases %standard-phases
           (delete 'configure))))
    (synopsis    #f) ;; FIXME: get
    (description #f) ;;        from tarball!
    (home-page (string-append "https://euandre.org/git/" name "/"))
    (license licenses:agpl3+)))


(define-public remembering
  (pkg
   "remembering"
   "22a7b4f0c8e018077984d58476a0c419b5e11942"
   "01wnq0vbl70dwxh19pqv258r9kd850kwi4nv1h4q4vmg5iiglhd1"))

(define-public eut
  (pkg
   "eut"
   "c5fbe36d5e71a94589039ad9bc422da543fddf01"
   "013aayqb64qvafvnpshwg30nndjv5gj69l5xs0li6xvjkhmpsvnw"))

(define-public cage
  (pkg
   "cage"
   "c0482531fc16a55715b759b695d27d555d927ab8"
   "0laan68dj3s1n2d2alcwpvhnjjc2483kyx5xl384rcwrn3s0kcyl"))

(define-public nicely
  (pkg
   "nicely"
   "6699e732f00d2a8d8c377527dc588824ba3cbece"
   "1j6s7z29m126mxgacqbk0g4lmk8ap526z716d70kbwadh91n1a5v"))

(define-public q
  (pkg
   "q"
   "5e8e65015a77ed7606c6cfbd2d1cedc79e42a6a5"
   "1dramr7p5ncbnna0v3ncaa77rm1c8vzxw5si4n6d3rr0ji2v48ac"))

(define-public syskeep
  (pkg
   "syskeep"
   "ff2fc08875db996c251a52f43c07fe93b7718fd6"
   "04d6fzycfv87gzsjaxlrkb3dgm4m2kqpx2ypjkbmyxq9qbqqd7m7"))

(define-public guile-heredoc
  (package
    (inherit
      (pkg
       "guile-heredoc"
       "065435cdce609604e33b879b9be3e81ab89f3e7b"
       "1y1110bg4ki0dvn8hggxy34wg7ig4r3377nc84isnj3dydqm2vjd"))
    (native-inputs
      (list
       guile-3.0
       texinfo))))



(define (format-inputs l)
  (map (lambda (p)
         (list (package-name p)
               p
               "out"))
       l))

(define (normalize-inputs l)
  (map (compose (lambda (l)
                  (cons (package-name (car l))
                        l))
                list
                specification->package+output
                symbol->string)
       l))

(define (gopkg name inputs version checksum)
  (package
    (inherit
      (pkg
       name
       version
       checksum))
    (source
      (origin
        (method url-fetch)
        (uri
          (string-append "https://papo.im/git/"
                         name
                         "/snapshot/"
                         name
                         "-"
                         version
                         ".tar.xz"))
        (sha256
          (base32 checksum))))
    (arguments
      (list
       #:strip-binaries? #f
       #:make-flags
       #~(list
          "-e"
          (string-append "PREFIX=" #$output)
          (string-append "VERSION=" #$version)
          (string-append "CC=" #$(cc-for-target)))
       #:phases
       #~(modify-phases %standard-phases
           (delete 'configure)
           (add-before 'build 'setenv-golang
             (lambda _
               (define (path->flags option)
                 (let ((search-path (getenv "GOLIBPACKPATH")))
                   (string-join
                    (map (lambda (path)
                           (string-append option " " path))
                         (if search-path
                           (string-split search-path #\:)
                           '()))
                    " ")))
               (setenv "GOCFLAGS"  (path->flags "-I"))
               (setenv "GOLDFLAGS" (path->flags "-L")))))))
    (native-inputs
      (append
       (format-inputs
        (list q:go-full))
       inputs))
    (native-search-paths
      (list
       (search-path-specification
         (variable "GOLIBPACKPATH")
         (files
           (list "lib/go")))))))


(define-public gobang
  (gopkg
   "gobang"
   '()
   "b1bed38e5e0a261616343c7555962162416c28e2"
   "1h937x3clk3xydvl7876qd3b6plapjsnxmdlyan1iydmh6ym7vg0"))

(define-public golite
  (gopkg
   "golite"
   (normalize-inputs '(sqlite))
   "b31e279bade22276f27f4990b7564a2114f3058a"
   "14q9bhkw1v60mby187balwnnwyz2ig8hi03v5f2nm8p3m8sl5ykd"))

(define-public binder
  (gopkg
   "binder"
   (append (format-inputs     (list gobang eut))
           (normalize-inputs '(socat lsof)))
   "aa44df7545e13f6d2bb5ea088786d14f4a31a04d"
   "15zdcvx1gxlzz3g7gasckna3xfrf0c6yd8pvii169ivgm0rrbpll"))

(define-public wscat
  (gopkg "wscat"
   (append (format-inputs     (list gobang eut))
           (normalize-inputs '()))
   "00f822df8bcecc3b40bdc39f0cd5dfb6d1efc45e"
   "0ypj05w6kh7dd55qn0gfc1fdiyy5kfalypxm5dhsbmqkzk09m3id"))

(define-public glaze
  (gopkg
   "glaze"
   (append (format-inputs     (list gobang eut))
           (normalize-inputs '()))
   "ebe6b2ae31145fd3534a0fb583410ce2cd8e8d69"
   "0r0lsfx5g6crgyrzf8kqid3370lvyq0h573qbcpzl6mcm57nc9hj"))

(define-public untls
  (gopkg
   "untls"
   (append (format-inputs     (list gobang eut))
           (normalize-inputs '()))
   "3833dbae57bcf87a33ecbb38fb877861fb1c8d63"
   "0pxmqhzy4286w3aivq1qykqdr4mcd6b3p7q9frbnwlqmk5gfp36z"))

(define-public papod
  (gopkg
   "papod"
   (append (format-inputs     (list gobang golite eut))
           (normalize-inputs '(sqlite sqlite:static)))
   "db0315223571daaf43ab5e8456bed7f3d7f9dafa"
   "19dr8w1hpi9h8rjad9dwb0s6r41xgj1x4m4j7yndchikwrwg4lgx"))






(define-public (mklist x)
  (if (not x)
    '()
    (if (pair? x)
      x
      (list x))))

(define-public (slurp path)
  (call-with-input-file
   path
   textual-ports:get-string-all))

(define-public (str . rest)
  (apply string-append rest))

(define-public (fmt . rest)
  (apply format #f rest))

(define-public (user-accounts users)
  (map (lambda (user)
         (let ((name    (s1:first  user))
               (comment (s1:second user))
               (groups  (s1:third  user)))
           (user-account
             (name name)
             (comment comment)
             (group "users")
             (supplementary-groups groups))))
       users))

(define-public (users->keys users)
  (let ((users-with-keys (filter (compose not null? cdddr)
                                 users)))
    (append
     (map (lambda (user)
            (let ((name (s1:first  user))
                  (key  (s1:fourth user)))
              `(,name ,(plain-file (str name "-id_rsa.pub") key))))
          users-with-keys)
    `(("git" ,@(map (lambda (user)
                      (let ((name (s1:first  user))
                            (key  (s1:fourth user)))
                        (plain-file (str name "-git-id_rsa.pub")
                                    (slurp key))))
                    users-with-keys))))))

(define (tuple->entry tuple)
  (let* ((name    (s1:first  tuple))
         (package (s1:second tuple))
         (path (string-append "/etc/" name)))
    (list
     name
     (computed-file
      (string-append "syskeep-" name)
      #~(begin
          (use-modules
            ((ice-9 textual-ports) #:prefix textual-ports:))

          (define (slurp p)
            (call-with-input-file p textual-ports:get-string-all))

          (define (spit p s)
            (call-with-output-file
             p
             (lambda (port)
               (display s port))))

          (spit #$output
                (slurp #$(file-append package path))))))))

(define (etc-entries package paths)
  (map
   tuple->entry
   (map (lambda (path)
          (list path package))
        paths)))

(define-public (package-set symbols records)
  (append
   records
   (map
    (compose list specification->package+output symbol->string)
    symbols)))

(define-public skeletons
  (etc-entries
   syskeep
   '(".profile")))

(define-public base-services
  (modify-services %base-services
    (rottlog-service-type config =>
      (rottlog-configuration
        (inherit config)
        (rc-file
          (file-append q:rottlog-mailutils-sendmail "/etc/rc"))))))



(define-record-type* <syskeep-configuration>
  syskeep-configuration
  make-syskeep-configuration
  syskeep-configuration?
  (package  syskeep-configuration-package  (default syskeep))
  (log-file syskeep-configuration-log-file (default "/var/log/cronjobs/cronjobs.log")))

(define (syskeep-profile config)
  (match-record config <syskeep-configuration>
      (package)
    (package-set
     '(parted
       guile-heredoc
       acl
       bind:utils
       knot:tools
       file
       git
       lsof
       moreutils
       mailutils-sendmail
       curl
       make
       borg
       rsync
       sqlite
       strace
       rlwrap
       trash-cli
       tree)
      (list
       package))))

(define (syskeep-rotations config)
  (match-record config <syskeep-configuration>
      (log-file)
    (list
     (log-rotation
       (frequency 'weekly)
       (files (list log-file))
       (options '("rotate 52"))))))

(define (syskeep-cronjobs config)
  (match-record config <syskeep-configuration>
      ()
    (list
     #~(job "0 0 * * *" "cronjob check")
     #~(job "0 1 * * *" "cronjob env BORG_REPO=/mnt/backup/borg backup -q cron")
     #~(job "0 2 * * *" "cronjob                                backup -q cron")
     #~(job "0 3 * * 0" "cronjob gc")
     #~(job "0 4 * * *" "cronjob reconfigure -U"))))

(define (syskeep-etc-files config)
  (match-record config <syskeep-configuration>
      (package)
    (etc-entries
     package
     '("rc.sh"
       "known_hosts"
       "ssh.conf"
       "init.scm"
       "gitconfig"))))

(define (syskeep-accounts config)
  (match-record config <syskeep-configuration>
      ()
    (list
     (user-account
       (name  "git")
       (group "git")
       (system? #t)
       (comment "External SSH Git user")
       (home-directory "/src/ĝit")
       (create-home-directory? #f)
       (shell
         (file-append git "/bin/git-shell")))
     (user-group
       (name "git")
       (system? #t)))))

(define-public syskeep-service-type
  (service-type
    (name 'syskeep)
    (extensions
      (list
       (service-extension rottlog-service-type
                          syskeep-rotations)
       (service-extension mcron-service-type
                          syskeep-cronjobs)
       (service-extension etc-service-type
                          syskeep-etc-files)
       (service-extension account-service-type
                          syskeep-accounts)
       (service-extension profile-service-type
                          syskeep-profile)))
    (default-value (syskeep-configuration))
    (description "Common configuration of maintained servers.")))



(define-record-type* <binder-configuration>
  binder-configuration
  make-binder-configuration
  binder-configuration?
  (name              binder-configuration-name              (default "binder"))
  (package           binder-configuration-package           (default binder))
  (user              binder-configuration-user              (default "binder"))
  (group             binder-configuration-group             (default "binder"))
  (log-file          binder-configuration-log-file          (default "/var/log/binder/binder.log"))
  (data-directory    binder-configuration-data-directory    (default #f))
  (run-directory     binder-configuration-run-directory     (default "/var/run/binder"))
  (run-in-container? binder-configuration-run-in-container? (default #t))
  (container-name    binder-configuration-container-name    (default "binder-container"))
  (extra-mappings    binder-configuration-extra-mappings    (default '()))
  (options           binder-configuration-options           (default '()))
  (listen-socket     binder-configuration-listen-socket     (default "0.0.0.0:4443"))
  (upstream-socket   binder-configuration-upstream-socket   (default "/var/run/untls/untls.socket")))

(define-record-type* <glaze-configuration>
  glaze-configuration
  make-glaze-configuration
  glaze-configuration?
  (name              glaze-configuration-name              (default "glaze"))
  (package           glaze-configuration-package           (default glaze))
  (user              glaze-configuration-user              (default "glaze"))
  (group             glaze-configuration-group             (default "glaze"))
  (log-file          glaze-configuration-log-file          (default "/var/log/glaze/glaze.log"))
  (data-directory    glaze-configuration-data-directory    (default "/var/lib/glaze"))
  (run-directory     glaze-configuration-run-directory     (default "/var/run/glaze"))
  (run-in-container? glaze-configuration-run-in-container? (default #t))
  (container-name    glaze-configuration-container-name    (default "glaze-container"))
  (extra-mappings    glaze-configuration-extra-mappings    (default '()))
  (options           glaze-configuration-options           (default '()))
  (listen-socket     glaze-configuration-listen-socket     (default "/var/run/glaze/glaze.socket"))
  (upstream-socket   glaze-configuration-upstream-socket   (default #f)))

(define-record-type* <untls-configuration>
  untls-configuration
  make-untls-configuration
  untls-configuration?
  (name              untls-configuration-name              (default "untls"))
  (package           untls-configuration-package           (default untls))
  (user              untls-configuration-user              (default "untls"))
  (group             untls-configuration-group             (default "untls"))
  (log-file          untls-configuration-log-file          (default "/var/log/untls/untls.log"))
  (data-directory    untls-configuration-data-directory    (default #f))
  (run-directory     untls-configuration-run-directory     (default "/var/run/untls"))
  (run-in-container? untls-configuration-run-in-container? (default #t))
  (container-name    untls-configuration-container-name    (default "untls-container"))
  (extra-mappings    untls-configuration-extra-mappings    (default '()))
  (options           untls-configuration-options           (default '()))
  (listen-socket     untls-configuration-listen-socket     (default "/var/run/untls/untls.socket"))
  (upstream-socket   untls-configuration-upstream-socket   (default #f)))

(define-record-type* <wscat-configuration>
  wscat-configuration
  make-wscat-configuration
  wscat-configuration?
  (name              wscat-configuration-name              (default "wscat"))
  (package           wscat-configuration-package           (default wscat))
  (user              wscat-configuration-user              (default "wscat"))
  (group             wscat-configuration-group             (default "wscat"))
  (log-file          wscat-configuration-log-file          (default "/var/log/wscat/wscat.log"))
  (data-directory    wscat-configuration-data-directory    (default #f))
  (run-directory     wscat-configuration-run-directory     (default "/var/run/wscat"))
  (run-in-container? wscat-configuration-run-in-container? (default #t))
  (container-name    wscat-configuration-container-name    (default "wscat-container"))
  (extra-mappings    wscat-configuration-extra-mappings    (default '()))
  (options           wscat-configuration-options           (default '()))
  (listen-socket     wscat-configuration-listen-socket     (default "/var/run/wscat/wscat.socket"))
  (upstream-socket   wscat-configuration-upstream-socket   (default "/var/run/papod/papod.socket")))

(define-record-type* <papod-configuration>
  papod-configuration
  make-papod-configuration
  papod-configuration?
  (name              papod-configuration-name              (default "papod"))
  (package           papod-configuration-package           (default papod))
  (user              papod-configuration-user              (default "papod"))
  (group             papod-configuration-group             (default "papod"))
  (log-file          papod-configuration-log-file          (default "/var/log/papod/papod.log"))
  (data-directory    papod-configuration-data-directory    (default "/var/lib/papod"))
  (run-directory     papod-configuration-run-directory     (default "/var/run/papod"))
  (run-in-container? papod-configuration-run-in-container? (default #t))
  (container-name    papod-configuration-container-name    (default "papod-container"))
  (extra-mappings    papod-configuration-extra-mappings    (default '()))
  (options           papod-configuration-options           (default '()))
  (listen-socket     papod-configuration-listen-socket     (default "/var/run/papod/papod.socket"))
  (upstream-socket   papod-configuration-upstream-socket   (default #f)))

(define-public (profile-for type)
  (lambda (config)
    (m:match config
      (($ type _name package)
       (list package)))))

(define-public (rotations-for type)
  (lambda (config)
    (m:match config
      (($ type _name _package _user _group log-file)
       (list
         (log-rotation
           (frequency 'weekly)
           (files (list log-file))
           (options '("rotate 5200"))))))))

(define-public (activation-for type)
  (lambda (config)
    (m:match config
      (($ type name _package user _group log-file data-directory run-directory)
       #~(begin
           (use-modules (guix build utils))
           (when #$log-file
             (format (current-error-port)
              "Creating ~a log directory for '~a'.~%" #$name #$log-file)
             (mkdir-p (dirname #$log-file))
             (when (not (file-exists? #$log-file))
               (call-with-output-file #$log-file (const #t)))
             (chmod #$log-file #o644))
           (let ((user (getpwnam #$user)))
             (when #$data-directory
               (format (current-error-port)
                "Creating ~a data directory '~a'.~%" #$name #$data-directory)
               (mkdir-p #$data-directory)
               (chown #$data-directory (passwd:uid user) (passwd:gid user))
               (chmod #$data-directory #o750))
             (when #$run-directory
               (format (current-error-port)
                "Creating ~a run directory '~a'.~%" #$name #$run-directory)
               (mkdir-p #$run-directory)
               (chown #$run-directory (passwd:uid user) (passwd:gid user))
               (chmod #$run-directory #o755))))))))

(define-public (accounts-for type)
  (lambda (config)
    (m:match config
      (($ type name _package user group)
       (list
        (user-group
          (name group)
          (system? #t))
        (user-account
          (name user)
          (group group)
          (system? #t)
          (comment (format #f "The user for runtime execution of ~a code" name))
          (home-directory "/var/empty")
          (create-home-directory? #f)
          (shell
            (file-append shadow "/sbin/nologin"))))))))

(define-public (cmd-for type config)
  (m:match config
    (($ type name package user group _log-file data-directory _run-directory
             run-in-container? container-name extra-mappings)
     (let ((bin (file-append package (string-append "/bin/" name))))
       (if (not run-in-container?)
         bin
         (least-authority-wrapper
          bin
          #:user      user
          #:group     group
          #:name      container-name
          #:directory (or data-directory "/")
          #:preserved-environment-variables
          '()
          #:mappings
          (append
           (mklist
            (and data-directory
                 (file-system-mapping
                   (source data-directory)
                   (target source)
                   (writable? #t))))
           extra-mappings)))))))

(define-public (shepherd-services-for type)
  (lambda (config)
    (m:match config
      (($ type name _package user group log-file data-directory _run-directory
               _run-in-container? _container-name _extra-mappings options
               listen-socket upstream-socket)
       (list
        (shepherd-service
          (provision (list (string->symbol name)))
          (requirement '())
          (start
            #~(make-forkexec-constructor
               (list #$(cmd-for type config)
                     #$@options
                     #$@(mklist listen-socket)
                     #$@(mklist upstream-socket))
               #:user      #$user
               #:group     #$group
               #:log-file  #$log-file
               #:directory #$data-directory))
          (stop #~(make-kill-destructor SIGKILL))
          (documentation
            (fmt "The Shepherd service that runs the server via \"~a\"." name))))))))

(define-public (service-type-for name type config extensions)
  (service-type
    (name name)
    (extensions
      (append
       (list
        (service-extension shepherd-root-service-type
                           (shepherd-services-for type))
        (service-extension profile-service-type
                           (profile-for type))
        (service-extension activation-service-type
                           (activation-for type))
        (service-extension account-service-type
                           (accounts-for type))
        (service-extension rottlog-service-type
                           (rotations-for type)))
       extensions))
    (default-value config)
    (description
      (fmt "The top-level generic system service, generated for ~a code.

It includes:
- the Shepherd service for starting, stopping and reloading the service;
- activation script for setting up the initial directories and permissions;
- the group and account for running the production service;
- log management (storage and rotation) for logs produced by the running services.

The default configuration should provide sane values for all of these."
       name))))



(define-public binder-service-type
  (service-type-for 'binder <binder-configuration> (binder-configuration) '()))

(define-public glaze-service-type
  (service-type-for 'glaze  <glaze-configuration>  (glaze-configuration)  '()))

(define-public untls-service-type
  (service-type-for 'untls  <untls-configuration>  (untls-configuration)  '()))

(define-public wscat-service-type
  (service-type-for 'wscat  <wscat-configuration>  (wscat-configuration)  '()))

(define-public papod-service-type
  (service-type-for 'papod  <papod-configuration>  (papod-configuration)  '()))



(list
 remembering
 eut
 cage
 nicely
 q
 syskeep
 guile-heredoc

 gobang
 golite
 binder
 glaze
 untls
 wscat
 papod)