-- |
-- Module      : Data.KindID
-- License     : MIT
-- Maintainer  : mmzk1526@outlook.com
-- Portability : GHC
--
-- IMPORTANT: In the next major release (breaking change), I will unify the
-- 'UUID' type with the one from the uuid-type package.
--
-- UUIDv7 implementation.
--
-- UUIDv7 is not currently present in the uuid package, therefore I have to
-- make a quick patch of my own.
--
-- Note that since the specification for v7 is not yet finalised, this module's
-- implementation may change in the future according to the potential
-- adjustments in the specification.
module Data.UUID.V7
  (
  -- * Data type
    UUID(..)
  , unUUID
  -- * UUID generation
  , nil
  , genUUID
  , genUUIDs
  -- * Encoding & decoding
  , parseString
  , parseText
  , parseByteString
  , toString
  , toText
  , toByteString
  -- * Miscellaneous helpers
  , getTime
  , getEpochMilli
  ) where

import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Data.Aeson.Types hiding (String)
import           Data.Array
import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Data.Bits
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BSL
import           Data.IORef
import           Data.String
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Encoding
import           Data.Time.Clock.POSIX
import           System.Entropy
import           System.IO.Unsafe (unsafePerformIO)

-- | A simple wrapper around a 'ByteString' representing a UUIDv7.
--
-- Note that the 'Show' instance is for debugging purposes only. To pretty-print
-- a 'UUID'v7, use 'toString', 'toText' or 'toByteString'.
--
-- The 'UUID' constructor will be hidden in favour of the 'Binary' instance in
-- the future.
newtype UUID = UUID ByteString
  deriving (UUID -> UUID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UUID -> UUID -> Bool
$c/= :: UUID -> UUID -> Bool
== :: UUID -> UUID -> Bool
$c== :: UUID -> UUID -> Bool
Eq, Eq UUID
UUID -> UUID -> Bool
UUID -> UUID -> Ordering
UUID -> UUID -> UUID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UUID -> UUID -> UUID
$cmin :: UUID -> UUID -> UUID
max :: UUID -> UUID -> UUID
$cmax :: UUID -> UUID -> UUID
>= :: UUID -> UUID -> Bool
$c>= :: UUID -> UUID -> Bool
> :: UUID -> UUID -> Bool
$c> :: UUID -> UUID -> Bool
<= :: UUID -> UUID -> Bool
$c<= :: UUID -> UUID -> Bool
< :: UUID -> UUID -> Bool
$c< :: UUID -> UUID -> Bool
compare :: UUID -> UUID -> Ordering
$ccompare :: UUID -> UUID -> Ordering
Ord, Int -> UUID -> ShowS
[UUID] -> ShowS
UUID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UUID] -> ShowS
$cshowList :: [UUID] -> ShowS
show :: UUID -> String
$cshow :: UUID -> String
showsPrec :: Int -> UUID -> ShowS
$cshowsPrec :: Int -> UUID -> ShowS
Show)

-- | Deprecated. Use the 'Binary' instance instead.
unUUID :: UUID -> ByteString
unUUID :: UUID -> ByteString
unUUID (UUID ByteString
bs) = ByteString
bs
{-# INLINE unUUID #-}
{-# DEPRECATED unUUID "Use the 'Binary' instance instead" #-}

instance ToJSON UUID where
  toJSON :: UUID -> Value
  toJSON :: UUID -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
toString
  {-# INLINE toJSON #-}

instance FromJSON UUID where
  parseJSON :: Value -> Parser UUID
  parseJSON :: Value -> Parser UUID
parseJSON Value
str = do
    String
s <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
str
    case String -> Maybe UUID
parseString String
s of
      Maybe UUID
Nothing   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid UUID"
      Just UUID
uuid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
uuid
  {-# INLINE parseJSON #-}

instance ToJSONKey UUID where
  toJSONKey :: ToJSONKeyFunction UUID
  toJSONKey :: ToJSONKeyFunction UUID
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText UUID -> Text
toText
  {-# INLINE toJSONKey #-}

instance FromJSONKey UUID where
  fromJSONKey :: FromJSONKeyFunction UUID
  fromJSONKey :: FromJSONKeyFunction UUID
fromJSONKey = forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser \Text
t -> case Text -> Maybe UUID
parseText Text
t of
    Maybe UUID
Nothing   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid UUID"
    Just UUID
uuid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
uuid
  {-# INLINE fromJSONKey #-}

instance Binary UUID where
  put :: UUID -> Put
  put :: UUID -> Put
put (UUID ByteString
bs) = ByteString -> Put
putLazyByteString ByteString
bs
  {-# INLINE put #-}

  get :: Get UUID
  get :: Get UUID
get = ByteString -> UUID
UUID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> Get ByteString
getLazyByteString Int64
16
  {-# INLINE get #-}

-- | Pretty-print a 'UUID'v7.
toString :: UUID -> String
toString :: UUID -> String
toString (UUID ByteString
bs)
    | ByteString -> Int64
BSL.length ByteString
bs forall a. Eq a => a -> a -> Bool
/= Int64
16 = String
"<INVALID-UUID>"
    | Bool
otherwise           = Word16 -> ShowS
word16ToHex Word16
b0
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ShowS
word16ToHex Word16
b1
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char
'-' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ShowS
word16ToHex Word16
b2)
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char
'-' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ShowS
word16ToHex Word16
b3)
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char
'-' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ShowS
word16ToHex Word16
b4)
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char
'-' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ShowS
word16ToHex Word16
b5)
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> ShowS
word16ToHex Word16
b6
                          forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
word16ToHex Word16
b7 String
""
    where
      [Word16
b0, Word16
b1, Word16
b2, Word16
b3, Word16
b4, Word16
b5, Word16
b6, Word16
b7]
        = forall a. Get a -> ByteString -> a
runGet (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 Get Word16
getWord16be) ByteString
bs
      hexTable :: Array Word16 Char
hexTable
        = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Word16
0, Word16
15) String
"0123456789abcdef"
      word16ToHex :: Word16 -> ShowS
word16ToHex Word16
w String
rem
       = let (Word16
q0, Word16
r0) = Word16
w forall a. Integral a => a -> a -> (a, a)
`divMod` Word16
16
             (Word16
q1, Word16
r1) = Word16
q0 forall a. Integral a => a -> a -> (a, a)
`divMod` Word16
16
             (Word16
q2, Word16
r2) = Word16
q1 forall a. Integral a => a -> a -> (a, a)
`divMod` Word16
16
             (Word16
q3, Word16
r3) = Word16
q2 forall a. Integral a => a -> a -> (a, a)
`divMod` Word16
16
         in  Array Word16 Char
hexTable forall i e. Ix i => Array i e -> i -> e
! Word16
r3 forall a. a -> [a] -> [a]
: Array Word16 Char
hexTable forall i e. Ix i => Array i e -> i -> e
! Word16
r2 forall a. a -> [a] -> [a]
: Array Word16 Char
hexTable forall i e. Ix i => Array i e -> i -> e
! Word16
r1 forall a. a -> [a] -> [a]
: Array Word16 Char
hexTable forall i e. Ix i => Array i e -> i -> e
! Word16
r0 forall a. a -> [a] -> [a]
: String
rem

-- | Pretty-print a 'UUID'v7 to strict 'Text'.
toText :: UUID -> Text
toText :: UUID -> Text
toText = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
toString
{-# INLINE toText #-}

-- | Pretty-print a 'UUID'v7 to lazy 'ByteString'.
toByteString :: UUID -> ByteString
toByteString :: UUID -> ByteString
toByteString = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
toString
{-# INLINE toByteString #-}

-- | Parse a 'UUID'v7 from its 'String' representation.
--
-- The representation is either standard or has no dashes. Does not care about
-- the case of the letters.
parseString :: String -> Maybe UUID
parseString :: String -> Maybe UUID
parseString = ByteString -> Maybe UUID
parseByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString
{-# INLINE parseString #-}

-- | Parse a 'UUID'v7 from its string representation as a strict 'Text'.
--
-- The representation is either standard or has no dashes. Does not care about
-- the case of the letters.
parseText :: Text -> Maybe UUID
parseText :: Text -> Maybe UUID
parseText = ByteString -> Maybe UUID
parseByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
{-# INLINE parseText #-}

-- | Parse a 'UUID'v7 from its string representation as a lazy 'ByteString'.
--
-- The representation is either standard or has no dashes. Does not care about
-- the case of the letters.
parseByteString :: ByteString -> Maybe UUID
parseByteString :: ByteString -> Maybe UUID
parseByteString ByteString
bs
  | ByteString -> Int64
BSL.length ByteString
bs forall a. Eq a => a -> a -> Bool
== Int64
32 = ByteString -> UUID
UUID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Maybe ByteString
parse Bool
False
  | ByteString -> Int64
BSL.length ByteString
bs forall a. Eq a => a -> a -> Bool
== Int64
36 = ByteString -> UUID
UUID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Maybe ByteString
parse Bool
True
  | Bool
otherwise           = forall a. Maybe a
Nothing
  where
    parse :: Bool -> Maybe ByteString
parse Bool
hasDashes    = (forall a. Get a -> ByteString -> a
`runGet` ByteString
bs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      [(Word8, Word8)]
raw1 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get Word8
getWord8 Get Word8
getWord8)
      [Word8]
seg1 <- forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (Ord b, Num b) => (b, b) -> Maybe b
readHexPair [(Word8, Word8)]
raw1
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasDashes MaybeT Get ()
checkDash
      [(Word8, Word8)]
raw2 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get Word8
getWord8 Get Word8
getWord8)
      [Word8]
seg2 <- forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (Ord b, Num b) => (b, b) -> Maybe b
readHexPair [(Word8, Word8)]
raw2
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasDashes MaybeT Get ()
checkDash
      [(Word8, Word8)]
raw3 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get Word8
getWord8 Get Word8
getWord8)
      [Word8]
seg3 <- forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (Ord b, Num b) => (b, b) -> Maybe b
readHexPair [(Word8, Word8)]
raw3
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasDashes MaybeT Get ()
checkDash
      [(Word8, Word8)]
raw4 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get Word8
getWord8 Get Word8
getWord8)
      [Word8]
seg4 <- forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (Ord b, Num b) => (b, b) -> Maybe b
readHexPair [(Word8, Word8)]
raw4
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasDashes MaybeT Get ()
checkDash
      [(Word8, Word8)]
raw5 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
6 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get Word8
getWord8 Get Word8
getWord8)
      [Word8]
seg5 <- forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {b}. (Ord b, Num b) => (b, b) -> Maybe b
readHexPair [(Word8, Word8)]
raw5
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Word8]
seg1, [Word8]
seg2, [Word8]
seg3, [Word8]
seg4, [Word8]
seg5]
    readHex :: a -> Maybe a
readHex a
w
      | a
w forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
w forall a. Ord a => a -> a -> Bool
<= a
57  = forall a. a -> Maybe a
Just (a
w forall a. Num a => a -> a -> a
- a
48)
      | a
w forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
w forall a. Ord a => a -> a -> Bool
<= a
70  = forall a. a -> Maybe a
Just (a
w forall a. Num a => a -> a -> a
- a
55)
      | a
w forall a. Ord a => a -> a -> Bool
>= a
97 Bool -> Bool -> Bool
&& a
w forall a. Ord a => a -> a -> Bool
<= a
102 = forall a. a -> Maybe a
Just (a
w forall a. Num a => a -> a -> a
- a
87)
      | Bool
otherwise           = forall a. Maybe a
Nothing
    readHexPair :: (b, b) -> Maybe b
readHexPair (b
x, b
y) = do
      b
x' <- forall {a}. (Ord a, Num a) => a -> Maybe a
readHex b
x
      b
y' <- forall {a}. (Ord a, Num a) => a -> Maybe a
readHex b
y
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
x' forall a. Num a => a -> a -> a
* b
16 forall a. Num a => a -> a -> a
+ b
y')
    checkDash :: MaybeT Get ()
checkDash          = do
      Word8
w <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word8
getWord8
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
w forall a. Eq a => a -> a -> Bool
== Word8
45)

-- | The nil 'UUID'v7.
nil :: UUID
nil :: UUID
nil = ByteString -> UUID
UUID forall a b. (a -> b) -> a -> b
$ Int64 -> Word8 -> ByteString
BSL.replicate Int64
16 Word8
0
{-# INLINE nil #-}

-- | Generate a 'UUID'v7.
genUUID :: IO UUID
genUUID :: IO UUID
genUUID = forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word16 -> IO [UUID]
genUUIDs Word16
1
{-# INLINE genUUID #-}

-- | Generate n 'UUID'v7s.
--
-- It tries its best to generate 'UUID's at the same timestamp, but it may not
-- be possible if we are asking too many 'UUID's at the same time.
--
-- It is guaranteed that the first 32768 'UUID's are generated at the same
-- timestamp.
genUUIDs :: Word16 -> IO [UUID]
genUUIDs :: Word16 -> IO [UUID]
genUUIDs Word16
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
genUUIDs Word16
n = do
  Word64
timestamp <- IO Word64
getEpochMilli
  -- We set the first bit of the entropy to 0 to ensure that there's enough
  -- room for incrementing the sequence number.
  Word16
entropy16 <- (forall a. Bits a => a -> a -> a
.&. Word16
0x7FFF) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word16
getEntropyWord16
  -- Calculate the maximum number of slots we can use for the current timestamp
  -- before the sequence number overflows.
  let getMaxSlots :: b -> b -> (b, b)
getMaxSlots b
num b
seqNo = if b
0xFFFF forall a. Num a => a -> a -> a
- b
seqNo forall a. Ord a => a -> a -> Bool
< b
num
        then (b
0xFFFF forall a. Num a => a -> a -> a
- b
seqNo, b
0xFFFF)
        else (b
num, b
seqNo forall a. Num a => a -> a -> a
+ b
num)
  -- Get the sequence number corresponding to the current timestamp and the
  -- number of UUIDs we can generate.
  (Word16
n', Word16
seqNo)  <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Word64, Word16)
__state__ forall a b. (a -> b) -> a -> b
$ \(Word64
ts, Word16
seqNo) -> if
    | Word64
ts forall a. Ord a => a -> a -> Bool
< Word64
timestamp -> let (Word16
n', Word16
entropy16') = forall {b}. (Ord b, Num b) => b -> b -> (b, b)
getMaxSlots Word16
n Word16
entropy16
                        in  ((Word64
timestamp, Word16
entropy16'), (Word16
n', Word16
entropy16 forall a. Num a => a -> a -> a
+ Word16
1))
    | Word64
ts forall a. Ord a => a -> a -> Bool
> Word64
timestamp -> ((Word64
ts, Word16
seqNo), (Word16
0, Word16
0))
    | Bool
otherwise      -> let (Word16
n', Word16
entropy16') = forall {b}. (Ord b, Num b) => b -> b -> (b, b)
getMaxSlots Word16
n Word16
seqNo
                        in  ((Word64
timestamp, Word16
entropy16'), (Word16
n', Word16
seqNo forall a. Num a => a -> a -> a
+ Word16
1))
  -- If we can't generate any UUIDs, we try again, hoping that the timestamp
  -- has changed.
  if Word16
n' forall a. Eq a => a -> a -> Bool
== Word16
0
    then Word16 -> IO [UUID]
genUUIDs Word16
n
    else do
      [UUID]
uuids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word16
0..(Word16
n' forall a. Num a => a -> a -> a
- Word16
1)] forall a b. (a -> b) -> a -> b
$ \Word16
curN -> do
        Word64
entropy64 <- IO Word64
getEntropyWord64
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> UUID
UUID forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut do
          Word64 -> Put
fillTime Word64
timestamp
          Word16 -> Put
fillVerAndRandA (Word16
seqNo forall a. Num a => a -> a -> a
+ Word16
curN)
          Word16 -> Word64 -> Put
fillVarAndRandB (Word16
seqNo forall a. Num a => a -> a -> a
+ Word16
curN) Word64
entropy64
      if Word16
n' forall a. Eq a => a -> a -> Bool
== Word16
n
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure [UUID]
uuids
        else ([UUID]
uuids forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word16 -> IO [UUID]
genUUIDs (Word16
n forall a. Num a => a -> a -> a
- Word16
n')

-- | Get the current time in milliseconds since the Unix epoch.
getEpochMilli :: IO Word64
getEpochMilli :: IO Word64
getEpochMilli = do
  POSIXTime
t <- IO POSIXTime
getPOSIXTime
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ POSIXTime
t forall a. Num a => a -> a -> a
* POSIXTime
1000
{-# INLINE getEpochMilli #-}

-- | Get the time field (unix_ts_ms) of a 'UUID'v7.
getTime :: UUID -> Word64
getTime :: UUID -> Word64
getTime (UUID ByteString
bs) = forall a. Get a -> ByteString -> a
runGet Get Word64
getWord64be ByteString
bs forall a. Bits a => a -> Int -> a
`shiftR` Int
16
{-# INLINE getTime #-}

-- | The global mutable state of (timestamp, sequence number).
--
-- The "NOINLINE" pragma is IMPORTANT! The logic would be flawed if it is
-- is inlined by its definition.
__state__ :: IORef (Word64, Word16)
__state__ :: IORef (Word64, Word16)
__state__ = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef (Word64
0, Word16
0))
{-# NOINLINE __state__ #-}

-- | Fill in the 48-bit time field (unix_ts_ms) of a 'UUID'v7 with the given
-- time.
fillTime :: Word64 -> Put
fillTime :: Word64 -> Put
fillTime Word64
timestamp = do
  let (Word16
_, Word16
p2, Word16
p1, Word16
p0) = Word64 -> (Word16, Word16, Word16, Word16)
splitWord64ToWord16s Word64
timestamp
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word16 -> Put
putWord16be [Word16
p2, Word16
p1, Word16
p0]
{-# INLINE fillTime #-}

-- | Fill in the version and rand_a part of a 'UUID'v7 with the given sequence
-- number.
--
-- The sequence number is a 16-bit integer, of which the first 12 bits are used
-- here in rand_a, and the last 4 bits are used in rand_b. The version is 7.
fillVerAndRandA :: Word16 -> Put
fillVerAndRandA :: Word16 -> Put
fillVerAndRandA Word16
seqNo = do
  let seqNoRandA :: Word16
seqNoRandA   = Word16
seqNo forall a. Bits a => a -> Int -> a
`shiftR` Int
4
  let randAWithVer :: Word16
randAWithVer = Word16
seqNoRandA forall a. Bits a => a -> a -> a
.|. (Word16
0x7 forall a. Bits a => a -> Int -> a
`shiftL` Int
12)
  Word16 -> Put
putWord16be Word16
randAWithVer
{-# INLINE fillVerAndRandA #-}

-- | Fill in the variant and rand_b part of a 'UUID'v7 with the given sequence
-- number and random number. The variant is 2.
--
-- The sequence number is a 16-bit integer, of which the last 4 bits are used
-- here in rand_b while the first 12 bits are used in rand_a.
--
-- The random number is a 64-bit integer of which the last 58 bits are used
-- while the rest are replaced by the variant bits and the last 4 bits of the
-- sequence number.
fillVarAndRandB :: Word16 -> Word64 -> Put
fillVarAndRandB :: Word16 -> Word64 -> Put
fillVarAndRandB Word16
seqNo Word64
entropy = do
  let seqNoRandB :: Word16
seqNoRandB   = Word16
seqNo forall a. Bits a => a -> a -> a
.&. Word16
0xF
  let randBWithVar :: Word64
randBWithVar = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
seqNoRandB forall a. Bits a => a -> a -> a
.|. (Word16
0x2 forall a. Bits a => a -> Int -> a
`shiftL` Int
4))
  Word64 -> Put
putWord64be forall a b. (a -> b) -> a -> b
$ (Word64
entropy forall a. Bits a => a -> a -> a
.&. Word64
0x3FFFFFFFFFFFFFF) forall a. Bits a => a -> a -> a
.|. (Word64
randBWithVar forall a. Bits a => a -> Int -> a
`shiftL` Int
58)
{-# INLINE fillVarAndRandB #-}

splitWord64ToWord16s :: Word64 -> (Word16, Word16, Word16, Word16)
splitWord64ToWord16s :: Word64 -> (Word16, Word16, Word16, Word16)
splitWord64ToWord16s Word64
n =
  let b0 :: Word16
b0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
n forall a. Bits a => a -> a -> a
.&. Word64
0xFFFF)
      b1 :: Word16
b1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
n forall a. Bits a => a -> Int -> a
`shiftR` Int
16) forall a. Bits a => a -> a -> a
.&. Word64
0xFFFF)
      b2 :: Word16
b2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
n forall a. Bits a => a -> Int -> a
`shiftR` Int
32) forall a. Bits a => a -> a -> a
.&. Word64
0xFFFF)
      b3 :: Word16
b3 = forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
n forall a. Bits a => a -> Int -> a
`shiftR` Int
48) forall a. Bits a => a -> a -> a
.&. Word64
0xFFFF)
  in (Word16
b3, Word16
b2, Word16
b1, Word16
b0)
{-# INLINE splitWord64ToWord16s #-}

getEntropyWord16 :: IO Word16
getEntropyWord16 :: IO Word16
getEntropyWord16 = do
  ByteString
bs <- ByteString -> ByteString
BSL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getEntropy Int
2
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> a
runGet Get Word16
getWord16host ByteString
bs
{-# INLINE getEntropyWord16 #-}

getEntropyWord64 :: IO Word64
getEntropyWord64 :: IO Word64
getEntropyWord64 = do
  ByteString
bs <- ByteString -> ByteString
BSL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getEntropy Int
8
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> a
runGet Get Word64
getWord64host ByteString
bs
{-# INLINE getEntropyWord64 #-}