basis/uuid/uuid.factor

   1 ! Copyright (C) 2008 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: calendar checksums checksums.md5 checksums.sha
   4 combinators endian kernel literals math math.bitwise math.parser
   5 random sequences ;
   6 IN: uuid
   7
   8 <PRIVATE
   9
  10 : (timestamp) ( -- time )
  11     ! 0x01b21dd213814000L is the number of 100-ns intervals
  12     ! between the UUID epoch 1582-10-15 00:00:00 and the
  13     ! Unix epoch 1970-01-01 00:00:00.
  14     now timestamp>micros 10 * 0x01b21dd213814000 + ;
  15
  16 : (hardware) ( -- address )
  17     ! Choose a random 48-bit number with eighth bit
  18     ! set to 1 (as recommended in RFC 4122)
  19     48 random-bits 0x010000000000 bitor ;
  20
  21 : (clock) ( -- clockseq )
  22     ! Choose a random 14-bit number
  23     14 random-bits ;
  24
  25 : (version) ( n version -- n' )
  26     [
  27         0xc000 48 shift bitnot bitand
  28         0x8000 48 shift bitor
  29         0xf000 64 shift bitnot bitand
  30     ] dip 76 shift bitor ;
  31
  32 : (uuid) ( a version b variant c -- n )
  33     {
  34         [ 48 bits 80 shift ]
  35         [ 76 shift + ]
  36         [ 12 bits 64 shift + ]
  37         [ 62 shift + ]
  38         [ 62 bits + ]
  39     } spread ;
  40
  41 : uuid>string ( n -- string )
  42     >hex 32 CHAR: 0 pad-head
  43     [ CHAR: - 20 ] dip insert-nth
  44     [ CHAR: - 16 ] dip insert-nth
  45     [ CHAR: - 12 ] dip insert-nth
  46     [ CHAR: - 8 ] dip insert-nth ;
  47
  48 : string>uuid ( string -- n )
  49     CHAR: - swap remove hex> ;
  50
  51 PRIVATE>
  52
  53 : uuid-parse ( string -- byte-array )
  54     string>uuid 16 >be ;
  55
  56 : uuid-unparse ( byte-array -- string )
  57     be> uuid>string ;
  58
  59 : uuid1 ( -- string )
  60     (timestamp)
  61     [ 32 bits 16 shift ] [ -32 shift 16 bits + 1 ] [ -48 shift ] tri
  62     0b01 (clock) 48 shift (hardware) +
  63     (uuid) uuid>string ;
  64
  65 : uuid3 ( namespace name -- string )
  66     [ uuid-parse ] dip append
  67     md5 checksum-bytes 16 cramp head be>
  68     3 (version) uuid>string ;
  69
  70 : uuid4 ( -- string )
  71     128 random-bits
  72     4 (version) uuid>string ;
  73
  74 : uuid5 ( namespace name -- string )
  75     [ uuid-parse ] dip append
  76     sha1 checksum-bytes 16 cramp head be>
  77     5 (version) uuid>string ;
  78
  79 : uuid6 ( -- string )
  80     (timestamp) [ -12 shift 6 ] [ 12 bits ] bi
  81     0b10 (clock) 48 shift $[ 48 random-bits ] +
  82     (uuid) uuid>string  ;
  83
  84 : uuid7 ( -- string )
  85     now timestamp>millis 7
  86     12 random-bits 0b11
  87     62 random-bits (uuid) uuid>string ;
  88
  89 : uuid8 ( a b c -- string )
  90     [ 8 ] 2dip [ 0b01 ] dip (uuid) uuid>string ;
  91
  92 : uuid-urn ( string -- url )
  93     "url:urn:" prepend ;
  94
  95 CONSTANT: NAMESPACE_DNS  "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
  96 CONSTANT: NAMESPACE_URL  "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
  97 CONSTANT: NAMESPACE_OID  "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
  98 CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"