;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; 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 linux)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system pam)
  #:use-module (gnu packages linux)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (earlyoom-configuration
            earlyoom-configuration?
            earlyoom-configuration-earlyoom
            earlyoom-configuration-minimum-available-memory
            earlyoom-configuration-minimum-free-swap
            earlyoom-configuration-prefer-regexp
            earlyoom-configuration-avoid-regexp
            earlyoom-configuration-memory-report-interval
            earlyoom-configuration-ignore-positive-oom-score-adj?
            earlyoom-configuration-show-debug-messages?
            earlyoom-configuration-send-notification-command
            earlyoom-service-type

            kernel-module-loader-service-type

            modprobe-service-type

            kernel-module
            kernel-module?
            kernel-module-name
            kernel-module-package
            kernel-module-aliases
            kernel-module-install
            kernel-module-remove
            kernel-module-pre-dependencies
            kernel-module-post-dependencies
            kernel-module-blacklist?
            kernel-module-load?
            kernel-module-is-builtin?
            kernel-module->kernel-arguments
            kernel-module-configuration-service-type))

\f
;;;
;;; Early OOM daemon.
;;;

(define-record-type* <earlyoom-configuration>
  earlyoom-configuration make-earlyoom-configuration
  earlyoom-configuration?
  (earlyoom earlyoom-configuration-earlyoom
            (default earlyoom))
  (minimum-available-memory earlyoom-configuration-minimum-available-memory
                            (default 10)) ; in percent
  (minimum-free-swap earlyoom-configuration-minimum-free-swap
                     (default 10))      ; in percent
  (prefer-regexp earlyoom-configuration-prefer-regexp ; <string>
                 (default #f))
  (avoid-regexp earlyoom-configuration-avoid-regexp  ; <string>
                (default #f))
  (memory-report-interval earlyoom-configuration-memory-report-interval
                          (default 0)) ; in seconds; 0 means disabled
  (ignore-positive-oom-score-adj?
   earlyoom-configuration-ignore-positive-oom-score-adj? (default #f))
  (run-with-higher-priority? earlyoom-configuration-run-with-higher-priority?
                             (default #f))
  (show-debug-messages? earlyoom-configuration-show-debug-messages?
                        (default #f))
  (send-notification-command
   earlyoom-configuration-send-notification-command  ; <string>
   (default #f)))

(define (earlyoom-configuration->command-line-args config)
  "Translate a <earlyoom-configuration> object to its command line arguments
representation."
  (match config
    (($ <earlyoom-configuration> earlyoom minimum-available-memory
                                 minimum-free-swap prefer-regexp avoid-regexp
                                 memory-report-interval
                                 ignore-positive-oom-score-adj?
                                 run-with-higher-priority? show-debug-messages?
                                 send-notification-command)
     `(,(file-append earlyoom "/bin/earlyoom")
       ,@(if minimum-available-memory
             (list "-m" (format #f "~s" minimum-available-memory))
             '())
       ,@(if minimum-free-swap
             (list "-s" (format #f "~s" minimum-free-swap))
             '())
       ,@(if prefer-regexp
             (list "--prefer" prefer-regexp)
             '())
       ,@(if avoid-regexp
             (list "--avoid" avoid-regexp)
             '())
       "-r" ,(format #f "~s" memory-report-interval)
       ,@(if ignore-positive-oom-score-adj?
             (list "-i")
             '())
       ,@(if run-with-higher-priority?
             (list "-p")
             '())
       ,@(if show-debug-messages?
             (list "-d")
             '())
       ,@(if send-notification-command
             (list "-N" send-notification-command)
             '())))))

(define (earlyoom-shepherd-service config)
  (shepherd-service
   (documentation "Run the Early OOM daemon.")
   (provision '(earlyoom))
   (start #~(make-forkexec-constructor
             '#$(earlyoom-configuration->command-line-args config)
             #:log-file "/var/log/earlyoom.log"))
   (stop #~(make-kill-destructor))))

(define earlyoom-service-type
  (service-type
   (name 'earlyoom)
   (default-value (earlyoom-configuration))
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list earlyoom-shepherd-service))))
   (description "Run @command{earlyoom}, the Early OOM daemon.")))

\f
;;;
;;; Kernel module loader.
;;;

(define kernel-module-loader-shepherd-service
  (match-lambda
    ((and (? list? kernel-modules) ((? string?) ...))
     (shepherd-service
      (documentation "Load kernel modules.")
      (provision '(kernel-module-loader))
      (requirement '(file-systems))
      (one-shot? #t)
      (modules `((srfi srfi-1)
                 (srfi srfi-34)
                 (srfi srfi-35)
                 (rnrs io ports)
                 ,@%default-modules))
      (start
       ;; TODO Verify that we are loading a loadable kernel and not a builtin
       ;; one looking in
       ;; /run/booted-system/kernel/lib/modules/5.4.39/modules.builtin
       #~(lambda _
           (cond
            ((null? '#$kernel-modules) #t)
            ((file-exists? "/proc/sys/kernel/modprobe")
             (let ((modprobe (call-with-input-file
                                 "/proc/sys/kernel/modprobe" get-line)))
               (guard (c ((message-condition? c)
                          (format (current-error-port) "~a~%"
                                  (condition-message c))
                          #f))
                 (every (lambda (module)
                          (invoke/quiet modprobe "--" module))
                        '#$kernel-modules))))
            (else
             (format (current-error-port) "error: ~a~%"
                     "Kernel is missing loadable module support.")
             #f))))))))

(define kernel-module-loader-service-type
  (service-type
   (name 'kernel-module-loader)
   (description "Load kernel modules.")
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list kernel-module-loader-shepherd-service))))
   (compose concatenate)
   (extend append)
   (default-value '())))

\f
;;;
;;; Modprobe service.
;;;

(define (%modprobe-wrapper directory)
  "Return a wrapper for modprobe loading configuration files from CONFIG."
  ;; Wrapper for the 'modprobe' command that knows where modules live.
  ;;
  ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
  ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
  ;; environment variable is not set---hence the need for this wrapper.
  (let ((modprobe "/run/current-system/profile/bin/modprobe"))
    (program-file "modprobe"
                  #~(begin
                      (setenv "LINUX_MODULE_DIRECTORY"
                              "/run/booted-system/kernel/lib/modules")
                      (setenv "MODPROBE_OPTIONS"
                              (string-append "--config=" #$directory))
                      (apply execl #$modprobe
                             (cons #$modprobe (cdr (command-line))))))))

(define (modprobe->activation-gexp configs)
  "Return a gexp to tell the kernel to use modprobe configured with CONFIGS
files."
  (let ((directory (file-union "modprobe.d" configs)))
    #~(activate-modprobe #$(%modprobe-wrapper directory))))

(define (modprobe-environment configs)
  (let ((options #~(string-append
                    "--config="
                    #$(file-union "modprobe.d"
                                  configs))))
    `(("MODPROBE_OPTIONS" . ,options))))

(define modprobe-service-type
  (service-type
   (name 'modropbe)
   (description "Tell the kernel to use Guix's 'modprobe'.")
   (default-value '())                  ; list of <file-like>
   (extensions
    (list (service-extension activation-service-type
                             modprobe->activation-gexp)
          (service-extension session-environment-service-type
                             modprobe-environment)))
   (compose concatenate)
   (extend append)))

\f
;;;
;;; Kernel module configuration.
;;;

;; NOTE Maybe have sperate records betwwen <kernel-builtin-module> and
;; <kernel-lodable-module>
(define-record-type* <kernel-module>
  kernel-module make-kernel-module
  kernel-module?
  (name               kernel-module-name) ; string
  ;; For out-of-tree modules
  (package            kernel-module-package
                      (default #f))     ; #f | <package>
  ;; NOTE Maybe use an alist instead
  (options            kernel-module-options
                      (default '()))    ; list of strings
  (aliases            kernel-module-aliases
                      (default '()))    ; list of strings
  (install            kernel-module-install
                      (default #f))     ; #f | string
  (remove             kernel-module-remove
                      (default #f))     ; #f | string
  (pre-dependencies   kernel-module-pre-dependencies
                      (default '()))    ; list of strings
  (post-dependencies  kernel-module-post-dependencies
                      (default '()))    ; list of strings
  (blacklist?         kernel-module-blacklist?
                      (default #f)) ; boolean
  ;; NOTE Only possible if it's not built-in
  ;; TODO maybe trow an error when it's set to true on a built-in module
  (load?              kernel-module-load?
                      (default #f)))                ; boolean

;; FIXME use 'modules.builtin' instead
(define (kernel-module-is-builtin? module)
  (if (kernel-module-package module) #f
      #t))

(define (kernel-module->kernel-arguments module)
  "Return a list of kernel arguments for MODULE."
  (match-record module <kernel-module>
    (name options blacklist?)
    (filter (lambda (s) (not (string-null? s)))
            (list (if blacklist? (string-append name ".blacklist=yes") "")
                  (if (null? options) ""
                      (map (lambda (option)
                             (string-append name "." option))
                           options))))))

(define (kernel-module->config module)
  "Return a config string for MODULE."
  (match-record module <kernel-module>
    (name options aliases install remove pre-dependencies
          post-dependencies blacklist?)
    (string-concatenate
     (list (if (null? options) ""
               (format #f "options ~a~{ ~a~}\n" name options))
           (if blacklist? (format #f "blacklist ~a\n" name)
               "")
           (if (null? aliases) ""
               (map (lambda (alias)
                      (format #f "alias ~a ~a\n" alias name))
                    aliases))
           (if install (format #f "install ~a ~a\n" name install)
               "")
           (if remove (format #f "remove ~a ~a\n" name remove)
               "")
           (if (null? pre-dependencies) ""
               (map (lambda (dependency)
                      (format #f "softdep ~a :pre ~a\n"
                              name dependency))
                    pre-dependencies))
           (if (null? post-dependencies) ""
               (map (lambda (dependency)
                      (format #f "softdep ~a :post ~a\n"
                              name dependency))
                    post-dependencies))))))

(define (string-underscorize s)
  "Replace '-' characters by '_' in string S."
  (string-map (lambda (c) (if (char=? c #\-) #\_ c)) s))

(define (kernel-modules->config-files modules)
  "Return a list of pairs of file name and gexp, to be used by 'file-union',
from MODULES."
  (define (kernel-module->filename-gexp module)
    (let ((config (kernel-module->config module))
          (name (kernel-module-name module)))
      (if (string-null? config) #f
          (list (string-append name ".conf")
                (plain-file (string-append name ".conf") config)))))
  (filter-map
   (lambda (module)
     (let ((module (kernel-module
                    (inherit module)
                    ;; XXX The kernel replace '-' by '_' in module name, we do
                    ;; the same to make name collision visible, that would
                    ;; otherwise be hidden.
                    (name (string-underscorize (kernel-module-name module))))))
       (if (kernel-module-is-builtin? module) #f
           (kernel-module->filename-gexp module))))
   modules))

(define (kernel-modules->packages modules)
  "Return a list of packages from MODULES."
  (filter-map (lambda (module)
                (kernel-module-package module))
              modules))

(define (kernel-modules-to-load modules)
  "Return a list of loadable module names, from MODULES, to be loaded."
  (filter-map (lambda (module)
                (if (and (not (kernel-module-is-builtin? module))
                         (kernel-module-load? module))
                    (kernel-module-name module)
                    #f))
              modules))

(define kernel-module-configuration-service-type
  (service-type
   (name 'kernel-module-configuration)
   (description
    "Configure kernel modules, in similar manner as @file{modprobe.d}.")
   (default-value '())
   (extensions
    (list (service-extension modprobe-service-type
                             kernel-modules->config-files)
          (service-extension kernel-profile-service-type
                             kernel-modules->packages)
          (service-extension kernel-module-loader-service-type
                             kernel-modules-to-load)))
   (compose concatenate)
   (extend append)))

;; TODO Make a naked modprobe call use MODPROBE_OPTIONS environment or
;; /proc/sys/kernel/modprobe

;; TODO write a helper to load a module from guile using modprobe command from
;; '/proc/sys/kernel/modprobe' or %modprobe-wrapper. See linux-module-builder
;; maybe.

;; NOTE Throw an error when kernel-module-name isn't unique?  It may already
;; do it by itself already because 2 loadable module will try to create
;; separeta config file with the same name.