From f9e6f9b7a18afea7e1afb428066e4b77e0634eeb Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
Date: Wed, 29 Aug 2018 16:14:34 +0200
Subject: debbugs: Add primitive caching.

* debbugs/cache.scm: New file.
* Makefile.am (SOURCES): Add it.
* debbugs/config.scm (%config): Add cache-ttl field.
* debbugs/soap.scm (soap-invoke*): New procedure.
---
 Makefile.am        |  1 +
 debbugs/cache.scm  | 49 +++++++++++++++++++++++++++++++++++++++++++++++++
 debbugs/config.scm |  5 +++--
 debbugs/soap.scm   | 11 ++++++++++-
 4 files changed, 63 insertions(+), 3 deletions(-)
 create mode 100644 debbugs/cache.scm

diff --git a/Makefile.am b/Makefile.am
index cc5de7d..0fc86ad 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -24,6 +24,7 @@ godir=$(libdir)/guile/@GUILE_EFFECTIVE_VERSION@/ccache
 SOURCES =									\
   debbugs/base64.scm						\
   debbugs/bug.scm							\
+  debbugs/cache.scm							\
   debbugs/config.scm						\
   debbugs/email.scm							\
   debbugs/operations.scm 					\
diff --git a/debbugs/cache.scm b/debbugs/cache.scm
new file mode 100644
index 0000000..7dfd375
--- /dev/null
+++ b/debbugs/cache.scm
@@ -0,0 +1,49 @@
+;;; Guile-Debbugs --- Guile bindings for Debbugs
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of Guile-Debbugs.
+;;;
+;;; Guile-Debbugs 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-Debbugs 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-Debbugs.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (debbugs cache)
+  #:use-module (debbugs config)
+  #:use-module (ice-9 match)
+  #:export (cached? cache! forget! forget-all!))
+
+(define %cache (make-hash-table))
+
+(define (cached? key)
+  "Return the value matching KEY from the cache if it has not yet
+expired or return #F."
+  (let ((t (current-time)))
+    (match (hash-ref %cache key)
+      ((#:expires time #:value value)
+       (if (< t time) value #f))
+      (_ #f))))
+
+(define* (cache! key value
+                 #:optional (ttl (config 'cache-ttl)))
+  "Store VALUE for the given KEY and mark it to expire after TTL
+seconds."
+  (let ((t (current-time)))
+    (hash-set! %cache key `(#:expires ,(+ t ttl) #:value ,value))
+    value))
+
+(define (forget! key)
+  "Delete KEY from the cache."
+  (hash-remove! %cache key))
+
+(define (forget-all!)
+  "Reset the cache."
+  (set! %cache (make-hash-table)))
diff --git a/debbugs/config.scm b/debbugs/config.scm
index 96f9624..217e725 100644
--- a/debbugs/config.scm
+++ b/debbugs/config.scm
@@ -1,5 +1,5 @@
 ;;; Guile-Debbugs --- Guile bindings for Debbugs
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of Guile-Debbugs.
 ;;;
@@ -20,7 +20,8 @@
   #:export (config))
 
 (define %config
-  `((debug . #f)))
+  `((debug . #f)
+    (cache-ttl . 240)))
 
 (define (config key)
   (assoc-ref %config key))
diff --git a/debbugs/soap.scm b/debbugs/soap.scm
index 97dabd1..27c5fce 100644
--- a/debbugs/soap.scm
+++ b/debbugs/soap.scm
@@ -1,5 +1,5 @@
 ;;; Guile-Debbugs --- Guile bindings for Debbugs
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of Guile-Debbugs.
 ;;;
@@ -18,6 +18,8 @@
 
 (define-module (debbugs soap)
   #:use-module (debbugs base64)
+  #:use-module (debbugs config)
+  #:use-module (debbugs cache)
   #:use-module (sxml simple)
   #:use-module (sxml xpath)
   #:use-module (web client)
@@ -33,6 +35,7 @@
             soap-request-callback
 
             soap-invoke
+            soap-invoke*
             soap->scheme))
 
 ;; (define (parse-wsdl file)
@@ -105,6 +108,12 @@ response body."
       ((soap-request-callback request)
        (xml->sxml body #:trim-whitespace? #t)))))
 
+(define (soap-invoke* . args)
+  "Cache the return value of SOAP-INVOKE.  Return the cached value if
+it is still fresh."
+  (or (cached? args)
+      (cache! args (apply soap-invoke args))))
+
 (define* (soap->scheme sxml #:optional (plain #f))
   "Convert a SOAP sxml expression for a named value to a Scheme value.
 If PLAIN is #T return only the value, otherwise return a pair of a
-- 
cgit v1.2.3