git.iko.soy/typeable/uuid
on 52eb205 help sign in
typeable/uuid/Data/UUID/Internal.hs
330 lines 11 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 ) where
29import Prelude hiding (null)
31import Control.Monad (liftM4)
32import Data.Char
33import Data.Bits
34import Data.Hashable
35import Data.Maybe
36import Data.List (elemIndices)
38#if MIN_VERSION_base(4,0,0)
39import Data.Data
40#else
41import Data.Generics.Basics
42#endif
44import Foreign.Storable
46import Data.Binary
47import Data.Binary.Put
48import Data.Binary.Get
49import qualified Data.ByteString.Lazy as Lazy
51import Data.UUID.Builder
53import System.Random
56-- |The UUID type. A 'Random' instance is provided which produces
57-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
58-- 'Binary' instances are compatible with RFC 4122, storing the fields
59-- in network order as 16 bytes.
60data UUID
61 = UUID
62 {-# UNPACK #-} !Word32
63 {-# UNPACK #-} !Word32
64 {-# UNPACK #-} !Word32
65 {-# UNPACK #-} !Word32
66 deriving (Eq, Ord, Typeable)
67{-
68 Other representations that we tried are:
69 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16
70 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8
71 Sixteen bytes: !Word8 ... (x 16)
72 Simple list of bytes: [Word8]
73 ByteString (strict) ByteString
74 Immutable array: UArray Int Word8
75 Vector: UArr Word8
76 None was as fast, overall, as the representation used here.
77-}
79-- | Covert a 'UUID' into a sequence of 'Word32' values.
80-- Usefull for when you need to serialize a UUID and
81-- neither 'Storable' nor 'Binary' are appropriate.
82-- Introduced in version 1.2.2.
83toWords :: UUID -> (Word32, Word32, Word32, Word32)
84toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)
86-- | Create a 'UUID' from a sequence of 'Word32'. The
87-- opposite of 'toWords'. Useful when you need a total
88-- function for constructing 'UUID' values.
89-- Introduced in version 1.2.2.
90fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
91fromWords = UUID
93--
94-- UTILITIES
95--
97-- |Build a Word32 from four Word8 values, presented in big-endian order
98word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
99word a b c d = (fromIntegral a `shiftL` 24)
100 .|. (fromIntegral b `shiftL` 16)
101 .|. (fromIntegral c `shiftL` 8)
102 .|. (fromIntegral d )
104-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,
105byte :: Int -> Word32 -> Word8
106byte i w = fromIntegral (w `shiftR` (i * 8))
109-- |Make a UUID from sixteen Word8 values
110makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8
111 -> Word8 -> Word8 -> Word8 -> Word8
112 -> Word8 -> Word8 -> Word8 -> Word8
113 -> Word8 -> Word8 -> Word8 -> Word8
114 -> UUID
115makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
116 = UUID w0 w1 w2 w3
117 where w0 = word b0 b1 b2 b3
118 w1 = word b4 b5 b6 b7
119 w2 = word b8 b9 ba bb
120 w3 = word bc bd be bf
122-- |Make a UUID from four Word32 values
123makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
124makeFromWords = UUID
126-- |A Builder for constructing a UUID of a given version.
127buildFromBytes :: Word8
128 -> Word8 -> Word8 -> Word8 -> Word8
129 -> Word8 -> Word8 -> Word8 -> Word8
130 -> Word8 -> Word8 -> Word8 -> Word8
131 -> Word8 -> Word8 -> Word8 -> Word8
132 -> UUID
133buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
134 makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf
135 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
136 b8' = b8 .&. 0x3f .|. 0x80
138-- |Build a UUID of a given version from Word32 values.
139buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
140buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
141 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
142 w2' = w2 .&. 0x3fffffff .|. 0x80000000
145-- |Return the bytes that make up the UUID
146toList :: UUID -> [Word8]
147toList (UUID w0 w1 w2 w3) =
148 [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,
149 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,
150 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,
151 byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]
153-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't
154-- exactly sixteen bytes long
155fromList :: [Word8] -> Maybe UUID
156fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =
157 Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
158fromList _ = Nothing
161--
162-- UUID API
163--
165-- |Returns true if the passed-in UUID is the 'nil' UUID.
166null :: UUID -> Bool
167null = (== nil)
168 -- Note: This actually faster than:
169 -- null (UUID 0 0 0 0) = True
170 -- null _ = False
172-- |The nil UUID, as defined in RFC 4122.
173-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
174nil :: UUID
175nil = UUID 0 0 0 0
177-- |Extract a UUID from a 'ByteString' in network byte order.
178-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
179fromByteString :: Lazy.ByteString -> Maybe UUID
180fromByteString = fromList . Lazy.unpack
182-- |Encode a UUID into a 'ByteString' in network order.
183toByteString :: UUID -> Lazy.ByteString
184toByteString = Lazy.pack . toList
186-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
187-- The hyphens may not be omitted.
188-- Example:
189--
190-- @
191-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
192-- @
193--
194-- Hex digits may be upper or lower-case.
195fromString :: String -> Maybe UUID
196fromString xs | validFmt = fromString' xs
197 | otherwise = Nothing
198 where validFmt = elemIndices '-' xs == [8,13,18,23]
200fromString' :: String -> Maybe UUID
201fromString' s0 = do
202 (w0, s1) <- hexWord s0
203 (w1, s2) <- hexWord s1
204 (w2, s3) <- hexWord s2
205 (w3, s4) <- hexWord s3
206 if s4 /= "" then Nothing
207 else Just $ UUID w0 w1 w2 w3
208 where hexWord :: String -> Maybe (Word32, String)
209 hexWord s = Just (0, s) >>= hexByte >>= hexByte
210 >>= hexByte >>= hexByte
212 hexByte :: (Word32, String) -> Maybe (Word32, String)
213 hexByte (w, '-':ds) = hexByte (w, ds)
214 hexByte (w, hi:lo:ds)
215 | bothHex = Just ((w `shiftL` 8) .|. octet, ds)
216 | otherwise = Nothing
217 where bothHex = isHexDigit hi && isHexDigit lo
218 octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
219 hexByte _ = Nothing
221-- | Convert a UUID into a hypenated string using lower-case letters.
222-- Example:
223--
224-- @
225-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
226-- @
227toString :: UUID -> String
228toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
229 where hexw :: Word32 -> String -> String
230 hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
231 : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
233 hexw' :: Word32 -> String -> String
234 hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
235 : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
237 hexn :: Word32 -> Int -> Char
238 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
241--
242-- Class Instances
243--
245instance Random UUID where
246 random g = (fromGenNext w0 w1 w2 w3 w4, g4)
247 where (w0, g0) = next g
248 (w1, g1) = next g0
249 (w2, g2) = next g1
250 (w3, g3) = next g2
251 (w4, g4) = next g3
252 randomR _ = random -- range is ignored
254-- |Build a UUID from the results of five calls to next on a StdGen.
255-- While next on StdGet returns an Int, it doesn't provide 32 bits of
256-- randomness. This code relies on at last 28 bits of randomness in the
257-- and optimizes its use so as to make only five random values, not six.
258fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
259fromGenNext w0 w1 w2 w3 w4 =
260 buildFromBytes 4 /-/ (ThreeByte w0)
261 /-/ (ThreeByte w1)
262 /-/ w2 -- use all 4 bytes because we know the version
263 -- field will "cover" the upper, non-random bits
264 /-/ (ThreeByte w3)
265 /-/ (ThreeByte w4)
267-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
268-- only returns 31 bits of randomness.
269type instance ByteSink ThreeByte g = Takes3Bytes g
270newtype ThreeByte = ThreeByte Int
271instance ByteSource ThreeByte where
272 f /-/ (ThreeByte w) = f b1 b2 b3
273 where b1 = fromIntegral (w `shiftR` 16)
274 b2 = fromIntegral (w `shiftR` 8)
275 b3 = fromIntegral w
277instance Hashable UUID where
278 hash (UUID w0 w1 w2 w3) =
279 hash w0 `hashWithSalt` w1
280 `hashWithSalt` w2
281 `hashWithSalt` w3
282 hashWithSalt s (UUID w0 w1 w2 w3) =
283 s `hashWithSalt` w0
284 `hashWithSalt` w1
285 `hashWithSalt` w2
286 `hashWithSalt` w3
288instance Show UUID where
289 show = toString
291instance Read UUID where
292 readsPrec _ str =
293 let noSpaces = dropWhile isSpace str
294 in case fromString (take 36 noSpaces) of
295 Nothing -> []
296 Just u -> [(u,drop 36 noSpaces)]
299instance Storable UUID where
300 sizeOf _ = 16
301 alignment _ = 1 -- UUIDs are stored as individual octets
303 peekByteOff p off =
304 mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList
306 pokeByteOff p off u =
307 sequence_ $ zipWith (pokeByteOff p) [off..] (toList u)
310instance Binary UUID where
311 put (UUID w0 w1 w2 w3) =
312 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3
313 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be
316-- My goal with this instance was to make it work just enough to do what
317-- I want when used with the HStringTemplate library.
318instance Data UUID where
319 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
320 gunfold _ _ = error "gunfold"
321 dataTypeOf _ = uuidType
323uuidType :: DataType
324uuidType = mkNoRepType "Data.UUID.UUID"
326#if !(MIN_VERSION_base(4,2,0))
327mkNoRepType :: String -> DataType
328mkNoRepType = mkNorepType
329#endif