git.iko.soy/typeable/uuid
on master help sign in
add V3 generation of UUIDs
commit42457dd788c30df5f6884a60db61ca542c1b487c authorAntoine Latter <aslatter@gmail.com> dateTue 5 Jan 2010, 03:05 (17 years ago) parent6ac8033
7 files changed+181−45
compare with master
unifiedsplit
Data/UUID/Internal.hs+2−2 Data/UUID/Named.hs+70 Data/UUID/V3.hs+65 Data/UUID/V5.hs+11−35 tests/BenchUUID.hs+4−2 tests/TestUUID.hs+27−6 uuid.cabal+2
Data/UUID/Internal.hs+2−2
@@ -114,9 +114,9 @@ buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
114114 b8' = b8 .&. 0x3f .|. 0x80
115115
116116-- |Build a UUID of a given version from Word32 values.
117−buildFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
117+buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
118118buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
119− where w1' = w1 .&. 0xffff0fff .|. (v `shiftL` 12)
119+ where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
120120 w2' = w2 .&. 0x3fffffff .|. 0x80000000
121121
122122
Data/UUID/Named.hsnew file+70
@@ -0,0 +1,70 @@
1+-- |
2+-- Module : Data.UUID.Named
3+-- Copyright : (c) 2008 Antoine Latter
4+--
5+-- License : BSD-style
6+--
7+-- Maintainer : aslatter@gmail.com
8+-- Stability : experimental
9+-- Portability : portable
10+--
11+--
12+-- This module implements Version 3/5 UUIDs as specified
13+-- in RFC 4122.
14+--
15+-- These UUIDs identify an object within a namespace,
16+-- and are deterministic.
17+--
18+-- The namespace is identified by a UUID. Several sample
19+-- namespaces are enclosed.
20+
21+module Data.UUID.Named
22+ (generateNamed
23+ ,namespaceDNS
24+ ,namespaceURL
25+ ,namespaceOID
26+ ,namespaceX500
27+ ) where
28+
29+import Data.UUID.Internal
30+
31+import Data.Binary
32+import Data.Maybe
33+
34+import qualified Data.ByteString.Lazy as BS
35+
36+import qualified Data.Digest.SHA1 as SHA1
37+
38+
39+-- |Generate a 'UUID' within the specified namespace out of the given
40+-- object.
41+generateNamed :: ([Word8] -> (Word32, Word32, Word32, Word32)) -- ^Hash
42+ -> Word8 -- ^Version
43+ -> UUID -- ^Namespace
44+ -> [Word8] -- ^Object
45+ -> UUID
46+generateNamed hash version namespace object =
47+ let chunk = BS.unpack (toByteString namespace) ++ object
48+ (w1, w2, w3, w4) = hash chunk
49+ in buildFromWords version w1 w2 w3 w4
50+
51+
52+
53+unsafeFromString :: String -> UUID
54+unsafeFromString = fromJust . fromString
55+
56+-- |The namespace for DNS addresses
57+namespaceDNS :: UUID
58+namespaceDNS = unsafeFromString "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
59+
60+-- |The namespace for URLs
61+namespaceURL :: UUID
62+namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
63+
64+-- |The namespace for ISO OIDs
65+namespaceOID :: UUID
66+namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
67+
68+-- |The namespace for X.500 DNs
69+namespaceX500 :: UUID
70+namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
Data/UUID/V3.hsnew file+65
@@ -0,0 +1,65 @@
1+-- |
2+-- Module : Data.UUID.V3
3+-- Copyright : (c) 2010 Antoine Latter
4+--
5+-- License : BSD-style
6+--
7+-- Maintainer : aslatter@gmail.com
8+-- Stability : experimental
9+-- Portability : portable
10+--
11+--
12+-- This module implements Version 3 UUIDs as specified
13+-- in RFC 4122.
14+--
15+-- These UUIDs identify an object within a namespace,
16+-- and are deterministic.
17+--
18+-- The namespace is identified by a UUID. Several sample
19+-- namespaces are enclosed.
20+
21+module Data.UUID.V3
22+ (generateNamed
23+ ,Shared.namespaceDNS
24+ ,Shared.namespaceURL
25+ ,Shared.namespaceOID
26+ ,Shared.namespaceX500
27+ ) where
28+
29+import Data.Word
30+import Data.Bits
31+
32+import Data.UUID.Internal
33+import qualified Data.UUID.Named as Shared
34+import qualified Data.Digest.MD5 as MD5
35+
36+
37+-- |Generate a 'UUID' within the specified namespace out of the given
38+-- object.
39+--
40+-- Uses an MD5 hash. The UUID is built from first 128 bits of the hash of
41+-- the namespace UUID and the name (as a series of Word8).
42+generateNamed :: UUID -- ^Namespace
43+ -> [Word8] -- ^Object
44+ -> UUID
45+generateNamed = Shared.generateNamed hash 3
46+
47+hash :: [Word8] -> (Word32, Word32, Word32, Word32)
48+hash bytes
49+ = case map f $ chunk 4 $ MD5.hash bytes of
50+ w1:w2:w3:w4:_ -> (w1, w2, w3, w4)
51+
52+ where f [b1, b2, b3, b4]
53+ = sum
54+ [ fromIntegral b4
55+ , fromIntegral b3 `shiftL` 8
56+ , fromIntegral b2 `shiftL` 16
57+ , fromIntegral b1 `shiftL` 24
58+ ]
59+
60+chunk :: Int -> [a] -> [[a]]
61+chunk n xs = go n [] xs
62+ where go _ [] [] = []
63+ go _ ys [] = reverse ys:[]
64+ go 0 ys xs = reverse ys:go n [] xs
65+ go m ys (x:xs) = go (m-1) (x:ys) xs
Data/UUID/V5.hs+11−35
@@ -20,19 +20,16 @@
2020
2121module Data.UUID.V5
2222 (generateNamed
23− ,namespaceDNS
24− ,namespaceURL
25− ,namespaceOID
26− ,namespaceX500
23+ ,Shared.namespaceDNS
24+ ,Shared.namespaceURL
25+ ,Shared.namespaceOID
26+ ,Shared.namespaceX500
2727 ) where
2828
29−import Data.UUID.Internal
30−
31−import Data.Binary
32−import Data.Maybe
33−
34−import qualified Data.ByteString.Lazy as BS
29+import Data.Word
3530
31+import Data.UUID.Internal
32+import qualified Data.UUID.Named as Shared
3633import qualified Data.Digest.SHA1 as SHA1
3734
3835
@@ -44,28 +41,7 @@ import qualified Data.Digest.SHA1 as SHA1
4441generateNamed :: UUID -- ^Namespace
4542 -> [Word8] -- ^Object
4643 -> UUID
47−generateNamed namespace object =
48− let chunk = BS.unpack (toByteString namespace) ++ object
49− SHA1.Word160 w1 w2 w3 w4 _w5 = SHA1.hash chunk
50− in buildFromWords 5 w1 w2 w3 w4
51−
52−
53−
54−unsafeFromString :: String -> UUID
55−unsafeFromString = fromJust . fromString
56−
57−-- |The namespace for DNS addresses
58−namespaceDNS :: UUID
59−namespaceDNS = unsafeFromString "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
60−
61−-- |The namespace for URLs
62−namespaceURL :: UUID
63−namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
64−
65−-- |The namespace for ISO OIDs
66−namespaceOID :: UUID
67−namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
68−
69−-- |The namespace for X.500 DNs
70−namespaceX500 :: UUID
71−namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
44+generateNamed = Shared.generateNamed hash 5
45+ where hash bytes
46+ = case SHA1.hash bytes of
47+ SHA1.Word160 w1 w2 w3 w4 _w5 -> (w1, w2, w3, w4)
tests/BenchUUID.hs+4−2
@@ -8,7 +8,8 @@ import qualified Data.ByteString.Lazy as BL
88import qualified Data.ByteString.Lazy.Internal as BL
99import qualified Data.UUID.Internal as U
1010import qualified Data.UUID.V1 as U
11−import qualified Data.UUID.V5 as U
11+import qualified Data.UUID.V3 as U3
12+import qualified Data.UUID.V5 as U5
1213import System.Random
1314
1415
@@ -52,7 +53,8 @@ main = do
5253 bgroup "generation" [
5354 bench "V1" $ nfIO U.nextUUID,
5455 bench "V4" $ nfIO (randomIO :: IO U.UUID),
55− bench "V5" $ nf (U.generateNamed U.namespaceURL) n1
56+ bench "V3" $ nf (U3.generateNamed U3.namespaceURL) n1,
57+ bench "V5" $ nf (U5.generateNamed U5.namespaceURL) n1
5658 ],
5759 bench "set making" $ nf Set.fromList uuids
5860 ]
tests/TestUUID.hs+27−6
@@ -7,7 +7,8 @@ import Data.Maybe
77import Data.Word
88import qualified Data.UUID as U
99import qualified Data.UUID.V1 as U
10−import qualified Data.UUID.V5 as U
10+import qualified Data.UUID.V3 as U3
11+import qualified Data.UUID.V5 as U5
1112import Test.HUnit
1213import Test.QuickCheck
1314import System.IO
@@ -34,7 +35,7 @@ instance Arbitrary Word8 where
3435test_null :: Test
3536test_null = TestList [
3637 "nil is null" ~: assertBool "" (U.null U.nil),
37− "namespaceDNS is not null" ~: assertBool "" (not $ U.null U.namespaceDNS)
38+ "namespaceDNS is not null" ~: assertBool "" (not $ U.null U3.namespaceDNS)
3839 ]
3940
4041test_nil :: Test
@@ -62,13 +63,20 @@ test_v1 v1s = TestList [
6263 where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test
6364 testUUID p u = maybe False p u ~? show u
6465
66+test_v3 :: Test
67+test_v3 = TestList [
68+ "V3 computation" ~:
69+ U3.generateNamed U3.namespaceDNS name @?= uV3
70+ ]
71+ where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8]
72+ uV3 = fromJust $ U.fromString "3d813cbb-47fb-32ba-91df-831e1593ac29"
73+
6574test_v5 :: Test
6675test_v5 = TestList [
6776 "V5 computation" ~:
68− U.generateNamed U.namespaceDNS name @?= uV5
77+ U5.generateNamed U5.namespaceDNS name @?= uV5
6978 ]
7079 where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8]
71− -- uV3 = fromJust $ U.fromString "3d813cbb-47fb-32ba-91df-831e1593ac29"
7280 uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"
7381
7482prop_stringRoundTrip :: Property
@@ -107,15 +115,25 @@ prop_randomsValid = label "Random valid" randomsValid
107115 where randomsValid :: U.UUID -> Bool
108116 randomsValid = isValidVersion 4
109117
118+prop_v3NotNull :: Property
119+prop_v3NotNull = label "V3 not null" v3NotNull
120+ where v3NotNull :: [Word8] -> Bool
121+ v3NotNull = not . U.null . U3.generateNamed U3.namespaceDNS
122+
123+prop_v3Valid :: Property
124+prop_v3Valid = label "V3 valid" v3Valid
125+ where v3Valid :: [Word8] -> Bool
126+ v3Valid = isValidVersion 3 . U3.generateNamed U3.namespaceDNS
127+
110128prop_v5NotNull :: Property
111129prop_v5NotNull = label "V5 not null" v5NotNull
112130 where v5NotNull :: [Word8] -> Bool
113− v5NotNull = not . U.null . U.generateNamed U.namespaceDNS
131+ v5NotNull = not . U.null . U5.generateNamed U5.namespaceDNS
114132
115133prop_v5Valid :: Property
116134prop_v5Valid = label "V5 valid" v5Valid
117135 where v5Valid :: [Word8] -> Bool
118− v5Valid = isValidVersion 5 . U.generateNamed U.namespaceDNS
136+ v5Valid = isValidVersion 5 . U5.generateNamed U5.namespaceDNS
119137
120138
121139main :: IO ()
@@ -126,6 +144,7 @@ main = do
126144 test_nil,
127145 test_conv,
128146 test_v1 v1s,
147+ test_v3,
129148 test_v5
130149 ])
131150 mapM_ quickCheck $ [
@@ -136,6 +155,8 @@ main = do
136155 prop_randomsDiffer,
137156 prop_randomNotNull,
138157 prop_randomsValid,
158+ prop_v3NotNull,
159+ prop_v3Valid,
139160 prop_v5NotNull,
140161 prop_v5Valid
141162 ]
uuid.cabal+2
@@ -35,11 +35,13 @@ Library
3535 Exposed-Modules:
3636 Data.UUID
3737 Data.UUID.V1
38+ Data.UUID.V3
3839 Data.UUID.V5
3940
4041 Other-Modules:
4142 Data.UUID.Builder
4243 Data.UUID.Internal
44+ Data.UUID.Named
4345
4446 Extensions: DeriveDataTypeable
4547 Ghc-Prof-Options: -auto-all -caf-all