diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,31 +1,51 @@ -# Ulid implementation in Haskell +# ULID Implementation in Haskell -Lexicographically sortable, 128-bit identifier with 48-bit timestamp and 80 random bits. -Canonically encoded as a 26 character string, as opposed to the 36 character UUID. +Lexicographically sortable, 128-bit identifier +with 48-bit timestamp and 80 random bits. +Canonically encoded as a 26 character string, +as opposed to the 36 character UUID. -Original implementation and spec: https://github.com/alizain/ulid/ +Original implementation and spec: [github.com/alizain/ulid] +[github.com/alizain/ulid]: https://github.com/alizain/ulid/ + +```txt + 01an4z07by 79ka1307sr9x4mv3 + +|----------| |----------------| + Timestamp Randomness + 48 bits 80 bits +``` + + # Universally Unique Lexicographically Sortable Identifier UUID can be suboptimal for many uses-cases because: - It isn't the most character efficient way of encoding 128 bits of randomness -- UUID v1/v2 is impractical in many environments, as it requires access to a unique, stable MAC address -- UUID v3/v5 requires a unique seed and produces randomly distributed IDs, which can cause fragmentation in many data structures -- UUID v4 provides no other information than randomness which can cause fragmentation in many data structures +- UUID v1/v2 is impractical in many environments, + as it requires access to a unique, stable MAC address +- UUID v3/v5 requires a unique seed and produces randomly distributed IDs, + which can cause fragmentation in many data structures +- UUID v4 provides no other information than randomness, + which can cause fragmentation in many data structures Instead, herein is proposed ULID: - 128-bit compatibility with UUID - 1.21e+24 unique ULIDs per millisecond -- Lexicographically sortable! -- Canonically encoded as a 26 character string, as opposed to the 36 character UUID -- Uses Crockford's base32 for better efficiency and readability (5 bits per character) +- Lexicographically sortable +- Canonically encoded as a 26 character string, + as opposed to the 36 character UUID +- Uses [Douglas Crockford's base 32] for better efficiency and readability + (5 bits per character) - Case insensitive - No special characters (URL safe) +[Douglas Crockford's base 32]: https://www.crockford.com/base32.html + ## Usage A simple usage example: @@ -33,61 +53,67 @@ ````haskell module Main where -import Data.ULID +import Data.ULID main :: IO () main = do - -- Derive a ULID using the current time and default random number generator - ulid1 <- getULID - print ulid1 + -- Derive a ULID using the current time and default random number generator + ulid1 <- getULID + print ulid1 - -- Derive a ULID using a specified time and default random number generator - ulid2 <- getULIDTime 1469918176.385 -- POSIX Time, specified to the millisecond - print ulid2 + -- Derive a ULID using a specified time and default random number generator + ulid2 <- getULIDTime 1469918176.385 -- POSIX Time, millisecond precision + print ulid2 ```` -As per the spec, it is also possible to use a cryptographically-secure random number generator to contribute the randomness. However, the programmer must manage the generator on their own. Example: +As per the spec, it is also possible to use a cryptographically-secure +random number generator to contribute the randomness. +However, the programmer must manage the generator on their own. +Example: ````haskell module Main where -import Data.ULID +import Data.ULID import qualified Crypto.Random as CR import qualified Data.ULID.Random as UR import qualified Data.ULID.TimeStamp as TS main :: IO () -main = do - -- This default instantiation may not be sufficiently secure, see the docs - -- https://hackage.haskell.org/package/crypto-api-0.13.2/docs/Crypto-Random.html - g <- (CR.newGenIO :: IO CR.SystemRandom) +main = do + -- This default instantiation may not be sufficiently secure. + -- See the docs at + -- hackage.haskell.org/package/crypto-api-0.13.2/docs/Crypto-Random.html + g <- (CR.newGenIO :: IO CR.SystemRandom) - -- Generate time stamp from current time - t <- TS.getULIDTimeStamp - - let ulid3 = case UR.mkCryptoULIDRandom g of - Left err -> error $ show err - Right (rnd, g2) -> ULID t rnd -- use g2, etc, to continue generating secure ULIDs - print ulid3 -```` + -- Generate timestamp from current time + t <- TS.getULIDTimeStamp + let ulid3 = case UR.mkCryptoULIDRandom g of + Left err -> error $ show err + -- use g2, …, to continue generating secure ULIDs + Right (rnd, g2) -> ULID t rnd + print ulid3 +```` + ## Test Suite -``` +```sh stack test ``` + ## Performance -``` +```sh stack bench ``` -``` +```txt Running 1 benchmarks... Benchmark ulid-bench: RUNNING... 217,868 op/s generate diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,35 +1,35 @@ -module Main where - -import Data.ULID - --- These imports only needed for cryptographically secure ULID -import qualified Crypto.Random as CR -import qualified Data.ULID.Random as UR -import qualified Data.ULID.TimeStamp as TS - -main :: IO () -main = do - -- Derive a ULID using the current time and default random number generator - ulid1 <- getULID - print ulid1 - - -- Derive a ULID using a specified time and default random number generator - ulid2 <- getULIDTime 1469918176.385 -- POSIX Time, specified to the millisecond - print ulid2 - - - -- Below only for crypographically secure ULID example - - -- This default instantiation may not be sufficiently secure, see the docs - -- https://hackage.haskell.org/package/crypto-api-0.13.2/docs/Crypto-Random.html - g <- (CR.newGenIO :: IO CR.SystemRandom) - - -- Generate time stamp from current time - t <- TS.getULIDTimeStamp - - let ulid3 = case UR.mkCryptoULIDRandom g of - Left err -> error $ show err - Right (rnd, g2) -> ULID t rnd -- use g2, etc, to continue generating secure ULIDs - print ulid3 - - +module Main where + +import Data.ULID + +-- These imports only needed for cryptographically secure ULID +import qualified Crypto.Random as CR +import qualified Data.ULID.Random as UR +import qualified Data.ULID.TimeStamp as TS + + +main :: IO () +main = do + -- Derive a ULID using the current time and default random number generator + ulid1 <- getULID + print ulid1 + + -- Derive a ULID using a specified time and default random number generator + ulid2 <- getULIDTime 1469918176.385 -- ^ POSIX Time in milliseconds + print ulid2 + + -- Below only for cryptographically secure ULID example + + -- This default instantiation may not be sufficiently secure, see the docs + -- https://hackage.haskell.org/package/crypto-api-0.13.3/docs/Crypto-Random.html + g <- (CR.newGenIO :: IO CR.SystemRandom) + + -- Generate time stamp from current time + t <- TS.getULIDTimeStamp + + let ulid3 = case UR.mkCryptoULIDRandom g of + Left err -> error $ show err + -- Use g2, etc, to continue generating secure ULIDs + Right (rnd, g2) -> ULID t rnd + + print ulid3 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,24 +1,28 @@ -module Main where - -import Data.ULID - -import Control.DeepSeq -import Control.Monad (replicateM) -import qualified Data.Text as T -import qualified Data.Text.Format.Numbers as FN -import qualified Data.Time.Clock.POSIX as PX - -formatTN = T.unpack . (FN.prettyI (Just ',')) - -main :: IO () -main = do - -- Run many iterations of getULID - let ops = 100000 - begin <- PX.getPOSIXTime - ulids <- replicateM ops (getULID >>= return.force) - end <- PX.getPOSIXTime - let elapsed = end - begin - let opsPerSec = (fromIntegral ops) / (realToFrac elapsed) :: Double - putStr $ formatTN (round opsPerSec) - putStrLn " op/s generate" - +module Main where + +import Data.ULID + +import Control.DeepSeq +import Control.Monad (replicateM) +import Data.Text as T +import Data.Text.IO as T +import Data.Text.Format.Numbers as FN +import Data.Time.Clock.POSIX as PX + + +formatTN :: Int -> Text +formatTN = + FN.prettyI $ Just ',' + + +main :: IO () +main = do + -- Run many iterations of getULID + let ops = 100000 + begin <- PX.getPOSIXTime + ulids <- replicateM ops (getULID >>= return.force) + end <- PX.getPOSIXTime + let elapsed = end - begin + let opsPerSec = (fromIntegral ops) / (realToFrac elapsed) :: Double + T.putStr $ formatTN $ round opsPerSec + T.putStrLn " op/s generate" diff --git a/src/Data/Binary/Roll.hs b/src/Data/Binary/Roll.hs --- a/src/Data/Binary/Roll.hs +++ b/src/Data/Binary/Roll.hs @@ -1,28 +1,31 @@ -module Data.Binary.Roll where - -import Data.Binary -import Data.Bits -import Data.List (foldl', unfoldr) - - --- | unroll and produce an exact number of bytes (left-pad with 0 bytes) -unroll :: Int -> Integer -> [Word8] -unroll bytes val = replicate (bytes - length xs) 0 ++ xs - where xs = unroll' val - --- source: http://hackage.haskell.org/package/binary-0.8.5.1/docs/src/Data-Binary-Class.html#line-311 --- --- Fold and unfold an Integer to and from a list of its bytes --- --- MOST SIGNIFICANT BYTE FIRST please (this is a change from the default Data.Binary impl) - -unroll' :: Integer -> [Word8] -unroll' = reverse . unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldl' unstep 0 - where - unstep a b = a `shiftL` 8 .|. fromIntegral b +module Data.Binary.Roll where + +import Data.Binary +import Data.Bits +import Data.List (foldl', unfoldr) + + +-- | Unroll and produce an exact number of bytes (left-pad with 0 bytes) +unroll :: Int -> Integer -> [Word8] +unroll bytes val = replicate (bytes - length xs) 0 ++ xs + where xs = unroll' (abs val) + + +-- | Source: +-- https://hackage.haskell.org/package/binary-0.8.5.1/docs/src/Data-Binary-Class.html#line-311 +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +-- MOST SIGNIFICANT BYTE FIRST please +-- (this is a change from the default `Data.Binary` impl) +unroll' :: Integer -> [Word8] +unroll' = reverse . unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 + where + unstep a b = a `shiftL` 8 .|. fromIntegral b diff --git a/src/Data/ULID.hs b/src/Data/ULID.hs --- a/src/Data/ULID.hs +++ b/src/Data/ULID.hs @@ -1,119 +1,144 @@ -{- | -Module : Data.ULID -Copyright : (c) 2017 Steve Kollmansberger - -License : BSD-style - -Maintainer : steve@kolls.net -Stability : experimental -Portability : portable - -This library implements the Universally Unique Lexicographically Sortable Identifier, as described at . - -UUID can be suboptimal for many uses-cases because: - -* It isn't the most character efficient way of encoding 128 bits of randomness -* UUID v1/v2 is impractical in many environments, as it requires access to a unique, stable MAC address -* UUID v3/v5 requires a unique seed and produces randomly distributed IDs, which can cause fragmentation in many data structures -* UUID v4 provides no other information than randomness which can cause fragmentation in many data structures - -Instead, herein is proposed ULID: - -* 128-bit compatibility with UUID -* 1.21e+24 unique ULIDs per millisecond -* Lexicographically sortable! -* Canonically encoded as a 26 character string, as opposed to the 36 character UUID -* Uses Crockford's base32 for better efficiency and readability (5 bits per character) -* Case insensitive -* No special characters (URL safe) - --} -{-# LANGUAGE DeriveDataTypeable #-} -module Data.ULID ( - ULID(..), - getULIDTime, - getULID, - ulidToInteger, - ulidFromInteger -) where - -import Control.DeepSeq -import Data.Binary -import qualified Data.ByteString.Lazy as LBS -import Data.Data -import Data.Hashable -import Data.Monoid ((<>)) -import Data.Time.Clock.POSIX -import System.IO.Unsafe -import qualified System.Random as R - -import Data.Binary.Roll -import Data.ULID.Random -import Data.ULID.TimeStamp - -data ULID = ULID { - timeStamp :: !ULIDTimeStamp, - random :: !ULIDRandom - } - deriving (Eq, Typeable, Data) - --- | Derive a ULID using a specified time and default random number generator -getULIDTime :: POSIXTime -- ^ The specified UNIX time (seconds) to millisecond precision, e.g. 1469918176.385 - -> IO ULID -getULIDTime t = do - let t' = mkULIDTimeStamp t - r <- getULIDRandom - return $ ULID t' r - --- | Derive a ULID using the current time and default random number generator -getULID :: IO ULID -getULID = do - t <- getULIDTimeStamp - r <- getULIDRandom - return $ ULID t r - --- | Convert a ULID to its corresponding (at most) 128-bit Integer. Integer equivalents retain sortable trait (same sort order). --- This could be useful for storing in a database using a smaller field than storing the Show'n string, but still human-readable unlike the Binary version. -ulidToInteger :: ULID -> Integer -ulidToInteger = roll.(LBS.unpack).encode - --- | Convert a ULID from its corresponding 128-bit Integer. -ulidFromInteger :: Integer -- ^ The ULID's Integer equivalent, as generated by toInteger - -> ULID -ulidFromInteger = decode.(LBS.pack).(unroll 16) -- 16 bytes = 128 bit - -instance Ord ULID where - compare (ULID ts1 _) (ULID ts2 _) = compare ts1 ts2 - -instance Show ULID where - show (ULID ts bytes) = (show ts) ++ (show bytes) - -instance Read ULID where - readsPrec _ str = do - (ts, str2) <- reads str - (rn, str3) <- reads str2 - return (ULID ts rn, str3) - -instance Binary ULID where - put (ULID ts bytes) = put ts <> put bytes - get = do - ts <- get - bytes <- get - return $ ULID ts bytes - --- Because of the strictness annotations, this shouldn't be needed and shouldn't do anything --- I tested and confirmed this in the benchmark, but since I did the work to put it here --- It's no harm to leave it in -instance NFData ULID where - rnf (ULID ts bytes) = rnf ts `seq` (rnf bytes `seq` ()) - -instance R.Random ULID where - randomR _ = R.random -- ignore range - random g = unsafePerformIO $ do - t <- getULIDTimeStamp - let (r, g') = mkULIDRandom g - return (ULID t r, g') - randomIO = getULID - -instance Hashable ULID where - hashWithSalt salt ulid = hashWithSalt salt (encode ulid) +{- | +This library implements the +Universally Unique Lexicographically Sortable Identifier, +as described at https://github.com/alizain/ulid. + +UUID can be suboptimal for many uses-cases because: + +* It isn't the most character efficient way of encoding 128 bits of randomness +* UUID v1/v2 is impractical in many environments, + as it requires access to a unique, stable MAC address +* UUID v3/v5 requires a unique seed and produces randomly distributed IDs, + which can cause fragmentation in many data structures +* UUID v4 provides no other information than randomness, + which can cause fragmentation in many data structures + +Instead, herein is proposed ULID: + +* 128-bit compatibility with UUID +* 1.21e+24 unique ULIDs per millisecond +* Lexicographically sortable! +* Canonically encoded as a 26 character text, + as opposed to the 36 character UUID +* Uses Douglas Crockford's base32 for better efficiency and readability + (5 bits per character) +* Case insensitive +* No special characters (URL safe) +-} + +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ULID ( + ULID(..), + getULIDTime, + getULID, + ulidToInteger, + ulidFromInteger +) where + +import Control.DeepSeq +import Data.Binary +import qualified Data.ByteString.Lazy as LBS +import Data.Data +import Data.Hashable +import Data.Monoid ((<>)) +import Data.Text as T +import Data.Time.Clock.POSIX +import System.IO.Unsafe +import qualified System.Random as R + +import Data.Binary.Roll +import Data.ULID.Random +import Data.ULID.TimeStamp + + +{- | +> t <- getULIDTimeStamp +> r <- getULIDRandom +> pure $ ULID t r +-} +data ULID = ULID + { timeStamp :: !ULIDTimeStamp + , random :: !ULIDRandom + } + deriving (Eq, Typeable, Data) + +instance Ord ULID where + compare (ULID ts1 _) (ULID ts2 _) = compare ts1 ts2 + +instance Show ULID where + show (ULID ts bytes) = (show ts) ++ (show bytes) + +instance Read ULID where + readsPrec _ str = do + (ts, str2) <- reads str + (rn, str3) <- reads str2 + return (ULID ts rn, str3) + +instance Binary ULID where + put (ULID ts bytes) = put ts <> put bytes + get = do + ts <- get + bytes <- get + return $ ULID ts bytes + +-- | Because of the strictness annotations, +-- this shouldn't be needed and shouldn't do anything. +-- This is tested and confirmed in the benchmark, +-- but since the work to put it here has already been done +-- it's no harm to leave it in. +instance NFData ULID where + rnf (ULID ts bytes) = rnf ts `seq` (rnf bytes `seq` ()) + +instance R.Random ULID where + randomR _ = R.random -- ignore range + random g = unsafePerformIO $ do + t <- getULIDTimeStamp + let (r, g') = mkULIDRandom g + return (ULID t r, g') + randomIO = getULID + +instance Hashable ULID where + hashWithSalt salt ulid = hashWithSalt salt (encode ulid) + + +-- | Derive a ULID using a specified time and default random number generator +getULIDTime + :: POSIXTime -- ^ Specified UNIX time with millisecond precision + -- (e.g. 1469918176.385) + -> IO ULID +getULIDTime t = do + let t' = mkULIDTimeStamp t + r <- getULIDRandom + return $ ULID t' r + + +-- | Derive a ULID using the current time and default random number generator +getULID :: IO ULID +getULID = do + t <- getULIDTimeStamp + r <- getULIDRandom + return $ ULID t r + + +-- | Convert a ULID to its corresponding (at most) 128-bit Integer. +-- Integer equivalents retain sortable trait (same sort order). +-- This could be useful for storing in a database using a smaller field +-- than storing the shown `Text`, +-- but still human-readable unlike the Binary version. +ulidToInteger :: ULID -> Integer +ulidToInteger = roll.(LBS.unpack).encode + + +-- | Convert a ULID from its corresponding 128-bit Integer. +ulidFromInteger + :: Integer -- ^ The ULID's Integer equivalent, as generated by toInteger + -> Either Text ULID +ulidFromInteger n + | n < 0 = Left "Value must not be negative" + | n > maxValidInteger = Left + "Value must not be larger than the maximum safe Integer size (128 bits)" + | otherwise = Right + . decode . LBS.pack . (unroll 16) $ n -- 16 bytes = 128 bit + where + maxValidInteger :: Integer + maxValidInteger = (2 ^ 128) - 1 diff --git a/src/Data/ULID/Base32.hs b/src/Data/ULID/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/ULID/Base32.hs @@ -0,0 +1,155 @@ +-- | Partly adapted from https://hackage.haskell.org/package/crockford +module Data.ULID.Base32 + ( encode + , encodeChar + , decode + , decodeChar + ) +where + +import Data.Char +import Data.Maybe +import Text.Read +import Data.Text as T + +import Data.ULID.Digits (digits, unDigits) + + +-- | Decodes a Crockford base 32 encoded `Text` into an natural number, +-- if possible. Returns `Nothing` if the `Text` is not a valid encoded value. +decodePlain :: Integral i => Text -> Maybe i +decodePlain base32text = do + numbers <- mapM decodeChar $ T.unpack base32text + pure $ unDigits 32 numbers + + +-- | Encodes an natural number into a Text, +-- using Douglas Crockford's base 32 encoding. +-- Returns `Nothing` if number is negative. +encodePlain :: Integral i => i -> Text +encodePlain = + T.pack . fmap encodeChar . digits 32 + + +-- | Decode a character to its corresponding integer +decodeChar :: Integral i => Char -> Maybe i +decodeChar c = case Data.Char.toUpper c of + '0' -> Just 0 + 'O' -> Just 0 + '1' -> Just 1 + 'I' -> Just 1 + 'L' -> Just 1 + '2' -> Just 2 + '3' -> Just 3 + '4' -> Just 4 + '5' -> Just 5 + '6' -> Just 6 + '7' -> Just 7 + '8' -> Just 8 + '9' -> Just 9 + 'A' -> Just 10 + 'B' -> Just 11 + 'C' -> Just 12 + 'D' -> Just 13 + 'E' -> Just 14 + 'F' -> Just 15 + 'G' -> Just 16 + 'H' -> Just 17 + 'J' -> Just 18 + 'K' -> Just 19 + 'M' -> Just 20 + 'N' -> Just 21 + 'P' -> Just 22 + 'Q' -> Just 23 + 'R' -> Just 24 + 'S' -> Just 25 + 'T' -> Just 26 + 'V' -> Just 27 + 'W' -> Just 28 + 'X' -> Just 29 + 'Y' -> Just 30 + 'Z' -> Just 31 + _ -> Nothing + + +-- | Encode an integer to its corresponding character +encodeChar :: Integral i => i -> Char +encodeChar i = case i of + 0 -> '0' + 1 -> '1' + 2 -> '2' + 3 -> '3' + 4 -> '4' + 5 -> '5' + 6 -> '6' + 7 -> '7' + 8 -> '8' + 9 -> '9' + 10 -> 'A' + 11 -> 'B' + 12 -> 'C' + 13 -> 'D' + 14 -> 'E' + 15 -> 'F' + 16 -> 'G' + 17 -> 'H' + 18 -> 'J' + 19 -> 'K' + 20 -> 'M' + 21 -> 'N' + 22 -> 'P' + 23 -> 'Q' + 24 -> 'R' + 25 -> 'S' + 26 -> 'T' + 27 -> 'V' + 28 -> 'W' + 29 -> 'X' + 30 -> 'Y' + 31 -> 'Z' + _ -> '0' + + +-- | Source: https://stackoverflow.com/a/29153602 +-- The safety for m > length was removed, because that should never happen. +-- If it does, it should crash. +leftpad :: Int -> Text -> Text +leftpad m xs = + T.replicate (m - T.length xs) "0" <> xs + + +-- | Converts all negative numbers to 0 +clampZero :: Integral i => i -> i +clampZero x = + if x < 0 + then 0 + else x + + +-- | >>> encode 5 123 +-- "0003V" +-- +-- | >>> encode (-5) (-123) +-- "" +encode + :: Integral i + => Int -- ^ Overall length of resulting Text + -> i -- ^ Natural number to encode + -> Text -- ^ 0 padded, Douglas Crockford's base 32 encoded Text +encode width = + (leftpad $ clampZero width) . encodePlain . clampZero + + +-- | >>> decode 5 "0003V" +-- [(123,"")] +decode + :: Integral i + => Int -- ^ Overall length of input Text + -> Text -- ^ Base 32 encoded Text + -> [(i, Text)] -- ^ List of possible parses +decode width str | T.length str >= width = let + (crock, remainder) = T.splitAt width str + in case decodePlain crock of + Nothing -> [] + Just c -> [(c, remainder)] + | otherwise = [] diff --git a/src/Data/ULID/Crockford.hs b/src/Data/ULID/Crockford.hs deleted file mode 100644 --- a/src/Data/ULID/Crockford.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Data.ULID.Crockford (encode, decode) where - -import qualified Codec.Crockford as CR -import Text.Read - --- source: https://stackoverflow.com/a/29153602 --- I removed the safety for m > length because that should never happen --- and if it does, I want it to crash! -leftpad m xs = replicate (m - length xs) '0' ++ xs - -encode :: Int -> Integer -> String -encode width = (leftpad width).(CR.encode) - -decode :: Int -> ReadS Integer -decode width str | length str >= width = let - (crock, remainder) = splitAt width str - in case CR.decode crock of - Nothing -> [] - Just c -> [(c, remainder)] - | otherwise = [] diff --git a/src/Data/ULID/Digits.hs b/src/Data/ULID/Digits.hs new file mode 100644 --- /dev/null +++ b/src/Data/ULID/Digits.hs @@ -0,0 +1,54 @@ +-- | Adapted from https://hackage.haskell.org/package/digits +module Data.ULID.Digits + ( digits + , unDigits + ) +where + +import Data.Maybe (fromJust) +import Data.List (genericTake) + + +-- | Returns the digits of a positive integer as a Maybe list, in reverse order +-- or Nothing if a zero or negative base is given +-- This is slightly more efficient than in forward order. +mDigitsRev :: Integral n + => n -- ^ The base to use. + -> n -- ^ The number to convert to digit form. + -> Maybe [n] -- ^ Nothing or Just the digits of the number + -- in list form, in reverse. +mDigitsRev base i = if base < 1 + then Nothing -- We do not support zero or negative bases + else Just $ dr base i + where + dr _ 0 = [] + dr b x = case base of + 1 -> genericTake x $ repeat 1 + _ -> let (rest, lastDigit) = quotRem x b + in lastDigit : dr b rest + + +-- | Returns the digits of a positive integer as a list, in reverse order. +-- Throws an error if given a zero or negative base. +digitsRev :: Integral n + => n -- ^ The base to use. + -> n -- ^ The number to convert to digit from. + -> [n] -- ^ The digits of the number in list from, in reverse. +digitsRev base = fromJust . mDigitsRev base + + +-- | Returns the digits of a positive integer as a list. +-- Throws an error if given a zero or negative base. +digits :: Integral n + => n -- ^ The base to use (typically 10). + -> n -- ^ The number to convert to digit form. + -> [n] -- ^ Either Nothing or the digits of the number in list form. +digits base = reverse . digitsRev base + + +-- | Takes a list of digits, and converts them back into a positive integer. +unDigits :: Integral n + => n -- ^ The base to use. + -> [n] -- ^ The digits of the number in list form. + -> n -- ^ The original number. +unDigits base = foldl (\ a b -> a * base + b) 0 diff --git a/src/Data/ULID/Random.hs b/src/Data/ULID/Random.hs --- a/src/Data/ULID/Random.hs +++ b/src/Data/ULID/Random.hs @@ -1,58 +1,78 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Data.ULID.Random ( - ULIDRandom, - mkCryptoULIDRandom, - mkULIDRandom, - getULIDRandom -) where - -import Control.DeepSeq -import Control.Monad -import Crypto.Random -import Data.Binary -import Data.Binary.Roll -import qualified Data.ByteString as BS -import Data.Data -import Data.Word -import System.Random - - -import qualified Data.ULID.Crockford as CR - - -newtype ULIDRandom = ULIDRandom BS.ByteString - deriving (Eq, Typeable, Data) - -numBytes = 10 -- 80 bits - --- | Generate a ULID Random based on a cryptographically secure random number generator. --- | see: https://hackage.haskell.org/package/crypto-api-0.13.2/docs/Crypto-Random.html -mkCryptoULIDRandom :: CryptoRandomGen g => g -> Either GenError (ULIDRandom, g) -mkCryptoULIDRandom g = do - (b, g2) <- genBytes numBytes g - return (ULIDRandom b, g2) - --- | Generate a ULID Random based on a standard random number generator. --- | see: https://hackage.haskell.org/package/random-1.1/docs/System-Random.html -mkULIDRandom :: RandomGen g => g -> (ULIDRandom, g) -mkULIDRandom g = let - (g1, g2) = split g - genbytes = (BS.pack) . take numBytes . randoms - in (ULIDRandom $ genbytes g, g2) - --- | Generate a ULID Random based on the global random number generator. -getULIDRandom :: IO ULIDRandom -getULIDRandom = fst <$> mkULIDRandom <$> newStdGen -- Note: the call to newStdGen splits the generator, so this is safe to call multiple times - -instance Show ULIDRandom where - show (ULIDRandom r) = (CR.encode) 16.roll.(BS.unpack) $ r - -instance Read ULIDRandom where - readsPrec _ = map (\(c,r)->(ULIDRandom $ (BS.pack) $ unroll numBytes c, r)) . (CR.decode) 16 - -instance Binary ULIDRandom where - put (ULIDRandom r) = mapM_ put (BS.unpack $ r) - get = ULIDRandom <$> (BS.pack) <$> replicateM numBytes get - -instance NFData ULIDRandom where - rnf (ULIDRandom r) = rnf r +-- | Helper functions to generate the random part of an ULID +-- either with PRNGs or TRNGs. + +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ULID.Random ( + ULIDRandom, + mkCryptoULIDRandom, + mkULIDRandom, + getULIDRandom +) where + +import Control.DeepSeq +import Control.Monad +import Crypto.Random +import Data.Binary +import Data.Binary.Roll +import Data.ByteString as BS hiding (split, take) +import Data.Data +import Data.Maybe +import Data.Word +import Data.Text as T hiding (split, take) +import System.Random + + +import qualified Data.ULID.Base32 as B32 + + +-- | Newtype wrapping a `ByteString` +newtype ULIDRandom = ULIDRandom BS.ByteString + deriving (Eq, Typeable, Data) + +instance Show ULIDRandom where + show (ULIDRandom r) = T.unpack $ B32.encode 16.roll.(BS.unpack) $ r + +instance Read ULIDRandom where + readsPrec _ = fmap + (\(int, rest) -> + (ULIDRandom $ BS.pack $ unroll numBytes int, T.unpack rest)) + . (B32.decode $ 16) + . T.pack + +instance Binary ULIDRandom where + put (ULIDRandom r) = mapM_ put (BS.unpack $ r) + get = ULIDRandom <$> (BS.pack) <$> replicateM numBytes get + +instance NFData ULIDRandom where + rnf (ULIDRandom r) = rnf r + + +numBytes = 10 -- 80 bits + + +-- | Generate a `ULIDRandom` based on a cryptographically secure +-- random number generator. +-- See: +-- https://hackage.haskell.org/package/crypto-api-0.13.3/docs/Crypto-Random.html +mkCryptoULIDRandom :: CryptoRandomGen g => g -> Either GenError (ULIDRandom, g) +mkCryptoULIDRandom g = do + (b, g2) <- genBytes numBytes g + return (ULIDRandom b, g2) + + +-- | Generate a `ULIDRandom` based on a standard random number generator. +-- See: +-- https://hackage.haskell.org/package/random-1.1/docs/System-Random.html +mkULIDRandom :: RandomGen g => g -> (ULIDRandom, g) +mkULIDRandom g = let + (g1, g2) = split g + genbytes = (BS.pack) . take numBytes . randoms + in (ULIDRandom $ genbytes g, g2) + + +-- | Generate a ULID Random based on the global random number generator. +getULIDRandom :: IO ULIDRandom +-- | Note: The call to `newStdGen` splits the generator, +-- so this is safe to call multiple times +getULIDRandom = + fst <$> mkULIDRandom <$> newStdGen diff --git a/src/Data/ULID/TimeStamp.hs b/src/Data/ULID/TimeStamp.hs --- a/src/Data/ULID/TimeStamp.hs +++ b/src/Data/ULID/TimeStamp.hs @@ -1,44 +1,56 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Data.ULID.TimeStamp ( - ULIDTimeStamp, - mkULIDTimeStamp, - getULIDTimeStamp -) where - -import Control.DeepSeq -import Control.Monad -import Data.Binary -import Data.Binary.Roll -import Data.Data -import Data.Time.Clock -import Data.Time.Clock.POSIX - -import qualified Data.ULID.Crockford as CR - -numBytes = 6 -- 48 bits - --- UNIX time in milliseconds -newtype ULIDTimeStamp = ULIDTimeStamp Integer - deriving (Eq, Ord, Typeable, Data) - --- | Generate a ULID Timestamp based on a specified time -mkULIDTimeStamp :: POSIXTime -- ^ The specified UNIX time (seconds) to millisecond precision, e.g. 1469918176.385 - -> ULIDTimeStamp -mkULIDTimeStamp = ULIDTimeStamp . round . (*1000) - --- | Generate a ULID Timestamp based on current system UNIX time -getULIDTimeStamp :: IO ULIDTimeStamp -getULIDTimeStamp = mkULIDTimeStamp <$> getPOSIXTime - -instance Show ULIDTimeStamp where - show (ULIDTimeStamp i) = CR.encode 10 i - -instance Read ULIDTimeStamp where - readsPrec _ = map (\(c,r)->(ULIDTimeStamp c, r)) . (CR.decode) 10 - -instance Binary ULIDTimeStamp where - put (ULIDTimeStamp i) = mapM_ put (unroll numBytes i) - get = ULIDTimeStamp <$> roll <$> replicateM numBytes get - -instance NFData ULIDTimeStamp where - rnf (ULIDTimeStamp i) = rnf i +-- | Custom data type for timestamps (milliseconds since 1970) + +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ULID.TimeStamp ( + ULIDTimeStamp, + mkULIDTimeStamp, + getULIDTimeStamp +) where + +import Control.DeepSeq +import Control.Monad +import Data.Binary +import Data.Binary.Roll +import Data.Data +import Data.Maybe +import Data.Text as T +import Data.Time.Clock +import Data.Time.Clock.POSIX + +import qualified Data.ULID.Base32 as B32 + + +numBytes = 6 -- 48 bits + +-- | UNIX time in milliseconds +newtype ULIDTimeStamp = ULIDTimeStamp Integer + deriving (Eq, Ord, Typeable, Data) + +instance Show ULIDTimeStamp where + show (ULIDTimeStamp i) = T.unpack $ B32.encode 10 i + +instance Read ULIDTimeStamp where + readsPrec _ = fmap + (\(int, rest)->(ULIDTimeStamp int, T.unpack rest)) + . (B32.decode) 10 + . T.pack + +instance Binary ULIDTimeStamp where + put (ULIDTimeStamp i) = mapM_ put (unroll numBytes i) + get = ULIDTimeStamp <$> roll <$> replicateM numBytes get + +instance NFData ULIDTimeStamp where + rnf (ULIDTimeStamp i) = rnf i + + +-- | Generate a ULID Timestamp based on a specified time +mkULIDTimeStamp + :: POSIXTime -- ^ Specified UNIX time with millisecond precision + -- (e.g. 1469918176.385) + -> ULIDTimeStamp +mkULIDTimeStamp = ULIDTimeStamp . round . (*1000) + + +-- | Generate a ULID Timestamp based on current system UNIX time +getULIDTimeStamp :: IO ULIDTimeStamp +getULIDTimeStamp = mkULIDTimeStamp <$> getPOSIXTime diff --git a/test/Data/ULID/Base32Spec.hs b/test/Data/ULID/Base32Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/ULID/Base32Spec.hs @@ -0,0 +1,43 @@ +module Data.ULID.Base32Spec where + +import Data.ULID.Base32 + +import Test.Hspec + + +-- | Known examples from +-- https://web.archive.org/web/20171219211624/crockfordbase32.codeplex.com +spec :: Spec +spec = do + describe "encode" $ do + it "compare to known examples" $ do + encode 1 1 `shouldBe` "1" + encode 2 194 `shouldBe` "62" + encode 11 3838385658376483 `shouldBe` "3D2ZQ6TVC93" + encode 13 18446744073709551615 `shouldBe` "FZZZZZZZZZZZZ" + + it "compare to known examples (padded)" $ do + encode 3 1 `shouldBe` "001" + encode 3 194 `shouldBe` "062" + encode 15 3838385658376483 `shouldBe` "00003D2ZQ6TVC93" + + describe "decode" $ do + it "compare to known examples" $ do + decode 1 "1" `shouldBe` [(1, "")] + decode 2 "62" `shouldBe` [(194, "")] + decode 11 "3D2ZQ6TVC93" `shouldBe` [(3838385658376483, "")] + decode 13 "FZZZZZZZZZZZZ" `shouldBe` [(18446744073709551615, "")] + + it "compare to known examples (padded)" $ do + decode 3 "001" `shouldBe` [(1, "")] + decode 3 "062" `shouldBe` [(194, "")] + decode 15 "00003D2ZQ6TVC93" `shouldBe` [(3838385658376483, "")] + + it "gives remainder text" $ do + decode 3 "001ABC" `shouldBe` [(1, "ABC")] + decode 3 "062DEF" `shouldBe` [(194, "DEF")] + decode 15 "00003D2ZQ6TVC93X1" `shouldBe` [(3838385658376483, "X1")] + + it "gives empty list if invalid" $ do + decode 3 "U01ABC" `shouldBe` [] + decode 2 "!01DEF" `shouldBe` [] diff --git a/test/Data/ULID/RandomSpec.hs b/test/Data/ULID/RandomSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/ULID/RandomSpec.hs @@ -0,0 +1,35 @@ +module Data.ULID.RandomSpec where + +import Data.Binary +import qualified Data.ByteString.Lazy as LBS + +import Data.ULID.Random + +import Test.Hspec + + +spec :: Spec +spec = do + describe "show/read" $ do + it "has show/read symmetry" $ do + a1 <- getULIDRandom + a2 <- getULIDRandom + a1 == a2 `shouldBe` False + read (show a1) `shouldBe` a1 + read (show a2) `shouldBe` a2 + + it "has correct show length" $ do + a1 <- getULIDRandom + length (show a1) `shouldBe` 16 + + describe "encode/decode" $ do + it "has correct binary length" $ do + a1 <- getULIDRandom + LBS.length (encode a1) `shouldBe` 10 -- 80 bit + + it "has encode/decode symmetry" $ do + a1 <- getULIDRandom + a2 <- getULIDRandom + a1 == a2 `shouldBe` False + decode (encode a1) `shouldBe` a1 + decode (encode a2) `shouldBe` a2 diff --git a/test/Data/ULID/TimeStampSpec.hs b/test/Data/ULID/TimeStampSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/ULID/TimeStampSpec.hs @@ -0,0 +1,46 @@ +module Data.ULID.TimeStampSpec where + +import Data.Binary +import qualified Data.ByteString.Lazy as LBS + +import Data.ULID.TimeStamp + +import Test.Hspec + + +spec :: Spec +spec = do + describe "show/read" $ do + it "works with a known value" $ do + show (mkULIDTimeStamp 1469918176.385) `shouldBe` "01ARYZ6S41" + + it "has show/read symmetry" $ do + let a1 = mkULIDTimeStamp 12345 + let a2 = mkULIDTimeStamp 54321 + a1 == a2 `shouldBe` False + read (show a1) `shouldBe` a1 + read (show a2) `shouldBe` a2 + + it "has correct show length" $ do + let a1 = mkULIDTimeStamp 12345 + length (show a1) `shouldBe` 10 + + describe "encode/decode" $ do + it "has correct binary length" $ do + let a1 = mkULIDTimeStamp 12345 + LBS.length (encode a1) `shouldBe` 6 -- 48 bit + + it "has encode/decode symmetry" $ do + let a1 = mkULIDTimeStamp 12345 + let a2 = mkULIDTimeStamp 54321 + a1 == a2 `shouldBe` False + decode (encode a1) `shouldBe` a1 + decode (encode a2) `shouldBe` a2 + + it "encodes MSB first" $ do + let a1 = mkULIDTimeStamp 12345 + let e1 = encode a1 + -- This works because the value is small, + -- so the MSB for this value should be 0 + LBS.head e1 `shouldBe` 0 + LBS.last e1 `shouldNotBe` 0 diff --git a/test/Data/ULIDSpec.hs b/test/Data/ULIDSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/ULIDSpec.hs @@ -0,0 +1,177 @@ +module Data.ULIDSpec where + +import Control.Concurrent +import Control.Monad (replicateM) +import Data.Binary +import qualified Data.ByteString.Lazy as LBS +import Data.Char +import Data.Hashable +import Data.List (nub, sort) +import qualified System.Random as R + +import Data.ULID + +import Test.Hspec + + +spec :: Spec +spec = do + describe "ulid capabilities" $ do + it "binary length 128-bit" $ do + a1 <- getULID + LBS.length (encode a1) `shouldBe` 16 -- 128 bit + + it "is lexicographically sortable" $ do + u1 <- getULID + threadDelay 1000 + u2 <- getULID + threadDelay 1000 + u3 <- getULID + threadDelay 1000 + u4 <- getULID + threadDelay 1000 + let l = [show u3, show u2, show u4, show u1] + let l' = sort l + l' `shouldBe` [show u1, show u2, show u3, show u4] + + -- make sure it works in internal representation too :) + let ul = [u3, u2, u4, u1] + let ul' = sort ul + ul' `shouldBe` [u1, u2, u3, u4] + + it "is encoded as 26 character text" $ do + u1 <- getULID + length (show u1) `shouldBe` 26 + + it "is case-insensitive" $ do + u1 <- getULID + let u2 = read (map toLower (show u1)) + let u3 = read (map toUpper (show u1)) + u1 `shouldBe` u2 + u1 `shouldBe` u3 + + it "no special characters" $ do + u1 <- getULID + filter (not.isAlphaNum) (show u1) `shouldBe` [] + + describe "ulid" $ do + it "starts with 0 (at least for the foreseeable future)" $ do + u1 <- getULID + head (show u1) `shouldBe` '0' + + it "generates unique ulids in default configuration" $ do + let ops = 1000 + ulids <- replicateM ops getULID + -- Verify uniqueness + let n' = length $ nub ulids + n' `shouldBe` ops + + describe "encode/decode" $ do + it "has encode/decode symmetry" $ do + a1 <- getULID + a2 <- getULID + a1 == a2 `shouldBe` False + decode (encode a1) `shouldBe` a1 + decode (encode a2) `shouldBe` a2 + encode a1 `shouldNotBe` encode a2 + + it "encodes MSB first" $ do + a1 <- getULIDTime 12345 + let e1 = encode a1 + -- This works because the time value is small, + -- and time is sequences first, + -- so the MSB for this value should be 0 + LBS.head e1 `shouldBe` 0 + LBS.last e1 `shouldNotBe` 0 + + describe "random" $ do + it "works in IO" $ do + u1 <- (R.randomIO :: IO ULID) + u2 <- (R.randomIO :: IO ULID) + u1 `shouldNotBe` u2 + + it "works with randomgen" $ do + g <- R.getStdGen + let (u1, g') = R.random g :: (ULID, R.StdGen) + let (u2, _) = R.random g' :: (ULID, R.StdGen) + u1 `shouldNotBe` u2 + + describe "hash" $ do + -- | The general contract of hashWithSalt is: + -- If two values are equal according to the == method, + -- then applying the hashWithSalt method on each of the two values + -- must produce the same integer result + -- if the same salt is used in each case. + it "produces same hash for equal ulids" $ do + u1 <- getULID + let u2 = (read (show u1)) :: ULID + let salt = 12345 + hashWithSalt salt u1 `shouldBe` hashWithSalt salt u2 + + -- | It is not required that if two values are unequal + -- according to the == method, + -- then applying the hashWithSalt method on each of the two values + -- must produce distinct integer results. + -- However, the programmer should be aware + -- that producing distinct integer results for unequal values + -- may improve the performance of hashing-based data structures. + it "produces different hash for nonequals ulids" $ do + u1 <- getULID + u2 <- getULID + let salt = 12345 + -- this could rarely fail due to hash nature + hashWithSalt salt u1 `shouldNotBe` hashWithSalt salt u2 + + -- | This method can be used to compute different hash values + -- for the same input by providing a different salt + -- in each application of the method. + -- This implies that any instance that defines `hashWithSalt` must + -- make use of the salt in its implementation. + it "produces different hash for equals ulids with different salt" $ do + u1 <- getULID + let u2 = (read (show u1)) :: ULID + let salt = 12345 + hashWithSalt salt u1 `shouldBe` hashWithSalt salt u2 + let salt2 = 54321 + hashWithSalt salt u1 `shouldNotBe` hashWithSalt salt2 u2 + + describe "to/from integer" $ do + it "is sortable" $ do + u1 <- getULID + threadDelay 1000 + u2 <- getULID + threadDelay 1000 + u3 <- getULID + threadDelay 1000 + u4 <- getULID + threadDelay 1000 + let + l = [ ulidToInteger u3 + , ulidToInteger u2 + , ulidToInteger u4 + , ulidToInteger u1 + ] + l' = sort l + l' `shouldBe` [ ulidToInteger u1 + , ulidToInteger u2 + , ulidToInteger u3 + , ulidToInteger u4 + ] + + it "has to/from symmetry" $ do + a1 <- getULID + a2 <- getULID + a1 == a2 `shouldBe` False + ulidFromInteger (ulidToInteger a1) `shouldBe` (Right a1) + ulidFromInteger (ulidToInteger a2) `shouldBe` (Right a2) + ulidToInteger a1 `shouldNotBe` ulidToInteger a2 + + it "handles out-of-range integer" $ do + a1 <- getULID + ulidFromInteger (negate (ulidToInteger a1)) + `shouldBe` Left "Value must not be negative" + ulidFromInteger (-1) + `shouldBe` Left "Value must not be negative" + ulidFromInteger (2 ^ 128) + `shouldBe` Left "Value must not be larger than \ + \the maximum safe Integer size (128 bits)" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,3 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover #-} --- see https://github.com/hspec/hspec-example/blob/master/strip.cabal +-- See https://github.com/hspec/hspec-example/blob/master/strip.cabal -- runhaskell -isrc -itest test/Spec.hs diff --git a/ulid.cabal b/ulid.cabal --- a/ulid.cabal +++ b/ulid.cabal @@ -1,50 +1,64 @@ name: ulid -version: 0.2.0.0 -synopsis: Implementation of ULID, lexicographically sortable unique identifiers -description: Implementation of alizain's ULID identifier. Canonically encoded as a 26 character string, as opposed to the 36 character UUID. - Uses Crockford's base32 for better efficiency and readability (5 bits per character) -homepage: https://github.com/steven777400/ulid +version: 0.3.0.0 +synopsis: Implementation of ULID - Universally Unique + Lexicographically Sortable Identifier +description: Implementation of Alizain Feerasta's ULID specification. + A 26 character string identifier, + as opposed to the 36 character UUID string. + Uses Douglas Crockford's base 32 encoding + for better efficiency and readability + (5 bits per character). +homepage: https://github.com/ad-si/ulid license: BSD3 license-file: LICENSE author: Steve Kollmansberger -maintainer: steve@kolls.net +maintainer: ulid@ad-si.com copyright: 2017 Steve Kollmansberger -category: Data +category: Data, Codec, Database build-type: Simple extra-source-files: README.md cabal-version: >=1.10 + library hs-source-dirs: src exposed-modules: Data.ULID - , Data.ULID.Crockford + , Data.ULID.Base32 + , Data.ULID.Digits , Data.ULID.Random , Data.ULID.TimeStamp - other-modules: Data.Binary.Roll + other-modules: Data.Binary.Roll build-depends: base >= 4.7 && < 5 - , crockford - , time - , crypto-api - , random - , bytestring , binary + , bytestring + , crypto-api , deepseq , hashable + , random + , text + , time default-language: Haskell2010 + default-extensions: OverloadedStrings + executable ulid-exe hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , ulid - , crypto-api + , crypto-api default-language: Haskell2010 + test-suite ulid-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: Data.ULID.Base32Spec + , Data.ULID.RandomSpec + , Data.ULID.TimeStampSpec + , Data.ULIDSpec build-depends: base , hspec , ulid @@ -54,18 +68,23 @@ , hashable ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 + default-extensions: OverloadedStrings + benchmark ulid-bench - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Main.hs - build-depends: base - , ulid - , time - , text - , format-numbers - , deepseq + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base + , ulid + , time + , text + , format-numbers + , deepseq + default-language: Haskell2010 + default-extensions: OverloadedStrings + source-repository head type: git - location: https://github.com/steven777400/ulid.git + location: https://github.com/ad-si/ulid.git