42457dd · typeable/uuid

Data/UUID/Internal.hs+2−2

compare with master

unifiedsplit

@@ -114,9 +114,9 @@ buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =

114 b8' = b8 .&. 0x3f .|. 0x80

115

116-- |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

118buildFromWords 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)

120 w2' = w2 .&. 0x3fffffff .|. 0x80000000

121

122

Data/UUID/Named.hsnew file+70

@@ -0,0 +1,70 @@

1+-- |

2+-- Module : Data.UUID.Named

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

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 @@

20

21module Data.UUID.V5

22 (generateNamed

23− ,namespaceDNS

23+ ,Shared.namespaceDNS

24− ,namespaceURL

24+ ,Shared.namespaceURL

25− ,namespaceOID

25+ ,Shared.namespaceOID

26− ,namespaceX500

26+ ,Shared.namespaceX500

27 ) where

28

29−import Data.UUID.Internal

29+import Data.Word

30−

31−import Data.Binary

32−import Data.Maybe

33−

34−import qualified Data.ByteString.Lazy as BS

35

30

31+import Data.UUID.Internal

32+import qualified Data.UUID.Named as Shared

36import qualified Data.Digest.SHA1 as SHA1

33import qualified Data.Digest.SHA1 as SHA1

37

34

38

35

@@ -44,28 +41,7 @@ import qualified Data.Digest.SHA1 as SHA1

44generateNamed :: UUID -- ^Namespace

41generateNamed :: UUID -- ^Namespace

45 -> [Word8] -- ^Object

42 -> [Word8] -- ^Object

46 -> UUID

43 -> UUID

47−generateNamed namespace object =

44+generateNamed = Shared.generateNamed hash 5

48− let chunk = BS.unpack (toByteString namespace) ++ object

45+ where hash bytes

46+ = case SHA1.hash bytes of

49− SHA1.Word160 w1 w2 w3 w4 _w5 = SHA1.hash chunk

47+ SHA1.Word160 w1 w2 w3 w4 _w5 -> (w1, w2, w3, w4)

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"

tests/BenchUUID.hs+4−2

@@ -8,7 +8,8 @@ import qualified Data.ByteString.Lazy as BL

8import qualified Data.ByteString.Lazy.Internal as BL

9import qualified Data.UUID.Internal as U

10import 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

12import System.Random

13import System.Random

13

14

15

@@ -52,7 +53,8 @@ main = do

52 bgroup "generation" [

53 bgroup "generation" [

53 bench "V1" $ nfIO U.nextUUID,

54 bench "V1" $ nfIO U.nextUUID,

54 bench "V4" $ nfIO (randomIO :: IO U.UUID),

55 bench "V4" $ nfIO (randomIO :: IO U.UUID),

56+ bench "V3" $ nf (U3.generateNamed U3.namespaceURL) n1,

55− bench "V5" $ nf (U.generateNamed U.namespaceURL) n1

57+ bench "V5" $ nf (U5.generateNamed U5.namespaceURL) n1

56 ],

58 ],

57 bench "set making" $ nf Set.fromList uuids

59 bench "set making" $ nf Set.fromList uuids

58 ]

60 ]

tests/TestUUID.hs+27−6

@@ -7,7 +7,8 @@ import Data.Maybe

7import Data.Word

8import qualified Data.UUID as U

9import 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

11import Test.HUnit

12import Test.HUnit

12import Test.QuickCheck

13import Test.QuickCheck

13import System.IO

14import System.IO

@@ -34,7 +35,7 @@ instance Arbitrary Word8 where

34test_null :: Test

35test_null :: Test

35test_null = TestList [

36test_null = TestList [

36 "nil is null" ~: assertBool "" (U.null U.nil),

37 "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)

38 ]

39 ]

39

40

40test_nil :: Test

41test_nil :: Test

@@ -62,13 +63,20 @@ test_v1 v1s = TestList [

62 where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test

63 where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test

63 testUUID p u = maybe False p u ~? show u

64 testUUID p u = maybe False p u ~? show u

64

65

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+

65test_v5 :: Test

74test_v5 :: Test

66test_v5 = TestList [

75test_v5 = TestList [

67 "V5 computation" ~:

76 "V5 computation" ~:

68− U.generateNamed U.namespaceDNS name @?= uV5

77+ U5.generateNamed U5.namespaceDNS name @?= uV5

69 ]

78 ]

70 where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8]

79 where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8]

71− -- uV3 = fromJust $ U.fromString "3d813cbb-47fb-32ba-91df-831e1593ac29"

72 uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"

80 uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"

73

81

74prop_stringRoundTrip :: Property

82prop_stringRoundTrip :: Property

@@ -107,15 +115,25 @@ prop_randomsValid = label "Random valid" randomsValid

107 where randomsValid :: U.UUID -> Bool

115 where randomsValid :: U.UUID -> Bool

108 randomsValid = isValidVersion 4

116 randomsValid = isValidVersion 4

109

117

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+

110prop_v5NotNull :: Property

128prop_v5NotNull :: Property

111prop_v5NotNull = label "V5 not null" v5NotNull

129prop_v5NotNull = label "V5 not null" v5NotNull

112 where v5NotNull :: [Word8] -> Bool

130 where v5NotNull :: [Word8] -> Bool

113− v5NotNull = not . U.null . U.generateNamed U.namespaceDNS

131+ v5NotNull = not . U.null . U5.generateNamed U5.namespaceDNS

114

132

115prop_v5Valid :: Property

133prop_v5Valid :: Property

116prop_v5Valid = label "V5 valid" v5Valid

134prop_v5Valid = label "V5 valid" v5Valid

117 where v5Valid :: [Word8] -> Bool

135 where v5Valid :: [Word8] -> Bool

118− v5Valid = isValidVersion 5 . U.generateNamed U.namespaceDNS

136+ v5Valid = isValidVersion 5 . U5.generateNamed U5.namespaceDNS

119

137

120

138

121main :: IO ()

139main :: IO ()

@@ -126,6 +144,7 @@ main = do

126 test_nil,

144 test_nil,

127 test_conv,

145 test_conv,

128 test_v1 v1s,

146 test_v1 v1s,

147+ test_v3,

129 test_v5

148 test_v5

130 ])

149 ])

131 mapM_ quickCheck $ [

150 mapM_ quickCheck $ [

@@ -136,6 +155,8 @@ main = do

136 prop_randomsDiffer,

155 prop_randomsDiffer,

137 prop_randomNotNull,

156 prop_randomNotNull,

138 prop_randomsValid,

157 prop_randomsValid,

158+ prop_v3NotNull,

159+ prop_v3Valid,

139 prop_v5NotNull,

160 prop_v5NotNull,

140 prop_v5Valid

161 prop_v5Valid

141 ]

162 ]

uuid.cabal+2

@@ -35,11 +35,13 @@ Library

35 Exposed-Modules:

36 Data.UUID

37 Data.UUID.V1

38+ Data.UUID.V3

38 Data.UUID.V5

39 Data.UUID.V5

39

40

40 Other-Modules:

41 Other-Modules:

41 Data.UUID.Builder

42 Data.UUID.Builder

42 Data.UUID.Internal

43 Data.UUID.Internal

44+ Data.UUID.Named

43

45

44 Extensions: DeriveDataTypeable

46 Extensions: DeriveDataTypeable

45 Ghc-Prof-Options: -auto-all -caf-all

47 Ghc-Prof-Options: -auto-all -caf-all