87 lines
2.5 KiB
Factor
87 lines
2.5 KiB
Factor
! Copyright (C) 2018, 2019 Alexander Ilin.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: ascii binary-search calendar io.binary kernel make math
|
|
math.bitwise math.order namespaces random sequences splitting
|
|
summary system tr ;
|
|
|
|
IN: ulid
|
|
|
|
ERROR: ulid-overflow ;
|
|
M: ulid-overflow summary drop "Too many ULIDs generated per msec" ;
|
|
|
|
<PRIVATE
|
|
|
|
CONSTANT: encoding "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
|
|
CONSTANT: base 32
|
|
CONSTANT: 80-bits 0xFFFFFFFFFFFFFFFFFFFF
|
|
|
|
SYMBOL: last-time-string
|
|
SYMBOL: last-random-bits
|
|
|
|
: encode-bits ( n chars -- string )
|
|
[ base /mod encoding nth ] "" replicate-as nip reverse! ;
|
|
|
|
: encode-random-bits ( n -- string )
|
|
16 encode-bits ;
|
|
|
|
: encode-time ( timestamp -- string )
|
|
timestamp>millis 10 encode-bits ;
|
|
|
|
: same-msec? ( -- ? )
|
|
nano-count 1000 /i dup \ same-msec? get =
|
|
[ drop t ] [ \ same-msec? set f ] if ;
|
|
|
|
: pack-bits ( seq -- seq' )
|
|
5 swap [ first ] [ rest ] bi [
|
|
[ ! can-take-bits overflow-byte elt
|
|
pick 5 >= [
|
|
swap 5 shift bitor swap 5 - [ , 0 8 ] when-zero swap
|
|
] [
|
|
3dup rot [ shift ] [ 5 - shift ] bi-curry bi* bitor ,
|
|
nip 5 rot - [ bits 8 ] keep - swap
|
|
] if
|
|
] each 2drop
|
|
] B{ } make ;
|
|
|
|
TR: (normalize-ulid) "ILO" "110" ; inline
|
|
|
|
: (ulid) ( same-msec? -- ulid )
|
|
[
|
|
last-time-string get last-random-bits get 1 +
|
|
dup 80-bits > [ ulid-overflow ] when
|
|
] [
|
|
now encode-time dup last-time-string set
|
|
80 random-bits
|
|
] if dup last-random-bits set encode-random-bits append ;
|
|
|
|
PRIVATE>
|
|
|
|
: ulid ( -- ulid )
|
|
same-msec? (ulid) ;
|
|
|
|
ERROR: ulid>bytes-bad-length n ;
|
|
M: ulid>bytes-bad-length summary drop "Invalid ULID length" ;
|
|
|
|
ERROR: ulid>bytes-bad-character ch ;
|
|
M: ulid>bytes-bad-character summary drop "Invalid character in ULID" ;
|
|
|
|
ERROR: ulid>bytes-overflow ;
|
|
M: ulid>bytes-overflow summary drop "Overflow error in ULID" ;
|
|
|
|
: ulid>bytes ( ulid -- byte-array )
|
|
dup length dup 26 = [ drop ] [ ulid>bytes-bad-length ] if
|
|
[
|
|
dup [ >=< ] curry encoding swap search pick =
|
|
[ nip ] [ drop ulid>bytes-bad-character ] if
|
|
] B{ } map-as dup first 7 > [ ulid>bytes-overflow ] when pack-bits ;
|
|
|
|
: normalize-ulid ( str -- str' )
|
|
>upper (normalize-ulid) ;
|
|
|
|
ERROR: bytes>ulid-bad-length n ;
|
|
M: bytes>ulid-bad-length summary drop "Invalid ULID byte-array length" ;
|
|
|
|
: bytes>ulid ( byte-array -- ulid )
|
|
dup length dup 16 = [ drop ] [ bytes>ulid-bad-length ] if
|
|
be> 26 encode-bits ;
|