;;;; uuid-ossp.scm
;;;; Kon Lovett, Jan '06
(module uuid-ossp
  (export uuid-version make-uuid uuid? uuid-nil? uuid= uuid<> uuid< uuid> uuid<= uuid>=
	  uuid-clone uuid-load uuid-import uuid-import-binary uuid-export uuid-export-binary
	  uuid-export-text)

  (import scheme chicken foreign)
  (use lolevel)

  (declare
    (usual-integrations)
    (fixnum)
    (inline)
    (no-procedure-checks)
    (no-bound-checks)
    (always-bound
      *uuid-error-codes*
      UUID_LEN_BIN UUID_LEN_STR
      UUID_RC_OK UUID_RC_ARG
      UUID_RC_MEM UUID_RC_SYS
      UUID_RC_INT UUID_RC_IMP
      UUID_MAKE_V1 UUID_MAKE_V1MC UUID_MAKE_V3 UUID_MAKE_V4 UUID_MAKE_V5
      UUID_FMT_BIN UUID_FMT_STR UUID_FMT_TXT)
    (bound-to-procedure
      uuid_create uuid_destroy uuid_clone
      uuid_load
      uuid_make_0 uuid_make_2
      uuid_isnil uuid_compare
      uuid_import uuid_export
      uuid_error uuid_version
      uuid-error-string signal-uuid-error
      new-uuid free-uuid
      uuid-import-format uuid-export-format
      uuid-compare
      get-ns-uuid make-uuid-2
      uuid-version
      make-uuid
      uuid?
      uuid-nil?
      uuid= uuid<> uuid< uuid> uuid<= uuid>=
      uuid-clone uuid-load
      uuid-import uuid-import-binary
      uuid-export uuid-export-binary uuid-export-text)
    (block-global
      *uuid-error-codes*
      UUID_LEN_BIN UUID_LEN_STR
      UUID_RC_OK UUID_RC_ARG
      UUID_RC_MEM UUID_RC_SYS
      UUID_RC_INT UUID_RC_IMP
      UUID_MAKE_V1 UUID_MAKE_V1MC UUID_MAKE_V3 UUID_MAKE_V4 UUID_MAKE_V5
      UUID_FMT_BIN UUID_FMT_STR UUID_FMT_TXT
      uuid_create uuid_destroy uuid_clone
      uuid_load
      uuid_make_0 uuid_make_2
      uuid_isnil uuid_compare
      uuid_import uuid_export
      uuid_error uuid_version
      uuid-error-string signal-uuid-error
      new-uuid free-uuid
      uuid-import-format uuid-export-format
      uuid-compare
      get-ns-uuid make-uuid-2))


#>
#include "uuid-ossp-fix.h"
<#

(define UUID_LEN_BIN (foreign-value "uuid_LEN_BIN" unsigned-int))
(define UUID_LEN_STR (foreign-value "uuid_LEN_STR" unsigned-int))

(define UUID_RC_OK (foreign-value "uuid_RC_OK" unsigned-int))
(define UUID_RC_ARG (foreign-value "uuid_RC_ARG" unsigned-int))
(define UUID_RC_MEM (foreign-value "uuid_RC_MEM" unsigned-int))
(define UUID_RC_SYS (foreign-value "uuid_RC_SYS" unsigned-int))
(define UUID_RC_INT (foreign-value "uuid_RC_INT" unsigned-int))
(define UUID_RC_IMP (foreign-value "uuid_RC_IMP" unsigned-int))

(define UUID_MAKE_V1 (foreign-value "uuid_MAKE_V1" unsigned-int))
(define UUID_MAKE_V1MC (foreign-value "uuid_MAKE_V1MC" unsigned-int))
(define UUID_MAKE_V3 (foreign-value "uuid_MAKE_V3" unsigned-int))
(define UUID_MAKE_V4 (foreign-value "uuid_MAKE_V4" unsigned-int))
(define UUID_MAKE_V5 (foreign-value "uuid_MAKE_V5" unsigned-int))

(define UUID_FMT_BIN (foreign-value "uuid_FMT_BIN" unsigned-int))
(define UUID_FMT_STR (foreign-value "uuid_FMT_STR" unsigned-int))
(define UUID_FMT_TXT (foreign-value "uuid_FMT_TXT" unsigned-int))

;;

(define-foreign-type size_t unsigned-long)
(define-foreign-type uuid_rc_t unsigned-int)
(define-foreign-type uuid_fmt_t unsigned-int)
(define-foreign-type uuid_t (struct "uuid_st"))

(define uuid_create
  (foreign-lambda uuid_rc_t uuid_create (c-pointer (c-pointer uuid_t))))

(define uuid_destroy
  (foreign-lambda uuid_rc_t uuid_destroy (c-pointer uuid_t)))

(define uuid_clone
  (foreign-lambda uuid_rc_t uuid_clone (const (c-pointer uuid_t)) (c-pointer (c-pointer uuid_t))))

(define uuid_load
  (foreign-lambda uuid_rc_t uuid_load (c-pointer uuid_t) (const c-string)))

(define uuid_make_0
  (foreign-lambda uuid_rc_t uuid_make (c-pointer uuid_t) unsigned-int))

(define uuid_make_2
  (foreign-lambda uuid_rc_t uuid_make (c-pointer uuid_t) unsigned-int (c-pointer uuid_t) (const c-string)))

(define uuid_isnil
  (foreign-lambda uuid_rc_t uuid_isnil (const (c-pointer uuid_t)) (c-pointer int)))

(define uuid_compare
  (foreign-lambda uuid_rc_t uuid_compare (const (c-pointer uuid_t)) (const (c-pointer uuid_t)) (c-pointer int)))

(define uuid_import
  (foreign-lambda uuid_rc_t uuid_import (c-pointer uuid_t) uuid_fmt_t (const c-string) size_t))

(define uuid_export
  (foreign-lambda uuid_rc_t uuid_export (const (c-pointer uuid_t)) uuid_fmt_t (c-pointer c-pointer) (c-pointer size_t)))

(define uuid_error
  (foreign-lambda c-string uuid_error uuid_rc_t))

(define uuid_version
  (foreign-lambda unsigned-long uuid_version))

;;

(define *uuid-error-codes* (list
  `(,UUID_RC_OK . "everything ok")
  `(,UUID_RC_ARG . "invalid argument")
  `(,UUID_RC_MEM . "out of memory")
  `(,UUID_RC_SYS . "system error")
  `(,UUID_RC_INT . "internal error")
  `(,UUID_RC_IMP . "not implemented") ) )

(define (uuid-error-string code)
  (or (uuid_error code)
    (let ([msg (assv code *uuid-error-codes*)])
      (if msg
        (cdr msg)
        "unknown error"))))

(define (signal-uuid-error code)
  (abort
    (make-composite-condition
      (make-property-condition 'exn 'message (uuid-error-string code))
      (make-property-condition 'uuid 'code code))))

(define-inline (uuid-status-ok? code)
  (= UUID_RC_OK code))

;;

(define-inline (error-check code)
  (unless (uuid-status-ok? code)
    (signal-uuid-error code) ) )

(define-inline (box-puuid puuid)
  (let ([boxed-puuid (tag-pointer puuid 'ossp-uuid)])
    (set-finalizer! boxed-puuid free-uuid)
    boxed-puuid ) )

(define-inline (unbox-puuid boxed-puuid)
  boxed-puuid )

;;

(define (new-uuid)
  (let-location ([puuid (c-pointer uuid_t)])
    (error-check (uuid_create (location puuid)))
    (box-puuid puuid)))

(define (free-uuid uuid)
  (uuid_destroy (unbox-puuid uuid)))

(define (uuid-import-format fmt str loc)
  (unless (string? str)
    (error loc "can only import from a string" str))
  (let ([str-len
      (select fmt
        [(UUID_FMT_BIN) UUID_LEN_BIN]
        [(UUID_FMT_STR) UUID_LEN_STR]
        [else (error loc "invalid format" fmt)])])
    (unless (= (string-length str) str-len)
      (error loc "invalid length of string" str "wanted:" str-len))
    (let ([uuid (new-uuid)])
      (error-check (uuid_import (unbox-puuid uuid) fmt str str-len))
      uuid)))

(define (uuid-export-format uuid fmt loc)
  (let ([str-bias
      (select fmt
        [(UUID_FMT_BIN) 0]
        [(UUID_FMT_STR) 1]
        [(UUID_FMT_TXT) 1]
        [else (error loc "invalid format" fmt)])])
    (let-location ([len size_t 0] [dat c-pointer #f])
      (error-check (uuid_export (unbox-puuid uuid) fmt (location dat) (location len)))
      (when (or (null-pointer? dat) (zero? len))
        (signal-uuid-error UUID_RC_INT))
      (let ([str-len (fx- (inexact->exact len) str-bias)])
        (let ([str (make-string str-len)])
          (move-memory! dat (make-locative str) str-len)
          (free dat)
          str)))))

(define (uuid-compare uuid1 uuid2)
  (let-location ([comp int])
    (error-check (uuid_compare (unbox-puuid uuid1) (unbox-puuid uuid2) (location comp)))
    comp))

(define (get-ns-uuid ns loc)
  (cond
    [(uuid? ns)
      ns]
    [(string? ns)
      (let ([uuid (new-uuid)])
        (error-check (uuid_load (unbox-puuid uuid) ns))
        uuid)]
    [else
      (error loc "invalid namespace" ns)]))

(define (make-uuid-2 args uuid mode loc)
  (unless (= (length args) 3)
    (error loc "invalid or missing namespace and name" args))
  (let ([ns-uuid (get-ns-uuid (cadr args) loc)] [name (caddr args)])
    (unless (string? name)
      (error loc "invalid name" name))
    (error-check (uuid_make_2 (unbox-puuid uuid) mode (unbox-puuid ns-uuid) name))))

;;

(define (uuid? uuid)
  (tagged-pointer? uuid 'ossp-uuid))

(define (uuid-nil? uuid)
  (and (uuid? uuid)
    (let-location ([result int])
      (error-check (uuid_isnil (unbox-puuid uuid) (location result)))
      (not (zero? result)))))

(define (uuid= uuid1 uuid2)
  (zero? (uuid-compare uuid1 uuid2)))

(define (uuid<> uuid1 uuid2)
  (not (zero? (uuid-compare uuid1 uuid2))))

(define (uuid< uuid1 uuid2)
  (negative? (uuid-compare uuid1 uuid2)))

(define (uuid> uuid1 uuid2)
  (positive? (uuid-compare uuid1 uuid2)))

(define (uuid<= uuid1 uuid2)
  (let ([comp (uuid-compare uuid1 uuid2)])
    (or (zero? comp) (negative? comp))))

(define (uuid>= uuid1 uuid2)
  (let ([comp (uuid-compare uuid1 uuid2)])
    (or (zero? comp) (positive? comp))))

;;

(define (uuid-clone uuid)
  (let-location ([puuid (c-pointer uuid_t)])
    (error-check (uuid_clone (unbox-puuid uuid) (location puuid)))
    (box-puuid puuid)))

(define (uuid-load ns)
  (get-ns-uuid ns 'uuid-load))

(define (make-uuid . args)
  (let ([uuid (new-uuid)])
    (unless (null? args)
      (let ([mode (car args)])
        (case mode
          [(V1)
            (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V1))]
          [(V1-MC)
            (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V1MC))]
          [(V3)
            (make-uuid-2 args uuid UUID_MAKE_V3 'make-uuid)]
          [(V4)
            (error-check (uuid_make_0 (unbox-puuid uuid) UUID_MAKE_V4))]
          [(V5)
            (make-uuid-2 args uuid UUID_MAKE_V5 'make-uuid)]
          [else
            (error 'make-uuid "invalid mode" mode)])))
    uuid))

(define (uuid-import str)
  (uuid-import-format UUID_FMT_STR str 'uuid-import))

(define (uuid-import-binary str)
  (uuid-import-format UUID_FMT_BIN str 'uuid-import))

(define (uuid-export uuid)
  (uuid-export-format uuid UUID_FMT_STR 'uuid-export))

(define (uuid-export-binary uuid)
  (uuid-export-format uuid UUID_FMT_BIN 'uuid-export))

(define (uuid-export-text uuid)
  (uuid-export-format uuid UUID_FMT_TXT 'uuid-export))

(define uuid-version uuid_version)

)