[jackhill/guix/guix.git] / tests / http-client.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-http-client)
  #:use-module (guix http-client)
  #:use-module (guix tests http)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (web response)
  #:use-module (web uri))

(test-begin "http-client")

(test-equal "http-fetch, one request, binary"
  (string->utf8 "Hello, world.")
  (with-http-server `((200 "Hello, world."))
    (let* ((port (http-fetch (%local-url)))
           (bv   (get-bytevector-all port)))
      (close-port port)
      bv)))

(test-equal "http-fetch, one request, text"
  "Hello, world."
  (with-http-server `((200 "Hello, world."))
    (let* ((port (http-fetch (%local-url) #:text? #t))
           (data (get-string-all port)))
      (close-port port)
      data)))

(test-equal "http-fetch, redirect"
  "Hello, world."
  (with-http-server `((,(build-response
                         #:code 301
                         #:headers
                         `((location
                            . ,(string->uri-reference "/elsewhere")))
                         #:reason-phrase "Moved")
                       "Redirect!")
                      (200 "Hello, world."))
    (let* ((port (http-fetch (%local-url)))
           (data (get-string-all port)))
      (close-port port)
      data)))

(test-equal "http-fetch, error"
  404
  (with-http-server `((404 "Ne trovita."))
    (guard (c ((http-get-error? c) (http-get-error-code c)))
      (http-fetch (%local-url))
      #f)))

(test-equal "http-fetch, redirect + error"
  403
  (with-http-server `((,(build-response
                         #:code 302
                         #:headers
                         `((location
                            . ,(string->uri-reference "/elsewhere")))
                         #:reason-phrase "Moved")
                       "Redirect!")
                      (403 "Verboten."))
    (guard (c ((http-get-error? c) (http-get-error-code c)))
      (http-fetch (%local-url))
      #f)))

(test-end "http-client")
Commit	Line	Data
049aefdd LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (test-http-client)
	20	#:use-module (guix http-client)
	21	#:use-module (guix tests http)
	22	#:use-module (srfi srfi-1)
	23	#:use-module (srfi srfi-34)
	24	#:use-module (srfi srfi-64)
	25	#:use-module (rnrs bytevectors)
	26	#:use-module (rnrs io ports)
	27	#:use-module (web response)
	28	#:use-module (web uri))
	29
	30	(test-begin "http-client")
	31
	32	(test-equal "http-fetch, one request, binary"
	33	(string->utf8 "Hello, world.")
	34	(with-http-server `((200 "Hello, world."))
	35	(let* ((port (http-fetch (%local-url)))
	36	(bv (get-bytevector-all port)))
	37	(close-port port)
	38	bv)))
	39
	40	(test-equal "http-fetch, one request, text"
	41	"Hello, world."
	42	(with-http-server `((200 "Hello, world."))
	43	(let* ((port (http-fetch (%local-url) #:text? #t))
	44	(data (get-string-all port)))
	45	(close-port port)
	46	data)))
	47
	48	(test-equal "http-fetch, redirect"
	49	"Hello, world."
	50	(with-http-server `((,(build-response
	51	#:code 301
	52	#:headers
	53	`((location
	54	. ,(string->uri-reference "/elsewhere")))
	55	#:reason-phrase "Moved")
	56	"Redirect!")
	57	(200 "Hello, world."))
	58	(let* ((port (http-fetch (%local-url)))
	59	(data (get-string-all port)))
	60	(close-port port)
	61	data)))
	62
	63	(test-equal "http-fetch, error"
	64	404
65	(with-http-server `((404 "Ne trovita."))
66	(guard (c ((http-get-error? c) (http-get-error-code c)))
67	(http-fetch (%local-url))
68	#f)))
69
70	(test-equal "http-fetch, redirect + error"
71	403
72	(with-http-server `((,(build-response
73	#:code 302
74	#:headers
75	`((location
76	. ,(string->uri-reference "/elsewhere")))
77	#:reason-phrase "Moved")
78	"Redirect!")
79	(403 "Verboten."))
80	(guard (c ((http-get-error? c) (http-get-error-code c)))
81	(http-fetch (%local-url))
82	#f)))
83
84	(test-end "http-client")