;;; Guix Home Manager.
;;;
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This program 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.
;;;
;;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (home ssh)
  #:use-module (guix build utils)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu packages lxde)
  #:use-module (ice-9 match)
  #:export (ssh-configuration
            ssh-configuration-authorized-keys
            ssh-configuration-known-hosts
            ssh-configuration-hosts
            ssh-configuration-default-host

            ssh-host-configuration
            ssh-host-configuration-host-name
            ssh-host-configuration-identity-file
            ssh-host-configuration-name
            ssh-host-configuration-port
            ssh-host-configuration-user

            ssh-known-host-configuration
            ssh-known-host-configuration-names
            ssh-known-host-configuration-algo
            ssh-known-host-configuration-key

            ssh-home))

(define-record-type* <ssh-host-configuration>
  ssh-host-configuration make-ssh-host-configuration
  ssh-host-configuration?
  (host-name     ssh-host-configuration-host-name
                 (default "*"))
  (identity-file ssh-host-configuration-identity-file
                 (default #f))
  (name          ssh-host-configuration-name
                 (default "*"))
  (port          ssh-host-configuration-port
                 (default #f))
  (user          ssh-host-configuration-user
                 (default #f)))

(define (ssh-host config)
  (match config
    (($ <ssh-host-configuration> host-name identity-file name port user)
     (string-append "Host " name "\n"
                    "  HostName " host-name "\n"
                    (if identity-file
                        (string-append "  IdentityFile " identity-file "\n")
                        "")
                    (if port
                        (string-append "  Port " port "\n")
                        "")
                    (if user
                        (string-append "  User " user "\n")
                        "")))))

(define (default-ssh config)
  (match config
    (($ <ssh-host-configuration> host-name identity-file name port user)
     (string-append
       (if identity-file
           (string-append "IdentityFile " identity-file "\n")
           "")
       (if port
           (string-append "Port " port "\n")
           "")
       (if user
           (string-append "User " user "\n")
           "")))))

(define (generate-ssh-hosts lst)
  (string-join (map ssh-host lst) "\n\n"))

(define (generate-ssh-config hosts default-host)
  (string-append (generate-ssh-hosts hosts)
                 "\n\n"
                 (default-ssh default-host)))

(define-record-type* <ssh-known-host-configuration>
  ssh-known-host-configuration make-ssh-known-host-configuration
  ssh-known-host-configuration?
  (names ssh-known-host-configuration-names)
  (algo  ssh-known-host-configuration-algo
         (default "ecdsa-sha2-nistp256"))
  (key   ssh-known-host-configuration-key))


(define (known-host config)
  (match config
    (($ <ssh-known-host-configuration> names algo key)
     (string-append
       (match names
         ((name) name)
         ((n1 ns ...)
          (string-join names ",")))
       " " algo " " key))))

(define-record-type* <ssh-configuration>
  ssh-configuration make-ssh-configuration
  ssh-configuration?
  (authorized-keys ssh-configuration-authorized-keys
                   (default '()))
  (known-hosts     ssh-configuration-known-hosts
                   (default '()))
  (hosts           ssh-configuration-hosts
                   (default '()))
  (default-host    ssh-configuration-default-host
                   (default #f)))

(define (generate-ssh-authorized-keys lst)
  (string-join lst "\n"))

(define (generate-ssh-known-hosts lst)
  (string-join (map known-host lst) "\n"))

(define (ssh-home config)
  (computed-file "ssh-home"
    (match config
      (($ <ssh-configuration> authorized-keys known-hosts hosts default-host)
       #~(let ((config #$(plain-file "config" (generate-ssh-config hosts default-host)))
               (known-hosts #$(plain-file "known_hosts"
                                          (generate-ssh-known-hosts known-hosts)))
               (authorized-keys #$(plain-file
                                    "authorized_keys"
                                    (generate-ssh-authorized-keys authorized-keys)))
               (ssh-dir (string-append #$output "/.ssh")))
           (use-modules (guix build utils))
           (mkdir-p ssh-dir)
           (copy-file authorized-keys (string-append ssh-dir "/authorized_keys"))
           (copy-file known-hosts (string-append ssh-dir "/known_hosts"))
           (copy-file config (string-append ssh-dir "/config")))))
    #:options
    '(#:local-build? #t
      #:modules ((guix build utils)))))