git.iko.soy/typeable/uuid
on 3fd3cf5 help sign in
typeable/uuid/Data/UUID/Internal.hs
431 lines 14 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 ) where
33import Prelude hiding (null)
35import Control.Applicative ((<*>))
36import Control.DeepSeq (NFData(..))
37import Control.Monad (liftM4, guard)
38import Data.Functor ((<$>))
39import Data.Char
40import Data.Bits
41import Data.Hashable
42import Data.Maybe
43import Data.List (elemIndices)
44import Foreign.Ptr (Ptr)
46#if MIN_VERSION_base(4,0,0)
47import Data.Data
48#else
49import Data.Generics.Basics
50#endif
52import Foreign.Storable
54import Data.Binary
55import Data.Binary.Put
56import Data.Binary.Get
57import qualified Data.ByteString as B
58import qualified Data.ByteString.Internal as BI
59import qualified Data.ByteString.Lazy as BL
60import qualified Data.ByteString.Unsafe as BU
62import Data.UUID.Builder
64import System.Random
67-- |The UUID type. A 'Random' instance is provided which produces
68-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
69-- 'Binary' instances are compatible with RFC 4122, storing the fields
70-- in network order as 16 bytes.
71data UUID
72 = UUID
73 {-# UNPACK #-} !Word32
74 {-# UNPACK #-} !Word32
75 {-# UNPACK #-} !Word32
76 {-# UNPACK #-} !Word32
77 deriving (Eq, Ord, Typeable)
78{-
79 Other representations that we tried are:
80 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16
81 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8
82 Sixteen bytes: !Word8 ... (x 16)
83 Simple list of bytes: [Word8]
84 ByteString (strict) ByteString
85 Immutable array: UArray Int Word8
86 Vector: UArr Word8
87 None was as fast, overall, as the representation used here.
88-}
90-- | Covert a 'UUID' into a sequence of 'Word32' values.
91-- Usefull for when you need to serialize a UUID and
92-- neither 'Storable' nor 'Binary' are appropriate.
93-- Introduced in version 1.2.2.
94toWords :: UUID -> (Word32, Word32, Word32, Word32)
95toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)
97-- | Create a 'UUID' from a sequence of 'Word32'. The
98-- opposite of 'toWords'. Useful when you need a total
99-- function for constructing 'UUID' values.
100-- Introduced in version 1.2.2.
101fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
102fromWords = UUID
104--
105-- UTILITIES
106--
108-- |Build a Word32 from four Word8 values, presented in big-endian order
109word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
110word a b c d = (fromIntegral a `shiftL` 24)
111 .|. (fromIntegral b `shiftL` 16)
112 .|. (fromIntegral c `shiftL` 8)
113 .|. (fromIntegral d )
115-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,
116byte :: Int -> Word32 -> Word8
117byte i w = fromIntegral (w `shiftR` (i * 8))
120-- |Make a UUID from sixteen Word8 values
121makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8
122 -> Word8 -> Word8 -> Word8 -> Word8
123 -> Word8 -> Word8 -> Word8 -> Word8
124 -> Word8 -> Word8 -> Word8 -> Word8
125 -> UUID
126makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
127 = UUID w0 w1 w2 w3
128 where w0 = word b0 b1 b2 b3
129 w1 = word b4 b5 b6 b7
130 w2 = word b8 b9 ba bb
131 w3 = word bc bd be bf
133-- |Make a UUID from four Word32 values
134makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
135makeFromWords = UUID
137-- |A Builder for constructing a UUID of a given version.
138buildFromBytes :: Word8
139 -> Word8 -> Word8 -> Word8 -> Word8
140 -> Word8 -> Word8 -> Word8 -> Word8
141 -> Word8 -> Word8 -> Word8 -> Word8
142 -> Word8 -> Word8 -> Word8 -> Word8
143 -> UUID
144buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
145 makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf
146 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
147 b8' = b8 .&. 0x3f .|. 0x80
149-- |Build a UUID of a given version from Word32 values.
150buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
151buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
152 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
153 w2' = w2 .&. 0x3fffffff .|. 0x80000000
156-- |Return the bytes that make up the UUID
157toList :: UUID -> [Word8]
158toList (UUID w0 w1 w2 w3) =
159 [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,
160 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,
161 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,
162 byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]
164-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't
165-- exactly sixteen bytes long
166fromList :: [Word8] -> Maybe UUID
167fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =
168 Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
169fromList _ = Nothing
172--
173-- UUID API
174--
176-- |Returns true if the passed-in UUID is the 'nil' UUID.
177null :: UUID -> Bool
178null = (== nil)
179 -- Note: This actually faster than:
180 -- null (UUID 0 0 0 0) = True
181 -- null _ = False
183-- |The nil UUID, as defined in RFC 4122.
184-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
185nil :: UUID
186nil = UUID 0 0 0 0
188-- |Extract a UUID from a 'ByteString' in network byte order.
189-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
190fromByteString :: BL.ByteString -> Maybe UUID
191fromByteString = fromList . BL.unpack
193-- |Encode a UUID into a 'ByteString' in network order.
194toByteString :: UUID -> BL.ByteString
195toByteString = BL.pack . toList
197-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
198-- The hyphens may not be omitted.
199-- Example:
200--
201-- @
202-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
203-- @
204--
205-- Hex digits may be upper or lower-case.
206fromString :: String -> Maybe UUID
207fromString xs | validFmt = fromString' xs
208 | otherwise = Nothing
209 where validFmt = elemIndices '-' xs == [8,13,18,23]
211fromString' :: String -> Maybe UUID
212fromString' s0 = do
213 (w0, s1) <- hexWord s0
214 (w1, s2) <- hexWord s1
215 (w2, s3) <- hexWord s2
216 (w3, s4) <- hexWord s3
217 if s4 /= "" then Nothing
218 else Just $ UUID w0 w1 w2 w3
219 where hexWord :: String -> Maybe (Word32, String)
220 hexWord s = Just (0, s) >>= hexByte >>= hexByte
221 >>= hexByte >>= hexByte
223 hexByte :: (Word32, String) -> Maybe (Word32, String)
224 hexByte (w, '-':ds) = hexByte (w, ds)
225 hexByte (w, hi:lo:ds)
226 | bothHex = Just ((w `shiftL` 8) .|. octet, ds)
227 | otherwise = Nothing
228 where bothHex = isHexDigit hi && isHexDigit lo
229 octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
230 hexByte _ = Nothing
232-- | Convert a UUID into a hypenated string using lower-case letters.
233-- Example:
234--
235-- @
236-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
237-- @
238toString :: UUID -> String
239toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
240 where hexw :: Word32 -> String -> String
241 hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
242 : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
244 hexw' :: Word32 -> String -> String
245 hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
246 : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
248 hexn :: Word32 -> Int -> Char
249 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
252--
253-- Class Instances
254--
256instance Random UUID where
257 random g = (fromGenNext w0 w1 w2 w3 w4, g4)
258 where (w0, g0) = next g
259 (w1, g1) = next g0
260 (w2, g2) = next g1
261 (w3, g3) = next g2
262 (w4, g4) = next g3
263 randomR _ = random -- range is ignored
265-- |Build a UUID from the results of five calls to next on a StdGen.
266-- While next on StdGet returns an Int, it doesn't provide 32 bits of
267-- randomness. This code relies on at last 28 bits of randomness in the
268-- and optimizes its use so as to make only five random values, not six.
269fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
270fromGenNext w0 w1 w2 w3 w4 =
271 buildFromBytes 4 /-/ (ThreeByte w0)
272 /-/ (ThreeByte w1)
273 /-/ w2 -- use all 4 bytes because we know the version
274 -- field will "cover" the upper, non-random bits
275 /-/ (ThreeByte w3)
276 /-/ (ThreeByte w4)
278-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
279-- only returns 31 bits of randomness.
280type instance ByteSink ThreeByte g = Takes3Bytes g
281newtype ThreeByte = ThreeByte Int
282instance ByteSource ThreeByte where
283 f /-/ (ThreeByte w) = f b1 b2 b3
284 where b1 = fromIntegral (w `shiftR` 16)
285 b2 = fromIntegral (w `shiftR` 8)
286 b3 = fromIntegral w
288instance Hashable UUID where
289 hash (UUID w0 w1 w2 w3) =
290 hash w0 `hashWithSalt` w1
291 `hashWithSalt` w2
292 `hashWithSalt` w3
293 hashWithSalt s (UUID w0 w1 w2 w3) =
294 s `hashWithSalt` w0
295 `hashWithSalt` w1
296 `hashWithSalt` w2
297 `hashWithSalt` w3
299instance Show UUID where
300 show = toString
302instance Read UUID where
303 readsPrec _ str =
304 let noSpaces = dropWhile isSpace str
305 in case fromString (take 36 noSpaces) of
306 Nothing -> []
307 Just u -> [(u,drop 36 noSpaces)]
310instance Storable UUID where
311 sizeOf _ = 16
312 alignment _ = 1 -- UUIDs are stored as individual octets
314 peekByteOff p off =
315 mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList
317 pokeByteOff p off u =
318 sequence_ $ zipWith (pokeByteOff p) [off..] (toList u)
321instance Binary UUID where
322 put (UUID w0 w1 w2 w3) =
323 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3
324 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be
327-- My goal with this instance was to make it work just enough to do what
328-- I want when used with the HStringTemplate library.
329instance Data UUID where
330 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
331 gunfold _ _ = error "gunfold"
332 dataTypeOf _ = uuidType
334uuidType :: DataType
335uuidType = mkNoRepType "Data.UUID.UUID"
337#if !(MIN_VERSION_base(4,2,0))
338mkNoRepType :: String -> DataType
339mkNoRepType = mkNorepType
340#endif
342fromASCIIBytes :: B.ByteString -> Maybe UUID
343fromASCIIBytes bs = do
344 guard wellFormed
345 fromWords <$> single 0 <*> double 9 14 <*> double 19 24 <*> single 28
346 where
347 -- ord '-' ==> 45
348 dashIx bs' ix = BU.unsafeIndex bs' ix == 45
350 -- Important: check the length first, given the `unsafeIndex` later.
351 wellFormed =
352 B.length bs == 36 && dashIx bs 8 && dashIx bs 13 &&
353 dashIx bs 18 && dashIx bs 23
355 single ix = combine <$> octet ix <*> octet (ix + 2)
356 <*> octet (ix + 4) <*> octet (ix + 6)
357 double ix0 ix1 = combine <$> octet ix0 <*> octet (ix0 + 2)
358 <*> octet ix1 <*> octet (ix1 + 2)
360 combine o0 o1 o2 o3 = shiftL o0 24 .|. shiftL o1 16 .|. shiftL o2 8 .|. o3
362 octet ix = do
363 hi <- fromIntegral <$> toDigit (BU.unsafeIndex bs ix)
364 lo <- fromIntegral <$> toDigit (BU.unsafeIndex bs (ix + 1))
365 return (16 * hi + lo)
367 toDigit :: Word8 -> Maybe Word8
368 toDigit w
369 -- Digit
370 | w >= 48 && w <= 57 = Just (w - 48)
371 -- Uppercase
372 | w >= 65 && w <= 70 = Just (10 + w - 65)
373 -- Lowercase
374 | w >= 97 && w <= 102 = Just (10 + w - 97)
375 | otherwise = Nothing
377toASCIIBytes :: UUID -> B.ByteString
378toASCIIBytes uuid = BI.unsafeCreate 36 (pokeASCII uuid)
380pokeASCII :: UUID -> Ptr Word8 -> IO ()
381pokeASCII uuid ptr = do
382 pokeDash 8
383 pokeDash 13
384 pokeDash 18
385 pokeDash 23
386 pokeSingle 0 w0
387 pokeDouble 9 w1
388 pokeDouble 19 w2
389 pokeSingle 28 w3
390 where
391 (w0, w1, w2, w3) = toWords uuid
393 -- ord '-' ==> 45
394 pokeDash ix = pokeElemOff ptr ix 45
396 pokeSingle ix w = do
397 pokeWord ix w 28
398 pokeWord (ix + 1) w 24
399 pokeWord (ix + 2) w 20
400 pokeWord (ix + 3) w 16
401 pokeWord (ix + 4) w 12
402 pokeWord (ix + 5) w 8
403 pokeWord (ix + 6) w 4
404 pokeWord (ix + 7) w 0
406 -- We skip the dash in the middle
407 pokeDouble ix w = do
408 pokeWord ix w 28
409 pokeWord (ix + 1) w 24
410 pokeWord (ix + 2) w 20
411 pokeWord (ix + 3) w 16
412 pokeWord (ix + 5) w 12
413 pokeWord (ix + 6) w 8
414 pokeWord (ix + 7) w 4
415 pokeWord (ix + 8) w 0
417 pokeWord ix w r =
418 pokeElemOff ptr ix (fromIntegral (toDigit ((w `shiftR` r) .&. 0xf)))
420 toDigit :: Word32 -> Word32
421 toDigit w = if w < 10 then 48 + w else 97 + w - 10
423fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
424fromLazyASCIIBytes bs =
425 if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
427toLazyASCIIBytes :: UUID -> BL.ByteString
428toLazyASCIIBytes = BL.fromStrict . toASCIIBytes
430instance NFData UUID where
431 rnf = rnf . toWords