diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,15 @@ -# hscuid [![Build Status](https://travis-ci.org/eightyeight/hscuid.svg?branch=master)](https://travis-ci.org/eightyeight/hscuid) +# hscuid +[![Build Status](https://img.shields.io/travis/crabmusket/hscuid/master.svg?label=tests)](https://travis-ci.org/crabmusket/hscuid) +[![Hackage](https://img.shields.io/hackage/v/hscuid.svg)](https://hackage.haskell.org/package/hscuid) + A Haskell port of the [JavaScript library][cuid] for collision-resistant identifiers. To install, [`cabal install hscuid`][hscuid]. ## What is a CUID? CUIDs are short random strings designed so that you can generate a lot of them over many different machines and not get collisions. -They are designed to be usable in many situations, such as HTML element IDs. +They are intended to be usable in situations from HTML element IDs to database keys. You can read more about them at [usecuid.org][]. ## How do I use this library? @@ -19,7 +22,30 @@ "y900001wmf" ``` +## Developing + +I am currently developing with [stack][]. +To install dependencies and compile the library and test suites: + +```sh +stack build +``` + +To run the collision test suite (which generates 1.2M IDs and makes sure they're all unique): + +```sh +stack test +``` + +To test performance with [criterion][]: + +```sh +stack exec perf-test -- --regress allocated:iters +RTS -T +``` + [cuid]: https://github.com/ericelliott/cuid [hscuid]: https://hackage.haskell.org/package/hscuid [semver]: http://semver.org [usecuid.org]: https://usecuid.org +[criterion]: https://hackage.haskell.org/package/criterion +[stack]: https://haskellstack.org diff --git a/hscuid.cabal b/hscuid.cabal --- a/hscuid.cabal +++ b/hscuid.cabal @@ -2,37 +2,44 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hscuid -version: 1.2.0.0 +version: 1.2.0.1 synopsis: Collision-resistant IDs description: See README (link below). -homepage: https://github.com/eightyeight/hscuid +homepage: https://github.com/crabmusket/hscuid license: BSD3 license-file: LICENSE author: Daniel Buckmaster maintainer: dan.buckmaster@gmail.com --- copyright: category: Web build-type: Simple -cabal-version: >=1.8 +cabal-version: >= 1.8 extra-source-files: README.md +tested-with: GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.1 + , GHC == 8.0.2 +source-repository head + type: git + location: git://github.com/crabmusket/hscuid.git + library hs-source-dirs: lib exposed-modules: Web.Cuid - other-modules: Web.Cuid.Internal + other-modules: Web.Cuid.Internal Web.Cuid.Internal.Formatting build-depends: base >= 4.6 && < 5, - formatting >= 6.2, time >= 1.4, random >= 1.0, transformers >= 0.4, hostname >= 1.0, + mwc-random >= 0.13, text >= 1.2 if os(windows) build-depends: Win32 >= 2.3 extra-libraries: kernel32 else build-depends: unix >= 2.6 - ghc-options: -Wall + ghc-options: -Wall -O2 test-suite hscuid-test type: exitcode-stdio-1.0 @@ -40,5 +47,20 @@ main-is: Test.hs build-depends: base >= 4.6 && < 5, containers ==0.5.*, + text >= 1.2, hscuid + ghc-options: -Wall -rtsopts -O2 + +executable perf-test + hs-source-dirs: test + main-is: Perf.hs + build-depends: base >= 4.6 && < 5, + hscuid + if impl(ghc < 7.8) + -- We cannot use criterion >= 1.1.1 with GHC 7.6 because of its dependency + -- on js-jquery, which requires Cabal library >= 1.18. + -- See https://github.com/crabmusket/hscuid/pull/5#issuecomment-294654898 + build-depends: criterion >= 1.1 && < 1.1.1 + else + build-depends: criterion >= 1.1 ghc-options: -Wall -rtsopts -O2 diff --git a/lib/Web/Cuid.hs b/lib/Web/Cuid.hs --- a/lib/Web/Cuid.hs +++ b/lib/Web/Cuid.hs @@ -16,11 +16,9 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.String (fromString) import Data.Text (Text) -import Formatting (sformat) -import Data.Monoid (Monoid, (<>)) #if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mconcat) +import Data.Monoid (Monoid, mconcat) #endif import Web.Cuid.Internal @@ -37,19 +35,17 @@ -- The second chunk is the timestamp. Note that this means it is possible -- to determine the time a particular CUID was created. - time = liftM (sformat number) getTimestamp + time = liftM formatNumber getTimestamp - -- To avoid collisions on the same machine, add a global counter to each ID. - count = liftM (sformat numberPadded) getNextCount + -- To avoid collisions in the same process, add a global counter to each ID. + count = liftM formatPadded getNextCount -- To avoid collisions between separate machines, generate a 'fingerprint' -- from details which are hopefully unique to this machine - PID and hostname. - fingerprint = do - (pid, host) <- getFingerprint - return (sformat twoOfNum pid <> sformat twoOfNum host) + fingerprint = return myFingerprint -- And some actual randomness for good measure. - random = liftM (sformat numberPadded) getRandomValue + random = liftM formatPadded getRandomValue -- | A Slug is not a Cuid. But it is also a strict Text. type Slug = Text @@ -58,12 +54,10 @@ -- techniques as CUIDs. newSlug :: MonadIO m => m Slug newSlug = concatResults [time, count, fingerprint, random] where - time = liftM (sformat twoOfNum) getTimestamp - count = liftM (sformat numberPadded) getNextCount - random = liftM (sformat twoOfNum) getRandomValue - fingerprint = do - (pid, host) <- getFingerprint - return (sformat firstOfNum pid <> sformat lastOfNum host) + time = liftM formatShort getTimestamp + count = liftM formatPadded getNextCount + random = liftM formatShort getRandomValue + fingerprint = return myFingerprint -- Evaluate IO actions and concatenate their results. concatResults :: (MonadIO m, Monoid a) => [IO a] -> m a diff --git a/lib/Web/Cuid/Internal.hs b/lib/Web/Cuid/Internal.hs --- a/lib/Web/Cuid/Internal.hs +++ b/lib/Web/Cuid/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} {-| Stability: unstable @@ -6,18 +6,22 @@ Contains internal implementation details for CUIDs. -} -module Web.Cuid.Internal where +module Web.Cuid.Internal ( + formatNumber, formatPadded, formatShort, + getNextCount, getRandomValue, getTimestamp, myFingerprint +) where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Char (ord) import Data.IORef (IORef, newIORef, atomicModifyIORef') -import Data.Text (Text) +import Data.Text (Text, append) import Data.Time.Clock.POSIX (getPOSIXTime) -import Formatting (Format, base, fitLeft, fitRight, left, (%.)) import Network.HostName (getHostName) import System.IO.Unsafe (unsafePerformIO) -import System.Random (randomRIO) +import System.Random.MWC (GenIO) +import qualified System.Random.MWC as MWC +import Web.Cuid.Internal.Formatting #if defined(mingw32_HOST_OS) import System.Win32 (ProcessId, failIfZero) @@ -25,6 +29,11 @@ import System.Posix.Process (getProcessID) #endif +-- | maxCount is derived from the output format and defines the maximum random +-- number we should generate. +maxCount :: Int +maxCount = formatBase ^ blockSize + -- | A machine's fingerprint is derived from its PID and hostname. We do some -- maths on the hostname's contents to boil it down to a single integer instead -- of exposing a string. @@ -35,16 +44,31 @@ let hostSum = 36 + length hostname + sum (map ord hostname) return (pid, hostSum) --- | Just get a random integer. Not referentially transparent. +-- | For efficiency, calculate the fingerptint and format it once. +myFingerprint :: Text +myFingerprint = unsafePerformIO $ do + (pid, host) <- getFingerprint + return (formatShort pid `append` formatShort host) +-- This ensures the action should only be evaluated once, rather than being +-- inlined and potentially evaluated inside another call. +{-# NOINLINE myFingerprint #-} + +-- | Global random number generator. +generator :: GenIO +generator = unsafePerformIO MWC.create +-- Don't want two different generators being created because of inlining. +-- For more info: https://wiki.haskell.org/Top_level_mutable_state +{-# NOINLINE generator #-} + +-- | Just get a random integer. getRandomValue :: IO Int -getRandomValue = randomRIO (0, maxCount) +getRandomValue = MWC.uniformR (0, maxCount) generator -- | CUID calls for a globally incrementing counter per machine. This is ugly, -- but it satisfies the requirement. counter :: IORef Int counter = unsafePerformIO (newIORef 0) -- Don't want two different counters being created because of inlining. --- For more info: https://wiki.haskell.org/Top_level_mutable_state {-# NOINLINE counter #-} -- | Get the next value of the global counter required for CUID. @@ -55,20 +79,6 @@ postIncrement :: MonadIO m => IORef Int -> m Int postIncrement c = liftIO (atomicModifyIORef' c incrementAndWrap) where incrementAndWrap count = (succ count `mod` maxCount, count) - --- | These constants are to do with number formatting. -formatBase, blockSize, maxCount :: Int -formatBase = 36 -blockSize = 4 -maxCount = formatBase ^ blockSize - --- | Number formatters for converting to the correct base and padding. -number, numberPadded, twoOfNum, firstOfNum, lastOfNum :: Format Text (Int -> Text) -number = base formatBase -numberPadded = left blockSize '0' %. number -twoOfNum = fitRight 2 %. number -lastOfNum = fitRight 1 %. number -firstOfNum = fitLeft 1 %. number -- | Get the current UNIX time in milliseconds. getTimestamp :: IO Int diff --git a/lib/Web/Cuid/Internal/Formatting.hs b/lib/Web/Cuid/Internal/Formatting.hs new file mode 100644 --- /dev/null +++ b/lib/Web/Cuid/Internal/Formatting.hs @@ -0,0 +1,88 @@ +{-| +Stability: unstable +Portability: portable + +Contains low-level number-formatting functions for CUIDs. +-} +module Web.Cuid.Internal.Formatting ( + blockSize, formatBase, + formatNumber, formatPadded, formatShort +) where + +import Data.Text (Text) +import qualified Data.Text as T + +-- | These constants are to do with the desired output formatting of numbers in +-- the CUID. +formatBase, blockSize :: Int +formatBase = 36 +blockSize = 4 + +-- | Expresses the given number as a list of digits in the given base. The +-- "digits" are just integers. The first element of the list is the most +-- significant digit and the last element is the least significant. +-- +-- > digitsInBase 10 1234 = [1, 2, 3, 4] +-- > digitsInBase 16 1234 = [4, 13, 2] -- "0x4D2" in the usual notation +digitsInBase :: Integral a => a -> a -> [a] +digitsInBase base' n' = go base' n' [] + where go base n accum + | n == 0 = if null accum then [0] else accum + | n < base = [n] ++ accum + | otherwise = go base q ([r] ++ accum) + where (q, r) = quotRem n base + +-- | Converts a single integer to a textual digit. The integer can be any value +-- between 0 and 35, inclusive; the numbers 10 through 35 are converted to the +-- lowercase letters "a" through "z". +numberToDigit :: Integral a => a -> Char +numberToDigit n_ + | n < 0 = error "numberToDigit: input is negative" + | n < 10 = toEnum (n + 48) + | n < 36 = toEnum (n + 97 - 10) + | otherwise = error "numberToDigit: input is too large" + where n = fromIntegral n_ + +-- | Returns the textual representation of the given integer in the given base. +-- +-- > formatInBase 10 999 = "999" +-- > formatInBase 16 999 = "3e7" +-- > formatInBase 36 999 = "rr" +formatInBase :: Integral a => a -> a -> Text +formatInBase base n = T.pack $ map numberToDigit $ digitsInBase base n + +-- | Returns the textual representation of the given integer in the given base, +-- padded on the left with zeroes so that the string is /at least/ the given +-- number of digits long. +-- +-- > formatPaddedInBase 10 3 1 = "001" +-- > formatPaddedInBase 10 3 12 = "012" +-- > formatPaddedInBase 10 3 123 = "123" +-- > formatPaddedInBase 10 3 1234 = "1234" +formatPaddedInBase :: Integral a => a -> a -> a -> Text +formatPaddedInBase base d n = T.justifyRight digits '0' $ formatInBase base n + where digits = fromIntegral d + +-- | Returns the textual representation of the first (i.e. most significant) two +-- digits of the given integer in the given base. If the number is only one +-- digit long then the resulting Text will be only one character long. +-- +-- > formatShortInBase 10 8 = "8" +-- > formatShortInBase 10 86 = "86" +-- > formatShortInBase 10 867 = "86" +formatShortInBase :: Integral a => a -> a -> Text +formatShortInBase base n = T.take 2 $ formatInBase base n + +-- | 'formatInBase' specialized to use the application's value of 'formatBase'. +formatNumber :: Int -> Text +formatNumber = formatInBase formatBase + +-- | 'formatPaddedInBase' specialized to use the application's values of +-- 'formatBase' and 'blockSize'. +formatPadded :: Int -> Text +formatPadded = formatPaddedInBase formatBase blockSize + +-- | 'formatShortInBase' specialized to use the application's value of +-- 'formatBase'. +formatShort :: Int -> Text +formatShort = formatShortInBase formatBase diff --git a/test/Perf.hs b/test/Perf.hs new file mode 100644 --- /dev/null +++ b/test/Perf.hs @@ -0,0 +1,8 @@ +import qualified Criterion.Main as C +import Web.Cuid (newCuid, newSlug) + +main :: IO () +main = C.defaultMain + [ C.bench "newCuid" $ C.nfIO newCuid + , C.bench "newSlug" $ C.nfIO newSlug + ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,28 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Control.Monad (foldM, when) import Data.Set (empty, insert, size) +import Data.Text (Text, append) +import qualified Data.Text.IO import System.Exit (ExitCode(..), exitWith) import Web.Cuid (Cuid, newCuid, newSlug) main :: IO () main = do - nCuid <- runCollisionTest newCuid 1200000 - nSlug <- runCollisionTest newSlug 1200000 - case (nCuid, nSlug) of - (0, 0) -> exitWith ExitSuccess + putStrLn "" + putTxtLn . (append "example cuid: ") =<< newCuid + putTxtLn . (append "example slug: ") =<< newSlug + putStrLn "Running collision test..." + cuidCollisions <- runCollisionTest newCuid 1200000 + slugCollisions <- runCollisionTest newSlug 1200000 + case (cuidCollisions, slugCollisions) of + (0, 0) -> do + putStrLn "Collision test passed" + exitWith ExitSuccess _otherwise -> do - when (nCuid /= 0) $ print ("cuid collisions: " ++ show nCuid) - when (nSlug /= 0) $ print ("slug collisions: " ++ show nSlug) + putStrLn "Collision test failed" + when (cuidCollisions /= 0) $ print ("cuid collisions: " ++ show cuidCollisions) + when (slugCollisions /= 0) $ print ("slug collisions: " ++ show slugCollisions) exitWith (ExitFailure 1) +-- We test the CUID generator by generating a lot of ids and putting them into +-- a huge set. Since sets retain only unique elements, the size of the set will +-- equal the number of CUIDs generated iff they were all unique. runCollisionTest :: IO Cuid -> Int -> IO Int -runCollisionTest action numberOfCuids = do - let accumulate set _i = do - cuid <- action - return $! insert cuid set - -- Generate a set containing a bunch of generated CUIDs. - set <- foldM accumulate empty [0 .. numberOfCuids - 1] - -- If every element was unique, the set will have the same size as the input. - return (numberOfCuids - size set) +runCollisionTest generator inputSize = do + set <- foldM build empty [0 .. inputSize - 1] + return (inputSize - size set) + where + build set _i = do + cid <- generator + return $! insert cid set + +putTxtLn :: Text -> IO () +putTxtLn = Data.Text.IO.putStrLn