;;; 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)
  #:use-module (home)
  #: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-type))

(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-type
  (home-type
    (name 'ssh)
    (extensions
      (list
        (home-extension
          (target root-home-type)
          (compute (lambda (config)
                     (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/authorized_keys" ,authorized-keys) (".ssh/known_hosts" ,known-hosts)
                       (".ssh/config" ,config))))))))))))