Define the ABNF types to parse RFC 4234

2 files changed, 153 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index fe6b458..bd167db 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -43,7 +43,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/parameters.scm \
   %reldir%/simulation.scm \
   %reldir%/web-i18n.scm \
-  %reldir%/serializable.scm
+  %reldir%/serializable.scm \
+  %reldir%/abnf-types.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -74,7 +75,8 @@ webidoidcgo_DATA += \
   %reldir%/parameters.go \
   %reldir%/simulation.go \
   %reldir%/web-i18n.go \
-  %reldir%/serializable.go
+  %reldir%/serializable.go \
+  %reldir%/abnf-types.go
 
 EXTRA_DIST += %reldir%/ChangeLog
 
diff --git a/src/scm/webid-oidc/abnf-types.scm b/src/scm/webid-oidc/abnf-types.scm
new file mode 100644
index 0000000..27ee4bf
--- /dev/null
+++ b/src/scm/webid-oidc/abnf-types.scm
@@ -0,0 +1,149 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc abnf-types)
+  #:use-module (oop goops)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 exceptions)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:export
+  (
+   <abnf>
+   rules
+
+   <rule> rule-name incremental? root
+
+   <concatenation> elements
+
+   <alternatives> ;; elements
+
+   <value-range-alternative> lower upper
+
+   <repetition> minimum maximum element
+
+   <prose> description
+
+   <rule-ref> ;; rule-name
+
+   extend
+   produce
+   ))
+
+(define-class <abnf> ()
+  (rules
+   #:init-keyword #:rules
+   #:init-value '()
+   #:accessor rules))
+
+(define-class <rule> ()
+  (rule-name
+   #:init-keyword #:rule-name
+   #:accessor rule-name)
+  (incremental?
+   #:init-keyword #:incremental?
+   #:init-value #f
+   #:accessor incremental?)
+  (root
+      #:init-keyword #:root
+      #:init-thunk (lambda () (make <concatenation>))
+      #:accessor root))
+
+(define-class <concatenation> ()
+  (elements
+   #:init-keyword #:elements
+   #:init-value '()
+   #:accessor elements))
+
+(define-class <alternatives> ()
+  (elements
+   #:init-keyword #:elements
+   #:init-value '()
+   #:accessor elements))
+
+(define-class <value-range-alternative> ()
+  (lower
+   #:init-keyword #:lower
+   #:init-value #\x00
+   #:accessor lower)
+  (upper
+   #:init-keyword #:upper
+   #:init-value #\xff
+   #:accessor upper))
+
+(define-class <repetition> ()
+  (minimum
+   #:init-keyword #:minimum
+   #:init-value 0
+   #:accessor minimum)
+  (maximum
+   #:init-keyword #:maximum
+   #:init-value #f
+   #:accessor maximum))
+
+(define-class <prose> ()
+  (description
+   #:init-keyword #:description
+   #:accessor description))
+
+(define-class <rule-ref> ()
+  (rule-name
+   #:init-keyword #:rule-name
+   #:accessor rule-name))
+
+(define-method (extend (base <rule>) (extension <rule>))
+  (unless (equal? (rule-name base) (rule-name extension))
+    (raise-exception
+     (make-exception
+      (make-exception-with-message
+       (format #f (G_ "extension rule ~s should have the same name as base rule ~s")
+               (rule-name extension)
+               (rule-name base)))
+      (make-exception-with-origin 'extend)
+      (make-error))))
+  (unless (incremental? extension)
+    (raise-exception
+     (make-exception
+      (make-exception-with-message
+       (format #f (G_ "extension rule of ~s should be an incremental extension")
+               (rule-name extension)))
+      (make-exception-with-origin 'extend)
+      (make-error))))
+  (unless (is-a? (root base) <alternatives>)
+    (set! base
+          (let ((ret (shallow-clone base)))
+            (set! (root ret)
+                  (make <alternatives> #:elements (list (root base))))
+            ret)))
+  (unless (is-a? (root extension) <alternatives>)
+    (set! extension
+          (let ((ret (shallow-clone extension)))
+            (set! (root ret)
+                  (make <alternatives> #:elements (list (root extension))))
+            ret)))
+  (let ((ret (shallow-clone base)))
+    (set! (root ret)
+          (let ((new-root (shallow-clone (root base))))
+            (set! (elements new-root)
+                  (append (elements (root base)) (elements (root extension))))
+            new-root))
+    ret))