@@ -1,85 +1,83 @@
1−{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP, ViewPatterns #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE Unsafe #-}
6+{-# LANGUAGE DeriveLift #-}
7+{-# LANGUAGE StandaloneDeriving #-}
2{-# OPTIONS_HADDOCK hide #-}
8{-# OPTIONS_HADDOCK hide #-}
5-- Module : Data.UUID.Types.Internal
11-- Module : Data.UUID.Types.Internal
12+-- Copyright : (c) 2017-2018 Herbert Valerio Riedel
6−-- Copyright : (c) 2008-2009, 2012 Antoine Latter
13+-- (c) 2008-2009, 2012 Antoine Latter
7-- (c) 2009 Mark Lentczner
14-- (c) 2009 Mark Lentczner
9-- License : BSD-style
16-- License : BSD-style
11−-- Maintainer : aslatter@gmail.com
18+-- Maintainer : hvr@gnu.org
12−-- Stability : experimental
13-- Portability : portable
19-- Portability : portable
15module Data.UUID.Types.Internal
21module Data.UUID.Types.Internal
16− (UUID(..)
22+ ( UUID(..)
19− ,fromByteString
25+ , fromByteString
20− ,toByteString
26+ , toByteString
21− ,fromString
27+ , fromString
22− ,toString
28+ , toString
23− ,fromText
29+ , fromText
25− ,fromWords
31+ , fromWords
26− ,toWords
32+ , toWords
28− ,buildFromBytes
36+ , buildFromBytes
29− ,buildFromWords
37+ , buildFromWords
30− ,fromASCIIBytes
38+ , fromASCIIBytes
31− ,toASCIIBytes
39+ , toASCIIBytes
32− ,fromLazyASCIIBytes
40+ , fromLazyASCIIBytes
33− ,toLazyASCIIBytes
41+ , toLazyASCIIBytes
34− ,UnpackedUUID(..)
42+ , UnpackedUUID(..)
39−import Prelude hiding (null)
47+import Prelude hiding (null)
41−import Control.Applicative ((<*>))
42−import Control.DeepSeq (NFData(..))
49+import Control.DeepSeq (NFData (..))
43−import Control.Monad (liftM2, guard)
50+import Control.Monad (guard, liftM2)
44−import Data.Functor ((<$>))
51+import Data.Bits
45−import Data.Char
52+import Data.Char
46−import Data.Bits
53+import Data.Data
47−import Data.Hashable
54+import Data.Hashable
48−import Data.List (elemIndices)
55+import Data.List (elemIndices)
49−import Foreign.Ptr (Ptr)
56+import Foreign.Ptr (Ptr)
51−#if MIN_VERSION_base(4,0,0)
58+import Foreign.Storable
54−import Data.Generics.Basics
60+import Data.Binary
57−import Foreign.Storable
59−import Data.Binary
61+import Data.Binary.Get
60−import Data.Binary.Put
62+import Data.Binary.Put
61−import Data.Binary.Get
62−import qualified Data.ByteString as B
63+import qualified Data.ByteString as B
63−import qualified Data.ByteString.Internal as BI
64+import qualified Data.ByteString.Internal as BI
64−import qualified Data.ByteString.Lazy as BL
65+import qualified Data.ByteString.Lazy as BL
65−import qualified Data.ByteString.Unsafe as BU
66+import qualified Data.ByteString.Unsafe as BU
66−import Data.Text (Text)
67+import Data.Text (Text)
67−import qualified Data.Text as T
68+import qualified Data.Text.Encoding as T
69−import Data.UUID.Types.Internal.Builder
70+import Data.UUID.Types.Internal.Builder
71−import System.Random
72+import System.Random (Random (..), uniform)
72−
73+import System.Random.Stateful (Uniform (..), uniformWord64)
74−-- |The UUID type. A 'Random' instance is provided which produces
75+import Language.Haskell.TH.Syntax (Lift)
75−-- insecure version 4 UUIDs as specified in RFC 4122. The 'Storable' and
76+
76−-- 'Binary' instances are compatible with RFC 4122, storing the fields in
77+-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
77−-- network order as 16 bytes.
78+-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
80− {-# UNPACK #-} !Word64
79+data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
81− {-# 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
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,25 +113,49 @@ 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
119− , time_mid :: Word16 -- 4-5
149+ , time_mid :: Word16 -- 4-5
120 , time_hi_and_version :: Word16 -- 6-7
150 , time_hi_and_version :: Word16 -- 6-7
121− , clock_seq_hi_res :: Word8 -- 8
151+ , clock_seq_hi_res :: Word8 -- 8
122− , clock_seq_low :: Word8 -- 9
152+ , clock_seq_low :: Word8 -- 9
123− , node_0 :: Word8
153+ , node_0 :: Word8
124− , node_1 :: Word8
154+ , node_1 :: Word8
125− , node_2 :: Word8
155+ , node_2 :: Word8
126− , node_3 :: Word8
156+ , node_3 :: Word8
127− , node_4 :: Word8
157+ , node_4 :: Word8
128− , node_5 :: Word8
158+ , node_5 :: Word8
130 deriving (Read, Show, Eq, Ord)
160 deriving (Read, Show, Eq, Ord)
@@ -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