guix-home-manager/home/ssh.scm

ssh.scm

1
;;; Guix Home Manager.
2
;;;
3
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
4
;;;
5
;;; This program is free software: you can redistribute it and/or modify
6
;;; it under the terms of the GNU General Public License as published by
7
;;; the Free Software Foundation, either version 3 of the License, or
8
;;; (at your option) any later version.
9
;;;
10
;;; This program is distributed in the hope that it will be useful,
11
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13
;;; GNU General Public License for more details.
14
;;;
15
;;; You should have received a copy of the GNU General Public License
16
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18
(define-module (home ssh)
19
  #:use-module (guix build utils)
20
  #:use-module (guix gexp)
21
  #:use-module (guix records)
22
  #:use-module (gnu packages lxde)
23
  #:use-module (ice-9 match)
24
  #:export (ssh-configuration
25
            ssh-configuration-authorized-keys
26
            ssh-configuration-known-hosts
27
            ssh-configuration-hosts
28
            ssh-configuration-default-host
29
30
            ssh-host-configuration
31
            ssh-host-configuration-host-name
32
            ssh-host-configuration-identity-file
33
            ssh-host-configuration-name
34
            ssh-host-configuration-port
35
            ssh-host-configuration-user
36
37
            ssh-known-host-configuration
38
            ssh-known-host-configuration-names
39
            ssh-known-host-configuration-algo
40
            ssh-known-host-configuration-key
41
42
            ssh-home))
43
44
(define-record-type* <ssh-host-configuration>
45
  ssh-host-configuration make-ssh-host-configuration
46
  ssh-host-configuration?
47
  (host-name     ssh-host-configuration-host-name
48
                 (default "*"))
49
  (identity-file ssh-host-configuration-identity-file
50
                 (default #f))
51
  (name          ssh-host-configuration-name
52
                 (default "*"))
53
  (port          ssh-host-configuration-port
54
                 (default #f))
55
  (user          ssh-host-configuration-user
56
                 (default #f)))
57
58
(define (ssh-host config)
59
  (match config
60
    (($ <ssh-host-configuration> host-name identity-file name port user)
61
     (string-append "Host " name "\n"
62
                    "  HostName " host-name "\n"
63
                    (if identity-file
64
                        (string-append "  IdentityFile " identity-file "\n")
65
                        "")
66
                    (if port
67
                        (string-append "  Port " port "\n")
68
                        "")
69
                    (if user
70
                        (string-append "  User " user "\n")
71
                        "")))))
72
73
(define (default-ssh config)
74
  (match config
75
    (($ <ssh-host-configuration> host-name identity-file name port user)
76
     (string-append
77
       (if identity-file
78
           (string-append "IdentityFile " identity-file "\n")
79
           "")
80
       (if port
81
           (string-append "Port " port "\n")
82
           "")
83
       (if user
84
           (string-append "User " user "\n")
85
           "")))))
86
87
(define (generate-ssh-hosts lst)
88
  (string-join (map ssh-host lst) "\n\n"))
89
90
(define (generate-ssh-config hosts default-host)
91
  (string-append (generate-ssh-hosts hosts)
92
                 "\n\n"
93
                 (default-ssh default-host)))
94
95
(define-record-type* <ssh-known-host-configuration>
96
  ssh-known-host-configuration make-ssh-known-host-configuration
97
  ssh-known-host-configuration?
98
  (names ssh-known-host-configuration-names)
99
  (algo  ssh-known-host-configuration-algo
100
         (default "ecdsa-sha2-nistp256"))
101
  (key   ssh-known-host-configuration-key))
102
103
104
(define (known-host config)
105
  (match config
106
    (($ <ssh-known-host-configuration> names algo key)
107
     (string-append
108
       (match names
109
         ((name) name)
110
         ((n1 ns ...)
111
          (string-join names ",")))
112
       " " algo " " key))))
113
114
(define-record-type* <ssh-configuration>
115
  ssh-configuration make-ssh-configuration
116
  ssh-configuration?
117
  (authorized-keys ssh-configuration-authorized-keys
118
                   (default '()))
119
  (known-hosts     ssh-configuration-known-hosts
120
                   (default '()))
121
  (hosts           ssh-configuration-hosts
122
                   (default '()))
123
  (default-host    ssh-configuration-default-host
124
                   (default #f)))
125
126
(define (generate-ssh-authorized-keys lst)
127
  (string-join lst "\n"))
128
129
(define (generate-ssh-known-hosts lst)
130
  (string-join (map known-host lst) "\n"))
131
132
(define (ssh-home config)
133
  (computed-file "ssh-home"
134
    (match config
135
      (($ <ssh-configuration> authorized-keys known-hosts hosts default-host)
136
       #~(let ((config #$(plain-file "config" (generate-ssh-config hosts default-host)))
137
               (known-hosts #$(plain-file "known_hosts"
138
                                          (generate-ssh-known-hosts known-hosts)))
139
               (authorized-keys #$(plain-file
140
                                    "authorized_keys"
141
                                    (generate-ssh-authorized-keys authorized-keys)))
142
               (ssh-dir (string-append #$output "/.ssh")))
143
           (use-modules (guix build utils))
144
           (mkdir-p ssh-dir)
145
           (copy-file authorized-keys (string-append ssh-dir "/authorized_keys"))
146
           (copy-file known-hosts (string-append ssh-dir "/known_hosts"))
147
           (copy-file config (string-append ssh-dir "/config")))))
148
    #:options
149
    '(#:local-build? #t
150
      #:modules ((guix build utils)))))
151