diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Robert Fischer (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Robert Fischer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# SnowChecked + +## A Checksummed UID Generator based on Twitter's Snowflake + +Unique ids are useful, but traditional GUID/UUID formats are lengthy, inefficient, and hard for humans to use. Twitter +created a novel format for UIDs called ["Snowflake"](https://developer.twitter.com/en/docs/twitter-ids) which addressed +these issues, with the added benefit that the UIDs monotonically increase over time. +This library extends the Snowflake format by adding checksum bits at the end. If you use this library with +the number of checksum bits set to 0, then you have a Snowflake implementation. + +This extension is valuable because the checksum detects error on input. If you're using ids in a human setting +(eg: having users type them in), then the checksum is valuable to catch typos, miscommunications, and other input issues. + +Like Snowflake, this algorithm uses some bits from the timestamp, some bits from a counter, and some bits of the node id. +This algorithm extends Snowflake by also using some bits to store the checksum, which derives from the sum of the other +parts. + +This implementation allows the number of bits in the id to range from 0 bits to 255^4 bits. The default configuration uses +64 bits, with 40 bits used for time, 10 bits used for the counter, 8 bits used for the node id, and 6 bits for the checksum. +The odds of a false positive on the checksum is `1/(2^checkbits)`, so the odds of a false positive in the default configuration +is ~1.5%. This configuration can generate 1024 UIDs per millisecond per node: the 1025th request to a node for a UID in that +millisecond will cause a pause in the thread for one millisecond, and then the counter will reset to 0. (If you need more UIDs +than that, then create more generators with distinct node ids.) + +# Credit + +This project derives distantly from the [`snowfake` package on Hackage](https://hackage.haskell.org/package/snowflake). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,79 @@ +name: snowchecked +version: 0.0.0.1 +github: robertfischer/hs-snowflake-checked +license: Apache-2.0 +author: Robert Fischer +maintainer: smokejumperit@gmail.com +copyright: 2021 Robert Fischer + +extra-source-files: + - LICENSE + - README.md + - package.yaml + - stack.yaml + - stack.yaml.lock + +# Metadata used when publishing your package +synopsis: A checksummed variation on Twitter's Snowflake UID generation algorithm +category: Data + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: See the file ./README.md, which is included in the package and also on GitHub. + +dependencies: + - base >= 4.14.1.0 && < 4.15 + - bytestring >= 0.10.12.0 + - wide-word >= 0.1.1.2 + - data-default >= 0.7.1.1 + - time >= 1.9.3 + - deepseq >= 1.4.4.0 + +ghc-options: + - -Wall + - -Wcompat + - -Widentities + - -Werror=unused-do-bind + - -Werror=incomplete-record-updates + - -Werror=incomplete-uni-patterns + - -Werror=partial-fields + - -Werror=incomplete-patterns + - -Wredundant-constraints + - -Werror=missing-exported-signatures + - -Wmissed-specializations + - -Wno-unused-packages + - -Wunused-type-patterns + - -Werror=warnings-deprecations + - -Wnoncanonical-monad-instances + - -Wno-type-defaults + - -Wno-tabs + - -feager-blackholing + - -fexcess-precision + - -flate-dmd-anal + - -fmax-inline-alloc-size=1024 + - -fmax-simplifier-iterations=8 + - -fpedantic-bottoms + - -fregs-iterative + - -fsimplifier-phases=4 + - -fspec-constr-count=10 + - -fspecialise-aggressively + - -flate-specialise + - -fstatic-argument-transformation + - -fstrictness-before=3 + +library: + source-dirs: src + +tests: + test-suite: + main: Spec.hs + source-dirs: test + dependencies: + - snowchecked + - hedgehog + + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N diff --git a/snowchecked.cabal b/snowchecked.cabal new file mode 100644 --- /dev/null +++ b/snowchecked.cabal @@ -0,0 +1,71 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: snowchecked +version: 0.0.0.1 +synopsis: A checksummed variation on Twitter's Snowflake UID generation algorithm +description: See the file ./README.md, which is included in the package and also on GitHub. +category: Data +homepage: https://github.com/robertfischer/hs-snowflake-checked#readme +bug-reports: https://github.com/robertfischer/hs-snowflake-checked/issues +author: Robert Fischer +maintainer: smokejumperit@gmail.com +copyright: 2021 Robert Fischer +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + LICENSE + README.md + package.yaml + stack.yaml + stack.yaml.lock + +source-repository head + type: git + location: https://github.com/robertfischer/hs-snowflake-checked + +library + exposed-modules: + Data.Snowchecked + Data.Snowchecked.Encoding.ByteString + Data.Snowchecked.Encoding.ByteString.Lazy + Data.Snowchecked.Encoding.Class + Data.Snowchecked.Encoding.Integral + Data.Snowchecked.Internal.Import + Data.Snowchecked.Types + other-modules: + Paths_snowchecked + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Werror=unused-do-bind -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=partial-fields -Werror=incomplete-patterns -Wredundant-constraints -Werror=missing-exported-signatures -Wmissed-specializations -Wno-unused-packages -Wunused-type-patterns -Werror=warnings-deprecations -Wnoncanonical-monad-instances -Wno-type-defaults -Wno-tabs -feager-blackholing -fexcess-precision -flate-dmd-anal -fmax-inline-alloc-size=1024 -fmax-simplifier-iterations=8 -fpedantic-bottoms -fregs-iterative -fsimplifier-phases=4 -fspec-constr-count=10 -fspecialise-aggressively -flate-specialise -fstatic-argument-transformation -fstrictness-before=3 + build-depends: + base >=4.14.1.0 && <4.15 + , bytestring >=0.10.12.0 + , data-default >=0.7.1.1 + , deepseq >=1.4.4.0 + , time >=1.9.3 + , wide-word >=0.1.1.2 + default-language: Haskell2010 + +test-suite test-suite + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_snowchecked + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Werror=unused-do-bind -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=partial-fields -Werror=incomplete-patterns -Wredundant-constraints -Werror=missing-exported-signatures -Wmissed-specializations -Wno-unused-packages -Wunused-type-patterns -Werror=warnings-deprecations -Wnoncanonical-monad-instances -Wno-type-defaults -Wno-tabs -feager-blackholing -fexcess-precision -flate-dmd-anal -fmax-inline-alloc-size=1024 -fmax-simplifier-iterations=8 -fpedantic-bottoms -fregs-iterative -fsimplifier-phases=4 -fspec-constr-count=10 -fspecialise-aggressively -flate-specialise -fstatic-argument-transformation -fstrictness-before=3 -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.14.1.0 && <4.15 + , bytestring >=0.10.12.0 + , data-default >=0.7.1.1 + , deepseq >=1.4.4.0 + , hedgehog + , snowchecked + , time >=1.9.3 + , wide-word >=0.1.1.2 + default-language: Haskell2010 diff --git a/src/Data/Snowchecked.hs b/src/Data/Snowchecked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-| +Description : Unique id generator derived from Twitter's Snowflake. +License : Apache 2.0 +Maintainer : smokejumperit@gmail.com +Stability : experimental + +This generates unique (guaranteed) identifiers build from a timestamp, +counter, and node id. Identifiers are convertible to values which are +monotonically increasing with respect to time. +-} +module Data.Snowchecked +( newSnowcheckedGen +, nextFlake +, SnowcheckedConfig(..) +, SnowcheckedGen +, Flake +, snowcheckedConfigBitCount +, uniqueFlakeCount +) where + +import Control.Concurrent (threadDelay) +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 = toMillisWord256 <$> getPOSIXTime + where + toMillisWord256 = round . (*1000) +{-# INLINE currentTimestamp #-} + +currentTimestampBits :: Word8 -> IO Word256 +currentTimestampBits n = (`cutBits` fromIntegral n) <$> currentTimestamp +{-# INLINE currentTimestampBits #-} + +-- | Create a new generator. Takes a configuration and node id. +newSnowcheckedGen :: (MonadIO io) => SnowcheckedConfig -> Word256 -> io SnowcheckedGen +newSnowcheckedGen conf@SnowcheckedConfig{..} nodeId = liftIO $ do + startTimeBits <- currentTimestampBits confTimeBits + SnowcheckedGen <$> newMVar Flake + { flakeTime = startTimeBits + , flakeCount = 0 + , flakeNodeId = cutBits nodeId confNodeBits + , flakeConfig = conf + } +{-# INLINEABLE newSnowcheckedGen #-} +{-# SPECIALIZE newSnowcheckedGen :: SnowcheckedConfig -> Word256 -> IO SnowcheckedGen #-} + +snowcheckedConfigBitCount :: SnowcheckedConfig -> Word32 +snowcheckedConfigBitCount SnowcheckedConfig{..} = foldr foldFunc 0 + [ confTimeBits + , confCountBits + , confNodeBits + , confCheckBits + ] + where + foldFunc :: Word8 -> Word32 -> Word32 + foldFunc nxt memo = memo + toWord32 nxt +{-# INLINEABLE snowcheckedConfigBitCount #-} + +-- | Generates the next id. +nextFlake :: (MonadIO io) => SnowcheckedGen -> io Flake +nextFlake SnowcheckedGen{..} = liftIO $ modifyMVar genLastFlake mkNextFlake + where + -- TODO: Special case when confTimeBits is 0. + -- TODO: Track the number of flakes generated and error out if we've exhausted them. + mkNextFlake flake@Flake{..} = + let SnowcheckedConfig{..} = flakeConfig in + currentTimestampBits confTimeBits >>= \currentTimeBits -> + if flakeTime < currentTimeBits then + let newFlake = flake + { flakeTime = currentTimeBits + , flakeCount = 0 + } + in return (newFlake, newFlake) + else if confCountBits == 0 then + threadDelay 1000 >> mkNextFlake flake + else + let nextCount = cutBits (flakeCount + 1) confCountBits in + if flakeCount < nextCount then + let newFlake = flake { flakeCount = nextCount } + in return (newFlake, newFlake) + else + -- The count wrapped and we need to wait for the time to change. + -- This assumes that the next millisecond will give us a new time. + threadDelay 1000 >> mkNextFlake flake +{-# INLINEABLE nextFlake #-} +{-# SPECIALIZE nextFlake :: SnowcheckedGen -> IO Flake #-} + + +-- | Provides the count of total number of unique flakes possibly generated by this configuration. +uniqueFlakeCount :: SnowcheckedConfig -> Integer +uniqueFlakeCount SnowcheckedConfig{..} = toInteger confCountBits * toInteger confTimeBits +{-# INLINE uniqueFlakeCount #-} diff --git a/src/Data/Snowchecked/Encoding/ByteString.hs b/src/Data/Snowchecked/Encoding/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked/Encoding/ByteString.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-| + - This module provides a conversion function between a + - 'Flake' and a strict 'ByteString'. The 'ByteString' + - is the series of bytes that make up the 'Flake', with + - the lower bytes being in the lower indecies. +-} + +module Data.Snowchecked.Encoding.ByteString + ( module Data.Snowchecked.Encoding.Class + ) where + +import Data.ByteString +import Data.ByteString.Lazy (fromStrict, + toStrict) +import Data.Snowchecked.Encoding.ByteString.Lazy +import Data.Snowchecked.Encoding.Class + +instance IsFlake ByteString where + fromFlake = toStrict . fromFlake + {-# INLINE fromFlake #-} + + parseFish cfg bs = parseFish cfg $ fromStrict bs + {-# INLINE parseFish #-} diff --git a/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs b/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked/Encoding/ByteString/Lazy.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-| + - This module provides a conversion function between a + - 'Flake' and a lazy 'ByteString'. +-} + +module Data.Snowchecked.Encoding.ByteString.Lazy + ( module Data.Snowchecked.Encoding.Class + ) where + +import Data.ByteString.Lazy +import Data.Snowchecked.Encoding.Class +import Data.Snowchecked.Encoding.Integral () +import Data.Snowchecked.Internal.Import +import Prelude hiding (foldr) + +integerToBS :: Integer -> ByteString +integerToBS = pack . mkBytes + where + mkBytes 0 = mempty + mkBytes n + = fromIntegral n + : mkBytes (n `shiftR` 8) +{-# INLINE integerToBS #-} + +bsToInteger :: ByteString -> Integer +bsToInteger = foldr mkInteger 0 + where + mkInteger :: Word8 -> Integer -> Integer + mkInteger nxt memo = memo `shiftL` 8 .|. toInteger nxt +{-# INLINE bsToInteger #-} + +instance IsFlake ByteString where + fromFlake = integerToBS . fromFlake + {-# INLINE fromFlake #-} + + parseFish cfg = parseFish cfg . bsToInteger + {-# INLINE parseFish #-} diff --git a/src/Data/Snowchecked/Encoding/Class.hs b/src/Data/Snowchecked/Encoding/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked/Encoding/Class.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RecordWildCards #-} + +module Data.Snowchecked.Encoding.Class ( IsFlake(..), Flakeish(..), goodFish ) where + +import Data.Snowchecked.Internal.Import + +{-| Something that might be a 'Flake'. The fields might not be truncated + - to the appropriate size. + -} +data Flakeish = Flakeish + { fishNodeId :: Word256 + , fishCount :: Word256 + , fishTime :: Word256 + , fishCheck :: Word256 + } + +{-| Is this 'Flakeish' valid under the given 'SnowcheckedConfig' settings? -} +goodFish :: SnowcheckedConfig -> Flakeish -> Bool +goodFish SnowcheckedConfig{..} Flakeish{..} = + checkInteger == cutBits (nodeInteger + countInteger + timeInteger) confCheckBits + where + checkInteger = cutBits fishCheck confCheckBits + nodeInteger = cutBits fishNodeId confNodeBits + countInteger = cutBits fishCount confCountBits + timeInteger = cutBits fishTime confTimeBits +{-# INLINEABLE goodFish #-} + +{-| The class of things that can be generated from and to a 'Flake'. + -} +class IsFlake a where + {-# MINIMAL fromFlake, (parseFish | parseFlake) #-} + fromFlake :: Flake -> a + parseFlake :: (MonadFail m) => SnowcheckedConfig -> a -> m Flake + parseFlake cfg@SnowcheckedConfig{..} a = parseFish cfg a >>= \fish@Flakeish{..} -> + if goodFish cfg fish then + return $ Flake + { flakeTime = cutBits fishTime confTimeBits + , flakeCount = cutBits fishCount confCountBits + , flakeNodeId = cutBits fishNodeId confNodeBits + , flakeConfig = cfg + } + else + fail "Checksum is incorrect for Snowchecked flake" + + parseFish :: (MonadFail m) => SnowcheckedConfig -> a -> m Flakeish + parseFish cfg a = toFlakeish <$> parseFlake cfg a + where + toFlakeish Flake{..} = Flakeish + { fishTime = flakeTime + , fishCount = flakeCount + , fishNodeId = flakeNodeId + , fishCheck = flakeTime + flakeCount + flakeNodeId + } diff --git a/src/Data/Snowchecked/Encoding/Integral.hs b/src/Data/Snowchecked/Encoding/Integral.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked/Encoding/Integral.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-| + - This module provides a generalized conversion function between a + - 'Flake' and all members of the typeclass 'Integral'. It is specialized + - for the 'Integer', 'Word32', and 'Word64' types. It is marked as + - incoherent due to the constraint being no smaller than the instance type, + - so it is undecidable. +-} + +module Data.Snowchecked.Encoding.Integral + ( module Data.Snowchecked.Encoding.Class + ) where + +import Data.Snowchecked.Encoding.Class +import Data.Snowchecked.Internal.Import + +instance {-# INCOHERENT #-} (Integral a) => IsFlake a where + fromFlake Flake{..} = fromInteger + $ cutBits checkInteger checkBitsInteger + .|. cutShiftBits nodeIdInteger nodeBitsInteger checkBitsInteger + .|. cutShiftBits countInteger countBitsInteger (checkBitsInteger + nodeBitsInteger) + .|. cutShiftBits timeInteger timeBitsInteger (checkBitsInteger + nodeBitsInteger + countBitsInteger) + where + SnowcheckedConfig{..} = flakeConfig + checkBitsInteger = toInteger confCheckBits + nodeBitsInteger = toInteger confNodeBits + timeBitsInteger = toInteger confTimeBits + countBitsInteger = toInteger confCountBits + nodeIdInteger = toInteger flakeNodeId + timeInteger = toInteger flakeTime + countInteger = toInteger flakeCount + checkInteger = nodeIdInteger + timeInteger + countInteger + {-# INLINEABLE fromFlake #-} + + parseFish SnowcheckedConfig{..} i = return $ Flakeish + { fishCheck = fromIntegral $ cutBits n checkBitsInteger + , fishNodeId = fromIntegral $ shiftCutBits n checkBitsInteger nodeBitsInteger + , fishCount = fromIntegral $ shiftCutBits n (checkBitsInteger + nodeBitsInteger) countBitsInteger + , fishTime = fromIntegral $ shiftCutBits n (checkBitsInteger + nodeBitsInteger + countBitsInteger) timeBitsInteger + } + where + n = toInteger i + checkBitsInteger = toInteger confCheckBits + nodeBitsInteger = toInteger confNodeBits + timeBitsInteger = toInteger confTimeBits + countBitsInteger = toInteger confCountBits + {-# INLINE parseFish #-} diff --git a/src/Data/Snowchecked/Internal/Import.hs b/src/Data/Snowchecked/Internal/Import.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked/Internal/Import.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeApplications #-} +module Data.Snowchecked.Internal.Import + ( module Data.Snowchecked.Internal.Import + , module Data.Snowchecked.Types + , module Data.Bits + , module Data.WideWord.Word256 + , module Data.Word + , module Numeric + ) where + +import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) +import Data.Snowchecked.Types +import Data.WideWord.Word256 +import Data.Word +import Numeric + +cutBits :: (Num a, Bits a, Integral bitCount) => a -> bitCount -> a +cutBits n bits = n .&. ((1 `shiftL` fromIntegral bits) - 1) +{-# INLINE cutBits #-} + +cutShiftBits :: (Num a, Bits a, Integral cutBitCount, Integral shiftBitCount) => a -> cutBitCount -> shiftBitCount -> a +cutShiftBits n cutBitCount shiftBitCount = cutBits n cutBitCount `shiftL` fromIntegral shiftBitCount +{-# INLINE cutShiftBits #-} + +shiftCutBits :: (Num a, Bits a, Integral cutBitCount, Integral shiftBitCount) => a -> shiftBitCount -> cutBitCount -> a +shiftCutBits n shiftBitCount = cutBits $ n `shiftR` fromIntegral shiftBitCount +{-# INLINE shiftCutBits #-} + +toInt :: (Integral a) => a -> Int +toInt = fromIntegral @_ @Int +{-# INLINE toInt #-} + +toWord8 :: (Integral a) => a -> Word8 +toWord8 = fromIntegral @_ @Word8 +{-# INLINE toWord8 #-} + +toWord32 :: (Integral a) => a -> Word32 +toWord32 = fromIntegral @_ @Word32 +{-# INLINE toWord32 #-} diff --git a/src/Data/Snowchecked/Types.hs b/src/Data/Snowchecked/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Snowchecked/Types.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} +{-| +Description : Types for the Data.Snowchecked module +License : Apache 2.0 +Maintainer : smokejumperit@gmail.com +Stability : experimental + +This module is internal, subject to breaking changes without a major version increment, +and therefore should only be imported by Data.Snowchecked. +-} +module Data.Snowchecked.Types + ( module Data.Snowchecked.Types ) + where + +import Control.Concurrent.MVar +import Control.DeepSeq (NFData) +import Data.Default +import Data.WideWord.Word256 +import Data.Word +import GHC.Generics (Generic) + +{-| +Configuration that specifies how much bits are used for each part of the id. +These values are not validated and may be any legal value for the type. + +The default value provided by 'def' is 64 bits in total length, just like +the original Snowflake algorithm. However, 4 bits are taken from the count +bits and used for check bits. Note that specifying 0 check bits results in +the normal snowflake generation. +-} +data SnowcheckedConfig = SnowcheckedConfig + { confTimeBits :: Word8 -- ^ Number of bits used to hold the time + , confCountBits :: Word8 -- ^ Number of bits used to count instances per-time + , confNodeBits :: Word8 -- ^ Number of bits derived from the node id + , confCheckBits :: Word8 -- ^ Number of bits used to store the checksum + } deriving (Eq, Show, Generic) + +instance NFData SnowcheckedConfig + +instance Default SnowcheckedConfig where + {-| A configuration using 40 bits for time, 10 bits for count, 8 bits for node id, + - and 6 bits for the checksum. + -} + def = SnowcheckedConfig + { confTimeBits = 40 + , confCountBits = 10 + , confNodeBits = 8 + , confCheckBits = 6 + } + +{-| The state that needs to be communicated between flake generation calls. + - This should not be accessed or created directly by consumers of this library: + - doing so may cause your code to hang indefinitely. + -} +newtype SnowcheckedGen = SnowcheckedGen { genLastFlake :: MVar Flake } + +{-| The state of a given generated instance. Note that the actual value is calculated on demand. -} +data Flake = Flake + { flakeTime :: Word256 -- ^ The bit-truncated time + , flakeCount :: Word256 -- ^ The bit-truncated count + , flakeNodeId :: Word256 -- ^ The bit-truncated node id + , flakeConfig :: SnowcheckedConfig -- ^ The configuration used to create the flake. + } deriving (Eq,Show,Generic) + +instance NFData Flake diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-18.5 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: + - . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 585817 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml + sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887 + original: lts-18.5 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +import Control.Monad (unless, void) +import Control.Monad.IO.Class (MonadIO) +import Data.List (nub) +import Data.Snowchecked +import Data.WideWord.Word256 +import Data.Word +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Main (defaultMain) +import qualified Hedgehog.Range as Range + +main :: IO () +main = do + recheck (Size 4) (Seed 14462958355020818941 14776761114051845121) prop_generatesUniqueValues + recheck (Size 8) (Seed 11763301661976410488 14055395789257366631) prop_generatesUniqueValues + recheck (Size 14) (Seed 6771904241892528611 8532317410904456029) prop_generatesUniqueValues + recheck (Size 14) (Seed 4790609826115340731 8375105224114527375) prop_generatesUniqueValues + defaultMain [ checkParallel $$(discover) ] + +genWord8 :: (MonadGen m) => m Word8 +genWord8 = Gen.word8 $ Range.linear (minBound @Word8) (maxBound @Word8) + +genWord256 :: (MonadGen m) => m Word256 +genWord256 = Gen.integral $ Range.linear (minBound @Word256) (maxBound @Word256) + +genConfig :: (MonadGen m) => m SnowcheckedConfig +genConfig = SnowcheckedConfig + <$> Gen.integral (Range.linear 2 (maxBound @Word8)) + <*> Gen.integral (Range.linear 2 (maxBound @Word8)) + <*> Gen.integral (Range.linear 2 (maxBound @Word8)) + <*> Gen.integral (Range.linear 2 (maxBound @Word8)) + +forAllFlake :: (MonadIO m) => PropertyT m Flake +forAllFlake = forAll genConfig >>= forAllFlake' + +forAllFlake' :: (MonadIO m) => SnowcheckedConfig -> PropertyT m Flake +forAllFlake' cfg = do + nodeId <- forAll genWord256 + newSnowcheckedGen cfg nodeId >>= nextFlake + +prop_generatesUniqueValues :: Property +prop_generatesUniqueValues = property $ do + lst <- forAll $ Gen.list (Range.linear 2 8192) (return ()) + cfg <- forAll genConfig + unless ( uniqueFlakeCount cfg > toInteger (length lst) ) discard + nodeId <- forAll genWord256 + flakeGen <- newSnowcheckedGen cfg nodeId + resultLst <- mapM (\_ -> nextFlake flakeGen) lst + resultLst === nub resultLst + +prop_roundTripIntegral :: Property +prop_roundTripIntegral = property $ do + cfg <- forAll genConfig + flake <- forAllFlake' cfg + result <- parseFlake cfg $ flakeToIntegral @Integer flake + flake === result + +prop_flakeCanBeNFed :: Property +prop_flakeCanBeNFed = property $ do + flake <- forAllFlake + void $ evalNF flake