diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +1.0.0 + +- Initial split from "uuid-1.3.8" diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,13 @@ +In order of appearance: + +Antoine Latter +Jason Dusek +Tim Newsham +Mark Lentczner +Neil Mitchell +Bas van Dijk +Sergei Trofimovich +davean +Francesco Mazzoli +Michael Snoyman +Bardur Arantsson diff --git a/Data/UUID/Types.hs b/Data/UUID/Types.hs new file mode 100644 --- /dev/null +++ b/Data/UUID/Types.hs @@ -0,0 +1,37 @@ +{- | +Module : Data.UUID.Types +Copyright : (c) 2008,2012 Antoine Latter + +License : BSD-style + +Maintainer : aslatter@gmail.com +Stability : experimental +Portability : portable + + +This library is useful for comparing, parsing and +printing Universally Unique Identifiers. +See for the general idea. +See for the specification. + +-} +module Data.UUID.Types(UUID + ,toString + ,fromString + ,toASCIIBytes + ,fromASCIIBytes + ,toLazyASCIIBytes + ,fromLazyASCIIBytes + ,toByteString + ,fromByteString + ,toWords + ,fromWords + ,null + ,nil + ) where + +import Prelude () -- we need to hide Prelude.null +import Data.UUID.Types.Internal + +-- Everything is really implemented in Data.UUID.Types.Internal, but I +-- don't want to export the constructors out of the package. diff --git a/Data/UUID/Types/Internal.hs b/Data/UUID/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/UUID/Types/Internal.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Module : Data.UUID.Types.Internal +-- Copyright : (c) 2008-2009, 2012 Antoine Latter +-- (c) 2009 Mark Lentczner +-- +-- License : BSD-style +-- +-- Maintainer : aslatter@gmail.com +-- Stability : experimental +-- Portability : portable + +module Data.UUID.Types.Internal + (UUID(..) + ,null + ,nil + ,fromByteString + ,toByteString + ,fromString + ,toString + ,fromWords + ,toWords + ,toList + ,buildFromBytes + ,buildFromWords + ,fromASCIIBytes + ,toASCIIBytes + ,fromLazyASCIIBytes + ,toLazyASCIIBytes + ,UnpackedUUID(..) + ,pack + ,unpack + ) where + +import Prelude hiding (null) + +import Control.Applicative ((<*>)) +import Control.DeepSeq (NFData(..)) +import Control.Monad (liftM4, guard) +import Data.Functor ((<$>)) +import Data.Char +import Data.Bits +import Data.Hashable +import Data.List (elemIndices) +import Foreign.Ptr (Ptr) + +#if MIN_VERSION_base(4,0,0) +import Data.Data +#else +import Data.Generics.Basics +#endif + +import Foreign.Storable + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Unsafe as BU + +import Data.UUID.Types.Internal.Builder + +import System.Random + + +-- |The UUID type. A 'Random' instance is provided which produces +-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and +-- 'Binary' instances are compatible with RFC 4122, storing the fields +-- in network order as 16 bytes. +data UUID + = UUID + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + deriving (Eq, Ord, Typeable) +{- + Other representations that we tried are: + Mimic V1 structure: !Word32 !Word16 !Word16 !Word16 + !Word8 !Word8 !Word8 !Word8 !Word8 !Word8 + Sixteen bytes: !Word8 ... (x 16) + Simple list of bytes: [Word8] + ByteString (strict) ByteString + Immutable array: UArray Int Word8 + Vector: UArr Word8 + None was as fast, overall, as the representation used here. +-} + +-- | Covert a 'UUID' into a sequence of 'Word32' values. +-- Useful for when you need to serialize a UUID and +-- neither 'Storable' nor 'Binary' are appropriate. +-- Introduced in version 1.2.2. +toWords :: UUID -> (Word32, Word32, Word32, Word32) +toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4) + +-- | Create a 'UUID' from a sequence of 'Word32'. The +-- opposite of 'toWords'. Useful when you need a total +-- function for constructing 'UUID' values. +-- Introduced in version 1.2.2. +fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID +fromWords = UUID + +data UnpackedUUID = + UnpackedUUID { + time_low :: Word32 -- 0-3 + , time_mid :: Word16 -- 4-5 + , time_hi_and_version :: Word16 -- 6-7 + , clock_seq_hi_res :: Word8 -- 8 + , clock_seq_low :: Word8 -- 9 + , node_0 :: Word8 + , node_1 :: Word8 + , node_2 :: Word8 + , node_3 :: Word8 + , node_4 :: Word8 + , node_5 :: Word8 + } + deriving (Read, Show, Eq, Ord) + +unpack :: UUID -> UnpackedUUID +unpack (UUID w0 w1 w2 w3) = + build /-/ w0 /-/ w1 /-/ w2 /-/ w3 + + where + build x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF = + UnpackedUUID { + time_low = word x0 x1 x2 x3 + , time_mid = w8to16 x4 x5 + , time_hi_and_version = w8to16 x6 x7 + , clock_seq_hi_res = x8 + , clock_seq_low = x9 + , node_0 = xA + , node_1 = xB + , node_2 = xC + , node_3 = xD + , node_4 = xE + , node_5 = xF + } + +pack :: UnpackedUUID -> UUID +pack unpacked = + makeFromBytes /-/ (time_low unpacked) + /-/ (time_mid unpacked) + /-/ (time_hi_and_version unpacked) + /-/ (clock_seq_hi_res unpacked) + /-/ (clock_seq_low unpacked) + /-/ (node_0 unpacked) /-/ (node_1 unpacked) + /-/ (node_2 unpacked) /-/ (node_3 unpacked) + /-/ (node_4 unpacked) /-/ (node_5 unpacked) + + +-- +-- UTILITIES +-- + +-- |Build a Word32 from four Word8 values, presented in big-endian order +word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 +word a b c d = (fromIntegral a `shiftL` 24) + .|. (fromIntegral b `shiftL` 16) + .|. (fromIntegral c `shiftL` 8) + .|. (fromIntegral d ) + +-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0, +byte :: Int -> Word32 -> Word8 +byte i w = fromIntegral (w `shiftR` (i * 8)) + +-- |Build a Word16 from two Word8 values, presented in big-endian order. +w8to16 :: Word8 -> Word8 -> Word16 +w8to16 w0s w1s = + (w0 `shiftL` 8) .|. w1 + where + w0 = fromIntegral w0s + w1 = fromIntegral w1s + + +-- |Make a UUID from sixteen Word8 values +makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> UUID +makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf + = UUID w0 w1 w2 w3 + where w0 = word b0 b1 b2 b3 + w1 = word b4 b5 b6 b7 + w2 = word b8 b9 ba bb + w3 = word bc bd be bf + +-- |Make a UUID from four Word32 values +makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID +makeFromWords = UUID + +-- |A Builder for constructing a UUID of a given version. +buildFromBytes :: Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> UUID +buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf = + makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf + where b6' = b6 .&. 0x0f .|. (v `shiftL` 4) + b8' = b8 .&. 0x3f .|. 0x80 + +-- |Build a UUID of a given version from Word32 values. +buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID +buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3 + where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12) + w2' = w2 .&. 0x3fffffff .|. 0x80000000 + + +-- |Return the bytes that make up the UUID +toList :: UUID -> [Word8] +toList (UUID w0 w1 w2 w3) = + [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0, + byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1, + byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2, + byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3] + +-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't +-- exactly sixteen bytes long +fromList :: [Word8] -> Maybe UUID +fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] = + Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf +fromList _ = Nothing + + +-- +-- UUID API +-- + +-- |Returns true if the passed-in UUID is the 'nil' UUID. +null :: UUID -> Bool +null = (== nil) + -- Note: This actually faster than: + -- null (UUID 0 0 0 0) = True + -- null _ = False + +-- |The nil UUID, as defined in RFC 4122. +-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@. +nil :: UUID +nil = UUID 0 0 0 0 + +-- |Extract a UUID from a 'ByteString' in network byte order. +-- The argument must be 16 bytes long, otherwise 'Nothing' is returned. +fromByteString :: BL.ByteString -> Maybe UUID +fromByteString = fromList . BL.unpack + +-- |Encode a UUID into a 'ByteString' in network order. +toByteString :: UUID -> BL.ByteString +toByteString = BL.pack . toList + +-- |If the passed in 'String' can be parsed as a 'UUID', it will be. +-- The hyphens may not be omitted. +-- Example: +-- +-- @ +-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\" +-- @ +-- +-- Hex digits may be upper or lower-case. +fromString :: String -> Maybe UUID +fromString xs | validFmt = fromString' xs + | otherwise = Nothing + where validFmt = elemIndices '-' xs == [8,13,18,23] + +fromString' :: String -> Maybe UUID +fromString' s0 = do + (w0, s1) <- hexWord s0 + (w1, s2) <- hexWord s1 + (w2, s3) <- hexWord s2 + (w3, s4) <- hexWord s3 + if s4 /= "" then Nothing + else Just $ UUID w0 w1 w2 w3 + where hexWord :: String -> Maybe (Word32, String) + hexWord s = Just (0, s) >>= hexByte >>= hexByte + >>= hexByte >>= hexByte + + hexByte :: (Word32, String) -> Maybe (Word32, String) + hexByte (w, '-':ds) = hexByte (w, ds) + hexByte (w, hi:lo:ds) + | bothHex = Just ((w `shiftL` 8) .|. octet, ds) + | otherwise = Nothing + where bothHex = isHexDigit hi && isHexDigit lo + octet = fromIntegral (16 * digitToInt hi + digitToInt lo) + hexByte _ = Nothing + +-- | Convert a UUID into a hypenated string using lower-case letters. +-- Example: +-- +-- @ +-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\" +-- @ +toString :: UUID -> String +toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 "" + where hexw :: Word32 -> String -> String + hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16 + : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s + + hexw' :: Word32 -> String -> String + hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16 + : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s + + hexn :: Word32 -> Int -> Char + hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf) + +-- | Convert a UUID into a hyphentated string using lower-case letters, packed +-- as ASCII bytes into `B.ByteString`. +-- +-- This should be equivalent to `toString` with `Data.ByteString.Char8.pack`. +toASCIIBytes :: UUID -> B.ByteString +toASCIIBytes uuid = BI.unsafeCreate 36 (pokeASCII uuid) + +-- | Helper function for `toASCIIBytes` +pokeASCII :: UUID -> Ptr Word8 -> IO () +pokeASCII uuid ptr = do + pokeDash 8 + pokeDash 13 + pokeDash 18 + pokeDash 23 + pokeSingle 0 w0 + pokeDouble 9 w1 + pokeDouble 19 w2 + pokeSingle 28 w3 + where + (w0, w1, w2, w3) = toWords uuid + + -- ord '-' ==> 45 + pokeDash ix = pokeElemOff ptr ix 45 + + pokeSingle ix w = do + pokeWord ix w 28 + pokeWord (ix + 1) w 24 + pokeWord (ix + 2) w 20 + pokeWord (ix + 3) w 16 + pokeWord (ix + 4) w 12 + pokeWord (ix + 5) w 8 + pokeWord (ix + 6) w 4 + pokeWord (ix + 7) w 0 + + -- We skip the dash in the middle + pokeDouble ix w = do + pokeWord ix w 28 + pokeWord (ix + 1) w 24 + pokeWord (ix + 2) w 20 + pokeWord (ix + 3) w 16 + pokeWord (ix + 5) w 12 + pokeWord (ix + 6) w 8 + pokeWord (ix + 7) w 4 + pokeWord (ix + 8) w 0 + + pokeWord ix w r = + pokeElemOff ptr ix (fromIntegral (toDigit ((w `shiftR` r) .&. 0xf))) + + toDigit :: Word32 -> Word32 + toDigit w = if w < 10 then 48 + w else 97 + w - 10 + +-- | If the passed in `B.ByteString` can be parsed as an ASCII representation of +-- a `UUID`, it will be. The hyphens may not be omitted. +-- +-- This should be equivalent to `fromString` with `Data.ByteString.Char8.unpack`. +fromASCIIBytes :: B.ByteString -> Maybe UUID +fromASCIIBytes bs = do + guard wellFormed + fromWords <$> single 0 <*> double 9 14 <*> double 19 24 <*> single 28 + where + -- ord '-' ==> 45 + dashIx bs' ix = BU.unsafeIndex bs' ix == 45 + + -- Important: check the length first, given the `unsafeIndex` later. + wellFormed = + B.length bs == 36 && dashIx bs 8 && dashIx bs 13 && + dashIx bs 18 && dashIx bs 23 + + single ix = combine <$> octet ix <*> octet (ix + 2) + <*> octet (ix + 4) <*> octet (ix + 6) + double ix0 ix1 = combine <$> octet ix0 <*> octet (ix0 + 2) + <*> octet ix1 <*> octet (ix1 + 2) + + combine o0 o1 o2 o3 = shiftL o0 24 .|. shiftL o1 16 .|. shiftL o2 8 .|. o3 + + octet ix = do + hi <- fromIntegral <$> toDigit (BU.unsafeIndex bs ix) + lo <- fromIntegral <$> toDigit (BU.unsafeIndex bs (ix + 1)) + return (16 * hi + lo) + + toDigit :: Word8 -> Maybe Word8 + toDigit w + -- Digit + | w >= 48 && w <= 57 = Just (w - 48) + -- Uppercase + | w >= 65 && w <= 70 = Just (10 + w - 65) + -- Lowercase + | w >= 97 && w <= 102 = Just (10 + w - 97) + | otherwise = Nothing + +-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`. +toLazyASCIIBytes :: UUID -> BL.ByteString +toLazyASCIIBytes = +#if MIN_VERSION_bytestring(0,10,0) + BL.fromStrict +#else + BL.fromChunks . return +#endif + . toASCIIBytes + +-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`. +fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID +fromLazyASCIIBytes bs = + if BL.length bs == 36 then fromASCIIBytes ( +#if MIN_VERSION_bytestring(0,10,0) + BL.toStrict bs +#else + B.concat $ BL.toChunks bs +#endif + ) else Nothing + +-- +-- Class Instances +-- + +instance Random UUID where + random g = (fromGenNext w0 w1 w2 w3 w4, g4) + where (w0, g0) = next g + (w1, g1) = next g0 + (w2, g2) = next g1 + (w3, g3) = next g2 + (w4, g4) = next g3 + randomR _ = random -- range is ignored + +-- |Build a UUID from the results of five calls to next on a StdGen. +-- While next on StdGet returns an Int, it doesn't provide 32 bits of +-- randomness. This code relies on at last 28 bits of randomness in the +-- and optimizes its use so as to make only five random values, not six. +fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID +fromGenNext w0 w1 w2 w3 w4 = + buildFromBytes 4 /-/ (ThreeByte w0) + /-/ (ThreeByte w1) + /-/ w2 -- use all 4 bytes because we know the version + -- field will "cover" the upper, non-random bits + /-/ (ThreeByte w3) + /-/ (ThreeByte w4) + +-- |A ByteSource to extract only three bytes from an Int, since next on StdGet +-- only returns 31 bits of randomness. +type instance ByteSink ThreeByte g = Takes3Bytes g +newtype ThreeByte = ThreeByte Int +instance ByteSource ThreeByte where + f /-/ (ThreeByte w) = f b1 b2 b3 + where b1 = fromIntegral (w `shiftR` 16) + b2 = fromIntegral (w `shiftR` 8) + b3 = fromIntegral w + +instance NFData UUID where + rnf = rnf . toWords + +instance Hashable UUID where + hash (UUID w0 w1 w2 w3) = + hash w0 `hashWithSalt` w1 + `hashWithSalt` w2 + `hashWithSalt` w3 + hashWithSalt s (UUID w0 w1 w2 w3) = + s `hashWithSalt` w0 + `hashWithSalt` w1 + `hashWithSalt` w2 + `hashWithSalt` w3 + +instance Show UUID where + show = toString + +instance Read UUID where + readsPrec _ str = + let noSpaces = dropWhile isSpace str + in case fromString (take 36 noSpaces) of + Nothing -> [] + Just u -> [(u,drop 36 noSpaces)] + + +instance Storable UUID where + sizeOf _ = 16 + alignment _ = 4 + + peekByteOff p off = + pack <$> + (UnpackedUUID + <$> peekByteOff p off -- Word32 + <*> peekByteOff p (off+4) -- Word16 + <*> peekByteOff p (off+6) -- Word16 + <*> peekByteOff p (off+8) -- Word8 + <*> peekByteOff p (off+9) -- Word8 + <*> peekByteOff p (off+10) -- Word8 + <*> peekByteOff p (off+11) -- Word8 + <*> peekByteOff p (off+12) -- Word8 + <*> peekByteOff p (off+13) -- Word8 + <*> peekByteOff p (off+14) -- Word8 + <*> peekByteOff p (off+15) -- Word8 + ) + + pokeByteOff p off u = + case unpack u of + (UnpackedUUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) -> + do + pokeByteOff p off x0 + pokeByteOff p (off+4) x1 + pokeByteOff p (off+6) x2 + pokeByteOff p (off+8) x3 + pokeByteOff p (off+9) x4 + pokeByteOff p (off+10) x5 + pokeByteOff p (off+11) x6 + pokeByteOff p (off+12) x7 + pokeByteOff p (off+13) x8 + pokeByteOff p (off+14) x9 + pokeByteOff p (off+15) x10 + +instance Binary UUID where + put (UUID w0 w1 w2 w3) = + putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3 + get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be + + +-- My goal with this instance was to make it work just enough to do what +-- I want when used with the HStringTemplate library. +instance Data UUID where + toConstr uu = mkConstr uuidType (show uu) [] (error "fixity") + gunfold _ _ = error "gunfold" + dataTypeOf _ = uuidType + +uuidType :: DataType +uuidType = mkNoRepType "Data.UUID.Types.UUID" + +#if !(MIN_VERSION_base(4,2,0)) +mkNoRepType :: String -> DataType +mkNoRepType = mkNorepType +#endif diff --git a/Data/UUID/Types/Internal/Builder.hs b/Data/UUID/Types/Internal/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/UUID/Types/Internal/Builder.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK hide #-} + +-- Module : Data.UUID.Types.Internal.Builder +-- Copyright : (c) 2009 Mark Lentczner +-- +-- License : BSD-style +-- +-- Maintainer : markl@glyphic.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides a system that can call a function that takes +-- a sequence of some number of Word8 arguments. +-- +-- The twist is that the Word8 arguments can be supplied directly +-- from Word8s, or from other sources that may provide more than +-- one Word8 apiece. Examples are Word16 and Word32 that supply +-- two and four Word8s respectively. Other ByteSource instances +-- can be defined. +-- +-- This module is admittedly overkill. There are only three places +-- in the uuid package that need to call buildFromBytes with 16 +-- Word8 values, but each place uses Words of different lengths: +-- version 1 uuids: 32-16-16-16-8-8-8-8-8-8 +-- version 4 uuids: 24-24-32-24-24 +-- version 5 uuids: 32-32-32-32 +-- Originally, these three constructions were hand coded but the +-- code was ungainly. Using this module makes the code very +-- concise, and turns out to optimize to just as fast, or faster! + +module Data.UUID.Types.Internal.Builder + (ByteSource(..) + ,ByteSink + ,Takes1Byte + ,Takes2Bytes + ,Takes3Bytes + ,Takes4Bytes + ) where + +import Data.Bits +import Data.Word + + + +type Takes1Byte g = Word8 -> g +type Takes2Bytes g = Word8 -> Word8 -> g +type Takes3Bytes g = Word8 -> Word8 -> Word8 -> g +type Takes4Bytes g = Word8 -> Word8 -> Word8 -> Word8 -> g + +-- | Type of function that a given ByteSource needs. +-- This function must take as many Word8 arguments as the ByteSource provides +type family ByteSink w g +type instance ByteSink Word8 g = Takes1Byte g +type instance ByteSink Word16 g = Takes2Bytes g +type instance ByteSink Word32 g = Takes4Bytes g +type instance ByteSink Int g = Takes4Bytes g + + +-- | Class of types that can add Word8s to a Builder. +-- Instances for Word8, Word16, Word32 and Int provide 1, 2, 4 and 4 bytes, +-- respectively, into a ByteSink +class ByteSource w where + -- | Apply the source's bytes to the sink + (/-/) :: ByteSink w g -> w -> g + +infixl 6 /-/ + +instance ByteSource Word8 where + f /-/ w = f w + +instance ByteSource Word16 where + f /-/ w = f b1 b2 + where b1 = fromIntegral (w `shiftR` 8) + b2 = fromIntegral w + +instance ByteSource Word32 where + f /-/ w = f b1 b2 b3 b4 + where b1 = fromIntegral (w `shiftR` 24) + b2 = fromIntegral (w `shiftR` 16) + b3 = fromIntegral (w `shiftR` 8) + b4 = fromIntegral w + +instance ByteSource Int where + f /-/ w = f b1 b2 b3 b4 + where b1 = fromIntegral (w `shiftR` 24) + b2 = fromIntegral (w `shiftR` 16) + b3 = fromIntegral (w `shiftR` 8) + b4 = fromIntegral w diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2008, Antoine Latter + +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. + * The names of the authors may not 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple +main :: IO () +main = defaultMain + diff --git a/tests/BenchByteString.hs b/tests/BenchByteString.hs new file mode 100644 --- /dev/null +++ b/tests/BenchByteString.hs @@ -0,0 +1,82 @@ +import Control.Applicative ((<*>)) +import Data.Functor ((<$>)) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC8 +import System.Random +import Test.QuickCheck + +import Criterion +import Criterion.Main + +import Data.UUID.Types + +instance Arbitrary UUID where + arbitrary = + fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +-- Testing what we do in the codebase +fromASCIIBytes_naive :: ByteString -> Maybe UUID +fromASCIIBytes_naive = fromString . BC8.unpack + +toASCIIBytes_naive :: UUID -> ByteString +toASCIIBytes_naive = BC8.pack . toString + +randomUUIDs :: IO [UUID] +randomUUIDs = sample' arbitrary + +randomCorrect :: IO [String] +randomCorrect = map toString <$> randomUUIDs + +randomSlightlyWrong :: IO [String] +randomSlightlyWrong = mapM screw =<< randomCorrect + where + screw s = do + ix <- randomRIO (0, length s - 1) + return (take ix s ++ "x" ++ drop (ix + 1) s) + +randomVeryWrong :: IO [String] +randomVeryWrong = sample' arbitrary + +main :: IO () +main = do + uuids <- randomUUIDs + correct <- randomCorrect + let correctBytes = map BC8.pack correct + slightlyWrong <- randomSlightlyWrong + let slightlyWrongBytes = map BC8.pack slightlyWrong + veryWrong <- randomVeryWrong + let veryWrongBytes = map BC8.pack veryWrong + + defaultMain + [ bgroup "decoding" + [ bcompare + [ bgroup "correct" + [ bench "fromASCIIBytes" (nf (map fromASCIIBytes) correctBytes) + , bench "fromString" (nf (map fromString) correct) + , bench "fromASCIIBytes_naive" (nf (map fromASCIIBytes_naive) correctBytes) + ] + ] + , bcompare + [ bgroup "slightly wrong" + [ bench "fromASCIIBytes" (nf (map fromASCIIBytes) slightlyWrongBytes) + , bench "fromString" (nf (map fromString) slightlyWrong) + , bench "fromASCIIBytes_naive" (nf (map fromASCIIBytes_naive) slightlyWrongBytes) + ] + ] + , bcompare + [ bgroup "very wrong" + [ bench "fromASCIIBytes" (nf (map fromASCIIBytes) veryWrongBytes) + , bench "fromString" (nf (map fromString) veryWrong) + , bench "fromASCIIBytes_naive" (nf (map fromASCIIBytes_naive) veryWrongBytes) + ] + ] + ] + , bcompare + [ bgroup "encoding" + [ bench "toASCIIBytes" (nf (map toASCIIBytes) uuids) + , bench "toString" (nf (map toString) uuids) + , bench "toASCIIBytes_naive" (nf (map toASCIIBytes_naive) uuids) + ] + ] + ] diff --git a/tests/BenchUUID.hs b/tests/BenchUUID.hs new file mode 100644 --- /dev/null +++ b/tests/BenchUUID.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} + +#if !(MIN_VERSION_bytestring(0,10,0)) +-- Needed for NFData instance +import Control.DeepSeq +import qualified Data.ByteString.Lazy.Internal as BL +#endif +import Criterion.Main +import Data.Maybe (fromJust) +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as BL +import qualified Data.UUID.Types as U +import Foreign (alloca, peek, poke) +import System.Random + +#if !(MIN_VERSION_bytestring(0,10,0)) +instance NFData BL.ByteString where + rnf BL.Empty = () + rnf (BL.Chunk _ ts) = rnf ts +#endif + +main :: IO () +main = do + u1 <- randomIO + let s1 = U.toString u1 + b1 = U.toByteString u1 + nil2 = fromJust $ + U.fromString "00000000-0000-0000-0000-000000000000" + u2a = fromJust $ U.fromString "169a5a43-c051-4a16-98f4-08447ddd5dc0" + u2b = fromJust $ U.fromByteString $ + BL.pack [0x16, 0x9a, 0x5a, 0x43, 0xc0, 0x51, 0x4a, 0x16, + 0x98, 0xf4, 0x08, 0x44, 0x7d, 0xdd, 0x5d, 0xc0] + u3 = fromJust $ U.fromString "dea6f619-1038-438b-b4af-f1cdec1e6e23" + + -- setup for Storable benchmark + alloca $ \ uuidPtr -> do + + poke uuidPtr u1 + + defaultMain [ + bgroup "testing" [ + bench "null non-nil" $ whnf U.null u1, + bench "null nil" $ whnf U.null U.nil, + bench "null nil2" $ whnf U.null nil2, + bench "eq same" $ whnf (==u2a) u2b, + bench "eq differ" $ whnf (==u2a) u3 + ], + bgroup "conversion" [ + bench "toString" $ nf U.toString u1, + bench "fromString" $ nf U.fromString s1, + bench "toByteString" $ nf U.toByteString u1, + bench "fromByteString" $ nf U.fromByteString b1 + ], + bench "set making" $ nf Set.fromList uuids, + + bgroup "storable" [ + bench "peek" $ nfIO (peek uuidPtr), + bench "poke" $ poke uuidPtr u1 + ] + ] + +-- 50 uuids, so tests can be repeatable +uuids :: [U.UUID] +uuids + = map (fromJust . U.fromString) + [ + "35d42593-1fca-4465-b588-a2e78cb996ba", + "1e97e407-eca7-4c5d-a947-6fbe9dc168b6", + "a41fd7ce-a053-4c0a-a742-77c95b85da2a", + "f7e3913a-0fd7-4355-a92f-d73f9b046efa", + "8961a35d-55c2-42f3-8680-08fce3986647", + "96246c58-d0b4-4e56-a543-356bd59686a9", + "72c46194-648c-4b1e-a9fb-2eba060ab43b", + "0fc252d4-a37b-4eca-9309-e3d2a59a3a22", + "a8aceb5a-6a8e-43f3-85bb-9653a3c1ebcd", + "b23d1118-6bc8-4add-9d56-99634d78949f", + "5f8c7896-9c4f-4d7e-a4d2-961bda298012", + "219a4137-7bc5-42b1-ac95-490948a978e1", + "5af5024f-fbe9-45ab-991d-49b655994437", + "569dfb33-185d-4a3c-99c4-bc2b83250a7c", + "43a58442-aa51-4a5d-8e00-b8a83b5fc5b0", + "2865ced1-b54d-4725-8f01-b408f4617424", + "b8cfaff0-4dee-4f32-af2f-0469b3e535fc", + "63f45bc0-f303-4f1a-b0d6-76f876be626d", + "d171eaf3-f20d-45d6-9268-0cc22dfbe887", + "7c28f457-ad27-494a-8642-6e47e7f3efb8", + "f8de9193-66ff-49e8-9826-fc50858d7855", + "2af85f28-cace-4740-b8bb-2b5860f5fdb3", + "b12a7a22-edb3-4694-b8f4-0532eaad6112", + "5e052a08-8e49-4668-bbe7-77cdbc4679a3", + "42d5a68d-3f08-4e39-9b8c-71cc17c538ed", + "ba2b1487-b3a4-4a19-98cc-59530f36613f", + "e4a5c569-b8ac-4851-8ad2-fbdb89986be2", + "35b4a1b6-b5ca-4646-803b-c337ee730d9a", + "f0df1206-05d9-49d6-a726-d49fb253e645", + "9656a0f0-89b2-4cec-bb1c-fdf5633e1cd7", + "d13382f5-04a1-422d-94d6-e47219425816", + "b8d0c762-4c6b-4bd0-ad0b-f68988a87166", + "06360e85-f18a-44f6-aa72-45f1e60b6b77", + "347491ca-62b3-48e8-ac94-6ffebe1318ed", + "014339d0-7b2d-4dda-914b-14ee5cb4391b", + "dc57931b-4744-41be-b3c4-e24dbeeb606a", + "2c9fdcf0-e1d6-4a2d-951d-4766b99032cb", + "b6bde422-eea8-4231-bf1c-ee0e56699511", + "921073c5-f7c1-4583-ac03-aeb7aef8662b", + "eff6a517-aeb1-453e-9810-1b4b324c5a1e", + "eadaae8c-cbf8-4e0b-ab80-e34284b07dad", + "4d307c36-70d9-453f-8455-ec7e2ba405ed", + "53ddef9a-2413-4f7f-8363-cff56ee17c6c", + "4dd4c27a-b300-4a00-ab87-eef505275492", + "4a5d7001-f0c1-4e2f-8362-8833bda2114b", + "0c46f438-9365-406a-b04e-34436806ec25", + "b35469cf-05f8-40ff-a38b-117604347957", + "f1c54df0-5f59-4891-b3c6-82bac0d814ca", + "8091837c-6456-42c3-a686-f4731a41d4f9", + "2a0e2efb-a11c-4a44-81ee-3efc37379b48" + ] diff --git a/tests/TestUUID.hs b/tests/TestUUID.hs new file mode 100644 --- /dev/null +++ b/tests/TestUUID.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE ViewPatterns #-} +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Char8 as BC8 +import Data.Char (ord) +import Data.Functor ((<$>)) +import Data.Word +import qualified Data.UUID.Types as U +import Foreign (alloca, peek, poke) +import System.IO.Unsafe (unsafePerformIO) +import qualified Test.HUnit as H +import Test.HUnit hiding (Test) +import Test.QuickCheck hiding ((.&.)) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (hUnitTestToTests) +import Test.Framework.Providers.QuickCheck2 (testProperty) + + +instance Arbitrary U.UUID where + -- the UUID random instance ignores bounds + arbitrary = choose (U.nil, U.nil) + + +test_null :: H.Test +test_null = H.TestList [ + "nil is null" ~: assertBool "" (U.null U.nil) + ] + +test_nil :: H.Test +test_nil = H.TestList [ + "nil string" ~: U.toString U.nil @?= "00000000-0000-0000-0000-000000000000", + "nil bytes" ~: U.toByteString U.nil @?= BL.pack (replicate 16 0) + ] + +test_conv :: H.Test +test_conv = H.TestList [ + "conv bytes to string" ~: + maybe "" (U.toString) (U.fromByteString b16) @?= s16, + "conv string to bytes" ~: + maybe BL.empty (U.toByteString) (U.fromString s16) @?= b16 + ] + where b16 = BL.pack [1..16] + s16 = "01020304-0506-0708-090a-0b0c0d0e0f10" + +-- | Test fromByteString with a fixed-input. +test_fromByteString :: H.Test +test_fromByteString = + "UUID fromByteString" ~: + Just inputUUID @=? + U.fromByteString (BL8.pack "\165\202\133f\217\197H5\153\200\225\241>s\181\226") + +-- | Test fromWords with a fixed-input +test_fromWords :: H.Test +test_fromWords = + "UUID fromWords" ~: + inputUUID @=? U.fromWords 2781513062 3653584949 2580079089 1047770594 + +inputUUID :: U.UUID +inputUUID = read "a5ca8566-d9c5-4835-99c8-e1f13e73b5e2" + +prop_stringRoundTrip :: Test +prop_stringRoundTrip = testProperty "String round trip" stringRoundTrip + where stringRoundTrip :: U.UUID -> Bool + stringRoundTrip u = maybe False (== u) $ U.fromString (U.toString u) + +prop_byteStringRoundTrip :: Test +prop_byteStringRoundTrip = testProperty "ByteString round trip" byteStringRoundTrip + where byteStringRoundTrip :: U.UUID -> Bool + byteStringRoundTrip u = maybe False (== u) + $ U.fromByteString (U.toByteString u) + +prop_stringLength :: Test +prop_stringLength = testProperty "String length" stringLength + where stringLength :: U.UUID -> Bool + stringLength u = length (U.toString u) == 36 + +prop_byteStringLength :: Test +prop_byteStringLength = testProperty "ByteString length" byteStringLength + where byteStringLength :: U.UUID -> Bool + byteStringLength u = BL.length (U.toByteString u) == 16 + +prop_randomsDiffer :: Test +prop_randomsDiffer = testProperty "Randoms differ" randomsDiffer + where randomsDiffer :: (U.UUID, U.UUID) -> Bool + randomsDiffer (u1, u2) = u1 /= u2 + +prop_randomNotNull :: Test +prop_randomNotNull = testProperty "Random not null" randomNotNull + where randomNotNull :: U.UUID -> Bool + randomNotNull = not. U.null + +prop_readShowRoundTrip :: Test +prop_readShowRoundTrip = testProperty "Read/Show round-trip" prop + where -- we're using 'Maybe UUID' to add a bit of + -- real-world complexity. + prop :: U.UUID -> Bool + prop uuid = read (show (Just uuid)) == Just uuid + +-- Mostly going to test for wrong UUIDs +fromASCIIBytes_fromString1 :: String -> Bool +fromASCIIBytes_fromString1 s = + if all (\c -> ord c < 256) s + then U.fromString s == U.fromASCIIBytes (BC8.pack s) + else True + +fromASCIIBytes_fromString2 :: U.UUID -> Bool +fromASCIIBytes_fromString2 (U.toString -> s) = + U.fromString s == U.fromASCIIBytes (BC8.pack s) + +toASCIIBytes_toString :: U.UUID -> Bool +toASCIIBytes_toString uuid = + U.toString uuid == BC8.unpack (U.toASCIIBytes uuid) + +fromASCIIBytes_toASCIIBytes :: U.UUID -> Bool +fromASCIIBytes_toASCIIBytes (BC8.pack . U.toString -> bs) = + Just bs == (U.toASCIIBytes <$> U.fromASCIIBytes bs) + +toASCIIBytes_fromASCIIBytes :: U.UUID -> Bool +toASCIIBytes_fromASCIIBytes uuid = + Just uuid == U.fromASCIIBytes (U.toASCIIBytes uuid) + +toWords_fromWords :: U.UUID -> Bool +toWords_fromWords uuid = + uuid == myUncurry4 U.fromWords (U.toWords uuid) + +fromWords_toWords :: (Word32, Word32, Word32, Word32) -> Bool +fromWords_toWords wds = + wds == U.toWords (myUncurry4 U.fromWords wds) + +myUncurry4 :: (x1 -> x2 -> x3 -> x4 -> y) -> (x1, x2, x3, x4) -> y +myUncurry4 f (a,b,c,d) = f a b c d + +prop_storableRoundTrip :: Test +prop_storableRoundTrip = + testProperty "Storeable round-trip" $ unsafePerformIO . prop + where + prop :: U.UUID -> IO Bool + prop uuid = + alloca $ \ptr -> do + poke ptr uuid + uuid2 <- peek ptr + return $ uuid == uuid2 + +main :: IO () +main = do + defaultMain $ + concat $ + [ hUnitTestToTests $ H.TestList [ + test_null, + test_nil, + test_conv, + test_fromByteString, + test_fromWords + ] + , [ prop_stringRoundTrip, + prop_readShowRoundTrip, + prop_byteStringRoundTrip, + prop_storableRoundTrip, + prop_stringLength, + prop_byteStringLength, + prop_randomsDiffer, + prop_randomNotNull + ] + , [ testProperty "fromASCIIBytes_fromString1" fromASCIIBytes_fromString1 + , testProperty "fromASCIIBytes_fromString2" fromASCIIBytes_fromString2 + , testProperty "fromASCIIBytes_toString" toASCIIBytes_toString + , testProperty "fromASCIIBytes_toASCIIBytes" fromASCIIBytes_toASCIIBytes + , testProperty "toASCIIBytes_fromASCIIBytes" toASCIIBytes_fromASCIIBytes + , testProperty "toWords_fromWords" toWords_fromWords + , testProperty "fromWords_toWords" fromWords_toWords + ] + ] diff --git a/uuid-types.cabal b/uuid-types.cabal new file mode 100644 --- /dev/null +++ b/uuid-types.cabal @@ -0,0 +1,89 @@ +Name: uuid-types +Version: 1.0.0 +Copyright: (c) 2008-2014 Antoine Latter +Author: Antoine Latter +Maintainer: aslatter@gmail.com +License: BSD3 +License-file: LICENSE + +Category: Data +Build-Type: Simple +Cabal-Version: >= 1.8 + +Description: + This library contains type definitions for Universally Unique Identifiers + and basic conversion functions. + + See for the general idea. + +Synopsis: Type definitions for Universally Unique Identifiers + +Homepage: https://github.com/aslatter/uuid +Bug-Reports: https://github.com/aslatter/uuid/issues + +Extra-Source-Files: + CHANGES + CONTRIBUTORS + + +Library + Build-Depends: base >=3 && < 5, + binary >= 0.4 && < 0.8, + bytestring >= 0.9 && < 0.11, + deepseq >= 1.3 && < 1.5, + hashable (>= 1.1.1.0 && < 1.2.0) || (>= 1.2.1 && < 1.3), + random >= 1.0.1 && < 1.2 + + Exposed-Modules: + Data.UUID.Types + -- Exposed for companion projects; *NOT* part of the official API: + Data.UUID.Types.Internal.Builder + Data.UUID.Types.Internal + + Extensions: DeriveDataTypeable + Ghc-Options: -Wall + +source-repository head + type: git + location: https://github.com/aslatter/uuid.git + +Test-Suite testuuid + Type: exitcode-stdio-1.0 + Main-is: TestUUID.hs + Hs-source-dirs: tests + Extensions: DeriveDataTypeable + Ghc-Options: -Wall -fno-warn-orphans + Build-Depends: base >= 3 && < 5, + uuid-types, + bytestring >= 0.9 && < 0.11, + HUnit >=1.2 && < 1.3, + QuickCheck >=2.4 && < 2.8, + test-framework == 0.8.*, + test-framework-hunit == 0.3.*, + test-framework-quickcheck2 == 0.3.* + +benchmark benchmark + Type: exitcode-stdio-1.0 + Main-is: BenchUUID.hs + Hs-source-dirs: tests + Extensions: DeriveDataTypeable, CPP + Ghc-Options: -Wall -fno-warn-orphans + Build-depends: base == 4.*, + uuid-types, + bytestring >= 0.9 && < 0.11, + containers >= 0.4 && < 0.6, + criterion >= 0.4 && < 0.9, + deepseq >= 1.1 && < 1.4, + random >= 1.0.1 && < 1.2 + +benchmark benchbytestring + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Main-Is: BenchByteString.hs + Ghc-Options: -threaded -rtsopts -Wall -O2 -fno-warn-orphans + Build-Depends: base >= 4 && < 5 + , uuid-types + , bytestring >= 0.10 + , criterion >= 0.8 + , random >= 1.0 + , QuickCheck >= 2