extra/ulid/ulid.factor

   1 ! Copyright (C) 2018, 2019 Alexander Ilin.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ascii binary-search calendar endian kernel make math
   4 math.bitwise math.order namespaces random sequences splitting
   5 summary system tr ;
   6
   7 IN: ulid
   8
   9 ERROR: ulid-overflow ;
  10 M: ulid-overflow summary drop "Too many ULIDs generated per msec" ;
  11
  12 <PRIVATE
  13
  14 CONSTANT: encoding "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
  15 CONSTANT: base 32
  16 CONSTANT: 80-bits 0xFFFFFFFFFFFFFFFFFFFF
  17
  18 SYMBOL: last-time-string
  19 SYMBOL: last-random-bits
  20
  21 : encode-bits ( n chars -- string )
  22     [ base /mod encoding nth ] "" replicate-as nip reverse! ;
  23
  24 : encode-random-bits ( n -- string )
  25     16 encode-bits ;
  26
  27 : encode-time ( timestamp -- string )
  28     timestamp>millis 10 encode-bits ;
  29
  30 : same-millisecond? ( -- ? )
  31     nano-count 1,000,000 /i dup \ same-millisecond? get =
  32     [ drop t ] [ \ same-millisecond? set f ] if ;
  33
  34 : pack-bits ( seq -- seq' )
  35     5 swap [ first ] [ rest ] bi [
  36         [ ! can-take-bits overflow-byte elt
  37             pick 5 >= [
  38                 swap 5 shift bitor swap 5 - [ , 0 8 ] when-zero swap
  39             ] [
  40                 3dup rot [ shift ] [ 5 - shift ] bi-curry bi* bitor ,
  41                 nip 5 rot - [ bits 8 ] keep - swap
  42             ] if
  43         ] each 2drop
  44     ] B{ } make ;
  45
  46 TR: (normalize-ulid) "ILO" "110" ; inline
  47
  48 : (ulid) ( same-millisecond? -- ulid )
  49     [
  50         last-time-string get last-random-bits get 1 +
  51         dup 80-bits > [ ulid-overflow ] when
  52     ] [
  53         now encode-time dup last-time-string set
  54         80 random-bits
  55     ] if dup last-random-bits set encode-random-bits append ;
  56
  57 PRIVATE>
  58
  59 : ulid ( -- ulid )
  60     same-millisecond? (ulid) ;
  61
  62 ERROR: ulid>bytes-bad-length n ;
  63 M: ulid>bytes-bad-length summary drop "Invalid ULID length" ;
  64
  65 ERROR: ulid>bytes-bad-character ch ;
  66 M: ulid>bytes-bad-character summary drop "Invalid character in ULID" ;
  67
  68 ERROR: ulid>bytes-overflow ;
  69 M: ulid>bytes-overflow summary drop "Overflow error in ULID" ;
  70
  71 : ulid>bytes ( ulid -- byte-array )
  72     dup length dup 26 = [ drop ] [ ulid>bytes-bad-length ] if
  73     [
  74         dup [ >=< ] curry encoding swap search pick =
  75         [ nip ] [ drop ulid>bytes-bad-character ] if
  76     ] B{ } map-as dup first 7 > [ ulid>bytes-overflow ] when pack-bits ;
  77
  78 : normalize-ulid ( str -- str' )
  79     >upper (normalize-ulid) ;
  80
  81 ERROR: bytes>ulid-bad-length n ;
  82 M: bytes>ulid-bad-length summary drop "Invalid ULID byte-array length" ;
  83
  84 : bytes>ulid ( byte-array -- ulid )
  85     dup length dup 16 = [ drop ] [ bytes>ulid-bad-length ] if
  86     be> 26 encode-bits ;