(define-module (email-key-rotation tests fake-gandi-livedns)
  #:use-module ((email-key-rotation) #:prefix ekr:)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 optargs)
  #:use-module (json)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:export (call-with-fake-gandi-livedns)
  #:declarative? #t
  #:duplicates (merge-generics))

(define (fake-http-request expected-domain expected-api-key log-port)
  (lambda* (uri #:key headers body)
    (unless (equal? (uri-scheme uri) 'https)
      (raise-exception
       (make-exception
	(make-error)
	(make-exception-with-irritants (list uri))
	(make-exception-with-message
	 "Gandi URI is not HTTPS."))))
    (unless (equal? (uri-host uri) "api.gandi.net")
      (raise-exception
       (make-exception
	(make-error)
	(make-exception-with-irritants (list uri))
	(make-exception-with-message
	 "Wrong Gandi URI host."))))
    (when (uri-port uri)
      (raise-exception
       (make-exception
	(make-error)
	(make-exception-with-irritants (list uri))
	(make-exception-with-message
	 "Custom Gandi URI port."))))
    (when (uri-userinfo uri)
      (raise-exception
       (make-exception
	(make-error)
	(make-exception-with-irritants (list uri))
	(make-exception-with-message
	 "Custom Gandi URI userinfo."))))
    (unless (string-prefix? "/" (uri-path uri))
      (raise-exception
       (make-exception
	(make-error)
	(make-exception-with-irritants (list uri))
	(make-exception-with-message
	 "Gandi URI path not absolute."))))
    (let ((path-components
	   (split-and-decode-uri-path (uri-path uri))))
      (match path-components
	(("v5" "livedns" "domains" domain
	  "records" name "TXT")
	 (begin
	   (unless (equal? domain expected-domain)
	     (raise-exception
	      (make-exception
	       (make-error)
	       (make-exception-with-irritants (list domain))
	       (make-exception-with-message
		"wrong domain in Gandi URI path."))))
	   (unless (equal? (assoc-ref headers 'content-type)
			   '(application/json))
	     (raise-exception
	      (make-exception
	       (make-error)
	       (make-exception-with-irritants (list headers))
	       (make-exception-with-message
		"wrong content-type header."))))
	   (unless (equal? (assoc-ref headers 'Authorization)
			   (string-append
			    "ApiKey " expected-api-key))
	     (raise-exception
	      (make-exception
	       (make-error)
	       (make-exception-with-irritants (list headers))
	       (make-exception-with-message
		"wrong Authorization header."))))
	   (when (bytevector? body)
	     (set! body (utf8->string body)))
	   (match (json-string->scm body)
	     ((("rrset_values"
		. (? vector?
		     (= vector->list
			(value)))))
	      (begin
		(format log-port "Change ~s TXT record to value ~s.\n"
			name value)
		(values (build-response) ""))))))))))

(define (call-with-fake-gandi-livedns expected-domain expected-api-key f)
  (with-exception-handler
      (lambda (exn)
	(raise-exception
	 (make-exception
	  (make-exception-with-origin 'call-with-fake-gandi-livedns)
	  (make-exception-with-message "with fake gandi livedns:")
	  exn)))
    (lambda ()
      (call-with-output-string
	(lambda (log-port)
	  (let ((http-request
		 (fake-http-request expected-domain
				    expected-api-key
				    log-port)))
	    (let ((materialize
		   (lambda (configuration-object output-port)
		     (ekr:materialize configuration-object output-port
				      #:http-request http-request))))
	      (f materialize))))))))