module Data.UUID.V7
(
UUID
, nil
, genUUID
, genUUID'
, genUUIDs
, validate
, validateWithTime
, getTime
, getEpochMilli
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import qualified Data.ByteString.Lazy as BSL
import Data.IORef
import Data.Time.Clock.POSIX
import Data.UUID.Types.Internal
import System.Entropy
import System.IO.Unsafe (unsafePerformIO)
genUUID :: MonadIO m => m UUID
genUUID :: forall (m :: * -> *). MonadIO m => m UUID
genUUID = forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Word16 -> m [UUID]
genUUIDs Word16
1
{-# INLINE genUUID #-}
genUUID' :: MonadIO m => m UUID
genUUID' :: forall (m :: * -> *). MonadIO m => m UUID
genUUID' = do
Word64
timestamp <- forall (m :: * -> *). MonadIO m => m Word64
getEpochMilli
Word16
entropy16 <- forall (m :: * -> *). MonadIO m => m Word16
getEntropyWord16
Word64
entropy64 <- forall (m :: * -> *). MonadIO m => m Word64
getEntropyWord64
let bs :: ByteString
bs = Put -> ByteString
runPut do
Word64 -> Put
fillTime Word64
timestamp
Word16 -> Put
fillVerAndRandA Word16
entropy16
Word16 -> Word64 -> Put
fillVarAndRandB Word16
entropy16 Word64
entropy64
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> Word64 -> UUID
UUID forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> a
runGet (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)) Get Word64
getWord64be) ByteString
bs
genUUIDs :: MonadIO m => Word16 -> m [UUID]
genUUIDs :: forall (m :: * -> *). MonadIO m => Word16 -> m [UUID]
genUUIDs Word16
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
genUUIDs Word16
n = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
Word64
timestamp <- forall (m :: * -> *). MonadIO m => m Word64
getEpochMilli
Word16
entropy16 <- (forall a. Bits a => a -> a -> a
.&. Word16
0x7FFF) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m Word16
getEntropyWord16
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)
(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 Word16
n' forall a. Eq a => a -> a -> Bool
== Word16
0
then forall (m :: * -> *). MonadIO m => Word16 -> m [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 <- forall (m :: * -> *). MonadIO m => m Word64
getEntropyWord64
let bs :: ByteString
bs = 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> Word64 -> UUID
UUID forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> a
runGet (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)) Get Word64
getWord64be) ByteString
bs
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
<$> forall (m :: * -> *). MonadIO m => Word16 -> m [UUID]
genUUIDs (Word16
n forall a. Num a => a -> a -> a
- Word16
n')
validate :: UUID -> Bool
validate :: UUID -> Bool
validate (UUID Word64
w1 Word64
w2)
= (Word64
w1 forall a. Bits a => a -> Int -> a
`shiftR` Int
12) forall a. Bits a => a -> a -> a
.&. Word64
0xF forall a. Eq a => a -> a -> Bool
== Word64
0x7 Bool -> Bool -> Bool
&& (Word64
w2 forall a. Bits a => a -> Int -> a
`shiftR` Int
62) forall a. Bits a => a -> a -> a
.&. Word64
0x3 forall a. Eq a => a -> a -> Bool
== Word64
0x2
{-# INLINE validate #-}
validateWithTime :: MonadIO m => UUID -> m Bool
validateWithTime :: forall (m :: * -> *). MonadIO m => UUID -> m Bool
validateWithTime UUID
uuid = do
Word64
curTime <- forall (m :: * -> *). MonadIO m => m Word64
getEpochMilli
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ UUID -> Bool
validate UUID
uuid Bool -> Bool -> Bool
&& (UUID -> Word64
getTime UUID
uuid forall a. Ord a => a -> a -> Bool
<= Word64
curTime)
{-# INLINE validateWithTime #-}
getEpochMilli :: MonadIO m => m Word64
getEpochMilli :: forall (m :: * -> *). MonadIO m => m Word64
getEpochMilli = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
POSIXTime
t <- IO POSIXTime
getPOSIXTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 #-}
getTime :: UUID -> Word64
getTime :: UUID -> Word64
getTime (UUID Word64
w1 Word64
_) = Word64
w1 forall a. Bits a => a -> Int -> a
`shiftR` Int
16
{-# INLINE getTime #-}
__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__ #-}
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 #-}
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 #-}
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 :: MonadIO m => m Word16
getEntropyWord16 :: forall (m :: * -> *). MonadIO m => m Word16
getEntropyWord16 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: MonadIO m => m Word64
getEntropyWord64 :: forall (m :: * -> *). MonadIO m => m Word64
getEntropyWord64 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 #-}