@@ -2,17 +2,20 @@
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE Unsafe #-}
6+{-# LANGUAGE DeriveLift #-}
7+{-# LANGUAGE StandaloneDeriving #-}
58{-# OPTIONS_HADDOCK hide #-}
69
710-- |
811-- Module : Data.UUID.Types.Internal
9−-- Copyright : (c) 2008-2009, 2012 Antoine Latter
12+-- Copyright : (c) 2017-2018 Herbert Valerio Riedel
13+-- (c) 2008-2009, 2012 Antoine Latter
1014-- (c) 2009 Mark Lentczner
1115--
1216-- License : BSD-style
1317--
14−-- Maintainer : aslatter@gmail.com
15−-- Stability : experimental
18+-- Maintainer : hvr@gnu.org
1619-- Portability : portable
1720
1821module Data.UUID.Types.Internal
@@ -27,6 +30,8 @@ module Data.UUID.Types.Internal
2730 , toText
2831 , fromWords
2932 , toWords
33+ , fromWords64
34+ , toWords64
3035 , toList
3136 , buildFromBytes
3237 , buildFromWords
@@ -41,22 +46,15 @@ module Data.UUID.Types.Internal
4146
4247import Prelude hiding (null)
4348
44−import Control.Applicative ((<*>))
4549import Control.DeepSeq (NFData (..))
4650import Control.Monad (guard, liftM2)
4751import Data.Bits
4852import Data.Char
49−import Data.Functor ((<$>))
53+import Data.Data
5054import Data.Hashable
5155import Data.List (elemIndices)
5256import Foreign.Ptr (Ptr)
5357
54−#if MIN_VERSION_base(4,0,0)
55−import Data.Data
56−#else
57−import Data.Generics.Basics
58−#endif
59−
6058import Foreign.Storable
6159
6260import Data.Binary
@@ -67,19 +65,19 @@ import qualified Data.ByteString.Internal as BI
6765import qualified Data.ByteString.Lazy as BL
6866import qualified Data.ByteString.Unsafe as BU
6967import Data.Text (Text)
70−import qualified Data.Text as T
68+import qualified Data.Text.Encoding as T
7169
7270import Data.UUID.Types.Internal.Builder
7371
74−import System.Random
72+import System.Random (Random (..), uniform)
73+import System.Random.Stateful (Uniform (..), uniformWord64)
7574
75+import Language.Haskell.TH.Syntax (Lift)
7676
77−-- |The UUID type. A 'Random' instance is provided which produces
78−-- insecure version 4 UUIDs as specified in RFC 4122. The 'Storable' and
79−-- 'Binary' instances are compatible with RFC 4122, storing the fields in
80−-- network order as 16 bytes.
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>.
8179data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
82− deriving (Eq, Ord, Typeable)
80+ deriving (Eq, Ord)
8381{-
8482 Prior to uuid-types-1.0.4:
8583 !Word32 !Word32 !Word32 !Word32
@@ -94,10 +92,18 @@ data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
9492 None was as fast, overall, as the representation used here.
9593-}
9694
97−-- | Covert a 'UUID' into a sequence of 'Word32' values.
95+-- | Convert a 'UUID' into a sequence of 'Word32' values.
9896-- Useful for when you need to serialize a UUID and
9997-- 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)
101+--
102+-- See also 'toWords64'.
103+--
104+-- /Since: @uuid-1.2.2@/
105+--
106+-- @since 1.0.0
101107toWords :: UUID -> (Word32, Word32, Word32, Word32)
102108toWords (UUID w12 w34) = (w1, w2, w3, w4)
103109 where
@@ -107,12 +113,36 @@ toWords (UUID w12 w34) = (w1, w2, w3, w4)
107113 w4 = fromIntegral w34
108114
109115-- | 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
111117-- function for constructing 'UUID' values.
112−-- Introduced in version 1.2.2.
118+--
119+-- See also 'fromWords64'.
120+--
121+-- /Since: @uuid-1.2.2@/
122+--
123+-- @since 1.0.0
113124fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
114125fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
115126
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+
116146data UnpackedUUID =
117147 UnpackedUUID {
118148 time_low :: Word32 -- 0-3
@@ -165,10 +195,10 @@ pack unpacked =
165195
166196-- |Build a Word32 from four Word8 values, presented in big-endian order
167197word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
168−word a b c d = (fromIntegral a `shiftL` 24)
169− .|. (fromIntegral b `shiftL` 16)
170− .|. (fromIntegral c `shiftL` 8)
171− .|. (fromIntegral d )
198+word a b c d = (fromIntegral a `unsafeShiftL` 24)
199+ .|. (fromIntegral b `unsafeShiftL` 16)
200+ .|. (fromIntegral c `unsafeShiftL` 8)
201+ .|. (fromIntegral d )
172202
173203-- |Extract a Word8 from a Word64. Bytes, high to low, are numbered from 7 to 0,
174204byte :: Int -> Word64 -> Word8
@@ -177,7 +207,7 @@ byte i w = fromIntegral (w `shiftR` (i * 8))
177207-- |Build a Word16 from two Word8 values, presented in big-endian order.
178208w8to16 :: Word8 -> Word8 -> Word16
179209w8to16 w0s w1s =
180− (w0 `shiftL` 8) .|. w1
210+ (w0 `unsafeShiftL` 8) .|. w1
181211 where
182212 w0 = fromIntegral w0s
183213 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 =
211241 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
212242 b8' = b8 .&. 0x3f .|. 0x80
213243
214−-- |Build a UUID of a given version from Word32 values.
244+-- |Build a UUID of a given version from 'Word32' values.
215245buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
216246buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
217247 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
@@ -245,8 +275,8 @@ null = (== nil)
245275 -- null (UUID 0 0 0 0) = True
246276 -- null _ = False
247277
248−-- |The nil UUID, as defined in RFC 4122.
249−-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
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'@.
250280nil :: UUID
251281nil = UUID 0 0
252282
@@ -256,6 +286,8 @@ fromByteString :: BL.ByteString -> Maybe UUID
256286fromByteString = fromList . BL.unpack
257287
258288-- |Encode a UUID into a 'ByteString' in network order.
289+--
290+-- This uses the same encoding as the 'Binary' instance.
259291toByteString :: UUID -> BL.ByteString
260292toByteString = BL.pack . toList
261293
@@ -263,9 +295,8 @@ toByteString = BL.pack . toList
263295-- The hyphens may not be omitted.
264296-- Example:
265297--
266−-- @
267−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
268−-- @
298+-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"
299+-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c
269300--
270301-- Hex digits may be upper or lower-case.
271302fromString :: String -> Maybe UUID
@@ -297,32 +328,39 @@ fromString' s0 = do
297328-- | Convert a UUID into a hypenated string using lower-case letters.
298329-- Example:
299330--
300−-- @
301−-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
302−-- @
331+-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"
332+-- Just "550e8400-e29b-41d4-a716-446655440000"
333+--
334+--
303335toString :: UUID -> String
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
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
314352 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
315353
316− (w0,w1,w2,w3) = toWords uuid
354+ (w0,w1) = toWords64 uuid
317355
318356-- | If the passed in `Text` can be parsed as an ASCII representation of
319357-- a `UUID`, it will be. The hyphens may not be omitted.
320358fromText :: Text -> Maybe UUID
321−fromText = fromString . T.unpack
359+fromText = fromASCIIBytes . T.encodeUtf8
322360
323361-- | Convert a UUID into a hyphentated string using lower-case letters.
324362toText :: UUID -> Text
325−toText = T.pack . toString
363+toText = T.decodeLatin1 . toASCIIBytes
326364
327365-- | Convert a UUID into a hyphentated string using lower-case letters, packed
328366-- as ASCII bytes into `B.ByteString`.
@@ -417,49 +455,30 @@ fromASCIIBytes bs = do
417455-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
418456toLazyASCIIBytes :: UUID -> BL.ByteString
419457toLazyASCIIBytes =
420−#if MIN_VERSION_bytestring(0,10,0)
421458 BL.fromStrict
422−#else
423− BL.fromChunks . return
424−#endif
425459 . toASCIIBytes
426460
427461-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
428462fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
429463fromLazyASCIIBytes bs =
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
464+ if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
437465
438466--
439467-- Class Instances
440468--
441469
470+-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471+-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
442472instance Random UUID where
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
473+ random = uniform
449474 randomR _ = random -- range is ignored
450475
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)
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
463482
464483-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
465484-- only returns 31 bits of randomness.
@@ -467,8 +486,8 @@ type instance ByteSink ThreeByte g = Takes3Bytes g
467486newtype ThreeByte = ThreeByte Int
468487instance ByteSource ThreeByte where
469488 f /-/ (ThreeByte w) = f b1 b2 b3
470− where b1 = fromIntegral (w `shiftR` 16)
471− b2 = fromIntegral (w `shiftR` 8)
489+ where b1 = fromIntegral (w `unsafeShiftR` 16)
490+ b2 = fromIntegral (w `unsafeShiftR` 8)
472491 b3 = fromIntegral w
473492
474493instance NFData UUID where
@@ -485,6 +504,11 @@ instance Hashable UUID where
485504 `hashWithSalt` w2
486505 `hashWithSalt` w3
487506
507+-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.
508+--
509+-- >>> show nil
510+-- "00000000-0000-0000-0000-000000000000"
511+--
488512instance Show UUID where
489513 show = toString
490514
@@ -495,7 +519,7 @@ instance Read UUID where
495519 Nothing -> []
496520 Just u -> [(u,drop 36 noSpaces)]
497521
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__.
499523instance Storable UUID where
500524 sizeOf _ = 16
501525 alignment _ = 4
@@ -532,6 +556,7 @@ instance Storable UUID where
532556 pokeByteOff p (off+14) x9
533557 pokeByteOff p (off+15) x10
534558
559+-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
535560instance Binary UUID where
536561 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
537562 get = liftM2 UUID getWord64be getWord64be
@@ -547,13 +572,4 @@ instance Data UUID where
547572uuidType :: DataType
548573uuidType = mkNoRepType "Data.UUID.Types.UUID"
549574
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
575+deriving instance Lift UUID