@@ -1,8 +1,8 @@
1−{-# LANGUAGE DeriveDataTypeable, CPP #-}
1+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-}
22
33-- |
44-- Module : Data.UUID
5−-- Copyright : (c) 2008 Antoine Latter
5+-- Copyright : (c) 2008-2009 Antoine Latter
66--
77-- License : BSD-style
88--
@@ -14,29 +14,22 @@ module Data.UUID.Internal
1414 (UUID(..)
1515 ,null
1616 ,nil
17− ,Node(..)
18− ,nullNode
19− ,nodeToList
20− ,listToNode
2117 ,fromByteString
2218 ,toByteString
2319 ,fromString
2420 ,toString
25− ,versionMask
26− ,reservedMask
27− ,reserved
21+ ,buildFromBytes
22+ ,buildFromWords
2823 ) where
2924
3025import Prelude hiding (null)
3126import qualified Prelude
3227
33−import Data.Word
28+import Control.Monad (liftM4)
3429import Data.Char
3530import Data.Maybe
3631import Data.Bits
37−import Data.List (splitAt, foldl', unfoldr)
38−
39−import Data.Typeable
32+import Data.List (elemIndices)
4033
4134#if MIN_VERSION_base(4,0,0)
4235import Data.Data
@@ -44,7 +37,6 @@ import Data.Data
4437import Data.Generics.Basics
4538#endif
4639
47−import Foreign.Ptr
4840import Foreign.Storable
4941
5042import Data.Binary
@@ -52,93 +44,214 @@ import Data.Binary.Put
5244import Data.Binary.Get
5345import qualified Data.ByteString.Lazy as Lazy
5446
55−import System.Random
47+import Data.UUID.Builder
5648
57−import Text.Printf
49+import System.Random
5850
59−#ifndef STRICT
60−#define SLOT(x) x
61−#else
62−#define SLOT(x) {-# UNPACK #-} !x
63−#endif
6451
6552-- |The UUID type. A 'Random' instance is provided which produces
66−-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
67−-- 'Binary' instances are compatable with RFC 4122. The 'Binary'
68−-- instance serializes to network byte order.
69−data UUID = UUID
70− {uuid_timeLow :: SLOT(Word32)
71− ,uuid_timeMid :: SLOT(Word16)
72− ,uuid_timeHigh :: SLOT(Word16) -- includes version number
73− ,uuid_clockSeqHi :: SLOT(Word8) -- includes reserved field
74− ,uuid_clokcSeqLow :: SLOT(Word8)
75− ,uuid_node :: SLOT(Node)
76− } deriving (Eq, Ord, Typeable)
53+-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
54+-- 'Binary' instances are compatible with RFC 4122, storing the fields
55+-- in network order as 16 bytes.
56+data UUID = UUID !Word32 !Word32 !Word32 !Word32
57+ deriving (Eq, Ord, Typeable)
58+{-
59+ Other representations that we tried are:
60+ Mimic V1 structure: !Word32 !Word16 !Word16 !Word16
61+ !Word8 !Word8 !Word8 !Word8 !Word8 !Word8
62+ Sixteen bytes: !Word8 ... (x 16)
63+ Simple list of bytes: [Word8]
64+ ByteString (strict) ByteString
65+ Immutable array: UArray Int Word8
66+ Vector: UArr Word8
67+ None was as fast, overall, as the representation used here.
68+-}
69+
70+
71+--
72+-- UTILITIES
73+--
74+
75+-- |Build a Word32 from four Word8 values, presented in big-endian order
76+word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
77+word a b c d = (fromIntegral a `shiftL` 24)
78+ .|. (fromIntegral b `shiftL` 16)
79+ .|. (fromIntegral c `shiftL` 8)
80+ .|. (fromIntegral d )
81+
82+-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,
83+byte :: Int -> Word32 -> Word8
84+byte i w = fromIntegral (w `shiftR` (i * 8))
85+
86+
87+-- |Make a UUID from sixteen Word8 values
88+makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8
89+ -> Word8 -> Word8 -> Word8 -> Word8
90+ -> Word8 -> Word8 -> Word8 -> Word8
91+ -> Word8 -> Word8 -> Word8 -> Word8
92+ -> UUID
93+makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
94+ = UUID w0 w1 w2 w3
95+ where w0 = word b0 b1 b2 b3
96+ w1 = word b4 b5 b6 b7
97+ w2 = word b8 b9 ba bb
98+ w3 = word bc bd be bf
99+
100+-- |Make a UUID from four Word32 values
101+makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
102+makeFromWords = UUID
103+
104+-- |A Builder for constructing a UUID of a given version.
105+buildFromBytes :: Word8
106+ -> Word8 -> Word8 -> Word8 -> Word8
107+ -> Word8 -> Word8 -> Word8 -> Word8
108+ -> Word8 -> Word8 -> Word8 -> Word8
109+ -> Word8 -> Word8 -> Word8 -> Word8
110+ -> UUID
111+buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
112+ makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf
113+ where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
114+ b8' = b8 .&. 0x3f .|. 0x80
115+
116+-- |Build a UUID of a given version from Word32 values.
117+buildFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
118+buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
119+ where w1' = w1 .&. 0xffff0fff .|. (v `shiftL` 12)
120+ w2' = w2 .&. 0x3fffffff .|. 0x80000000
121+
122+
123+-- |Return the bytes that make up the UUID
124+toList :: UUID -> [Word8]
125+toList (UUID w0 w1 w2 w3) =
126+ [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,
127+ byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,
128+ byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,
129+ byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]
130+
131+-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't
132+-- exactly sixteen bytes long
133+fromList :: [Word8] -> Maybe UUID
134+fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =
135+ Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
136+fromList _ = Nothing
137+
138+
139+--
140+-- UUID API
141+--
77142
78143-- |Returns true if the passed-in UUID is the 'nil' UUID.
79144null :: UUID -> Bool
80−null (UUID 0 0 0 0 0 node) | nullNode node = True
81−null _ = False
145+null = (== nil)
146+ -- Note: This actually faster than:
147+ -- null (UUID 0 0 0 0) = True
148+ -- null _ = False
82149
83150-- |The nil UUID, as defined in RFC 4122.
84151-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
85152nil :: UUID
86−nil = UUID 0 0 0 0 0 (Node 0 0 0 0 0 0)
153+nil = UUID 0 0 0 0
87154
88−instance Random UUID where
89− random g = let (timeLow, g1) = randomBoundedIntegral g
90− (timeMid, g2) = randomBoundedIntegral g1
91− (timeHigh, g3) = randomBoundedIntegral g2
92− (seqHigh, g4) = randomBoundedIntegral g3
93− (seqLow, g5) = randomBoundedIntegral g4
94− (node, g6) = random g5
95− seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
96− timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
97− in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
155+-- |Extract a UUID from a 'ByteString' in network byte order.
156+-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
157+fromByteString :: Lazy.ByteString -> Maybe UUID
158+fromByteString = fromList . Lazy.unpack
98159
99− randomR _ = random -- range is ignored
160+-- |Encode a UUID into a 'ByteString' in network order.
161+toByteString :: UUID -> Lazy.ByteString
162+toByteString = Lazy.pack . toList
100163
101−versionMask :: Word16 -- 0000 1111 1111 1111
102−versionMask = 0x0FFF
164+-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
165+-- The hyphens may not be omitted.
166+-- Example:
167+--
168+-- @
169+-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
170+-- @
171+--
172+-- Hex digits may be upper or lower-case.
173+fromString :: String -> Maybe UUID
174+fromString xs | validFmt = fromString' xs
175+ | otherwise = Nothing
176+ where validFmt = elemIndices '-' xs == [8,13,18,23]
177+
178+fromString' :: String -> Maybe UUID
179+fromString' s0 = do
180+ (w0, s1) <- hexWord s0
181+ (w1, s2) <- hexWord s1
182+ (w2, s3) <- hexWord s2
183+ (w3, s4) <- hexWord s3
184+ if s4 /= "" then Nothing
185+ else Just $ UUID w0 w1 w2 w3
186+ where hexWord :: String -> Maybe (Word32, String)
187+ hexWord s = Just (0, s) >>= hexByte >>= hexByte
188+ >>= hexByte >>= hexByte
189+
190+ hexByte :: (Word32, String) -> Maybe (Word32, String)
191+ hexByte (w, '-':ds) = hexByte (w, ds)
192+ hexByte (w, hi:lo:ds)
193+ | bothHex = Just ((w `shiftL` 8) .|. octet, ds)
194+ | otherwise = Nothing
195+ where bothHex = isHexDigit hi && isHexDigit lo
196+ octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
197+ hexByte _ = Nothing
103198
104−versionRandom :: Word16
105−versionRandom = 4 `shiftL` 12
199+-- | Convert a UUID into a hypenated string using lower-case letters.
200+-- Example:
201+--
202+-- @
203+-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
204+-- @
205+toString :: UUID -> String
206+toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
207+ where hexw :: Word32 -> String -> String
208+ hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
209+ : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
106210
107−reservedMask :: Word8 -- 0011 1111
108−reservedMask = 0x3F
211+ hexw' :: Word32 -> String -> String
212+ hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
213+ : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
109214
110−reserved :: Word8
111−reserved = bit 7
215+ hexn :: Word32 -> Int -> Char
216+ hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
112217
113−data Node = Node
114− SLOT(Word8)
115− SLOT(Word8)
116− SLOT(Word8)
117− SLOT(Word8)
118− SLOT(Word8)
119− SLOT(Word8)
120− deriving (Eq, Ord, Typeable)
121218
122−instance Random Node where
123− random g = let (w1, g1) = randomBoundedIntegral g
124− (w2, g2) = randomBoundedIntegral g1
125− (w3, g3) = randomBoundedIntegral g2
126− (w4, g4) = randomBoundedIntegral g3
127− (w5, g5) = randomBoundedIntegral g4
128− (w6, g6) = randomBoundedIntegral g5
129− in (Node w1 w2 w3 w4 w5 w6, g6)
130− randomR _ = random -- neglect range
219+--
220+-- Class Instances
221+--
131222
132−nullNode :: Node -> Bool
133−nullNode (Node 0 0 0 0 0 0) = True
134−nullNode _ = False
223+instance Random UUID where
224+ random g = (fromGenNext w0 w1 w2 w3 w4, g4)
225+ where (w0, g0) = next g
226+ (w1, g1) = next g0
227+ (w2, g2) = next g1
228+ (w3, g3) = next g2
229+ (w4, g4) = next g3
230+ randomR _ = random -- range is ignored
135231
136−nodeToList :: Node -> [Word8]
137−nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
232+-- |Build a UUID from the results of five calls to next on a StdGen.
233+-- While next on StdGet returns an Int, it doesn't provide 32 bits of
234+-- randomness. This code relies on at last 28 bits of randomness in the
235+-- and optimizes its use so as to make only five random values, not six.
236+fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
237+fromGenNext w0 w1 w2 w3 w4 =
238+ buildFromBytes 4 /-/ (ThreeByte w0)
239+ /-/ (ThreeByte w1)
240+ /-/ w2 -- use all 4 bytes because we know the version
241+ -- field will "cover" the upper, non-random bits
242+ /-/ (ThreeByte w3)
243+ /-/ (ThreeByte w4)
244+
245+-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
246+-- only returns 31 bits of randomness.
247+type instance ByteSink ThreeByte g = Takes3Bytes g
248+newtype ThreeByte = ThreeByte Int
249+instance ByteSource ThreeByte where
250+ f /-/ (ThreeByte w) = f b1 b2 b3
251+ where b1 = fromIntegral (w `shiftR` 16)
252+ b2 = fromIntegral (w `shiftR` 8)
253+ b3 = fromIntegral w
138254
139−listToNode :: [Word8] -> Maybe Node
140−listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
141−listToNode _ = Nothing
142255
143256instance Show UUID where
144257 show = toString
@@ -151,93 +264,20 @@ instance Read UUID where
151264
152265instance Storable UUID where
153266 sizeOf _ = 16
154− alignment _ = 4 -- not sure what to put here
155−
156− peek p = do
157− tl <- peek $ castPtr p
158− tm <- peekByteOff p 4
159− th <- peekByteOff p 6
160− ch <- peekByteOff p 8
161− cl <- peekByteOff p 9
162− node <- peekByteOff p 10
163− return $ UUID tl tm th ch cl node
164−
165− poke p (UUID tl tm th ch cl node) = do
166− poke (castPtr p) tl
167− pokeByteOff p 4 tm
168− pokeByteOff p 6 th
169− pokeByteOff p 8 ch
170− pokeByteOff p 9 cl
171− pokeByteOff p 10 node
172−
173−instance Storable Node where
174− sizeOf _ = 6
175− alignment _ = 1 -- ???
176−
177− peek p = do
178− w1 <- peek $ castPtr p
179− w2 <- peekByteOff p 1
180− w3 <- peekByteOff p 2
181− w4 <- peekByteOff p 3
182− w5 <- peekByteOff p 4
183− w6 <- peekByteOff p 5
184− return $ Node w1 w2 w3 w4 w5 w6
185−
186− poke p (Node w1 w2 w3 w4 w5 w6) = do
187− poke (castPtr p) w1
188− pokeByteOff p 1 w2
189− pokeByteOff p 2 w3
190− pokeByteOff p 3 w4
191− pokeByteOff p 4 w5
192− pokeByteOff p 5 w6
193−
194−-- Binary instance in network byte-order
195−instance Binary UUID where
196− put (UUID tl tm th ch cl n) = do
197− putWord32be tl
198− putWord16be tm
199− putWord16be th
200− putWord8 ch
201− putWord8 cl
202− put n
203−
204− get = do
205− tl <- getWord32be
206− tm <- getWord16be
207− th <- getWord16be
208− ch <- getWord8
209− cl <- getWord8
210− node <- get
211− return $ UUID tl tm th ch cl node
212−
213−instance Binary Node where
214− put (Node w1 w2 w3 w4 w5 w6) = do
215− putWord8 w1
216− putWord8 w2
217− putWord8 w3
218− putWord8 w4
219− putWord8 w5
220− putWord8 w6
221−
222− get = do
223− w1 <- getWord8
224− w2 <- getWord8
225− w3 <- getWord8
226− w4 <- getWord8
227− w5 <- getWord8
228− w6 <- getWord8
229− return $ Node w1 w2 w3 w4 w5 w6
267+ alignment _ = 1 -- UUIDs are stored as individual octets
230268
269+ peekByteOff p off =
270+ mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList
231271
232−-- |Extract a UUID from a 'ByteString' in network byte order.
233−-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
234−fromByteString :: Lazy.ByteString -> Maybe UUID
235−fromByteString bs | Lazy.length bs == 16 = Just $ decode bs
236− | otherwise = Nothing
272+ pokeByteOff p off u =
273+ sequence_ $ zipWith (pokeByteOff p) [off..] (toList u)
274+
275+
276+instance Binary UUID where
277+ put (UUID w0 w1 w2 w3) =
278+ putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3
279+ get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be
237280
238−-- |Encode a UUID into a 'ByteString' in network order.
239−toByteString :: UUID -> Lazy.ByteString
240−toByteString uu = encode uu
241281
242282-- My goal with this instance was to make it work just enough to do what
243283-- I want when used with the HStringTemplate library.
@@ -246,6 +286,7 @@ instance Data UUID where
246286 gunfold _ _ = error "gunfold"
247287 dataTypeOf _ = uuidType
248288
289+uuidType :: DataType
249290uuidType = mkNoRepType "Data.UUID.UUID"
250291
251292#if !(MIN_VERSION_base(4,2,0))
@@ -253,72 +294,3 @@ mkNoRepType :: String -> DataType
253294mkNoRepType = mkNorepType
254295#endif
255296
256−-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
257−-- The hyphens may not be omitted.
258−-- Example:
259−--
260−-- @
261−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
262−-- @
263−--
264−-- Hex digits may be upper or lower-case.
265−fromString :: String -> Maybe UUID
266−fromString xs | validFmt = Just uuid
267− | otherwise = Nothing
268− where validFmt = length ws == 5 &&
269− map length ws == [8,4,4,4,12] &&
270− all isHexDigit (concat ws) &&
271− isJust node
272− ws = splitList '-' xs
273− [tl, tm, th, c, n] = ws
274− ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
275− node = listToNode $ map hexVal ns :: Maybe Node
276− uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
277−
278−-- | Convert a string to a hex value, assuming the string is already validated.
279−hexVal :: Num a => String -> a
280−hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
281−
282−digitToInteger :: Char -> Integer
283−digitToInteger = fromIntegral . digitToInt
284−
285−
286−-- | Convert a UUID into a hypenated string using lower-case letters.
287−-- Example:
288−--
289−-- @
290−-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
291−-- @
292−toString :: UUID -> String
293−toString (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
294− where ns = concatMap hexb $ nodeToList n
295− hexb x = printf "%02x" x :: String
296−
297−
298−-- remove all occurances of the input element in the inpt list.
299−-- none of the sub-lists are empty.
300−splitList :: Eq a => a -> [a] -> [[a]]
301−splitList c xs = let ys = dropWhile (== c) xs
302− in case span (/= c) ys of
303− ([],_) -> []
304− (sub,rest) -> sub : splitList c rest
305−
306−-- the passed-in predicate signals when to stop unfolding
307−unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
308−unfoldUntil p f n = unfoldr g n
309− where g m | p m = Nothing
310− | otherwise = Just $ f m
311−
312−
313−-- no random intance for Data.Word types :-(
314−-- this will work, though
315−
316−randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
317−randomBoundedIntegral g =
318− let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
319− _ = n :: Integer
320− retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
321− u = maxBound
322− l = minBound
323− in (retVal, g1)
324−