master..99fbbfd · typeable/uuid

uuid-bench/bench/uuid-benchmark.hs+1

since splitsnapshots

unifiedsplit

@@ -3,6 +3,7 @@ import Data.Char (ord)

3import Data.IORef

4import Data.Word

5import qualified Data.UUID as U

6+import qualified Data.UUID.V1 as U

6import qualified Data.UUID.V4 as U

7import qualified Data.UUID.V4 as U

7import qualified Data.UUID.V3 as U3

8import qualified Data.UUID.V3 as U3

8import qualified Data.UUID.V5 as U5

9import qualified Data.UUID.V5 as U5

uuid-bench/uuid-bench.cabal+2−1

@@ -58,6 +58,7 @@ library

58 exposed-modules:

59 Data.UUID

60 Data.UUID.Util

61+ Data.UUID.V1

61 Data.UUID.V3

62 Data.UUID.V3

62 Data.UUID.V4

63 Data.UUID.V4

63 Data.UUID.V5

64 Data.UUID.V5

@@ -105,7 +106,7 @@ benchmark uuid-types-benchmark

105

106

106benchmark uuid-benchmark

107benchmark uuid-benchmark

107 type: exitcode-stdio-1.0

108 type: exitcode-stdio-1.0

108− main-is: uuid-benchmark.hs

109+ main-is: uuid-benchmark.hs

109 hs-source-dirs: bench

110 hs-source-dirs: bench

110 default-language: Haskell2010

111 default-language: Haskell2010

111 default-extensions:

112 default-extensions:

uuid-types/src/Data/UUID/Types/Internal.hs+3−1

@@ -46,11 +46,13 @@ module Data.UUID.Types.Internal

46

47import Prelude hiding (null)

48

49+import Control.Applicative ((<*>))

49import Control.DeepSeq (NFData (..))

50import Control.DeepSeq (NFData (..))

50import Control.Monad (guard, liftM2)

51import Control.Monad (guard, liftM2)

51import Data.Bits

52import Data.Bits

52import Data.Char

53import Data.Char

53import Data.Data

54import Data.Data

55+import Data.Functor ((<$>))

54import Data.Hashable

56import Data.Hashable

55import Data.List (elemIndices)

57import Data.List (elemIndices)

56import Foreign.Ptr (Ptr)

58import Foreign.Ptr (Ptr)

@@ -77,7 +79,7 @@ import Language.Haskell.TH.Syntax (Lift)

77-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in

79-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in

78-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.

80-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.

79data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64

81data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64

80− deriving (Eq, Ord)

82+ deriving (Eq, Ord, Typeable)

81{-

83{-

82 Prior to uuid-types-1.0.4:

84 Prior to uuid-types-1.0.4:

83 !Word32 !Word32 !Word32 !Word32

85 !Word32 !Word32 !Word32 !Word32

uuid-types/uuid-types.cabal−2

@@ -77,8 +77,6 @@ test-suite testuuid

77 default-language: Haskell2010

78 other-extensions: ViewPatterns

79 ghc-options: -Wall

80− if impl(ghc >= 8.10)

81− ghc-options: -Wunused-packages

82

80

83 -- inherited constraints

81 -- inherited constraints

84 build-depends:

82 build-depends:

uuid/src/Data/UUID.hs+3

@@ -18,6 +18,9 @@ See <http://tools.ietf.org/html/rfc4122> for the specification.

18favorite instance of 'System.Random.Random' for faster but insecure

19generation of UUIDs.

20

21+* We have an implementation of generating a UUID from the hardware

22+MAC address and current system time in "Data.UUID.V1".

23+

21* For name-based generation of UUIDs using SHA-1 hashing see

24* For name-based generation of UUIDs using SHA-1 hashing see

22"Data.UUID.V5".

25"Data.UUID.V5".

23-}

26-}

uuid/src/Data/UUID/Util.hs+11

@@ -3,6 +3,7 @@ module Data.UUID.Util (

3 UnpackedUUID(..)

4 , unpack, pack

5 , version

6+ , extractMac

6 , extractTime

7 , extractTime

7 , setTime

8 , setTime

8 ) where

9 ) where

@@ -12,6 +13,7 @@ import Data.Word

12import Data.Word.Util

13import Data.Word.Util

13import Data.Bits

14import Data.Bits

14import Data.UUID.Types.Internal

15import Data.UUID.Types.Internal

16+import Network.Info

15import Data.Int (Int64)

17import Data.Int (Int64)

16

18

17version :: UUID -> Int

19version :: UUID -> Int

@@ -40,3 +42,12 @@ extractTime uuid =

40

42

41timeAndVersionToTime :: Word16 -> Word16

43timeAndVersionToTime :: Word16 -> Word16

42timeAndVersionToTime tv = tv .&. 0x0FFF

44timeAndVersionToTime tv = tv .&. 0x0FFF

45+

46+extractMac :: UUID -> Maybe MAC

47+extractMac uuid =

48+ if version uuid == 1

49+ then Just $

50+ MAC (node_0 unpacked) (node_1 unpacked) (node_2 unpacked) (node_3 unpacked) (node_4 unpacked) (node_5 unpacked)

51+ else Nothing

52+ where

53+ unpacked = unpack uuid

uuid/src/Data/UUID/V1.hsnew file+135

@@ -0,0 +1,135 @@

1+{-# OPTIONS_GHC -fno-cse #-}

2+{-# LANGUAGE TypeFamilies #-}

3+

4+{- |

5+Module : Data.UUID.V1

9+

10+License : BSD-style

11+

12+Maintainer : aslatter@gmail.com

13+Stability : experimental

14+Portability : portable

15+

16+RFC 4122 Version 1 UUID state machine.

17+

18+The generated UUID is based on the hardware MAC

19+address and the system clock.

20+

21+If we cannot lookup the MAC address we seed the

22+generator with a pseudo-random number.

23+-}

24+

25+module Data.UUID.V1(nextUUID)

26+where

27+

28+

29+import Data.Bits

30+import Data.Maybe

31+import Data.Time

32+import Data.Word

33+

34+import Control.Applicative ((<$>),(<*>))

35+import Control.Concurrent.MVar

36+import System.IO.Unsafe

37+

38+import qualified System.Random as R

39+

40+import Network.Info

41+

42+import Data.UUID.Types.Internal.Builder

43+import Data.UUID.Types.Internal

44+

45+-- | Returns a new UUID derived from the local hardware MAC

46+-- address and the current system time.

47+-- Is generated according to the Version 1 UUID specified in

48+-- RFC 4122.

49+--

50+-- Returns 'Nothing' if you request UUIDs too quickly.

51+nextUUID :: IO (Maybe UUID)

52+nextUUID = do

53+ res <- stepTime

54+ case res of

55+ Just (mac', c, t) -> return $ Just $ makeUUID t c mac'

56+ _ -> return Nothing

57+

58+

59+makeUUID :: Word64 -> Word16 -> MAC -> UUID

60+makeUUID time clock mac' =

61+ buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac')

62+ where tLow = (fromIntegral time) :: Word32

63+ tMid = (fromIntegral (time `shiftR` 32)) :: Word16

64+ tHigh = (fromIntegral (time `shiftR` 48)) :: Word16

65+

66+newtype MACSource = MACSource MAC

67+instance ByteSource MACSource where

68+ z /-/ (MACSource (MAC a b c d e f)) = z a b c d e f

69+type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)

70+

71+

72+-- |Approximates the clock algorithm in RFC 4122, section 4.2

73+-- Isn't system wide or thread safe, nor does it properly randomize

74+-- the clock value on initialization.

75+stepTime :: IO (Maybe (MAC, Word16, Word64))

76+stepTime = do

77+ h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime

78+ modifyMVar state $ \s@(State mac' c0 h0) ->

79+ if h1 > h0

80+ then

81+ return (State mac' c0 h1, Just (mac', c0, h1))

82+ else

83+ let

84+ c1 = succ c0

85+ in if c1 <= 0x3fff -- when clock is initially randomized,

86+ -- then this test will need to change

87+ then

88+ return (State mac' c1 h1, Just (mac', c1, h1))

89+ else

90+ return (s, Nothing)

91+

92+

93+{-# NOINLINE state #-}

94+state :: MVar State

95+state = unsafePerformIO $ do

96+ h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime

97+ mac' <- getMac

98+ newMVar $ State mac' 0 h0 -- the 0 should be a random number

99+

100+-- SysMAC.mac can fail on some machines.

101+-- In those cases we fake it with a random

102+-- 6 bytes seed.

103+getMac :: IO MAC

104+getMac =

105+ getNetworkInterfaces >>=

106+ return . listToMaybe . filter (minBound /=) . map mac >>=

107+ \macM -> case macM of

108+ Just m -> return m

109+ Nothing -> randomMac

110+

111+randomMac :: IO MAC

112+randomMac =

113+ -- I'm too lazy to thread through

114+ -- the random state ...

115+ MAC

116+ <$> (R.randomIO >>= return . (1 .|.)) -- We must set the multicast bit to True. See section 4.5 of the RFC.

117+ <*> R.randomIO

118+ <*> R.randomIO

119+ <*> R.randomIO

120+ <*> R.randomIO

121+ <*> R.randomIO

122+

123+data State = State

124+ {-# UNPACK #-} !MAC

125+ {-# UNPACK #-} !Word16

126+ {-# UNPACK #-} !Word64

127+ deriving (Show)

128+

129+

130+

131+hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64

132+hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt

133+ where

134+ gregorianReform = UTCTime (fromGregorian 1582 10 15) 0

135+ dt = t `diffUTCTime` gregorianReform

uuid/tests/TestUUID.hs+20−4

@@ -1,15 +1,18 @@

1{-# LANGUAGE ViewPatterns #-}

2

3+import Control.Monad (replicateM)

3import Data.Bits

4import Data.Bits

4import qualified Data.ByteString.Lazy as BL

5import qualified Data.ByteString.Lazy as BL

5import Data.Char (ord)

6import Data.Char (ord)

7+import Data.List (nub, (\\))

6import Data.Maybe

8import Data.Maybe

7import Data.Word

9import Data.Word

8import qualified Data.UUID as U

10import qualified Data.UUID as U

11+import qualified Data.UUID.V1 as U

9import qualified Data.UUID.V3 as U3

12import qualified Data.UUID.V3 as U3

10import qualified Data.UUID.V5 as U5

13import qualified Data.UUID.V5 as U5

11

14

12−import Test.QuickCheck ( Arbitrary(arbitrary) )

15+import Test.QuickCheck ( Arbitrary(arbitrary), choose )

13import Test.Tasty ( TestTree, testGroup, defaultMain )

16import Test.Tasty ( TestTree, testGroup, defaultMain )

14import Test.Tasty.HUnit

17import Test.Tasty.HUnit

15 ( assertBool, (@?=), testCase )

18 ( assertBool, (@?=), testCase )

@@ -21,13 +24,13 @@ isValidVersion :: Int -> U.UUID -> Bool

21isValidVersion v u = lenOK && variantOK && versionOK

24isValidVersion v u = lenOK && variantOK && versionOK

22 where bs = U.toByteString u

25 where bs = U.toByteString u

23 lenOK = BL.length bs == 16

26 lenOK = BL.length bs == 16

24− variantOK = BL.index bs 8 .&. 0xc0 == 0x80

27+ variantOK = (BL.index bs 8) .&. 0xc0 == 0x80

25− versionOK = BL.index bs 6 .&. 0xf0 == fromIntegral (v `shiftL` 4)

28+ versionOK = (BL.index bs 6) .&. 0xf0 == fromIntegral (v `shiftL` 4)

26

29

27

30

28instance Arbitrary U.UUID where

31instance Arbitrary U.UUID where

29 -- the UUID random instance ignores bounds

32 -- the UUID random instance ignores bounds

30− arbitrary = pure U.nil

33+ arbitrary = choose (U.nil, U.nil)

31

34

32

35

33test_null :: Test

36test_null :: Test

@@ -35,6 +38,17 @@ test_null =

35 testCase "namespaceDNS is not null" $

38 testCase "namespaceDNS is not null" $

36 assertBool "" (not $ U.null U3.namespaceDNS)

39 assertBool "" (not $ U.null U3.namespaceDNS)

37

40

41+test_v1 :: [Maybe U.UUID] -> Test

42+test_v1 v1s = testGroup "version 1" [

43+ testCase "V1 unique" $ nub (v1s \\ nub v1s) @?= [],

44+ testGroup "V1 not null" $ map (testUUID (not . U.null)) v1s,

45+ testGroup "V1 valid" $ map (testUUID (isValidVersion 1)) v1s

46+ ]

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

48+ testUUID p u =

49+ testCase (show u) $

50+ assertBool "" $ maybe False p u

51+

38test_v3 :: Test

52test_v3 :: Test

39test_v3 =

53test_v3 =

40 testCase "V3 computation" $

54 testCase "V3 computation" $

@@ -79,11 +93,13 @@ prop_v5Valid = testProperty "V5 valid" v5Valid

79

93

80main :: IO ()

94main :: IO ()

81main = do

95main = do

96+ v1s <- replicateM 100 U.nextUUID

82 defaultMain $

97 defaultMain $

83 testGroup "tests" $

98 testGroup "tests" $

84 concat $

99 concat $

85 [ [

100 [ [

86 test_null,

101 test_null,

102+ test_v1 v1s,

87 test_v3,

103 test_v3,

88 test_v5

104 test_v5

89 ]

105 ]

uuid/uuid.cabal+6−4

@@ -47,6 +47,10 @@ library

47 , cryptohash-md5 >=0.11.100 && <0.12

48 , cryptohash-sha1 >=0.11.100 && <0.12

49 , entropy >=0.3.7 && <0.5

50+ , network-info >=0.2 && <0.3

51+ , random >=1.2.1.2 && <1.3

52+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2

53+ , time >=1.4 && <1.15

50

54

51 -- strict dependency on uuid-types,

55 -- strict dependency on uuid-types,

52 -- as we re-rexport datatype, thus leak instances etc.

56 -- as we re-rexport datatype, thus leak instances etc.

@@ -54,6 +58,7 @@ library

54 exposed-modules:

58 exposed-modules:

55 Data.UUID

59 Data.UUID

56 Data.UUID.Util

60 Data.UUID.Util

61+ Data.UUID.V1

57 Data.UUID.V3

62 Data.UUID.V3

58 Data.UUID.V4

63 Data.UUID.V4

59 Data.UUID.V5

64 Data.UUID.V5

@@ -66,8 +71,6 @@ library

66 default-extensions: DeriveDataTypeable

71 default-extensions: DeriveDataTypeable

67 other-extensions: TypeFamilies

72 other-extensions: TypeFamilies

68 ghc-options: -Wall

73 ghc-options: -Wall

69− if impl(ghc >= 8.10)

70− ghc-options: -Wunused-packages

71 hs-source-dirs: src

74 hs-source-dirs: src

72

75

73test-suite testuuid

76test-suite testuuid

@@ -78,13 +81,12 @@ test-suite testuuid

78 default-extensions: DeriveDataTypeable

81 default-extensions: DeriveDataTypeable

79 other-extensions: ViewPatterns

82 other-extensions: ViewPatterns

80 ghc-options: -Wall -fno-warn-orphans

83 ghc-options: -Wall -fno-warn-orphans

81− if impl(ghc >= 8.10)

82− ghc-options: -Wunused-packages

83

84

84 -- inherited constraints

85 -- inherited constraints

85 build-depends:

86 build-depends:

86 base

87 base

87 , bytestring

88 , bytestring

89+ , random

88 , uuid

90 , uuid

89

91

90 -- deps w/o inherited constraints

92 -- deps w/o inherited constraints