{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Snowchecked
( newSnowcheckedGen
, nextFlake
, SnowcheckedConfig(..)
, SnowcheckedGen
, Flake
, snowcheckedConfigBitCount
, uniqueFlakeCount
) where
import Control.Concurrent.MVar
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Snowchecked.Internal.Import
import Data.Time.Clock.POSIX (getPOSIXTime)
currentTimestamp :: IO Word256
currentTimestamp :: IO Word256
currentTimestamp = POSIXTime -> Word256
toMillisWord256 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime
where
toMillisWord256 :: POSIXTime -> Word256
toMillisWord256 = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*POSIXTime
1000)
{-# INLINE currentTimestamp #-}
currentTimestampBits :: Word8 -> IO Word256
currentTimestampBits :: Word8 -> IO Word256
currentTimestampBits Word8
n =
if Word8
n forall a. Eq a => a -> a -> Bool
== Word8
0 then
forall (m :: * -> *) a. Monad m => a -> m a
return Word256
0
else
(forall a. (Num a, Bits a) => a -> Int -> a
`cutBits` forall a. Integral a => a -> Int
toInt Word8
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word256
currentTimestamp
{-# INLINE currentTimestampBits #-}
newSnowcheckedGen :: (MonadIO io) => SnowcheckedConfig -> Word256 -> io SnowcheckedGen
newSnowcheckedGen :: forall (io :: * -> *).
MonadIO io =>
SnowcheckedConfig -> Word256 -> io SnowcheckedGen
newSnowcheckedGen conf :: SnowcheckedConfig
conf@SnowcheckedConfig{Word8
confCheckBits :: SnowcheckedConfig -> Word8
confNodeBits :: SnowcheckedConfig -> Word8
confCountBits :: SnowcheckedConfig -> Word8
confTimeBits :: SnowcheckedConfig -> Word8
confCheckBits :: Word8
confNodeBits :: Word8
confCountBits :: Word8
confTimeBits :: Word8
..} Word256
nodeId = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
MVar Flake -> SnowcheckedGen
SnowcheckedGen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar Flake
{ flakeTime :: Word256
flakeTime = Word256
0
, flakeCount :: Word256
flakeCount = Word256
0
, flakeNodeId :: Word256
flakeNodeId = forall a. (Num a, Bits a) => a -> Int -> a
cutBits Word256
nodeId (forall a. Integral a => a -> Int
toInt Word8
confNodeBits)
, flakeConfig :: SnowcheckedConfig
flakeConfig = SnowcheckedConfig
conf
}
{-# INLINEABLE newSnowcheckedGen #-}
{-# SPECIALIZE newSnowcheckedGen :: SnowcheckedConfig -> Word256 -> IO SnowcheckedGen #-}
snowcheckedConfigBitCount :: SnowcheckedConfig -> Word32
snowcheckedConfigBitCount :: SnowcheckedConfig -> Word32
snowcheckedConfigBitCount SnowcheckedConfig{Word8
confCheckBits :: Word8
confNodeBits :: Word8
confCountBits :: Word8
confTimeBits :: Word8
confCheckBits :: SnowcheckedConfig -> Word8
confNodeBits :: SnowcheckedConfig -> Word8
confCountBits :: SnowcheckedConfig -> Word8
confTimeBits :: SnowcheckedConfig -> Word8
..} = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> Word32 -> Word32
foldFunc Word32
0
[ Word8
confTimeBits
, Word8
confCountBits
, Word8
confNodeBits
, Word8
confCheckBits
]
where
foldFunc :: Word8 -> Word32 -> Word32
foldFunc :: Word8 -> Word32 -> Word32
foldFunc Word8
nxt = (forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> Word32
toWord32 Word8
nxt)
{-# INLINEABLE snowcheckedConfigBitCount #-}
nextFlake :: (MonadIO io) => SnowcheckedGen -> io Flake
nextFlake :: forall (io :: * -> *). MonadIO io => SnowcheckedGen -> io Flake
nextFlake SnowcheckedGen{MVar Flake
genLastFlake :: SnowcheckedGen -> MVar Flake
genLastFlake :: MVar Flake
..} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Flake
genLastFlake Flake -> IO (Flake, Flake)
mkNextFlake
where
mkNextFlake :: Flake -> IO (Flake, Flake)
mkNextFlake flake :: Flake
flake@Flake{Word256
SnowcheckedConfig
flakeConfig :: SnowcheckedConfig
flakeNodeId :: Word256
flakeCount :: Word256
flakeTime :: Word256
flakeConfig :: Flake -> SnowcheckedConfig
flakeNodeId :: Flake -> Word256
flakeCount :: Flake -> Word256
flakeTime :: Flake -> Word256
..} =
let SnowcheckedConfig{Word8
confCheckBits :: Word8
confNodeBits :: Word8
confCountBits :: Word8
confTimeBits :: Word8
confCheckBits :: SnowcheckedConfig -> Word8
confNodeBits :: SnowcheckedConfig -> Word8
confCountBits :: SnowcheckedConfig -> Word8
confTimeBits :: SnowcheckedConfig -> Word8
..} = SnowcheckedConfig
flakeConfig in
Word8 -> IO Word256
currentTimestampBits Word8
confTimeBits forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word256
currentTimeBits ->
if Word256
flakeTime forall a. Ord a => a -> a -> Bool
< Word256
currentTimeBits then
let newFlake :: Flake
newFlake = Flake
flake {
flakeTime :: Word256
flakeTime = Word256
currentTimeBits,
flakeCount :: Word256
flakeCount = Word256
0
} in forall (m :: * -> *) a. Monad m => a -> m a
return (Flake
newFlake, Flake
newFlake)
else if Word8
confTimeBits forall a. Eq a => a -> a -> Bool
== Word8
0 then
let newFlake :: Flake
newFlake = Flake
flake
{ flakeTime :: Word256
flakeTime = Word256
0
, flakeCount :: Word256
flakeCount = Word256
flakeCount forall a. Num a => a -> a -> a
+ Word256
1
}
in forall (m :: * -> *) a. Monad m => a -> m a
return (Flake
newFlake, Flake
newFlake)
else if Word8
confCountBits forall a. Eq a => a -> a -> Bool
== Word8
0 then
let newFlake :: Flake
newFlake = Flake
flake
{ flakeTime :: Word256
flakeTime = Word256
flakeTime forall a. Num a => a -> a -> a
+ Word256
1
, flakeCount :: Word256
flakeCount = Word256
0
}
in forall (m :: * -> *) a. Monad m => a -> m a
return (Flake
newFlake, Flake
newFlake)
else
let nextCount :: Word256
nextCount = forall a. (Num a, Bits a) => a -> Int -> a
cutBits (Word256
flakeCount forall a. Num a => a -> a -> a
+ Word256
1) (forall a. Integral a => a -> Int
toInt Word8
confCountBits) in
if Word256
nextCount forall a. Eq a => a -> a -> Bool
== Word256
0 then
let newFlake :: Flake
newFlake = Flake
flake
{ flakeTime :: Word256
flakeTime = Word256
flakeTime forall a. Num a => a -> a -> a
+ Word256
1
, flakeCount :: Word256
flakeCount = Word256
0
}
in forall (m :: * -> *) a. Monad m => a -> m a
return (Flake
newFlake, Flake
newFlake)
else
let newFlake :: Flake
newFlake = Flake
flake { flakeCount :: Word256
flakeCount = Word256
nextCount }
in forall (m :: * -> *) a. Monad m => a -> m a
return (Flake
newFlake, Flake
newFlake)
{-# INLINEABLE nextFlake #-}
{-# SPECIALIZE nextFlake :: SnowcheckedGen -> IO Flake #-}
uniqueFlakeCount :: SnowcheckedConfig -> Integer
uniqueFlakeCount :: SnowcheckedConfig -> Integer
uniqueFlakeCount SnowcheckedConfig{Word8
confCheckBits :: Word8
confNodeBits :: Word8
confCountBits :: Word8
confTimeBits :: Word8
confCheckBits :: SnowcheckedConfig -> Word8
confNodeBits :: SnowcheckedConfig -> Word8
confCountBits :: SnowcheckedConfig -> Word8
confTimeBits :: SnowcheckedConfig -> Word8
..}
| Word8
confCountBits forall a. Eq a => a -> a -> Bool
== Word8
0 = Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Word8
confTimeBits
| Word8
confTimeBits forall a. Eq a => a -> a -> Bool
== Word8
0 = Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Word8
confCountBits
| Bool
otherwise = Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Word8
confCountBits forall a. Num a => a -> a -> a
* Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Word8
confTimeBits
{-# INLINE uniqueFlakeCount #-}