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