diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,28 @@ -The MIT License (MIT) +Copyright (c) 2015, Daniel Buckmaster. -Copyright (c) 2015 Daniel Buckmaster +All rights reserved. -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. + 1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. + 2. 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. + + 3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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/hscuid.cabal b/hscuid.cabal --- a/hscuid.cabal +++ b/hscuid.cabal @@ -2,12 +2,32 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hscuid -version: 1.0.0 +version: 1.1.0 synopsis: Collision-resistant IDs description: CUIDs are designed for horizontal scalability and collision - resistance. Read more about them at . + resistance. + Read more about them at . + Here's everything you need to know: + . + >>> import Web.Cuid (newCuid, newSlug) + >>> newCuid + "cib3c3tcu0000zwowx9ho2gh4" + >>> newSlug + "c900001wmf" + . + This module does not use crypto-strength sources of + randomness. + Use at your own peril! + . + For better or worse, this module uses semantic versioning + (see ). + That is, if you want to depend upon, for example, version 1 + of the API, you should add @hscuid ==1.*@ to your Cabal + file. No breaking changes will be (deliberately) introduced + under that version number. + homepage: https://github.com/eightyeight/hscuid -license: MIT +license: BSD3 license-file: LICENSE author: Daniel Buckmaster maintainer: dan.buckmaster@gmail.com @@ -19,6 +39,7 @@ library hs-source-dirs: lib exposed-modules: Web.Cuid + other-modules: Web.Cuid.Internal build-depends: base ==4.*, formatting ==6.*, time ==1.*, diff --git a/lib/Web/Cuid.hs b/lib/Web/Cuid.hs --- a/lib/Web/Cuid.hs +++ b/lib/Web/Cuid.hs @@ -1,116 +1,70 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} {-| Stability: stable Portability: portable -You can generate a new CUID inside any IO-enabled monad using this module's -one exported function: - ->>> cuid <- newCuid ->>> print cuid -"ciaafthr00000qhpm0jp81gry" +You can generate a new CUID or slug inside any IO-enabled monad using 'newCuid' +and 'newSlug'. -} module Web.Cuid ( - Cuid, newCuid + Cuid, newCuid, + Slug, newSlug ) where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Char (ord) -import Data.Monoid (mconcat, (<>)) -import Data.IORef (IORef, newIORef, atomicModifyIORef') import Data.String (fromString) import Data.Text (Text) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Formatting (Format, base, fitRight, sformat, left, (%.)) -import Network.HostName (getHostName) -import System.IO.Unsafe (unsafePerformIO) -import System.Random (randomRIO) +import Formatting (sformat) -#if defined(mingw32_HOST_OS) -import System.Win32 (ProcessId, failIfZero) -#else -import System.Posix.Process (getProcessID) +import Data.Monoid (Monoid, (<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat) #endif +import Web.Cuid.Internal + -- | Convenience type so that you don't have to import Text downstream. Note that -- this is strict Text. type Cuid = Text -- | Generate a new random CUID. newCuid :: MonadIO m => m Cuid -newCuid = concatM [c, time, count, fingerprint, random, random] where +newCuid = concatResults [c, time, count, fingerprint, random, random] where -- The CUID starts with a letter so it's usable in HTML element IDs. c = return (fromString "c") -- 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 . millis) getPOSIXTime + time = liftM (sformat number) getTimestamp -- To avoid collisions on the same machine, add a global counter to each ID. - count = liftM (sformat numberPadded) (postIncrement counter) + count = liftM (sformat numberPadded) 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 <- getPid - hostname <- getHostName - let hostSum = 36 + length hostname + sum (map ord hostname) - twoOfNum = sformat (fitRight 2 %. number) - return (twoOfNum pid <> twoOfNum hostSum) - - -- And some randomness for good measure. Note that System.Random is not a - -- source of crypto-strength randomness. - random = liftM (sformat numberPadded) (randomRIO (0, maxValue)) - - -- Evaluate IO actions and concatenate their results. - concatM actions = liftM mconcat (liftIO $ sequence actions) - - -- POSIX time library gives the result in fractional seconds. - millis posix = round (posix * 1000) - --- 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 #-} - --- Increment the counter, and return the value before it was incremented. -postIncrement :: MonadIO m => IORef Int -> m Int -postIncrement c = liftIO (atomicModifyIORef' c incrementAndWrap) where - incrementAndWrap count = (succ count `mod` maxValue, count) - --- These constants are to do with number formatting. -formatBase, blockSize, maxValue :: Int -formatBase = 36 -blockSize = 4 -maxValue = formatBase ^ blockSize - --- Number formatters for converting to the correct base and padding. -number, numberPadded :: Format Text (Int -> Text) -(number, numberPadded) = (toBase, toBlockSize %. toBase) where - toBlockSize = left blockSize '0' - toBase = base formatBase - --- Get the ID of the current process. This function has a platform-specific --- implementation. Fun times. -getPid :: MonadIO m => m Int - -#if defined(mingw32_HOST_OS) - -foreign import stdcall unsafe "windows.h GetCurrentProcessId" - c_GetCurrentProcessId :: IO ProcessId - -getCurrentProcessId :: IO ProcessId -getCurrentProcessId = failIfZero "GetCurrentProcessId" c_GetCurrentProcessId + (pid, host) <- getFingerprint + return (sformat twoOfNum pid <> sformat twoOfNum host) -getPid = liftM fromIntegral (liftIO getCurrentProcessId) + -- And some actual randomness for good measure. + random = liftM (sformat numberPadded) getRandomValue -#else +-- | A Slug is not a Cuid. But it is also a strict Text. +type Slug = Text -getPid = liftM fromIntegral (liftIO getProcessID) +-- | A slug is a shorter piece of text generated using some of the same +-- 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) -#endif +-- Evaluate IO actions and concatenate their results. +concatResults :: (MonadIO m, Monoid a) => [IO a] -> m a +concatResults actions = liftM mconcat (liftIO $ sequence actions) diff --git a/lib/Web/Cuid/Internal.hs b/lib/Web/Cuid/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Web/Cuid/Internal.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +{-| +Stability: unstable +Portability: portable + +Contains internal implementation details for CUIDs. +-} +module Web.Cuid.Internal 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.Time.Clock.POSIX (getPOSIXTime) +import Formatting (Format, base, fitLeft, fitRight, left, (%.)) +import Network.HostName (getHostName) +import System.IO.Unsafe (unsafePerformIO) +import System.Random (randomRIO) + +#if defined(mingw32_HOST_OS) +import System.Win32 (ProcessId, failIfZero) +#else +import System.Posix.Process (getProcessID) +#endif + +-- | 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. +getFingerprint :: IO (Int, Int) +getFingerprint = do + pid <- getPid + hostname <- getHostName + let hostSum = 36 + length hostname + sum (map ord hostname) + return (pid, hostSum) + +-- | Just get a random integer. Not referentially transparent. +getRandomValue :: IO Int +getRandomValue = randomRIO (0, maxCount) + +-- | 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. +getNextCount :: IO Int +getNextCount = postIncrement counter + +-- | Increment the counter, and return the value before it was incremented. +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 +getTimestamp = liftM toMillis getPOSIXTime where + toMillis posix = round (posix * 1000) + +-- | Get the ID of the current process. This function has a platform-specific +-- implementation. Fun times. +getPid :: MonadIO m => m Int + +#if defined(mingw32_HOST_OS) + +foreign import stdcall unsafe "windows.h GetCurrentProcessId" + c_GetCurrentProcessId :: IO ProcessId + +getCurrentProcessId :: IO ProcessId +getCurrentProcessId = failIfZero "GetCurrentProcessId" c_GetCurrentProcessId + +getPid = liftM fromIntegral (liftIO getCurrentProcessId) + +#else + +getPid = liftM fromIntegral (liftIO getProcessID) + +#endif diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,28 +1,28 @@ module Main where +import Control.Monad (foldM, when) import Data.Set (empty, insert, size) -import Control.Monad (foldM) import System.Exit (ExitCode(..), exitWith) -import Web.Cuid (newCuid) +import Web.Cuid (Cuid, newCuid, newSlug) main :: IO () main = do - result <- runCollisionTest 1200000 - case result of - Nothing -> exitWith ExitSuccess - Just n -> do - print ("Number of collisions: " ++ show n) + nCuid <- runCollisionTest newCuid 1200000 + nSlug <- runCollisionTest newSlug 1200000 + case (nCuid, nSlug) of + (0, 0) -> exitWith ExitSuccess + _otherwise -> do + when (nCuid /= 0) $ print ("cuid collisions: " ++ show nCuid) + when (nSlug /= 0) $ print ("slug collisions: " ++ show nSlug) exitWith (ExitFailure 1) -runCollisionTest :: Int -> IO (Maybe Int) -runCollisionTest numberOfCuids = do +runCollisionTest :: IO Cuid -> Int -> IO Int +runCollisionTest action numberOfCuids = do let accumulate set _i = do - cuid <- newCuid + cuid <- action return $! insert cuid set -- Generate a set containing a bunch of generated CUIDs. - set <- foldM accumulate empty [0..numberOfCuids-1] + set <- foldM accumulate empty [0 .. numberOfCuids - 1] -- If every element was unique, the set will have the same size as the input. - return $ if size set == numberOfCuids - then Nothing - else Just (numberOfCuids - size set) + return (numberOfCuids - size set)