Authentication handler in drracket

2026-08-13 19:13:58 +02:00
parent 12788edc7b
commit d3b5fdf830
7 changed files with 242 additions and 34 deletions
@@ -0,0 +1,101 @@
+#lang racket/base
+
+(require setup/getinfo
+         racket/string
+         )
+
+(provide info-version
+         set-info-version!
+         info-next-version
+         )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Read a package version from info.rkt.
+; pre    : dir contains a readable info.rkt.
+; post   : info.rkt has only been inspected.
+; result : A list containing major, minor and patch.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (info-version dir)
+  (let* ((l (get-info/full dir))
+         (re #px"([0-9]+)[.]([0-9]+)([.]([0-9]+))?")
+         (v (with-handlers ([exn:fail?
+                             (λ (e) "0.1")])
+              (l 'version)))
+         (m (regexp-match re v))
+         )
+    (map string->number
+         (list (cadr m) (caddr m) (if (eq? (cadddr (cdr m)) #f)
+                                      "0"
+                                      (cadddr (cdr m)))))
+    ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Store a package version in info.rkt.
+; pre    : dir contains info.rkt and version parts are numbers.
+; post   : The version definition has been replaced.
+; result : #t after writing the file.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (set-info-version! dir maj min patch)
+  
+  (define (write-version fh)
+    (let ((str (if (= patch 0)
+                   (format "(define version \"~a.~a\")" maj min)
+                   (format "(define version \"~a.~a.~a\")" maj min patch))))
+      (unless (eq? fh #f)
+        (displayln str fh))
+      str))
+
+  (let ((info-file (build-path dir "info.rkt")))
+    (unless (file-exists? info-file)
+      (error (format "No info.rkt exists at ~a" info-file)))
+    
+    (let ((fh (open-input-file info-file)))
+      (letrec ((reader (λ ()
+                         (let ((line (read-line fh)))
+                           (if (eof-object? line)
+                               '()
+                               (cons line (reader)))))))
+        (let* ((text (string-join (reader) "\n")))
+          (close-input-port fh)
+          (let* ((re #px"[(]define\\s+version\\s+[\"][^\"]+[\"]\\s*[)]")
+                 (ntext (regexp-replace re text (write-version #f)))
+                 (fout (open-output-file info-file #:exists 'replace))
+                 )
+            (display ntext fout)
+            (close-output-port fout)
+            #t)))))
+  )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Increment a package version.
+; pre    : kind is maj, major, min, minor or patch.
+; post   : The version definition in info.rkt has been updated.
+; result : #t after writing the new version.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (info-next-version kind . dir*)
+  (let ((dir (if (null? dir*)
+                 "."
+                 (car dir*))))
+    (if (memq kind '(maj major min minor patch))
+        (let ((v (info-version dir)))
+          (cond
+            ((or (eq? kind 'maj)
+                 (eq? kind 'major))
+             (apply set-info-version! (cons dir
+                                            (list (+ (car v) 1) 0 0))))
+            ((or (eq? kind 'min)
+                 (eq? kind 'minor))
+             (apply set-info-version! (cons dir
+                                            (list (car v) (+ (cadr v) 1) 0))))
+            (else
+             (apply set-info-version! (cons dir
+                                            (list (car v) (cadr v)
+                                                  (+ (caddr v) 1)))))
+            )
+          )
+        (error "kind must be 'maj, 'major, 'min, 'minor or 'patch")
+        )
+    )
+  )