1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
;;; Guile-Git --- GNU Guile bindings of libgit2
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Marius Bakke <marius@devup.no>
;;;
;;; This file is part of Guile-Git.
;;;
;;; Guile-Git 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.
;;;
;;; Guile-Git 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 Guile-Git. If not, see <http://www.gnu.org/licenses/>.
(define-module (git fetch)
#:use-module (system foreign)
#:use-module (git auth)
#:use-module (git bindings)
#:use-module (git cred)
#:use-module (git structs)
#:use-module (git types)
#:use-module (srfi srfi-26)
#:export (make-fetch-options
fetch-init-options ;deprecated!
set-fetch-auth-with-ssh-agent!
set-fetch-auth-with-ssh-key!
set-fetch-auth-with-default-ssh-key!))
(define FETCH-OPTIONS-VERSION 1)
(define make-fetch-options
(let ((proc (libgit2->procedure* "git_fetch_init_options"
`(* ,unsigned-int))))
(lambda* (#:optional auth-method
#:key
proxy-url (proxy-type (if proxy-url 'specified 'none))
transfer-progress)
"Return a <fetch-options> record. When AUTH-METHOD is true, it must be
an object as returned by '%make-auth-ssh-agent' or
'%make-auth-ssh-credentials'. When TRANSFER-PROGRESS is true, it must be a
one-argument procedure. TRANSFER-PROGRESS is called periodically and passed
an <indexer-progress> record; when TRANSFER-PROGRESS returns #false,
transfers are canceled.
When PROXY-URL is true, it is the URL of an HTTP/HTTPS proxy to use.
PROXY-TYPE is one of 'none, 'specified, or 'auto. The default is 'specified
when PROXY-URL is true and 'none when PROXY-URL is false. Setting it to
'auto enables proxy detection based on the Git configuration."
(let ((fetch-options (make-fetch-options-bytestructure)))
(proc (fetch-options->pointer fetch-options) FETCH-OPTIONS-VERSION)
(cond
((auth-ssh-credentials? auth-method)
(set-fetch-auth-with-ssh-key! fetch-options auth-method))
((auth-ssh-agent? auth-method)
(set-fetch-auth-with-ssh-agent! fetch-options)))
(set-fetch-options-proxy-type! fetch-options proxy-type)
(when proxy-url
(set-fetch-options-proxy-url! fetch-options proxy-url))
(when transfer-progress
(set-fetch-options-transfer-progress! fetch-options
transfer-progress))
fetch-options))))
(define fetch-init-options
;; Deprecated alias for compatibility with 0.2.
make-fetch-options)
(define (set-fetch-auth-callback fetch-options callback)
(let ((callbacks (fetch-options-remote-callbacks fetch-options)))
(set-remote-callbacks-credentials! callbacks
(pointer-address callback))))
(define (current-user-name)
"Return the current user name."
;; Note: 'getlogin', which relies on 'getutent', doesn't work inside Guix
;; build environments.
(or (getlogin)
(and=> (false-if-exception (getpwuid (getuid)))
passwd:name)
(getenv "LOGNAME")
(getenv "USER")))
(define (set-fetch-auth-with-ssh-agent! fetch-options)
(set-fetch-auth-callback
fetch-options
(cred-acquire-cb
(lambda (cred url username allowed payload)
(let ((username (if (eq? username %null-pointer)
""
(pointer->string username))))
(cond
;; If no username were specified in URL, we will be asked for
;; one. Try with the current user login.
((= allowed CREDTYPE-SSH-USERNAME)
(cred-username-new cred (current-user-name)))
(else
(cred-ssh-key-from-agent cred username))))))))
(define* (set-fetch-auth-with-ssh-key! fetch-options
auth-ssh-credentials)
(set-fetch-auth-callback
fetch-options
(cred-acquire-cb
(lambda (cred url username allowed payload)
(cond
;; Same as above.
((= allowed CREDTYPE-SSH-USERNAME)
(cred-username-new cred (current-user-name)))
(else
(let* ((pri-key-file
(auth-ssh-credentials-private-key auth-ssh-credentials))
(pub-key-file
(auth-ssh-credentials-public-key auth-ssh-credentials))
(username (if (eq? username %null-pointer)
""
(pointer->string username))))
(cred-ssh-key-new cred
username
pub-key-file
pri-key-file
""))) )))))
(define (set-fetch-options-transfer-progress! fetch-options
transfer-progress)
(let ((callbacks (fetch-options-remote-callbacks fetch-options)))
(set-remote-callbacks-transfer-progress! callbacks transfer-progress)))
(define (set-fetch-options-proxy-type! fetch-options type)
(let ((proxy (fetch-options-proxy-options fetch-options)))
(set-proxy-options-type! proxy type)))
(define (set-fetch-options-proxy-url! fetch-options url)
(let ((proxy (fetch-options-proxy-options fetch-options)))
(set-proxy-options-url! proxy url)))
|
