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