basis/uuid/uuid.factor

   1 ! Copyright (C) 2008 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: byte-arrays checksums checksums.md5 checksums.sha1
   5 kernel math math.parser math.ranges random unicode.case
   6 sequences strings system ;
   7
   8 IN: uuid
   9
  10 <PRIVATE
  11
  12 : (timestamp) ( -- time_high time_mid time_low )
  13     ! 0x01b21dd213814000L is the number of 100-ns intervals
  14     ! between the UUID epoch 1582-10-15 00:00:00 and the
  15     ! Unix epoch 1970-01-01 00:00:00.
  16     micros 10 * HEX: 01b21dd213814000 +
  17     [ -48 shift HEX: 0fff bitand ]
  18     [ -32 shift HEX: ffff bitand ]
  19     [ HEX: ffffffff bitand ] tri ;
  20
  21 : (hardware) ( -- address )
  22     ! Choose a random 48-bit number with eighth bit
  23     ! set to 1 (as recommended in RFC 4122)
  24     48 random-bits HEX: 010000000000 bitor ;
  25
  26 : (clock) ( -- clockseq )
  27     ! Choose a random 14-bit number
  28     14 random-bits ;
  29
  30 : <uuid> ( address clockseq time_high time_mid time_low -- n )
  31     96 shift
  32     [ 80 shift ] dip bitor
  33     [ 64 shift ] dip bitor
  34     [ 48 shift ] dip bitor
  35     bitor ;
  36
  37 : (version) ( n version -- n' )
  38     [ HEX: c000 48 shift bitnot bitand
  39       HEX: 8000 48 shift bitor
  40       HEX: f000 64 shift bitnot bitand
  41     ] dip 76 shift bitor ;
  42
  43 : uuid>string ( n -- string )
  44     >hex 32 CHAR: 0 pad-left
  45     [ CHAR: - 20 ] dip insert-nth
  46     [ CHAR: - 16 ] dip insert-nth
  47     [ CHAR: - 12 ] dip insert-nth
  48     [ CHAR: - 8 ] dip insert-nth ;
  49
  50 : string>uuid ( string -- n )
  51     [ CHAR: - = not ] filter 16 base> ;
  52
  53 : uuid>byte-array ( n -- byte-array )
  54     16 <byte-array> 15 -1 [a,b) [
  55         [ dup HEX: ff bitand ] 2dip swap
  56         [ set-nth -8 shift ] keep
  57     ] each nip ;
  58
  59 : byte-array>uuid ( byte-array -- n )
  60      0 swap [ [ 8 shift ] dip + ] each ;
  61
  62 PRIVATE>
  63
  64 : uuid-parse ( string -- byte-array )
  65     string>uuid uuid>byte-array ;
  66
  67 : uuid-unparse ( byte-array -- string )
  68     byte-array>uuid uuid>string ;
  69
  70 : uuid1 ( -- string )
  71     (hardware) (clock) (timestamp) <uuid>
  72     1 (version) uuid>string ;
  73
  74 : uuid3 ( namespace name -- string )
  75     [ uuid-parse ] dip >byte-array append
  76     md5 checksum-bytes 16 short head byte-array>uuid
  77     3 (version) uuid>string ;
  78
  79 : uuid4 ( -- string )
  80     128 random-bits
  81     4 (version) uuid>string ;
  82
  83 : uuid5 ( namespace name -- string )
  84    [ uuid-parse ] dip >byte-array append
  85     sha1 checksum-bytes 16 short head byte-array>uuid
  86     5 (version) uuid>string ;
  87
  88
  89 : NAMESPACE_DNS  "6ba7b810-9dad-11d1-80b4-00c04fd430c8" ; inline
  90 : NAMESPACE_URL  "6ba7b811-9dad-11d1-80b4-00c04fd430c8" ; inline
  91 : NAMESPACE_OID  "6ba7b812-9dad-11d1-80b4-00c04fd430c8" ; inline
  92 : NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8" ; inline
  93
  94