;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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 (gnu services authentication)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services dbus)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages openldap)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (fprintd-configuration
            fprintd-configuration?
            fprintd-service-type

            nslcd-configuration
            nslcd-configuration?
            nslcd-service-type))

(define-configuration fprintd-configuration
  (fprintd      (file-like fprintd)
                "The fprintd package"))

(define (fprintd-dbus-service config)
  (list (fprintd-configuration-fprintd config)))

(define fprintd-service-type
  (service-type (name 'fprintd)
                (extensions
                 (list (service-extension dbus-root-service-type
                                          fprintd-dbus-service)
                       (service-extension polkit-service-type
                                          fprintd-dbus-service)))
                (default-value (fprintd-configuration))
                (description
                 "Run fprintd, a fingerprint management daemon.")))


;;;
;;; NSS Pam LDAP service (nslcd)
;;;

(define (uglify-field-name name)
  (match name
    ('filters "filter")
    ('maps "map")
    (_ (string-map (match-lambda
                     (#\- #\_)
                     (chr chr))
                   (symbol->string name)))))

(define (value->string val)
  (cond
   ((boolean? val)
    (if val "on" "off"))
   ((number? val)
    (number->string val))
   ((symbol? val)
    (string-map (match-lambda
                     (#\- #\_)
                     (chr chr))
                   (symbol->string val)))
   (else val)))

(define (serialize-field field-name val)
  (if (eq? field-name 'pam-services)
      #t
      (format #t "~a ~a\n"
              (uglify-field-name field-name)
              (value->string val))))

(define serialize-string serialize-field)
(define serialize-boolean serialize-field)
(define serialize-number serialize-field)
(define (serialize-list field-name val)
  (map (cut serialize-field field-name <>) val))
(define-maybe string)
(define-maybe boolean)
(define-maybe number)

(define (ssl-option? val)
  (or (boolean? val)
      (eq? val 'start-tls)))
(define serialize-ssl-option serialize-field)
(define-maybe ssl-option)

(define (tls-reqcert-option? val)
  (member val '(never allow try demand hard)))
(define serialize-tls-reqcert-option serialize-field)
(define-maybe tls-reqcert-option)

(define (deref-option? val)
  (member val '(never searching finding always)))
(define serialize-deref-option serialize-field)
(define-maybe deref-option)

(define (comma-separated-list-of-strings? val)
  (and (list? val)
       (every string? val)))
(define (ignore-users-option? val)
  (or (comma-separated-list-of-strings? val)
      (eq? 'all-local val)))
(define (serialize-ignore-users-option field-name val)
  (serialize-field field-name (if (eq? 'all-local val)
                                  val
                                  (string-join val ","))))
(define-maybe ignore-users-option)

(define (log-option? val)
  (let ((valid-scheme? (lambda (scheme)
                         (or (string? scheme)
                             (member scheme '(none syslog))))))
    (match val
      ((scheme level)
       (and (valid-scheme? scheme)
            (member level '(crit error warning notice info debug))))
      ((scheme)
       (valid-scheme? scheme)))))
(define (serialize-log-option field-name val)
  (serialize-field field-name
                   (string-join (map (cut format #f "~a" <>) val))))

(define (valid-map? val)
  "Is VAL a supported map name?"
  (member val
          '(alias aliases ether ethers group host hosts netgroup network networks
            passwd protocol protocols rpc service services shadow)))

(define (scope-option? val)
  (let ((valid-scopes '(subtree onelevel base children)))
    (match val
      ((map-name scope)
       (and (valid-map? map-name)
            (member scope valid-scopes)))
      ((scope)
       (member scope valid-scopes)))))
(define (serialize-scope-option field-name val)
  (serialize-field field-name
                   (string-join (map (cut format #f "~a" <>) val))))

(define (map-entry? val)
  (match val
    (((? valid-map? map-name)
      (? string? attribute)
      (? string? new-attribute)) #t)
    (_ #f)))

(define (list-of-map-entries? val)
  (and (list? val)
       (every map-entry? val)))

(define (filter-entry? val)
  (match val
    (((? valid-map? map-name)
      (? string? filter-expression)) #t)
    (_ #f)))

(define (list-of-filter-entries? val)
  (and (list? val)
       (every filter-entry? val)))

(define (serialize-filter-entry field-name val)
  (serialize-field 'filter
                   (match val
                     (((? valid-map? map-name)
                       (? string? filter-expression))
                      (string-append (symbol->string map-name)
                                     " " filter-expression)))))

(define (serialize-list-of-filter-entries field-name val)
  (for-each (cut serialize-filter-entry field-name <>) val))

(define (serialize-map-entry field-name val)
  (serialize-field 'map
                   (match val
                     (((? valid-map? map-name)
                       (? string? attribute)
                       (? string? new-attribute))
                      (string-append (symbol->string map-name)
                                     " " attribute
                                     " " new-attribute)))))

(define (serialize-list-of-map-entries field-name val)
  (for-each (cut serialize-map-entry field-name <>) val))


(define-configuration nslcd-configuration
  (nss-pam-ldapd
   (file-like nss-pam-ldapd)
   "The NSS-PAM-LDAPD package to use.")

  ;; Runtime options
  (threads
   maybe-number
   "The number of threads to start that can handle requests and perform LDAP
queries.  Each thread opens a separate connection to the LDAP server.  The
default is to start 5 threads.")
  (uid
   (string "nslcd")
   "This specifies the user id with which the daemon should be run.")
  (gid
   (string "nslcd")
   "This specifies the group id with which the daemon should be run.")
  (log
   (log-option '("/var/log/nslcd" info))
   "This option controls the way loggi