;;;; uuid-lib.scm
;;;; Kon Lovett, May '06
;;;; BSD

;;; Wrapper for Theodore Y. Ts'o OSF DCE 1.1 UUID Suite
;;; http://lib.sourceforge.net/
;;; Part of MacOS X & Linux (every modern unix?)

;; Issues
;;
;; - `uuid' is type, argument, struct tag variable, ...

(declare
  (bound-to-procedure
    ##sys#signal-hook))

#>
#if defined(__APPLE__) || defined(__linux__)
# include <uuid/uuid.h>
#else
# include <uuid.h>
#endif
<#

(module uuid-lib

(;export
  ;Common API
  make-uuid
  uuid?
  uuid-null?
  uuid-compare
  uuid=? uuid<? uuid>? uuid<=? uuid>=?
  uuid-hash
  uuid-copy
  uuid-clear!
  string->uuid uuid->string
  ;FIXME add to uuid-ossp
  uuid-version? check-uuid-version error-uuid-version
  uuid-version->method uuid-method->version
  check-uuid error-uuid
  uuid-method
  uuid-version-number
  uuid-print
  ;Specialized API
  uuid-generate
  uuid-parse
  uuid-unparse)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (chicken format))
(import (chicken bitwise))
(import (chicken condition))
(import (chicken foreign))
(import (chicken memory))
(import (chicken gc))
(import (chicken locative))
(import record-variants)

;NOTE works w/o recourse to `define-record' for tag, so ok for tag "defining" module
(cond-expand
  ((or chicken-5.0 chicken-5.1)
    (define (set-record-printer! tag proc)
      (##sys#register-record-printer tag proc) ) )
  (else) )

(define-type uuid (struct uuid))

(define-type uuid-version (or false fixnum))
(define-type uuid-method (or false symbol))

(: uuid-version? (* -> boolean : uuid-version))
(: error-uuid-version (symbol * #!optional (or string symbol) -> void))
(: check-uuid-version (symbol * #!optional (or string symbol) -> uuid-version))

(: uuid-version->method (uuid-version --> uuid-method))
(: uuid-method->version (uuid-method --> uuid-version))

(: uuid? (* -> boolean : uuid))
(: error-uuid (symbol * #!optional (or string symbol) -> void))
(: check-uuid (symbol * #!optional (or string symbol) -> uuid))

(: uuid-method (uuid --> uuid-method))
(: uuid-version-number (uuid --> fixnum))

(: uuid-null? (* --> boolean)) ;not a `predicate'

(: uuid-hash (uuid #!optional fixnum fixnum --> fixnum))

(: uuid-compare (uuid uuid --> fixnum))
(: uuid=? (uuid uuid --> boolean))
(: uuid<? (uuid uuid --> boolean))
(: uuid>? (uuid uuid --> boolean))
(: uuid<=? (uuid uuid --> boolean))
(: uuid>=? (uuid uuid --> boolean))

(: uuid-clear! (uuid -> uuid))

(: uuid-copy (uuid --> uuid))

(: uuid-generate (#!optional uuid-method -> uuid))
(: make-uuid (#!optional uuid-method -> uuid))
(: uuid-parse ((or string symbol) -> uuid))

(: uuid-unparse (uuid #!optional (or false symbol) --> string))

(: string->uuid (string --> uuid))
(: uuid->string (uuid --> string))

;fx-inlines

(define-inline (fxabs n) (if (fx< n 0) (fxneg n) n))

(define-inline (fxnegative? n) (fx< n 0))
(define-inline (fxzero? n) (fx= n 0))
(define-inline (fxpositive? n) (fx> n 0))

;srfi-69

(foreign-declare "#define C_rnd_fix() (C_fix(rand()))")
(define-constant hash-default-bound 536870912)
;NOTE fix for randomization - must fit within `hash-default-bound'
(define hash-default-randomization (fxmod (##core#inline "C_rnd_fix")
                                          hash-default-bound))

(define C_MOST_POSITIVE_32_BIT_FIXNUM
        (foreign-value "C_MOST_POSITIVE_32_BIT_FIXNUM" int))

;@32bit-hash-limit
;@=> bounded & randomized hash value, a non-negative fixnum
;@hsh hash value, an unsigned-integer
;@bnd 32bit bound, a non-negative fixnum
;@rnd randomization mask, a non-negative fixnum
;
(define-inline (32bit-hash-limit hsh bnd rnd)
  ;; use 32-bit mask to have identical hashes on 64-bit platforms
  (fxxor (fxmod (bitwise-and (fxabs hsh)
                             C_MOST_POSITIVE_32_BIT_FIXNUM)
                bnd)
         rnd) )

#; ;https://nullprogram.com/blog/2018/07/31/
(define (triple32 u32)
  (define 2^32-1 (sub1 (expt 2 32)))
  (let* ((u32 (bitwise-xor u32 (arithmetic-shift u32 -17)))
         (u32 (bitwise-and (* u32 #xed5ad4bb) 2^32-1))
         (u32 (bitwise-xor u32 (arithmetic-shift u32 -11)))
         (u32 (bitwise-and (* u32 #xac4c1b51) 2^32-1))
         (u32 (bitwise-xor u32 (arithmetic-shift u32 -15)))
         (u32 (bitwise-and (* u32 #x31848bab) 2^32-1))
         (u32 (bitwise-xor u32 (arithmetic-shift u32 -14))) )
    u32 ) )

;restricted input & mixers to 30bits!
(define (fxtriple32 u32)
  (let* ((u32 (fxxor u32 (fxshr u32 17)))
         (u32 (fx* u32 #x3d5ad4bb))
         (u32 (fxxor u32 (fxshr u32 11)))
         (u32 (fx* u32 #x3c4c1b51))
         (u32 (fxxor u32 (fxshr u32 15)))
         (u32 (fx* u32 #x31848bab))
         (u32 (fxxor u32 (fxshr u32 14))) )
    (fxabs u32) ) )

;;

(define-inline (puuid-high puuid) (pointer-u64-ref puuid))
(define-inline (puuid-low puuid) (pointer-u64-ref (pointer+ puuid 8)))

(define (puuid-version puuid)
  (bitwise-and (arithmetic-shift (puuid-high puuid) -52)
               #b1111) )

(cond-expand
  (64bit
    (define (puuid-32 n)
      (abs (+ (arithmetic-shift n -32)
              (bitwise-and n C_MOST_POSITIVE_32_BIT_FIXNUM))) ) )
  (else
    (define (puuid-32 n) n) ) )

;;

(define UUID-SIZEOF (foreign-value "sizeof(uuid_t)" int))

(define-constant UUID-STRING-LENGTH 36)

(define uuid_is_null
  (foreign-lambda bool uuid_is_null nonnull-c-pointer))

(define uuid_compare
  (foreign-lambda int uuid_compare nonnull-c-pointer nonnull-c-pointer))

(define uuid_clear
  (foreign-lambda void uuid_clear nonnull-c-pointer))

(define uuid_copy
  (foreign-lambda void uuid_copy nonnull-c-pointer nonnull-c-pointer))

(define uuid_generate
  (foreign-lambda void uuid_generate nonnull-c-pointer))

(define uuid_generate_random
  (foreign-lambda void uuid_generate_random nonnull-c-pointer))

(define uuid_generate_time
  (foreign-lambda void uuid_generate_time nonnull-c-pointer))

(define uuid_parse
  (foreign-lambda int uuid_parse c-string nonnull-c-pointer))

(define uuid_unparse
  (foreign-lambda void uuid_unparse nonnull-c-pointer nonnull-c-pointer))

(define uuid_unparse_upper
  (foreign-lambda void uuid_unparse_upper nonnull-c-pointer nonnull-c-pointer))

(define uuid_unparse_lower
  (foreign-lambda void uuid_unparse_lower nonnull-c-pointer nonnull-c-pointer))

;;

(define (error-bad-argument-type loc obj #!optional msg)
  (##sys#signal-hook #:type-error loc
                     (apply string-append "bad argument type"
                                          (if msg (list " - " msg) '("")))
                     obj) )

(define (error-uuid-method loc obj)
  (error-bad-argument-type loc obj "invalid method; #f or symbol 'v[0..15]") )

(define (error-uuid-form loc obj)
  (error-bad-argument-type loc obj "not a string or symbol") )

(define (error-uuid-string-case loc obj)
  (error-bad-argument-type loc obj "invalid case; #f, upper, or lower") )

;;

(define uuid 'uuid)
(define-record-type-variant uuid (unchecked inline unsafe)
  (%make-uuid var puuid)
  %uuid?
  (var %uuid-method %set-uuid-method!)
  (puuid %uuid-puuid))

(define (free-uuid uuid)
  (free (%uuid-puuid uuid)) )

(define-inline (box-puuid puuid method)
  (set-finalizer! (%make-uuid method puuid) free-uuid) )

(define (new-uuid method)
  (box-puuid (allocate UUID-SIZEOF) method) )

;;

(define (*uuid-version->method ver)
  (cond ((not ver)
          #f )
        ((fxzero? ver)
          #f )
        (else
          (string->symbol (string-append "v" (number->string ver))) ) ) )

(define (*uuid-version-number uuid) (puuid-version (%uuid-puuid uuid)))

;;

(define (uuid-version-number? ver)
  (and (fixnum? ver)
       (fx<= 0 ver) (fx<= ver 15)) )

;@uuid-method-version-number @=> 0 .. 15 or #f for parse failure
;@var uuid-method
;
(define (uuid-method-version-number var)
  (and-let* (((symbol? var))
              (s (symbol->string var))
              ((char=? #\v (string-ref s 0)))
              (ver (string->number (substring s 1)))
              ((uuid-version-number? ver)) )
    ver ) )

(define (uuid-version? obj)
  (or (not obj)
      (uuid-version-number? obj)) )

(define (error-uuid-version loc obj . _)
  (error-bad-argument-type loc obj "invalid uuid version; #f or 0 .. 15 ") )

(define (check-uuid-version loc obj . _)
  (unless (uuid-version? obj) (error-uuid-version loc obj))
  obj )

(define (uuid-version->method ver)
  (*uuid-version->method (check-uuid-version 'uuid-version->method ver)) )

(define (uuid-method->version var)
  (cond ((not var) #f)
        ((uuid-method-version-number var))
        (else
          (error-uuid-method 'uuid-method->version var))) )

(define (validate-uuid-method loc obj)
  (case obj
    ((v0 V0 #f) #f)
    ((v1 V1 time) 'v1)
    ((v4 V4 random) 'v4)
    (else
      (error-uuid-method loc obj))) )

(define (set-uuid-method/version! uuid)
  (%set-uuid-method! uuid (*uuid-version->method (*uuid-version-number uuid))) )

(define (uuid-v4-hash uuid)
  ;"random" already
  (puuid-32 (puuid-low (%uuid-puuid uuid))) )

(define (uuid-v1-hash uuid)
  (let* ((puuid (%uuid-puuid uuid))
         (high (puuid-high puuid))
         (low (puuid-low puuid)) )
    (fxtriple32 (bitwise-and (+ high low) C_MOST_POSITIVE_32_BIT_FIXNUM)) ) )

;;

(define (uuid? obj)
  (%uuid? obj) )

;optional @argnam is ignored
(define (error-uuid loc obj . _)
  (error-bad-argument-type loc obj "not a uuid") )

;optional @argnam is ignored
(define (check-uuid loc obj . _)
  (unless (%uuid? obj) (error-uuid loc obj))
  obj )

(define (uuid-hash uuid #!optional (bound hash-default-bound)
                                   (randomization hash-default-randomization))
  (let ((hsh (case (%uuid-method (check-uuid 'uuid-hash uuid))
               ((#f) 0)
               ((v1) (uuid-v1-hash uuid))
               ((v4) (uuid-v4-hash uuid)))) )
    (32bit-hash-limit hsh bound randomization) ) )

(define (uuid-method uuid)
  (%uuid-method (check-uuid 'uuid-method uuid)) )

(define (uuid-version-number uuid)
  (*uuid-version-number (check-uuid 'uuid-version-number uuid)) )

(define (uuid-null? obj)
  (uuid_is_null (%uuid-puuid (check-uuid 'uuid-null? obj))) )

(define (*uuid-compare loc uuid1 uuid2)
  (uuid_compare (%uuid-puuid (check-uuid loc uuid1))
                (%uuid-puuid (check-uuid loc uuid2))) )

(define (uuid-compare uuid1 uuid2)
  (*uuid-compare 'uuid-compare uuid1 uuid2) )

(define (uuid=? uuid1 uuid2)
  (fxzero? (*uuid-compare 'uuid=? uuid1 uuid2)) )

(define (uuid<? uuid1 uuid2)
  (fxnegative? (*uuid-compare 'uuid<? uuid1 uuid2)) )

(define (uuid>? uuid1 uuid2)
  (fxpositive? (*uuid-compare 'uuid>? uuid1 uuid2)) )

(define (uuid<=? uuid1 uuid2)
  (let ((cmp (*uuid-compare 'uuid<=? uuid1 uuid2)))
    (or (fxzero? cmp) (fxnegative? cmp))) )

(define (uuid>=? uuid1 uuid2)
  (let ((cmp (*uuid-compare 'uuid>=? uuid1 uuid2)))
    (or (fxzero? cmp) (fxpositive? cmp))) )

(define (uuid-clear! uuid)
  (uuid_clear (%uuid-puuid (check-uuid 'uuid-clear! uuid)))
  (%set-uuid-method! uuid #f)
  uuid )

(define (uuid-copy old-uuid)
  (check-uuid 'uuid-copy old-uuid)
  (let ((uuid (new-uuid (%uuid-method old-uuid))))
    (uuid_copy (%uuid-puuid uuid) (%uuid-puuid old-uuid))
    uuid) )

(define (uuid-generate #!optional (method #f))
  (let* ((method (validate-uuid-method 'uuid-generate method))
         (uuid (new-uuid method))
         (puuid (%uuid-puuid uuid)) )
    (case method
      ((#f)
        (uuid_generate puuid)
        ;determine library default at runtime
        (set-uuid-method/version! uuid) )
      ((v1)
        (uuid_generate_time puuid) )
      ((v4)
        (uuid_generate_random puuid) ) )
    uuid ) )

(define (make-uuid . args)
  (if (null? args)
      ;then default is a null uuid
      (uuid-clear! (new-uuid #f))
      ;else per generate
      (apply uuid-generate args)) )

(define (uuid-parse uuid-text)
  (let* ((uuid-text (cond ((symbol? uuid-text) (symbol->string uuid-text))
                          ((string? uuid-text) uuid-text)
                          (else
                            (error-uuid-form 'uuid-parse uuid-text))))
         (uuid (new-uuid #f)) )
         ;then parse failure
    (and (fxzero? (uuid_parse uuid-text (%uuid-puuid uuid)))
         ;else determine method from parsed version
         (begin
           (set-uuid-method/version! uuid)
           uuid) ) ) )

(define (uuid-unparse uuid #!optional (kase #f))
  (check-uuid 'uuid-unparse uuid)
  ;allocate string buffer, +1 for NUL byte; use string so gc
  (let* ((uuid-text (make-string (add1 UUID-STRING-LENGTH)))
         (puuid-text (make-locative uuid-text))
         (puuid (%uuid-puuid uuid)))
    (case kase
      ((#f)
        (uuid_unparse puuid puuid-text))
      ((upper)
        (uuid_unparse_upper puuid puuid-text))
      ((lower)
        (uuid_unparse_lower puuid puuid-text))
      (else
        (error-uuid-string-case 'uuid-generate kase)) )
    ;trim NUL byte
    (substring uuid-text 0 UUID-STRING-LENGTH)) )

(define (string->uuid str)
  (uuid-parse str) )

(define (uuid->string uuid)
  (uuid-unparse uuid 'lower) )

(define (uuid-print obj #!optional (port (current-output-port)))
  (format port "#<~A ~A ~A>" uuid (uuid-method obj) (uuid->string obj)) )

(set-record-printer! uuid uuid-print)

) ;module uuid-lib