;;; 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))))))))))))