git.iko.soy/typeable/uuid
on 22d4cbb help sign in
typeable/uuid/Data/UUID/Internal.hs
530 lines 17 kB history raw
1{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-}
3-- |
4-- Module : Data.UUID
5-- Copyright : (c) 2008-2009, 2012 Antoine Latter
6-- (c) 2009 Mark Lentczner
7--
8-- License : BSD-style
9--
10-- Maintainer : aslatter@gmail.com
11-- Stability : experimental
12-- Portability : portable
14module Data.UUID.Internal
15 (UUID(..)
16 ,null
17 ,nil
18 ,fromByteString
19 ,toByteString
20 ,fromString
21 ,toString
22 ,fromWords
23 ,toWords
24 ,toList
25 ,buildFromBytes
26 ,buildFromWords
27 ,fromASCIIBytes
28 ,toASCIIBytes
29 ,fromLazyASCIIBytes
30 ,toLazyASCIIBytes
31 ,UnpackedUUID(..)
32 ,pack
33 ,unpack
34 ) where
36import Prelude hiding (null)
38import Control.Applicative ((<*>))
39import Control.DeepSeq (NFData(..))
40import Control.Monad (liftM4, guard)
41import Data.Functor ((<$>))
42import Data.Char
43import Data.Bits
44import Data.Hashable
45import Data.List (elemIndices)
46import Foreign.Ptr (Ptr)
48#if MIN_VERSION_base(4,0,0)
49import Data.Data
50#else
51import Data.Generics.Basics
52#endif
54import Foreign.Storable
56import Data.Binary
57import Data.Binary.Put
58import Data.Binary.Get
59import qualified Data.ByteString as B
60import qualified Data.ByteString.Internal as BI
61import qualified Data.ByteString.Lazy as BL
62import qualified Data.ByteString.Unsafe as BU
64import Data.UUID.Builder
65import Data.Word.Util
67import System.Random
70-- |The UUID type. A 'Random' instance is provided which produces
71-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
72-- 'Binary' instances are compatible with RFC 4122, storing the fields
73-- in network order as 16 bytes.
74data UUID
75 = UUID
76 {-# UNPACK #-} !Word32
77 {-# UNPACK #-} !Word32
78 {-# UNPACK #-} !Word32
79 {-# UNPACK #-} !Word32
80 deriving (Eq, Ord, Typeable)
81{-
82 Other representations that we tried are:
83 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16
84 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8
85 Sixteen bytes: !Word8 ... (x 16)
86 Simple list of bytes: [Word8]
87 ByteString (strict) ByteString
88 Immutable array: UArray Int Word8
89 Vector: UArr Word8
90 None was as fast, overall, as the representation used here.
91-}
93-- | Covert a 'UUID' into a sequence of 'Word32' values.
94-- Usefull for when you need to serialize a UUID and
95-- neither 'Storable' nor 'Binary' are appropriate.
96-- Introduced in version 1.2.2.
97toWords :: UUID -> (Word32, Word32, Word32, Word32)
98toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)
100-- | Create a 'UUID' from a sequence of 'Word32'. The
101-- opposite of 'toWords'. Useful when you need a total
102-- function for constructing 'UUID' values.
103-- Introduced in version 1.2.2.
104fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
105fromWords = UUID
107data UnpackedUUID =
108 UnpackedUUID {
109 time_low :: Word32 -- 0-3
110 , time_mid :: Word16 -- 4-5
111 , time_hi_and_version :: Word16 -- 6-7
112 , clock_seq_hi_res :: Word8 -- 8
113 , clock_seq_low :: Word8 -- 9
114 , node_0 :: Word8
115 , node_1 :: Word8
116 , node_2 :: Word8
117 , node_3 :: Word8
118 , node_4 :: Word8
119 , node_5 :: Word8
120 }
121 deriving (Read, Show, Eq, Ord)
123unpack :: UUID -> UnpackedUUID
124unpack (UUID w0 w1 w2 w3) =
125 build /-/ w0 /-/ w1 /-/ w2 /-/ w3
127 where
128 build x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF =
129 UnpackedUUID {
130 time_low = word x0 x1 x2 x3
131 , time_mid = w8to16 x4 x5
132 , time_hi_and_version = w8to16 x6 x7
133 , clock_seq_hi_res = x8
134 , clock_seq_low = x9
135 , node_0 = xA
136 , node_1 = xB
137 , node_2 = xC
138 , node_3 = xD
139 , node_4 = xE
140 , node_5 = xF
141 }
143pack :: UnpackedUUID -> UUID
144pack unpacked =
145 makeFromBytes /-/ (time_low unpacked)
146 /-/ (time_mid unpacked)
147 /-/ (time_hi_and_version unpacked)
148 /-/ (clock_seq_hi_res unpacked)
149 /-/ (clock_seq_low unpacked)
150 /-/ (node_0 unpacked) /-/ (node_1 unpacked)
151 /-/ (node_2 unpacked) /-/ (node_3 unpacked)
152 /-/ (node_4 unpacked) /-/ (node_5 unpacked)
155--
156-- UTILITIES
157--
159-- |Build a Word32 from four Word8 values, presented in big-endian order
160word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
161word a b c d = (fromIntegral a `shiftL` 24)
162 .|. (fromIntegral b `shiftL` 16)
163 .|. (fromIntegral c `shiftL` 8)
164 .|. (fromIntegral d )
166-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,
167byte :: Int -> Word32 -> Word8
168byte i w = fromIntegral (w `shiftR` (i * 8))
171-- |Make a UUID from sixteen Word8 values
172makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8
173 -> Word8 -> Word8 -> Word8 -> Word8
174 -> Word8 -> Word8 -> Word8 -> Word8
175 -> Word8 -> Word8 -> Word8 -> Word8
176 -> UUID
177makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
178 = UUID w0 w1 w2 w3
179 where w0 = word b0 b1 b2 b3
180 w1 = word b4 b5 b6 b7
181 w2 = word b8 b9 ba bb
182 w3 = word bc bd be bf
184-- |Make a UUID from four Word32 values
185makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
186makeFromWords = UUID
188-- |A Builder for constructing a UUID of a given version.
189buildFromBytes :: Word8
190 -> Word8 -> Word8 -> Word8 -> Word8
191 -> Word8 -> Word8 -> Word8 -> Word8
192 -> Word8 -> Word8 -> Word8 -> Word8
193 -> Word8 -> Word8 -> Word8 -> Word8
194 -> UUID
195buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
196 makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf
197 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
198 b8' = b8 .&. 0x3f .|. 0x80
200-- |Build a UUID of a given version from Word32 values.
201buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
202buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
203 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
204 w2' = w2 .&. 0x3fffffff .|. 0x80000000
207-- |Return the bytes that make up the UUID
208toList :: UUID -> [Word8]
209toList (UUID w0 w1 w2 w3) =
210 [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,
211 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,
212 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,
213 byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]
215-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't
216-- exactly sixteen bytes long
217fromList :: [Word8] -> Maybe UUID
218fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =
219 Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
220fromList _ = Nothing
223--
224-- UUID API
225--
227-- |Returns true if the passed-in UUID is the 'nil' UUID.
228null :: UUID -> Bool
229null = (== nil)
230 -- Note: This actually faster than:
231 -- null (UUID 0 0 0 0) = True
232 -- null _ = False
234-- |The nil UUID, as defined in RFC 4122.
235-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
236nil :: UUID
237nil = UUID 0 0 0 0
239-- |Extract a UUID from a 'ByteString' in network byte order.
240-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
241fromByteString :: BL.ByteString -> Maybe UUID
242fromByteString = fromList . BL.unpack
244-- |Encode a UUID into a 'ByteString' in network order.
245toByteString :: UUID -> BL.ByteString
246toByteString = BL.pack . toList
248-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
249-- The hyphens may not be omitted.
250-- Example:
251--
252-- @
253-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
254-- @
255--
256-- Hex digits may be upper or lower-case.
257fromString :: String -> Maybe UUID
258fromString xs | validFmt = fromString' xs
259 | otherwise = Nothing
260 where validFmt = elemIndices '-' xs == [8,13,18,23]
262fromString' :: String -> Maybe UUID
263fromString' s0 = do
264 (w0, s1) <- hexWord s0
265 (w1, s2) <- hexWord s1
266 (w2, s3) <- hexWord s2
267 (w3, s4) <- hexWord s3
268 if s4 /= "" then Nothing
269 else Just $ UUID w0 w1 w2 w3
270 where hexWord :: String -> Maybe (Word32, String)
271 hexWord s = Just (0, s) >>= hexByte >>= hexByte
272 >>= hexByte >>= hexByte
274 hexByte :: (Word32, String) -> Maybe (Word32, String)
275 hexByte (w, '-':ds) = hexByte (w, ds)
276 hexByte (w, hi:lo:ds)
277 | bothHex = Just ((w `shiftL` 8) .|. octet, ds)
278 | otherwise = Nothing
279 where bothHex = isHexDigit hi && isHexDigit lo
280 octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
281 hexByte _ = Nothing
283-- | Convert a UUID into a hypenated string using lower-case letters.
284-- Example:
285--
286-- @
287-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
288-- @
289toString :: UUID -> String
290toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
291 where hexw :: Word32 -> String -> String
292 hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
293 : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
295 hexw' :: Word32 -> String -> String
296 hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
297 : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
299 hexn :: Word32 -> Int -> Char
300 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
302-- | Convert a UUID into a hyphentated string using lower-case letters, packed
303-- as ASCII bytes into `B.ByteString`.
304--
305-- This should be equivalent to `toString` with `Data.ByteString.Char8.pack`.
306toASCIIBytes :: UUID -> B.ByteString
307toASCIIBytes uuid = BI.unsafeCreate 36 (pokeASCII uuid)
309-- | Helper function for `toASCIIBytes`
310pokeASCII :: UUID -> Ptr Word8 -> IO ()
311pokeASCII uuid ptr = do
312 pokeDash 8
313 pokeDash 13
314 pokeDash 18
315 pokeDash 23
316 pokeSingle 0 w0
317 pokeDouble 9 w1
318 pokeDouble 19 w2
319 pokeSingle 28 w3
320 where
321 (w0, w1, w2, w3) = toWords uuid
323 -- ord '-' ==> 45
324 pokeDash ix = pokeElemOff ptr ix 45
326 pokeSingle ix w = do
327 pokeWord ix w 28
328 pokeWord (ix + 1) w 24
329 pokeWord (ix + 2) w 20
330 pokeWord (ix + 3) w 16
331 pokeWord (ix + 4) w 12
332 pokeWord (ix + 5) w 8
333 pokeWord (ix + 6) w 4
334 pokeWord (ix + 7) w 0
336 -- We skip the dash in the middle
337 pokeDouble ix w = do
338 pokeWord ix w 28
339 pokeWord (ix + 1) w 24
340 pokeWord (ix + 2) w 20
341 pokeWord (ix + 3) w 16
342 pokeWord (ix + 5) w 12
343 pokeWord (ix + 6) w 8
344 pokeWord (ix + 7) w 4
345 pokeWord (ix + 8) w 0
347 pokeWord ix w r =
348 pokeElemOff ptr ix (fromIntegral (toDigit ((w `shiftR` r) .&. 0xf)))
350 toDigit :: Word32 -> Word32
351 toDigit w = if w < 10 then 48 + w else 97 + w - 10
353-- | If the passed in `B.ByteString` can be parsed as an ASCII representation of
354-- a `UUID`, it will be. The hyphens may not be omitted.
355--
356-- This should be equivalent to `fromString` with `Data.ByteString.Char8.unpack`.
357fromASCIIBytes :: B.ByteString -> Maybe UUID
358fromASCIIBytes bs = do
359 guard wellFormed
360 fromWords <$> single 0 <*> double 9 14 <*> double 19 24 <*> single 28
361 where
362 -- ord '-' ==> 45
363 dashIx bs' ix = BU.unsafeIndex bs' ix == 45
365 -- Important: check the length first, given the `unsafeIndex` later.
366 wellFormed =
367 B.length bs == 36 && dashIx bs 8 && dashIx bs 13 &&
368 dashIx bs 18 && dashIx bs 23
370 single ix = combine <$> octet ix <*> octet (ix + 2)
371 <*> octet (ix + 4) <*> octet (ix + 6)
372 double ix0 ix1 = combine <$> octet ix0 <*> octet (ix0 + 2)
373 <*> octet ix1 <*> octet (ix1 + 2)
375 combine o0 o1 o2 o3 = shiftL o0 24 .|. shiftL o1 16 .|. shiftL o2 8 .|. o3
377 octet ix = do
378 hi <- fromIntegral <$> toDigit (BU.unsafeIndex bs ix)
379 lo <- fromIntegral <$> toDigit (BU.unsafeIndex bs (ix + 1))
380 return (16 * hi + lo)
382 toDigit :: Word8 -> Maybe Word8
383 toDigit w
384 -- Digit
385 | w >= 48 && w <= 57 = Just (w - 48)
386 -- Uppercase
387 | w >= 65 && w <= 70 = Just (10 + w - 65)
388 -- Lowercase
389 | w >= 97 && w <= 102 = Just (10 + w - 97)
390 | otherwise = Nothing
392-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
393toLazyASCIIBytes :: UUID -> BL.ByteString
394toLazyASCIIBytes =
395#if MIN_VERSION_bytestring(0,10,0)
396 BL.fromStrict
397#else
398 BL.fromChunks . return
399#endif
400 . toASCIIBytes
402-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
403fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
404fromLazyASCIIBytes bs =
405 if BL.length bs == 36 then fromASCIIBytes (
406#if MIN_VERSION_bytestring(0,10,0)
407 BL.toStrict bs
408#else
409 B.concat $ BL.toChunks bs
410#endif
411 ) else Nothing
413--
414-- Class Instances
415--
417instance Random UUID where
418 random g = (fromGenNext w0 w1 w2 w3 w4, g4)
419 where (w0, g0) = next g
420 (w1, g1) = next g0
421 (w2, g2) = next g1
422 (w3, g3) = next g2
423 (w4, g4) = next g3
424 randomR _ = random -- range is ignored
426-- |Build a UUID from the results of five calls to next on a StdGen.
427-- While next on StdGet returns an Int, it doesn't provide 32 bits of
428-- randomness. This code relies on at last 28 bits of randomness in the
429-- and optimizes its use so as to make only five random values, not six.
430fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
431fromGenNext w0 w1 w2 w3 w4 =
432 buildFromBytes 4 /-/ (ThreeByte w0)
433 /-/ (ThreeByte w1)
434 /-/ w2 -- use all 4 bytes because we know the version
435 -- field will "cover" the upper, non-random bits
436 /-/ (ThreeByte w3)
437 /-/ (ThreeByte w4)
439-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
440-- only returns 31 bits of randomness.
441type instance ByteSink ThreeByte g = Takes3Bytes g
442newtype ThreeByte = ThreeByte Int
443instance ByteSource ThreeByte where
444 f /-/ (ThreeByte w) = f b1 b2 b3
445 where b1 = fromIntegral (w `shiftR` 16)
446 b2 = fromIntegral (w `shiftR` 8)
447 b3 = fromIntegral w
449instance NFData UUID where
450 rnf = rnf . toWords
452instance Hashable UUID where
453 hash (UUID w0 w1 w2 w3) =
454 hash w0 `hashWithSalt` w1
455 `hashWithSalt` w2
456 `hashWithSalt` w3
457 hashWithSalt s (UUID w0 w1 w2 w3) =
458 s `hashWithSalt` w0
459 `hashWithSalt` w1
460 `hashWithSalt` w2
461 `hashWithSalt` w3
463instance Show UUID where
464 show = toString
466instance Read UUID where
467 readsPrec _ str =
468 let noSpaces = dropWhile isSpace str
469 in case fromString (take 36 noSpaces) of
470 Nothing -> []
471 Just u -> [(u,drop 36 noSpaces)]
474instance Storable UUID where
475 sizeOf _ = 16
476 alignment _ = 4
478 peekByteOff p off =
479 pack <$>
480 (UnpackedUUID
481 <$> peekByteOff p off -- Word32
482 <*> peekByteOff p (off+4) -- Word16
483 <*> peekByteOff p (off+6) -- Word16
484 <*> peekByteOff p (off+8) -- Word8
485 <*> peekByteOff p (off+9) -- Word8
486 <*> peekByteOff p (off+10) -- Word8
487 <*> peekByteOff p (off+11) -- Word8
488 <*> peekByteOff p (off+12) -- Word8
489 <*> peekByteOff p (off+13) -- Word8
490 <*> peekByteOff p (off+14) -- Word8
491 <*> peekByteOff p (off+15) -- Word8
492 )
494 pokeByteOff p off u =
495 case unpack u of
496 (UnpackedUUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->
497 do
498 pokeByteOff p off x0
499 pokeByteOff p (off+4) x1
500 pokeByteOff p (off+6) x2
501 pokeByteOff p (off+8) x3
502 pokeByteOff p (off+9) x4
503 pokeByteOff p (off+10) x5
504 pokeByteOff p (off+11) x6
505 pokeByteOff p (off+12) x7
506 pokeByteOff p (off+13) x8
507 pokeByteOff p (off+14) x9
508 pokeByteOff p (off+15) x10
510instance Binary UUID where
511 put (UUID w0 w1 w2 w3) =
512 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3
513 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be
516-- My goal with this instance was to make it work just enough to do what
517-- I want when used with the HStringTemplate library.
518instance Data UUID where
519 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
520 gunfold _ _ = error "gunfold"
521 dataTypeOf _ = uuidType
523uuidType :: DataType
524uuidType = mkNoRepType "Data.UUID.UUID"
526#if !(MIN_VERSION_base(4,2,0))
527mkNoRepType :: String -> DataType
528mkNoRepType = mkNorepType
529#endif