module Data.UUID.V7
(
UUID
, 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 Data.UUID.Versions
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
{-# INLINE genUUID' #-}
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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip UUID -> UUIDVersion -> Bool
validateWithVersion UUIDVersion
V7
{-# 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 #-}