@@ -1,83 +1,85 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE ViewPatterns #-}
5−{-# LANGUAGE Unsafe #-}
6−{-# LANGUAGE DeriveLift #-}
7−{-# LANGUAGE StandaloneDeriving #-}
1+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP, ViewPatterns #-}
82{-# OPTIONS_HADDOCK hide #-}
93
104-- |
115-- Module : Data.UUID.Types.Internal
12−-- Copyright : (c) 2017-2018 Herbert Valerio Riedel
13−-- (c) 2008-2009, 2012 Antoine Latter
6+-- Copyright : (c) 2008-2009, 2012 Antoine Latter
147-- (c) 2009 Mark Lentczner
158--
169-- License : BSD-style
1710--
18−-- Maintainer : hvr@gnu.org
11+-- Maintainer : aslatter@gmail.com
12+-- Stability : experimental
1913-- Portability : portable
2014
2115module Data.UUID.Types.Internal
22− ( UUID(..)
23− , null
24− , nil
25− , fromByteString
26− , toByteString
27− , fromString
28− , toString
29− , fromText
30− , toText
31− , fromWords
32− , toWords
33− , fromWords64
34− , toWords64
35− , toList
36− , buildFromBytes
37− , buildFromWords
38− , fromASCIIBytes
39− , toASCIIBytes
40− , fromLazyASCIIBytes
41− , toLazyASCIIBytes
42− , UnpackedUUID(..)
43− , pack
44− , unpack
16+ (UUID(..)
17+ ,null
18+ ,nil
19+ ,fromByteString
20+ ,toByteString
21+ ,fromString
22+ ,toString
23+ ,fromText
24+ ,toText
25+ ,fromWords
26+ ,toWords
27+ ,toList
28+ ,buildFromBytes
29+ ,buildFromWords
30+ ,fromASCIIBytes
31+ ,toASCIIBytes
32+ ,fromLazyASCIIBytes
33+ ,toLazyASCIIBytes
34+ ,UnpackedUUID(..)
35+ ,pack
36+ ,unpack
4537 ) where
4638
47−import Prelude hiding (null)
48−
49−import Control.DeepSeq (NFData (..))
50−import Control.Monad (guard, liftM2)
51−import Data.Bits
52−import Data.Char
53−import Data.Data
54−import Data.Hashable
55−import Data.List (elemIndices)
56−import Foreign.Ptr (Ptr)
57−
58−import Foreign.Storable
59−
60−import Data.Binary
61−import Data.Binary.Get
62−import Data.Binary.Put
63−import qualified Data.ByteString as B
64−import qualified Data.ByteString.Internal as BI
65−import qualified Data.ByteString.Lazy as BL
66−import qualified Data.ByteString.Unsafe as BU
67−import Data.Text (Text)
68−import qualified Data.Text.Encoding as T
69−
70−import Data.UUID.Types.Internal.Builder
71−
72−import System.Random (Random (..), uniform)
73−import System.Random.Stateful (Uniform (..), uniformWord64)
74−
75−import Language.Haskell.TH.Syntax (Lift)
76−
77−-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
78−-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
79−data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
80− deriving (Eq, Ord)
39+import Prelude hiding (null)
40+
41+import Control.Applicative ((<*>))
42+import Control.DeepSeq (NFData(..))
43+import Control.Monad (liftM2, guard)
44+import Data.Functor ((<$>))
45+import Data.Char
46+import Data.Bits
47+import Data.Hashable
48+import Data.List (elemIndices)
49+import Foreign.Ptr (Ptr)
50+
51+#if MIN_VERSION_base(4,0,0)
52+import Data.Data
53+#else
54+import Data.Generics.Basics
55+#endif
56+
57+import Foreign.Storable
58+
59+import Data.Binary
60+import Data.Binary.Put
61+import Data.Binary.Get
62+import qualified Data.ByteString as B
63+import qualified Data.ByteString.Internal as BI
64+import qualified Data.ByteString.Lazy as BL
65+import qualified Data.ByteString.Unsafe as BU
66+import Data.Text (Text)
67+import qualified Data.Text as T
68+
69+import Data.UUID.Types.Internal.Builder
70+
71+import System.Random
72+
73+
74+-- |The UUID type. A 'Random' instance is provided which produces
75+-- insecure version 4 UUIDs as specified in RFC 4122. The 'Storable' and
76+-- 'Binary' instances are compatible with RFC 4122, storing the fields in
77+-- network order as 16 bytes.
78+data UUID
79+ = UUID
80+ {-# UNPACK #-} !Word64
81+ {-# UNPACK #-} !Word64
82+ deriving (Eq, Ord, Typeable)
8183{-
8284 Prior to uuid-types-1.0.4:
8385 !Word32 !Word32 !Word32 !Word32
@@ -92,18 +94,10 @@ data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
9294 None was as fast, overall, as the representation used here.
9395-}
9496
95−-- | Convert a 'UUID' into a sequence of 'Word32' values.
97+-- | Covert a 'UUID' into a sequence of 'Word32' values.
9698-- Useful for when you need to serialize a UUID and
9799-- neither 'Storable' nor 'Binary' are appropriate.
98−--
99−-- >>> toWords <$> fromString "550e8400-e29b-41d4-a716-446655440000"
100−-- Just (1427014656,3801825748,2803254374,1430519808)
101−--
102−-- See also 'toWords64'.
103−--
104−-- /Since: @uuid-1.2.2@/
105−--
106−-- @since 1.0.0
100+-- Introduced in version 1.2.2.
107101toWords :: UUID -> (Word32, Word32, Word32, Word32)
108102toWords (UUID w12 w34) = (w1, w2, w3, w4)
109103 where
@@ -113,49 +107,25 @@ toWords (UUID w12 w34) = (w1, w2, w3, w4)
113107 w4 = fromIntegral w34
114108
115109-- | Create a 'UUID' from a sequence of 'Word32'. The
116−-- inverse of 'toWords'. Useful when you need a total
110+-- opposite of 'toWords'. Useful when you need a total
117111-- function for constructing 'UUID' values.
118−--
119−-- See also 'fromWords64'.
120−--
121−-- /Since: @uuid-1.2.2@/
122−--
123−-- @since 1.0.0
112+-- Introduced in version 1.2.2.
124113fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
125114fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
126115
127−-- | Convert a 'UUID' into a pair of 'Word64's.
128−--
129−-- >>> toWords64 <$> fromString "550e8400-e29b-41d4-a716-446655440000"
130−-- Just (6128981282234515924,12039885860129472512)
131−--
132−-- See also 'toWords'.
133−--
134−-- @since 1.0.4
135−toWords64 :: UUID -> (Word64, Word64)
136−toWords64 (UUID w12 w34) = (w12,w34)
137−
138−-- | Create a 'UUID' from a pair of 'Word64's.
139−--
140−-- Inverse of 'toWords64'. See also 'fromWords'.
141−--
142−-- @since 1.0.4
143−fromWords64 :: Word64 -> Word64 -> UUID
144−fromWords64 = UUID
145−
146116data UnpackedUUID =
147117 UnpackedUUID {
148− time_low :: Word32 -- 0-3
149− , time_mid :: Word16 -- 4-5
118+ time_low :: Word32 -- 0-3
119+ , time_mid :: Word16 -- 4-5
150120 , time_hi_and_version :: Word16 -- 6-7
151− , clock_seq_hi_res :: Word8 -- 8
152− , clock_seq_low :: Word8 -- 9
153− , node_0 :: Word8
154− , node_1 :: Word8
155− , node_2 :: Word8
156− , node_3 :: Word8
157− , node_4 :: Word8
158− , node_5 :: Word8
121+ , clock_seq_hi_res :: Word8 -- 8
122+ , clock_seq_low :: Word8 -- 9
123+ , node_0 :: Word8
124+ , node_1 :: Word8
125+ , node_2 :: Word8
126+ , node_3 :: Word8
127+ , node_4 :: Word8
128+ , node_5 :: Word8
159129 }
160130 deriving (Read, Show, Eq, Ord)
161131
@@ -195,10 +165,10 @@ pack unpacked =
195165
196166-- |Build a Word32 from four Word8 values, presented in big-endian order
197167word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
198−word a b c d = (fromIntegral a `unsafeShiftL` 24)
199− .|. (fromIntegral b `unsafeShiftL` 16)
200− .|. (fromIntegral c `unsafeShiftL` 8)
201− .|. (fromIntegral d )
168+word a b c d = (fromIntegral a `shiftL` 24)
169+ .|. (fromIntegral b `shiftL` 16)
170+ .|. (fromIntegral c `shiftL` 8)
171+ .|. (fromIntegral d )
202172
203173-- |Extract a Word8 from a Word64. Bytes, high to low, are numbered from 7 to 0,
204174byte :: Int -> Word64 -> Word8
@@ -207,7 +177,7 @@ byte i w = fromIntegral (w `shiftR` (i * 8))
207177-- |Build a Word16 from two Word8 values, presented in big-endian order.
208178w8to16 :: Word8 -> Word8 -> Word16
209179w8to16 w0s w1s =
210− (w0 `unsafeShiftL` 8) .|. w1
180+ (w0 `shiftL` 8) .|. w1
211181 where
212182 w0 = fromIntegral w0s
213183 w1 = fromIntegral w1s
@@ -241,7 +211,7 @@ buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
241211 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
242212 b8' = b8 .&. 0x3f .|. 0x80
243213
244−-- |Build a UUID of a given version from 'Word32' values.
214+-- |Build a UUID of a given version from Word32 values.
245215buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
246216buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
247217 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
@@ -275,8 +245,8 @@ null = (== nil)
275245 -- null (UUID 0 0 0 0) = True
276246 -- null _ = False
277247
278−-- |The 'nil' UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
279−-- It is a UUID of all zeros. @'null' u@ /iff/ @'u' == 'nil'@.
248+-- |The nil UUID, as defined in RFC 4122.
249+-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
280250nil :: UUID
281251nil = UUID 0 0
282252
@@ -286,8 +256,6 @@ fromByteString :: BL.ByteString -> Maybe UUID
286256fromByteString = fromList . BL.unpack
287257
288258-- |Encode a UUID into a 'ByteString' in network order.
289−--
290−-- This uses the same encoding as the 'Binary' instance.
291259toByteString :: UUID -> BL.ByteString
292260toByteString = BL.pack . toList
293261
@@ -295,8 +263,9 @@ toByteString = BL.pack . toList
295263-- The hyphens may not be omitted.
296264-- Example:
297265--
298−-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"
299−-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c
266+-- @
267+-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
268+-- @
300269--
301270-- Hex digits may be upper or lower-case.
302271fromString :: String -> Maybe UUID
@@ -328,39 +297,32 @@ fromString' s0 = do
328297-- | Convert a UUID into a hypenated string using lower-case letters.
329298-- Example:
330299--
331−-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"
332−-- Just "550e8400-e29b-41d4-a716-446655440000"
333−--
334−--
300+-- @
301+-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
302+-- @
335303toString :: UUID -> String
336−toString uuid = hexw0 w0 $ hexw1 w1 ""
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
340− : '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
341− : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
342− : s
343−
344− hexw1 :: Word64 -> String -> String
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
348− : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
349− : s
350−
351− hexn :: Word64 -> Int -> Char
304+toString uuid = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
305+ where hexw :: Word32 -> String -> String
306+ hexw w s = 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
308+
309+ hexw' :: Word32 -> String -> String
310+ hexw' w s = '-' : 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
312+
313+ hexn :: Word32 -> Int -> Char
352314 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
353315
354− (w0,w1) = toWords64 uuid
316+ (w0,w1,w2,w3) = toWords uuid
355317
356318-- | If the passed in `Text` can be parsed as an ASCII representation of
357319-- a `UUID`, it will be. The hyphens may not be omitted.
358320fromText :: Text -> Maybe UUID
359−fromText = fromASCIIBytes . T.encodeUtf8
321+fromText = fromString . T.unpack
360322
361323-- | Convert a UUID into a hyphentated string using lower-case letters.
362324toText :: UUID -> Text
363−toText = T.decodeLatin1 . toASCIIBytes
325+toText = T.pack . toString
364326
365327-- | Convert a UUID into a hyphentated string using lower-case letters, packed
366328-- as ASCII bytes into `B.ByteString`.
@@ -455,30 +417,49 @@ fromASCIIBytes bs = do
455417-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
456418toLazyASCIIBytes :: UUID -> BL.ByteString
457419toLazyASCIIBytes =
420+#if MIN_VERSION_bytestring(0,10,0)
458421 BL.fromStrict
422+#else
423+ BL.fromChunks . return
424+#endif
459425 . toASCIIBytes
460426
461427-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
462428fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
463429fromLazyASCIIBytes bs =
464− if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
430+ if BL.length bs == 36 then fromASCIIBytes (
431+#if MIN_VERSION_bytestring(0,10,0)
432+ BL.toStrict bs
433+#else
434+ B.concat $ BL.toChunks bs
435+#endif
436+ ) else Nothing
465437
466438--
467439-- Class Instances
468440--
469441
470−-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471−-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
472442instance Random UUID where
473− random = uniform
443+ random g = (fromGenNext w0 w1 w2 w3 w4, g4)
444+ where (w0, g0) = next g
445+ (w1, g1) = next g0
446+ (w2, g2) = next g1
447+ (w3, g3) = next g2
448+ (w4, g4) = next g3
474449 randomR _ = random -- range is ignored
475450
476−-- @since 1.0.4
477−instance Uniform UUID where
478− uniformM gen = do
479− w0 <- uniformWord64 gen
480− w1 <- uniformWord64 gen
481− pure $ buildFromBytes 4 /-/ w0 /-/ w1
451+-- |Build a UUID from the results of five calls to next on a StdGen.
452+-- While next on StdGet returns an Int, it doesn't provide 32 bits of
453+-- randomness. This code relies on at last 28 bits of randomness in the
454+-- and optimizes its use so as to make only five random values, not six.
455+fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
456+fromGenNext w0 w1 w2 w3 w4 =
457+ buildFromBytes 4 /-/ (ThreeByte w0)
458+ /-/ (ThreeByte w1)
459+ /-/ w2 -- use all 4 bytes because we know the version
460+ -- field will "cover" the upper, non-random bits
461+ /-/ (ThreeByte w3)
462+ /-/ (ThreeByte w4)
482463
483464-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
484465-- only returns 31 bits of randomness.
@@ -486,8 +467,8 @@ type instance ByteSink ThreeByte g = Takes3Bytes g
486467newtype ThreeByte = ThreeByte Int
487468instance ByteSource ThreeByte where
488469 f /-/ (ThreeByte w) = f b1 b2 b3
489− where b1 = fromIntegral (w `unsafeShiftR` 16)
490− b2 = fromIntegral (w `unsafeShiftR` 8)
470+ where b1 = fromIntegral (w `shiftR` 16)
471+ b2 = fromIntegral (w `shiftR` 8)
491472 b3 = fromIntegral w
492473
493474instance NFData UUID where
@@ -504,11 +485,6 @@ instance Hashable UUID where
504485 `hashWithSalt` w2
505486 `hashWithSalt` w3
506487
507−-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.
508−--
509−-- >>> show nil
510−-- "00000000-0000-0000-0000-000000000000"
511−--
512488instance Show UUID where
513489 show = toString
514490
@@ -519,7 +495,7 @@ instance Read UUID where
519495 Nothing -> []
520496 Just u -> [(u,drop 36 noSpaces)]
521497
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__.
498+
523499instance Storable UUID where
524500 sizeOf _ = 16
525501 alignment _ = 4
@@ -556,7 +532,6 @@ instance Storable UUID where
556532 pokeByteOff p (off+14) x9
557533 pokeByteOff p (off+15) x10
558534
559−-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
560535instance Binary UUID where
561536 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
562537 get = liftM2 UUID getWord64be getWord64be
@@ -572,4 +547,13 @@ instance Data UUID where
572547uuidType :: DataType
573548uuidType = mkNoRepType "Data.UUID.Types.UUID"
574549
575−deriving instance Lift UUID
550+#if !(MIN_VERSION_base(4,2,0))
551+mkNoRepType :: String -> DataType
552+mkNoRepType = mkNorepType
553+#endif
554+
555+#if !MIN_VERSION_base(4,5,0)
556+unsafeShiftR, unsafeShiftL :: Word64 -> Int -> Word64
557+unsafeShiftR = shiftR
558+unsafeShiftL = shiftL
559+#endif