diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,7 @@ +1.2.4 + +- Unpack Word32 values into UUID constructor. + 1.2.3 - The Read instance now drops leading spaces in the string to be parsed. diff --git a/Data/UUID/Internal.hs b/Data/UUID/Internal.hs --- a/Data/UUID/Internal.hs +++ b/Data/UUID/Internal.hs @@ -2,7 +2,7 @@ -- | -- Module : Data.UUID --- Copyright : (c) 2008-2009 Antoine Latter +-- Copyright : (c) 2008-2009, 2012 Antoine Latter -- (c) 2009 Mark Lentczner -- -- License : BSD-style @@ -55,7 +55,12 @@ -- 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 !Word32 !Word32 !Word32 !Word32 +data UUID + = UUID + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 deriving (Eq, Ord, Typeable) {- Other representations that we tried are: diff --git a/tests/BenchUUID.hs b/tests/BenchUUID.hs new file mode 100644 --- /dev/null +++ b/tests/BenchUUID.hs @@ -0,0 +1,125 @@ +import Control.DeepSeq +import Criterion.Main +import Data.Char (ord) +import Data.IORef +import Data.Maybe (fromJust) +import Data.Word +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL +import qualified Data.UUID as U +import qualified Data.UUID.V1 as U +import qualified Data.UUID.V3 as U3 +import qualified Data.UUID.V5 as U5 +import System.Random +import System.Random.Mersenne.Pure64 + +instance NFData BL.ByteString where + rnf BL.Empty = () + rnf (BL.Chunk _ ts) = rnf ts + +instance NFData U.UUID where + + +main :: IO () +main = do + u1 <- randomIO + let s1 = U.toString u1 + b1 = U.toByteString u1 + n1 = (map (fromIntegral . ord) "http://www.haskell.org/") :: [Word8] + 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 random generation + randomState <- newPureMT >>= newIORef + let randomUUID = do + state <- readIORef randomState + let (uuid, state') = random state + writeIORef randomState state' + return uuid + + 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 + ], + bgroup "generation" [ + bench "V1" $ nfIO U.nextUUID, + bench "V4" $ nfIO (randomUUID :: IO U.UUID), + bench "V3" $ nf (U3.generateNamed U3.namespaceURL) n1, + bench "V5" $ nf (U5.generateNamed U5.namespaceURL) n1 + ], + bench "set making" $ nf Set.fromList uuids + ] + +-- 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,168 @@ +import Control.Monad (replicateM) +import Data.Bits +import qualified Data.ByteString.Lazy as B +import Data.Char (ord) +import Data.List (nub, (\\)) +import Data.Maybe +import Data.Word +import qualified Data.UUID as U +import qualified Data.UUID.V1 as U +import qualified Data.UUID.V3 as U3 +import qualified Data.UUID.V5 as U5 +import Test.HUnit +import Test.QuickCheck hiding ((.&.)) +import System.IO +import System.Random + + +isValidVersion :: Int -> U.UUID -> Bool +isValidVersion v u = lenOK && variantOK && versionOK + where bs = U.toByteString u + lenOK = B.length bs == 16 + variantOK = (B.index bs 8) .&. 0xc0 == 0x80 + versionOK = (B.index bs 6) .&. 0xf0 == fromIntegral (v `shiftL` 4) + + +instance Arbitrary U.UUID where + -- the UUID random instance ignores bounds + arbitrary = choose (U.nil, U.nil) + +-- instance Arbitrary Word8 where +-- arbitrary = (fromIntegral . fst . randomR (0,255::Int)) `fmap` rand + + +test_null :: Test +test_null = TestList [ + "nil is null" ~: assertBool "" (U.null U.nil), + "namespaceDNS is not null" ~: assertBool "" (not $ U.null U3.namespaceDNS) + ] + +test_nil :: Test +test_nil = TestList [ + "nil string" ~: U.toString U.nil @?= "00000000-0000-0000-0000-000000000000", + "nil bytes" ~: U.toByteString U.nil @?= B.pack (replicate 16 0) + ] + +test_conv :: Test +test_conv = TestList [ + "conv bytes to string" ~: + maybe "" (U.toString) (U.fromByteString b16) @?= s16, + "conv string to bytes" ~: + maybe B.empty (U.toByteString) (U.fromString s16) @?= b16 + ] + where b16 = B.pack [1..16] + s16 = "01020304-0506-0708-090a-0b0c0d0e0f10" + +test_v1 :: [Maybe U.UUID] -> Test +test_v1 v1s = TestList [ + "V1 unique" ~: nub (v1s \\ nub v1s) @?= [], + "V1 not null" ~: TestList $ map (testUUID (not . U.null)) v1s, + "V1 valid" ~: TestList $ map (testUUID (isValidVersion 1)) v1s + ] + where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test + testUUID p u = maybe False p u ~? show u + +test_v3 :: Test +test_v3 = TestList [ + "V3 computation" ~: + U3.generateNamed U3.namespaceDNS name @?= uV3 + ] + where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8] + uV3 = fromJust $ U.fromString "3d813cbb-47fb-32ba-91df-831e1593ac29" + +test_v5 :: Test +test_v5 = TestList [ + "V5 computation" ~: + U5.generateNamed U5.namespaceDNS name @?= uV5 + ] + where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8] + uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a" + +prop_stringRoundTrip :: Property +prop_stringRoundTrip = label "String round trip" stringRoundTrip + where stringRoundTrip :: U.UUID -> Bool + stringRoundTrip u = maybe False (== u) $ U.fromString (U.toString u) + +prop_byteStringRoundTrip :: Property +prop_byteStringRoundTrip = label "ByteString round trip" byteStringRoundTrip + where byteStringRoundTrip :: U.UUID -> Bool + byteStringRoundTrip u = maybe False (== u) + $ U.fromByteString (U.toByteString u) + +prop_stringLength :: Property +prop_stringLength = label "String length" stringLength + where stringLength :: U.UUID -> Bool + stringLength u = length (U.toString u) == 36 + +prop_byteStringLength :: Property +prop_byteStringLength = label "ByteString length" byteStringLength + where byteStringLength :: U.UUID -> Bool + byteStringLength u = B.length (U.toByteString u) == 16 + +prop_randomsDiffer :: Property +prop_randomsDiffer = label "Randoms differ" randomsDiffer + where randomsDiffer :: (U.UUID, U.UUID) -> Bool + randomsDiffer (u1, u2) = u1 /= u2 + +prop_randomNotNull :: Property +prop_randomNotNull = label "Random not null" randomNotNull + where randomNotNull :: U.UUID -> Bool + randomNotNull = not. U.null + +prop_randomsValid :: Property +prop_randomsValid = label "Random valid" randomsValid + where randomsValid :: U.UUID -> Bool + randomsValid = isValidVersion 4 + +prop_v3NotNull :: Property +prop_v3NotNull = label "V3 not null" v3NotNull + where v3NotNull :: [Word8] -> Bool + v3NotNull = not . U.null . U3.generateNamed U3.namespaceDNS + +prop_v3Valid :: Property +prop_v3Valid = label "V3 valid" v3Valid + where v3Valid :: [Word8] -> Bool + v3Valid = isValidVersion 3 . U3.generateNamed U3.namespaceDNS + +prop_v5NotNull :: Property +prop_v5NotNull = label "V5 not null" v5NotNull + where v5NotNull :: [Word8] -> Bool + v5NotNull = not . U.null . U5.generateNamed U5.namespaceDNS + +prop_v5Valid :: Property +prop_v5Valid = label "V5 valid" v5Valid + where v5Valid :: [Word8] -> Bool + v5Valid = isValidVersion 5 . U5.generateNamed U5.namespaceDNS + +prop_readShowRoundTrip :: Property +prop_readShowRoundTrip = label "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 + +main :: IO () +main = do + v1s <- replicateM 100 U.nextUUID + runTestText (putTextToHandle stderr False) (TestList [ + test_null, + test_nil, + test_conv, + test_v1 v1s, + test_v3, + test_v5 + ]) + mapM_ quickCheck $ [ + prop_stringRoundTrip, + prop_readShowRoundTrip, + prop_byteStringRoundTrip, + prop_stringLength, + prop_byteStringLength, + prop_randomsDiffer, + prop_randomNotNull, + prop_randomsValid, + prop_v3NotNull, + prop_v3Valid, + prop_v5NotNull, + prop_v5Valid + ] diff --git a/uuid.cabal b/uuid.cabal --- a/uuid.cabal +++ b/uuid.cabal @@ -1,6 +1,6 @@ Name: uuid -Version: 1.2.3 -Copyright: (c) 2008-2011 Antoine Latter +Version: 1.2.4 +Copyright: (c) 2008-2012 Antoine Latter Author: Antoine Latter Maintainer: aslatter@gmail.com License: BSD3 @@ -45,6 +45,10 @@ Ghc-Shared-Options: Ghc-Options: -Wall +source-repository head + type: darcs + location: http://code.haskell.org/uuid + -- not strictly a test, but we want it to error if -- it can't build Test-Suite benchmark @@ -52,8 +56,8 @@ Main-is: BenchUUID.hs Hs-source-dirs: tests Extensions: DeriveDataTypeable, CPP - Build-depends: base == 4.*, uuid, random, criterion >= 0.4 && < 0.6, mersenne-random-pure64, - bytestring == 0.9.*, containers == 0.4.*, deepseq == 1.1.* + Build-depends: base == 4.*, uuid, random, criterion >= 0.4 && < 0.7, mersenne-random-pure64, + bytestring == 0.9.*, containers == 0.4.*, deepseq >= 1.1 && < 1.4 Test-Suite testuuid Type: exitcode-stdio-1.0 @@ -62,4 +66,4 @@ Extensions: DeriveDataTypeable Ghc-Options: -Wall -fno-warn-orphans Build-Depends: random, bytestring, base >=3, base < 5, uuid, - HUnit >=1.2 && < 1.3, QuickCheck >=1.2 && < 1.3 + HUnit >=1.2 && < 1.3, QuickCheck >=2.4 && < 2.5