summaryrefslogtreecommitdiff
path: root/tests/client.scm
blob: fb0371320255a0aa890f875b4afcfb1c6308905b (about) (plain)
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
;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(use-modules (srfi srfi-26)
             (srfi srfi-64)
             (ice-9 match))

(define (with-variable variable value thunk)
  "Set VARIABLE to VALUE, run THUNK and restore the old value of
VARIABLE. Return the value returned by THUNK."
  (let ((old-value (variable-ref variable)))
    (dynamic-wind
      (cut variable-set! variable value)
      thunk
      (cut variable-set! variable old-value))))

(define (with-variables variable-bindings thunk)
  "Set VARIABLE-BINDINGS, run THUNK and restore the old values of the
variables. Return the value returned by THUNK. VARIABLE-BINDINGS is a
list of pairs mapping variables to their values."
  (match variable-bindings
    (((variable . value) tail ...)
     (with-variable variable value
       (cut with-variables tail thunk)))
    (() (thunk))))

(define-syntax-rule (var@@ module-name variable-name)
  (module-variable (resolve-module 'module-name)
                   'variable-name))

(define (trace-calls function-variable thunk)
  "Run THUNK and return a list of argument lists FUNCTION-VARIABLE is
called with."
  (let ((args-list (list)))
    (with-variable function-variable (lambda args
                                       (set! args-list
                                             (cons args args-list)))
      thunk)
    (reverse args-list)))

(define client-config-stub
  (cons (var@@ (mumi client) client-config)
        (lambda (key)
          (case key
            ((debbugs-host) "example.com")
            ((patch-email-address) "foo@patches.com")
            (else (error "Key unimplemented in stub" key))))))

(test-begin "client")

(test-equal "send patches to new issue"
  '(("git" "send-email" "--to=foo@patches.com" "foo.patch")
    ("git" "send-email" "--to=12345@example.com" "bar.patch" "foobar.patch"))
  (map (match-lambda
         ((command _) command))
       (trace-calls (var@@ (mumi client) call-with-input-pipe)
         (lambda ()
           (with-variables (list (cons (var@@ (mumi client) issue-number-of-message)
                                       (const 12345))
                                 client-config-stub)
             (cut (@@ (mumi client) send-email)
                  (list "foo.patch" "bar.patch" "foobar.patch")))))))

(test-equal "send patches to existing issue"
  '(("git" "send-email" "--to=12345@example.com" "foo.patch" "bar.patch" "foobar.patch"))
  (map (match-lambda
         ((command _) command))
       (trace-calls (var@@ (mumi client) call-with-input-pipe)
         (lambda ()
           (with-variables (list (cons (var@@ (mumi client) current-issue-number)
                                       (const 12345))
                                 client-config-stub)
             (cut (@@ (mumi client) send-email)
                  (list "foo.patch" "bar.patch" "foobar.patch")))))))

(test-equal "send single patch to new issue"
  '(("git" "send-email" "--to=foo@patches.com" "foo.patch"))
  (map (match-lambda
         ((command _) command))
       (trace-calls (var@@ (mumi client) call-with-input-pipe)
         (lambda ()
           (with-variables (list (cons (var@@ (mumi client) issue-number-of-message)
                                       (lambda _
                                         (error "Do not poll server for issue number")))
                                 client-config-stub)
             (cut (@@ (mumi client) send-email)
                  (list "foo.patch")))))))

(test-equal "send single patch to existing issue"
  '(("git" "send-email" "--to=12345@example.com" "foo.patch"))
  (map (match-lambda
         ((command _) command))
       (trace-calls (var@@ (mumi client) call-with-input-pipe)
         (lambda ()
           (with-variables (list (cons (var@@ (mumi client) current-issue-number)
                                       (const 12345))
                                 (cons (var@@ (mumi client) issue-number-of-message)
                                       (lambda _
                                         (error "Do not poll server for issue number")))
                                 client-config-stub)
             (cut (@@ (mumi client) send-email)
                  (list "foo.patch")))))))

(test-end "client")