;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
;;;
;;; 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 kerberos)
  #:use-module (gnu packages admin)
  #:use-module (gnu services)
  #:use-module (gnu system pam)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:export (pam-krb5-configuration
            pam-krb5-configuration?
            pam-krb5-service-type

            krb5-realm
            krb5-realm?

            krb5-configuration
            krb5-configuration?
            krb5-service-type))

(define-record-type* <krb5-realm>
  krb5-realm      make-krb5-realm
  krb5-realm?
  (name                krb5-realm-name)

  (admin-server        krb5-realm-admin-server)
  (kdc                 krb5-realm-kdc)
  (auth-to-local       krb5-realm-auth-to-local (default '()))
  (auth-to-local-names krb5-realm-auth-to-local-names (default '()))
  (http-anchors        krb5-realm-http-anchors (default '()))
  (default-domain      krb5-realm-default-domain (default #f))
  (kpasswd-server      krb5-realm-kpasswd-server (default #f))
  (master-kdc          krb5-realm-master-kdc (default #f))
  (v4-instance-convert krb5-realm-v4-instance-convert (default '()))
  (v4-realm            krb5-realm-v4-realm (default #f)))


(define-syntax  guile->krb-cfg
  (syntax-rules ()
    ((guile->krb-cfg accessor what)
     (string-map
      (lambda (c) (if (eq? c #\-) #\_ c))
      (string-drop (symbol->string accessor)
                   (string-length what))))))

(define-syntax cfg-opt-string
  (syntax-rules ()
    ((cfg-opt-string accessor realm)
     (if (accessor realm)
         (format #f "\n\t~a = ~a"
                        (guile->krb-cfg 'accessor "krb5-realm-")
                        (accessor realm))
         ""))))


;; Generates one line of text per list item
(define-syntax cfg-opt-list
  (syntax-rules ()
    ((cfg-opt-list accessor realm)
     (if (not (null? (accessor realm)))
         (string-concatenate
          (map (lambda (item)
                 (format #f "\n\t~a = ~a"
                         (guile->krb-cfg 'accessor "krb5-realm-")
                         item))
              (accessor realm)))
     ""))))

(define (krb5-realm->string realm)
  "Return a string suitable for a krb5.conf fragment representing REALM"
  (string-append "\n" (krb5-realm-name realm) " = {"
                 (cfg-opt-string krb5-realm-kdc realm)
                 (cfg-opt-string krb5-realm-admin-server realm)
                 (cfg-opt-string krb5-realm-default-domain realm)
                 (cfg-opt-list krb5-realm-auth-to-local realm)
                 (cfg-opt-list krb5-realm-http-anchors realm)
                 (cfg-opt-string krb5-realm-kpasswd-server realm)
                 (cfg-opt-string krb5-realm-master-kdc realm)
                 (cfg-opt-string krb5-realm-v4-realm realm)
                 "\n}"))


;; For explanation of these fields see man 5 krb5.conf
(define-record-type* <krb5-configuration>
  krb5-configuration    make-krb5-configuration
  krb5-configuration?

  ;; [libdefaults]
  (allow-weak-crypto          krb5-configuration-allow-weak-crypto (default #f))
  (ap-req-checksum-type       krb5-configuration-ap-req-checksum-type (default #f))
  (canonicalize               krb5-configuration-canonicalize (default #f))
  (ccache-type                krb5-configuration-ccache-type (default #f))
  (clockskew                  krb5-configuration-clockskew (default #f))
  (default-ccache-name        krb5-configuration-default-ccache-name (default #f))
  (default-client-keytab-name krb5-configuration-default-client-keytab-name
                                                                     (default #f))
  (default-keytab-name        krb5-configuration-default-keytab-name (default #f))
  (default-realm              krb5-configuration-default-realm (default #f))
  (default-tgs-enctypes       krb5-configuration-default-tgs-enctypes (default #f))
  (default-tkt-enctypes       krb5-configuration-default-tkt-enctypes (default #f))
  (dns-canonicalize-hostname  krb5-configuration-dns-canonicalize-hostname
                              (default #t))
  (dns-lookup-kdc             krb5-configuration-dns-lookup-kdc
                              (default #f))
  (err-fmt                    krb5-configuration-err-fmt (default #f))
  (extra-addresses            krb5-configuration-extra-addresses
                              (default #f))
  (forwardable                krb5-configuration-forwardable (default #t))
  (ignore-acceptor-hostname   krb5-configuration-ignore-acceptor-hostname
                              (default #f))
  (k5login-authoritative      krb5-configuration-k5login-authoritative (default #t))
  (k5login-directory          krb5-configuration-k5login-directory (default #f))
  (kcm-mach-service           krb5-configuration-kcm-mach-service
                                (default "org.h5l.kcm"))
  (kcm-socket                 krb5-configuration-kcm-socket
                                (default "/var/run/.heim_org.h5l.kcm-socket"))
  (kdc-default-options        krb5-configuration-kdc-default-options
                                (default #f))
  (kdc-timesync               krb5-configuration-kdc-timesync (default #t))
  (kdc-req-checksum-type      krb5-configuration-kdc-req-checksum-type (default #f))
  (noaddresses                krb5-configuration-noaddresses
                               (default #f))
  (permitted-enctypes         krb5-configuration-permitted-enctypes
                              (default #f))
  (plugin-base-dir            krb5-configuration-plugin-base-dir
                                (default #f))
  (preferred-preauth-types    krb5-configuration-preferred-preauth-types
                              (default #f))
  (proxiable                  krb5-configuration-proxiable (default #f))
  (rdns                       krb5-configuration-rdns (default #t))
  (realm-try-domains          krb5-configuration-realm-try-domains
                               (default #f))
  (renew-lifetime             krb5-configuration-renew-lifetime
                              (default #f))
  (safe-checksum-type         krb5-configuration-safe-checksum-type
                              (default #f))
  (ticket-lifetime            krb5-configuration-ticket-lifetime
                              (default #f))
  (udp-preference-limit       krb5-configuration-udp-preference-limit
                              (default #f))
  (verify-ap-req-nofail       krb5-configuration-verify-ap-req-nofail
                              (default #f))

  ;;[realms]
  (realms                     krb5-configuration-realms)

  ;;[domain_realm]
  (domain-realm-map           krb5-configuration-domain-realm-map (default '())))


(define-syntax cfg-string
  (syntax-rules ()
    ((cfg-string accessor config)
     (if (accessor config)
         (format #f "\n\t~a = ~a"
                 (guile->krb-cfg 'accessor "krb5-configuration-")
                 (accessor config))
         ""))))

(define-syntax cfg-boolean
  (syntax-rules ()
    ((cfg-string accessor config)
     (format #f "\n\t~a = ~a"
                    (guile->krb-cfg 'accessor "krb5-configuration-")
                    (if (accessor config) "true" "false")))))

;; Generates a comma separated list
(define-syntax cfg-list
  (syntax-rules ()
    ((cfg-string accessor config)
     (if (accessor config)
         (format #f "\n\t~a = ~a"
                 (guile->krb-cfg 'accessor "krb5-configuration-")
                 (fold (lambda (i prev)
                         (string-append prev
                                        (if (zero? (string-length prev))
                                            ""  ", ") i)) ""
                                            (accessor config))) ""))))

(define (krb5-configuration-file config)
  "Create a Kerberos 5 configuration file based on CONFIG"
  (mixed-text-file "krb5.conf"

"[libdefaults]"
(cfg-string  krb5-configuration-default-realm config)
(cfg-boolean krb5-configuration-allow-weak-crypto config)
(cfg-string  krb5-configuration-ap-req-checksum-type config)
(cfg-boolean krb5-configuration-canonicalize config)
(cfg-string  krb5-configuration-ccache-type config)
(cfg-string  krb5-configuration-clockskew config)
(cfg-string  krb5-configuration-default-ccache-name config)
(cfg-string  krb5-configuration-default-client-keytab-name config)
(cfg-string  krb5-configuration-default-keytab-name config)
(cfg-string  krb5-configuration-default-tgs-enctypes config)
(cfg-string  krb5-configuration-default-tkt-enctypes config)
(cfg-boolean krb5-configuration-dns-canonicalize-hostname config)
(cfg-boolean krb5-configuration-dns-lookup-kdc config)
(cfg-string  krb5-configuration-err-fmt config)
(cfg-list    krb5-configuration-extra-addresses config)
(cfg-boolean krb5-configuration-ignore-acceptor-hostname config)
(cfg-boolean krb5-configuration-k5login-authoritative config)
(cfg-string  krb5-configuration-k5login-directory config)
(cfg-boolean krb5-configuration-forwardable config)
(cfg-string  krb5-configuration-kcm-mach-service config)
(cfg-string  krb5-configuration-kcm-socket config)
(cfg-string  krb5-configuration-kdc-default-options config)
(cfg-boolean krb5-configuration-kdc-timesync config)
(cfg-boolean krb5-configuration-proxiable config)
(cfg-string  krb5-configuration-kdc-req-checksum-type config)
(cfg-boolean krb5-configuration-noaddresses config)
(cfg-list    krb5-configuration-permitted-enctypes config)
(cfg-string  krb5-configuration-plugin-base-dir config)
(cfg-list    krb5-configuration-preferred-preauth-types config)
(cfg-boolean krb5-configuration-rdns config)
(cfg-string  krb5-configuration-realm-try-domains config)
(cfg-string  krb5-configuration-renew-lifetime config)
(cfg-string  krb5-configuration-safe-checksum-type config)
(cfg-string  krb5-configuration-ticket-lifetime config)
(cfg-string  krb5-configuration-udp-preference-limit config)
(cfg-boolean krb5-configuration-verify-ap-req-nofail config)

"\n\n[realms]"
(string-concatenate (map krb5-realm->string (krb5-configuration-realms config)))

"\n"))


(define (krb5-etc-service config)
  (list `("krb5.conf" ,(krb5-configuration-file config))))


(define krb5-service-type
  (service-type (name 'krb5)
                (extensions
                 (list (service-extension etc-service-type
                                          krb5-etc-service)))))


\f

(define-record-type* <pam-krb5-configuration>
  pam-krb5-configuration  make-pam-krb5-configuration
  pam-krb5-configuration?
  (pam-krb5               pam-krb5-configuration-pam-krb5
                          (default pam-krb5))
  (minimum-uid            pam-krb5-configuration-minimum-uid
                          (default 1000)))

(define (pam-krb5-pam-service config)
  "Return a PAM service for Kerberos authentication."
  (lambda (pam)
    (define pam-krb5-module
      #~(string-append #$(pam-krb5-configuration-pam-krb5 config) "/lib/security/pam_krb5.so"))

    (let ((pam-krb5-sufficient
           (pam-entry
            (control "sufficient")
            (module pam-krb5-module)
            (arguments (list
                        (format #f "minimum_uid=~a"
                                (pam-krb5-configuration-minimum-uid config)))))))
      (pam-service
       (inherit pam)
       (auth (cons* pam-krb5-sufficient
                    (pam-service-auth pam)))
       (session (cons* pam-krb5-sufficient
                       (pam-service-session pam)))
       (account (cons* pam-krb5-sufficient
                       (pam-service-account pam)))))))

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

(define pam-krb5-service-type
  (service-type (name 'pam-krb5)
                (extensions
                 (list
                  (service-extension pam-root-service-type
                                     pam-krb5-pam-services)))))