(define-module (gnu services sssd)
  #:use-module (guix gexp)
  #:use-module (gnu system pam)
  #:use-module (gnu services dbus)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages sssd)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:export (sssd-domain-configuration sssd-configuration sssd-service-type))

(define-maybe string)

(define (serialize-field conv)
  (lambda (name value)
    (string-append (symbol->string name) " = "
                   (conv value) "\n")))

(define serialize-string
  (serialize-field (lambda (val)
                     val)))

(define-maybe boolean)
(define serialize-boolean
  (serialize-field (lambda (val)
                     (if val "True" "False"))))

(define-configuration sssd-domain-configuration
                      (id_provider maybe-string "id provider")
                      (auth_provider maybe-string "auth provider")
                      (cache_credentials maybe-boolean "cache credentials")
                      (ldap_uri maybe-string "ldap server uri")
                      (ldap_tls_reqcert maybe-string "tls_reqcert")
                      (ldap_tls_cacertdir maybe-string
                                          "ca certificate directory")
                      (ldap_search_base maybe-string "base dn for search")
                      (ldap_default_bind_dn maybe-string
                                            "dn to bind for search")
                      (ldap_default_authtok_type maybe-string
                                                 "ldap auth token type")
                      (ldap_default_authtok maybe-string
                                            "token to use for ldap bind"))

(define (sssd-domain-configuration-with-name? val)
  (if (pair? val)
      (if (string? (car val))
          (if (sssd-domain-configuration? (cdr val)) #t) #t) #f))

(define list-of-sssd-domain-configurations?
  (list-of sssd-domain-configuration-with-name?))

(define (serialize-sssd-domain-and-name value)
  (let ((name (car value))
        (config (cdr value)))
    #~(string-append "[domain/"
                     #$name "]\n"
                     #$(serialize-configuration config
                        sssd-domain-configuration-fields))))

(define (serialize-list-of-sssd-domain-configurations name value)
  #~(string-append "domains = "
                   (string-join (list #$@(map (lambda (x)
                                                (car x)) value)) ", ") "\n\n"
                   (string-join (list #$@(map serialize-sssd-domain-and-name
                                              value)) "\n")))

(define serialize-list-of-strings
  (serialize-field (lambda (value)
                     (string-join value ", "))))

(define-configuration sssd-configuration
                      (sssd (file-like sssd) "sssd package to use")
                      (pam-services (list-of-strings (list "su" "gdm-password"
                                                           "login" "sshd"
                                                           "passwd"))
                       "list of pam services to configure login for"
                       (lambda (a b)
                         ""))
                      (services (list-of-strings (list "nss" "sudo" "pam"
                                                       "ssh" "ifp"))
                                "list of services")
                      (domains (list-of-sssd-domain-configurations '())
                               "sssd domains to configure"))

(define (sssd-pam-service config)
  (define sssd-pam-module
    (file-append (sssd-configuration-sssd config) "/lib/security/pam_sss.so"))
  (lambda (pam)
    (if (member (pam-service-name pam)
                (sssd-configuration-pam-services config))
        (let ((sufficient (pam-entry (control "sufficient")
                                     (module sssd-pam-module))))
          (pam-service (inherit pam)
                       (auth (cons sufficient
                                   (pam-service-auth pam)))
                       (account (cons sufficient
                                      (pam-service-account pam)))
                       (password (cons sufficient
                                       (pam-service-password pam)))
                       (session (cons sufficient
                                      (pam-service-session pam))))) pam)))

(define (sssd-pam-services config)
  (list (sssd-pam-service config)))

(define (sssd-shepherd-service config)
  (list (shepherd-service (documentation "")
                          (provision '(sssd))
                          (requirement '(networking user-processes))
                          (start #~(make-forkexec-constructor (list (string-append #$
                                                                     (sssd-configuration-sssd
                                                                      config)
                                                                     "/sbin/sssd")
                                                               "-i"
                                                               "-c/var/lib/sss/sssd.conf")
                                                              #:user "root"
                                                              #:group "root"
                                                              #:environment-variables
                                                              (list (string-append
                                                                     "LD_LIBRARY_PATH="
                                                                     #$(sssd-configuration-sssd
                                                                        config)
                                                                     "/lib"))))
                          (stop #~(make-kill-destructor)))))

(define (sssd-configuration-file config)
  (mixed-text-file "sssd.conf"
                   #~(string-append "[sssd]\n"
                                    #$(serialize-configuration config
                                       sssd-configuration-fields))))

(define (sssd-activation config)
  #~(begin
      (let ((dbdir "/var/lib/sss/db")
            (dbusdir "/var/lib/sss/pipes/private")
            (user (getpw "root")))
        (mkdir-p/perms dbusdir user 493)
        (mkdir-p/perms dbdir user 493)
        (copy-file #$(sssd-configuration-file config) "/var/lib/sss/sssd.conf")
        (chmod "/var/lib/sss/sssd.conf" #o600))))

(define-public sssd-service-type
  (service-type (name 'sssd)
                (description "SSSD Service")
                (extensions (list (service-extension pam-root-service-type
                                                     sssd-pam-services)
                                  (service-extension dbus-root-service-type
                                                     (compose list
                                                      sssd-configuration-sssd))
                                  (service-extension activation-service-type
                                                     sssd-activation)
                                  (service-extension nscd-service-type
                                                     (const (list sssd)))
                                  (service-extension
                                   shepherd-root-service-type
                                   sssd-shepherd-service)))
                (default-value (sssd-configuration))))