module Data.UUID.V7
(
UUID(..)
, unUUID
, nil
, genUUID
, genUUIDs
, parseString
, parseText
, parseByteString
, toString
, toText
, toByteString
, 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)
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)
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 #-}
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
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 #-}
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 #-}
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 #-}
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 #-}
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)
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 #-}
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 #-}
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
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
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 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')
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 #-}
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 #-}
__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 :: 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 #-}