@@ -2,17 +2,20 @@
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE Unsafe #-}
6+{-# LANGUAGE DeriveLift #-}
7+{-# LANGUAGE StandaloneDeriving #-}
5{-# OPTIONS_HADDOCK hide #-}
8{-# OPTIONS_HADDOCK hide #-}
8-- Module : Data.UUID.Types.Internal
11-- Module : Data.UUID.Types.Internal
12+-- Copyright : (c) 2017-2018 Herbert Valerio Riedel
9−-- Copyright : (c) 2008-2009, 2012 Antoine Latter
13+-- (c) 2008-2009, 2012 Antoine Latter
10-- (c) 2009 Mark Lentczner
14-- (c) 2009 Mark Lentczner
12-- License : BSD-style
16-- License : BSD-style
14−-- Maintainer : aslatter@gmail.com
18+-- Maintainer : hvr@gnu.org
15−-- Stability : experimental
16-- Portability : portable
19-- Portability : portable
18module Data.UUID.Types.Internal
21module Data.UUID.Types.Internal
@@ -27,6 +30,8 @@ module Data.UUID.Types.Internal
28 , fromWords
31 , fromWords
31 , buildFromBytes
36 , buildFromBytes
32 , buildFromWords
37 , buildFromWords
@@ -41,22 +46,15 @@ module Data.UUID.Types.Internal
42import Prelude hiding (null)
47import Prelude hiding (null)
44−import Control.Applicative ((<*>))
45import Control.DeepSeq (NFData (..))
49import Control.DeepSeq (NFData (..))
46import Control.Monad (guard, liftM2)
50import Control.Monad (guard, liftM2)
47import Data.Bits
51import Data.Bits
48import Data.Char
52import Data.Char
49−import Data.Functor ((<$>))
53+import Data.Data
50import Data.Hashable
54import Data.Hashable
51import Data.List (elemIndices)
55import Data.List (elemIndices)
52import Foreign.Ptr (Ptr)
56import Foreign.Ptr (Ptr)
54−#if MIN_VERSION_base(4,0,0)
57−import Data.Generics.Basics
60import Foreign.Storable
58import Foreign.Storable
62import Data.Binary
60import Data.Binary
@@ -67,19 +65,19 @@ import qualified Data.ByteString.Internal as BI
67import qualified Data.ByteString.Lazy as BL
65import qualified Data.ByteString.Lazy as BL
68import qualified Data.ByteString.Unsafe as BU
66import qualified Data.ByteString.Unsafe as BU
69import Data.Text (Text)
67import Data.Text (Text)
70−import qualified Data.Text as T
68+import qualified Data.Text.Encoding as T
72import Data.UUID.Types.Internal.Builder
70import Data.UUID.Types.Internal.Builder
74−import System.Random
72+import System.Random (Random (..), uniform)
73+import System.Random.Stateful (Uniform (..), uniformWord64)
75+import Language.Haskell.TH.Syntax (Lift)
77−-- |The UUID type. A 'Random' instance is provided which produces
77+-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
78−-- insecure version 4 UUIDs as specified in RFC 4122. The 'Storable' and
78+-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
79−-- 'Binary' instances are compatible with RFC 4122, storing the fields in
80−-- network order as 16 bytes.
81data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
79data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
82− deriving (Eq, Ord, Typeable)
80+ deriving (Eq, Ord)
84 Prior to uuid-types-1.0.4:
82 Prior to uuid-types-1.0.4:
85 !Word32 !Word32 !Word32 !Word32
83 !Word32 !Word32 !Word32 !Word32
@@ -94,10 +92,18 @@ data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
94 None was as fast, overall, as the representation used here.
92 None was as fast, overall, as the representation used here.
97−-- | Covert a 'UUID' into a sequence of 'Word32' values.
95+-- | Convert a 'UUID' into a sequence of 'Word32' values.
98-- Useful for when you need to serialize a UUID and
96-- Useful for when you need to serialize a UUID and
99-- neither 'Storable' nor 'Binary' are appropriate.
97-- neither 'Storable' nor 'Binary' are appropriate.
100−-- Introduced in version 1.2.2.
98+--
99+-- >>> toWords <$> fromString "550e8400-e29b-41d4-a716-446655440000"
100+-- Just (1427014656,3801825748,2803254374,1430519808)
102+-- See also 'toWords64'.
104+-- /Since: @uuid-1.2.2@/
101toWords :: UUID -> (Word32, Word32, Word32, Word32)
107toWords :: UUID -> (Word32, Word32, Word32, Word32)
102toWords (UUID w12 w34) = (w1, w2, w3, w4)
108toWords (UUID w12 w34) = (w1, w2, w3, w4)
@@ -107,12 +113,36 @@ toWords (UUID w12 w34) = (w1, w2, w3, w4)
107 w4 = fromIntegral w34
113 w4 = fromIntegral w34
109-- | Create a 'UUID' from a sequence of 'Word32'. The
115-- | Create a 'UUID' from a sequence of 'Word32'. The
110−-- opposite of 'toWords'. Useful when you need a total
116+-- inverse of 'toWords'. Useful when you need a total
111-- function for constructing 'UUID' values.
117-- function for constructing 'UUID' values.
112−-- Introduced in version 1.2.2.
118+--
119+-- See also 'fromWords64'.
121+-- /Since: @uuid-1.2.2@/
113fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
124fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
114fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
125fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
127+-- | Convert a 'UUID' into a pair of 'Word64's.
129+-- >>> toWords64 <$> fromString "550e8400-e29b-41d4-a716-446655440000"
130+-- Just (6128981282234515924,12039885860129472512)
132+-- See also 'toWords'.
135+toWords64 :: UUID -> (Word64, Word64)
136+toWords64 (UUID w12 w34) = (w12,w34)
138+-- | Create a 'UUID' from a pair of 'Word64's.
140+-- Inverse of 'toWords64'. See also 'fromWords'.
143+fromWords64 :: Word64 -> Word64 -> UUID
116data UnpackedUUID =
146data UnpackedUUID =
117 UnpackedUUID {
147 UnpackedUUID {
118 time_low :: Word32 -- 0-3
148 time_low :: Word32 -- 0-3
@@ -165,10 +195,10 @@ pack unpacked =
166-- |Build a Word32 from four Word8 values, presented in big-endian order
196-- |Build a Word32 from four Word8 values, presented in big-endian order
167word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
197word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
168−word a b c d = (fromIntegral a `shiftL` 24)
198+word a b c d = (fromIntegral a `unsafeShiftL` 24)
169− .|. (fromIntegral b `shiftL` 16)
199+ .|. (fromIntegral b `unsafeShiftL` 16)
170− .|. (fromIntegral c `shiftL` 8)
200+ .|. (fromIntegral c `unsafeShiftL` 8)
171− .|. (fromIntegral d )
201+ .|. (fromIntegral d )
173-- |Extract a Word8 from a Word64. Bytes, high to low, are numbered from 7 to 0,
203-- |Extract a Word8 from a Word64. Bytes, high to low, are numbered from 7 to 0,
174byte :: Int -> Word64 -> Word8
204byte :: Int -> Word64 -> Word8
@@ -177,7 +207,7 @@ byte i w = fromIntegral (w `shiftR` (i * 8))
177-- |Build a Word16 from two Word8 values, presented in big-endian order.
207-- |Build a Word16 from two Word8 values, presented in big-endian order.
178w8to16 :: Word8 -> Word8 -> Word16
208w8to16 :: Word8 -> Word8 -> Word16
179w8to16 w0s w1s =
209w8to16 w0s w1s =
180− (w0 `shiftL` 8) .|. w1
210+ (w0 `unsafeShiftL` 8) .|. w1
182 w0 = fromIntegral w0s
212 w0 = fromIntegral w0s
183 w1 = fromIntegral w1s
213 w1 = fromIntegral w1s
@@ -211,7 +241,7 @@ buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
211 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
241 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
212 b8' = b8 .&. 0x3f .|. 0x80
242 b8' = b8 .&. 0x3f .|. 0x80
214−-- |Build a UUID of a given version from Word32 values.
244+-- |Build a UUID of a given version from 'Word32' values.
215buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
245buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
216buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
246buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
217 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
247 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
@@ -245,8 +275,8 @@ null = (== nil)
245 -- null (UUID 0 0 0 0) = True
275 -- null (UUID 0 0 0 0) = True
246 -- null _ = False
276 -- null _ = False
248−-- |The nil UUID, as defined in RFC 4122.
278+-- |The 'nil' UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
249−-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
279+-- It is a UUID of all zeros. @'null' u@ /iff/ @'u' == 'nil'@.
250nil :: UUID
280nil :: UUID
251nil = UUID 0 0
281nil = UUID 0 0
@@ -256,6 +286,8 @@ fromByteString :: BL.ByteString -> Maybe UUID
256fromByteString = fromList . BL.unpack
286fromByteString = fromList . BL.unpack
258-- |Encode a UUID into a 'ByteString' in network order.
288-- |Encode a UUID into a 'ByteString' in network order.
290+-- This uses the same encoding as the 'Binary' instance.
259toByteString :: UUID -> BL.ByteString
291toByteString :: UUID -> BL.ByteString
260toByteString = BL.pack . toList
292toByteString = BL.pack . toList
@@ -263,9 +295,8 @@ toByteString = BL.pack . toList
263-- The hyphens may not be omitted.
295-- The hyphens may not be omitted.
264-- Example:
296-- Example:
267−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
298+-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"
268−-- @
299+-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c
270-- Hex digits may be upper or lower-case.
301-- Hex digits may be upper or lower-case.
271fromString :: String -> Maybe UUID
302fromString :: String -> Maybe UUID
@@ -297,32 +328,39 @@ fromString' s0 = do
297-- | Convert a UUID into a hypenated string using lower-case letters.
328-- | Convert a UUID into a hypenated string using lower-case letters.
298-- Example:
329-- Example:
301−-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
331+-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"
302−-- @
332+-- Just "550e8400-e29b-41d4-a716-446655440000"
303toString :: UUID -> String
335toString :: UUID -> String
304−toString uuid = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
336+toString uuid = hexw0 w0 $ hexw1 w1 ""
305− where hexw :: Word32 -> String -> String
337+ where hexw0 :: Word64 -> String -> String
338+ hexw0 w s = hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48
339+ : hexn w 44 : hexn w 40 : hexn w 36 : hexn w 32
306− hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
340+ : '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
307− : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
341+ : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
309− hexw' :: Word32 -> String -> String
344+ hexw1 :: Word64 -> String -> String
310− hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
345+ hexw1 w s = '-' : hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48
346+ : '-' : hexn w 44 : hexn w 40 : hexn w 36 : hexn w 32
347+ : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
311− : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
348+ : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
313− hexn :: Word32 -> Int -> Char
351+ hexn :: Word64 -> Int -> Char
314 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
352 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
316− (w0,w1,w2,w3) = toWords uuid
354+ (w0,w1) = toWords64 uuid
318-- | If the passed in `Text` can be parsed as an ASCII representation of
356-- | If the passed in `Text` can be parsed as an ASCII representation of
319-- a `UUID`, it will be. The hyphens may not be omitted.
357-- a `UUID`, it will be. The hyphens may not be omitted.
320fromText :: Text -> Maybe UUID
358fromText :: Text -> Maybe UUID
321−fromText = fromString . T.unpack
359+fromText = fromASCIIBytes . T.encodeUtf8
323-- | Convert a UUID into a hyphentated string using lower-case letters.
361-- | Convert a UUID into a hyphentated string using lower-case letters.
324toText :: UUID -> Text
362toText :: UUID -> Text
325−toText = T.pack . toString
363+toText = T.decodeLatin1 . toASCIIBytes
327-- | Convert a UUID into a hyphentated string using lower-case letters, packed
365-- | Convert a UUID into a hyphentated string using lower-case letters, packed
328-- as ASCII bytes into `B.ByteString`.
366-- as ASCII bytes into `B.ByteString`.
@@ -417,49 +455,30 @@ fromASCIIBytes bs = do
417-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
455-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
418toLazyASCIIBytes :: UUID -> BL.ByteString
456toLazyASCIIBytes :: UUID -> BL.ByteString
419toLazyASCIIBytes =
457toLazyASCIIBytes =
420−#if MIN_VERSION_bytestring(0,10,0)
421 BL.fromStrict
458 BL.fromStrict
423− BL.fromChunks . return
425 . toASCIIBytes
459 . toASCIIBytes
427-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
461-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
428fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
462fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
429fromLazyASCIIBytes bs =
463fromLazyASCIIBytes bs =
430− if BL.length bs == 36 then fromASCIIBytes (
464+ if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
431−#if MIN_VERSION_bytestring(0,10,0)
434− B.concat $ BL.toChunks bs
439-- Class Instances
467-- Class Instances
470+-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471+-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
442instance Random UUID where
472instance Random UUID where
443− random g = (fromGenNext w0 w1 w2 w3 w4, g4)
473+ random = uniform
444− where (w0, g0) = next g
449 randomR _ = random -- range is ignored
474 randomR _ = random -- range is ignored
451−-- |Build a UUID from the results of five calls to next on a StdGen.
476+-- @since 1.0.4
452−-- While next on StdGet returns an Int, it doesn't provide 32 bits of
477+instance Uniform UUID where
453−-- randomness. This code relies on at last 28 bits of randomness in the
478+ uniformM gen = do
454−-- and optimizes its use so as to make only five random values, not six.
479+ w0 <- uniformWord64 gen
455−fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
480+ w1 <- uniformWord64 gen
456−fromGenNext w0 w1 w2 w3 w4 =
457− buildFromBytes 4 /-/ (ThreeByte w0)
481+ pure $ buildFromBytes 4 /-/ w0 /-/ w1
459− /-/ w2 -- use all 4 bytes because we know the version
460− -- field will "cover" the upper, non-random bits
464-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
483-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
465-- only returns 31 bits of randomness.
484-- only returns 31 bits of randomness.
@@ -467,8 +486,8 @@ type instance ByteSink ThreeByte g = Takes3Bytes g
467newtype ThreeByte = ThreeByte Int
486newtype ThreeByte = ThreeByte Int
468instance ByteSource ThreeByte where
487instance ByteSource ThreeByte where
469 f /-/ (ThreeByte w) = f b1 b2 b3
488 f /-/ (ThreeByte w) = f b1 b2 b3
470− where b1 = fromIntegral (w `shiftR` 16)
489+ where b1 = fromIntegral (w `unsafeShiftR` 16)
471− b2 = fromIntegral (w `shiftR` 8)
490+ b2 = fromIntegral (w `unsafeShiftR` 8)
472 b3 = fromIntegral w
491 b3 = fromIntegral w
474instance NFData UUID where
493instance NFData UUID where
@@ -485,6 +504,11 @@ instance Hashable UUID where
485 `hashWithSalt` w2
504 `hashWithSalt` w2
486 `hashWithSalt` w3
505 `hashWithSalt` w3
507+-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.
510+-- "00000000-0000-0000-0000-000000000000"
488instance Show UUID where
512instance Show UUID where
489 show = toString
513 show = toString
@@ -495,7 +519,7 @@ instance Read UUID where
495 Nothing -> []
519 Nothing -> []
496 Just u -> [(u,drop 36 noSpaces)]
520 Just u -> [(u,drop 36 noSpaces)]
498−
522+-- | This 'Storable' instance uses the memory layout as described in <http://tools.ietf.org/html/rfc4122 RFC 4122>, but in contrast to the 'Binary' instance, __the fields are stored in host byte order__.
499instance Storable UUID where
523instance Storable UUID where
500 sizeOf _ = 16
524 sizeOf _ = 16
501 alignment _ = 4
525 alignment _ = 4
@@ -532,6 +556,7 @@ instance Storable UUID where
532 pokeByteOff p (off+14) x9
556 pokeByteOff p (off+14) x9
533 pokeByteOff p (off+15) x10
557 pokeByteOff p (off+15) x10
559+-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
535instance Binary UUID where
560instance Binary UUID where
536 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
561 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
537 get = liftM2 UUID getWord64be getWord64be
562 get = liftM2 UUID getWord64be getWord64be
@@ -547,13 +572,4 @@ instance Data UUID where
547uuidType :: DataType
572uuidType :: DataType
548uuidType = mkNoRepType "Data.UUID.Types.UUID"
573uuidType = mkNoRepType "Data.UUID.Types.UUID"
550−#if !(MIN_VERSION_base(4,2,0))
575+deriving instance Lift UUID
551−mkNoRepType :: String -> DataType
552−mkNoRepType = mkNorepType
555−#if !MIN_VERSION_base(4,5,0)
556−unsafeShiftR, unsafeShiftL :: Word64 -> Int -> Word64
557−unsafeShiftR = shiftR
558−unsafeShiftL = shiftL