git.iko.soy/typeable/uuid
on master help sign in
re-record of recent, conflicting patches:
6ac8033Antoine Latter
Data/UUID/Builder.hsnew file+88
compare with master
unifiedsplit
@@ -0,0 +1,88 @@
1+{-# LANGUAGE TypeFamilies #-}
2+
3+-- Module : Data.UUID.Builder
4+-- Copyright : (c) 2009 Mark Lentczner
5+--
6+-- License : BSD-style
7+--
8+-- Maintainer : markl@glyphic.com
9+-- Stability : experimental
10+-- Portability : portable
11+--
12+-- This module provides a system that can call a function that takes
13+-- a sequence of some number of Word8 arguments.
14+--
15+-- The twist is that the Word8 arguments can be supplied directly
16+-- from Word8s, or from other sources that may provide more than
17+-- one Word8 apiece. Examples are Word16 and Word32 that supply
18+-- two and four Word8s respectively. Other ByteSource instances
19+-- can be defined.
20+--
21+-- This module is admittedly overkill. There are only three places
22+-- in the uuid package that need to call buildFromBytes with 16
23+-- Word8 values, but each place uses Words of different lengths:
24+-- version 1 uuids: 32-16-16-16-8-8-8-8-8-8
25+-- version 4 uuids: 24-24-32-24-24
26+-- version 5 uuids: 32-32-32-32
27+-- Originally, these three constructions were hand coded but the
28+-- code was ungainly. Using this module makes the code very
29+-- concise, and turns out to optimize to just as fast, or faster!
30+
31+module Data.UUID.Builder
32+ (ByteSource(..)
33+ ,ByteSink
34+ ,Takes1Byte
35+ ,Takes2Bytes
36+ ,Takes3Bytes
37+ ,Takes4Bytes
38+ ) where
39+
40+import Data.Bits
41+import Data.Word
42+
43+
44+
45+type Takes1Byte g = Word8 -> g
46+type Takes2Bytes g = Word8 -> Word8 -> g
47+type Takes3Bytes g = Word8 -> Word8 -> Word8 -> g
48+type Takes4Bytes g = Word8 -> Word8 -> Word8 -> Word8 -> g
49+
50+-- | Type of function that a given ByteSource needs.
51+-- This function must take as many Word8 arguments as the ByteSource provides
52+type family ByteSink w g
53+type instance ByteSink Word8 g = Takes1Byte g
54+type instance ByteSink Word16 g = Takes2Bytes g
55+type instance ByteSink Word32 g = Takes4Bytes g
56+type instance ByteSink Int g = Takes4Bytes g
57+
58+
59+-- | Class of types that can add Word8s to a Builder.
60+-- Instances for Word8, Word16, Word32 and Int provide 1, 2, 4 and 4 bytes,
61+-- respectively, into a ByteSink
62+class ByteSource w where
63+ -- | Apply the source's bytes to the sink
64+ (/-/) :: ByteSink w g -> w -> g
65+
66+infixl 6 /-/
67+
68+instance ByteSource Word8 where
69+ f /-/ w = f w
70+
71+instance ByteSource Word16 where
72+ f /-/ w = f b1 b2
73+ where b1 = fromIntegral (w `shiftR` 8)
74+ b2 = fromIntegral w
75+
76+instance ByteSource Word32 where
77+ f /-/ w = f b1 b2 b3 b4
78+ where b1 = fromIntegral (w `shiftR` 24)
79+ b2 = fromIntegral (w `shiftR` 16)
80+ b3 = fromIntegral (w `shiftR` 8)
81+ b4 = fromIntegral w
82+
83+instance ByteSource Int where
84+ f /-/ w = f b1 b2 b3 b4
85+ where b1 = fromIntegral (w `shiftR` 24)
86+ b2 = fromIntegral (w `shiftR` 16)
87+ b3 = fromIntegral (w `shiftR` 8)
88+ b4 = fromIntegral w
Data/UUID/Internal.hs+204−232
@@ -1,8 +1,8 @@
1−{-# LANGUAGE DeriveDataTypeable, CPP #-}
1+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-}
2
2
3-- |
3-- |
4-- Module : Data.UUID
4-- Module : Data.UUID
5−-- Copyright : (c) 2008 Antoine Latter
5+-- Copyright : (c) 2008-2009 Antoine Latter
6--
6--
7-- License : BSD-style
7-- License : BSD-style
8--
8--
@@ -14,29 +14,22 @@ module Data.UUID.Internal
14 (UUID(..)
14 (UUID(..)
15 ,null
15 ,null
16 ,nil
16 ,nil
17− ,Node(..)
18− ,nullNode
19− ,nodeToList
20− ,listToNode
21 ,fromByteString
17 ,fromByteString
22 ,toByteString
18 ,toByteString
23 ,fromString
19 ,fromString
24 ,toString
20 ,toString
25− ,versionMask
21+ ,buildFromBytes
26− ,reservedMask
22+ ,buildFromWords
27− ,reserved
28 ) where
23 ) where
29
24
30import Prelude hiding (null)
25import Prelude hiding (null)
31import qualified Prelude
26import qualified Prelude
32
27
33−import Data.Word
28+import Control.Monad (liftM4)
34import Data.Char
29import Data.Char
35import Data.Maybe
30import Data.Maybe
36import Data.Bits
31import Data.Bits
37−import Data.List (splitAt, foldl', unfoldr)
32+import Data.List (elemIndices)
38−
39−import Data.Typeable
40
33
41#if MIN_VERSION_base(4,0,0)
34#if MIN_VERSION_base(4,0,0)
42import Data.Data
35import Data.Data
@@ -44,7 +37,6 @@ import Data.Data
44import Data.Generics.Basics
37import Data.Generics.Basics
45#endif
38#endif
46
39
47−import Foreign.Ptr
48import Foreign.Storable
40import Foreign.Storable
49
41
50import Data.Binary
42import Data.Binary
@@ -52,93 +44,214 @@ import Data.Binary.Put
52import Data.Binary.Get
44import Data.Binary.Get
53import qualified Data.ByteString.Lazy as Lazy
45import qualified Data.ByteString.Lazy as Lazy
54
46
55−import System.Random
47+import Data.UUID.Builder
56
48
57−import Text.Printf
49+import System.Random
58
50
59−#ifndef STRICT
60−#define SLOT(x) x
61−#else
62−#define SLOT(x) {-# UNPACK #-} !x
63−#endif
64
51
65-- |The UUID type. A 'Random' instance is provided which produces
52-- |The UUID type. A 'Random' instance is provided which produces
66−-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
53+-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
67−-- 'Binary' instances are compatable with RFC 4122. The 'Binary'
54+-- 'Binary' instances are compatible with RFC 4122, storing the fields
68−-- instance serializes to network byte order.
55+-- in network order as 16 bytes.
69−data UUID = UUID
56+data UUID = UUID !Word32 !Word32 !Word32 !Word32
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)
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+--
77
142
78-- |Returns true if the passed-in UUID is the 'nil' UUID.
143-- |Returns true if the passed-in UUID is the 'nil' UUID.
79null :: UUID -> Bool
144null :: UUID -> Bool
145+null = (== nil)
146+ -- Note: This actually faster than:
80−null (UUID 0 0 0 0 0 node) | nullNode node = True
147+ -- null (UUID 0 0 0 0) = True
81−null _ = False
148+ -- null _ = False
82
149
83-- |The nil UUID, as defined in RFC 4122.
150-- |The nil UUID, as defined in RFC 4122.
84-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
151-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
85nil :: UUID
152nil :: UUID
86−nil = UUID 0 0 0 0 0 (Node 0 0 0 0 0 0)
153+nil = UUID 0 0 0 0
87
154
88−instance Random UUID where
155+-- |Extract a UUID from a 'ByteString' in network byte order.
89− random g = let (timeLow, g1) = randomBoundedIntegral g
156+-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
90− (timeMid, g2) = randomBoundedIntegral g1
157+fromByteString :: Lazy.ByteString -> Maybe UUID
91− (timeHigh, g3) = randomBoundedIntegral g2
158+fromByteString = fromList . Lazy.unpack
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)
98
159
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
100
163
101−versionMask :: Word16 -- 0000 1111 1111 1111
164+-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
102−versionMask = 0x0FFF
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
103
198
104−versionRandom :: Word16
199+-- | Convert a UUID into a hypenated string using lower-case letters.
105−versionRandom = 4 `shiftL` 12
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
106
210
107−reservedMask :: Word8 -- 0011 1111
211+ hexw' :: Word32 -> String -> String
108−reservedMask = 0x3F
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
109
214
110−reserved :: Word8
215+ hexn :: Word32 -> Int -> Char
111−reserved = bit 7
216+ hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
112
217
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)
121
218
122−instance Random Node where
219+--
123− random g = let (w1, g1) = randomBoundedIntegral g
220+-- Class Instances
124− (w2, g2) = randomBoundedIntegral g1
221+--
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
131
222
132−nullNode :: Node -> Bool
223+instance Random UUID where
133−nullNode (Node 0 0 0 0 0 0) = True
224+ random g = (fromGenNext w0 w1 w2 w3 w4, g4)
134−nullNode _ = False
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
135
231
136−nodeToList :: Node -> [Word8]
232+-- |Build a UUID from the results of five calls to next on a StdGen.
137−nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
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
138
254
139−listToNode :: [Word8] -> Maybe Node
140−listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
141−listToNode _ = Nothing
142
255
143instance Show UUID where
256instance Show UUID where
144 show = toString
257 show = toString
@@ -151,93 +264,20 @@ instance Read UUID where
151
264
152instance Storable UUID where
265instance Storable UUID where
153 sizeOf _ = 16
266 sizeOf _ = 16
154− alignment _ = 4 -- not sure what to put here
267+ alignment _ = 1 -- UUIDs are stored as individual octets
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
230
268
269+ peekByteOff p off =
270+ mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList
231
271
232−-- |Extract a UUID from a 'ByteString' in network byte order.
272+ pokeByteOff p off u =
233−-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
273+ sequence_ $ zipWith (pokeByteOff p) [off..] (toList u)
234−fromByteString :: Lazy.ByteString -> Maybe UUID
274+
235−fromByteString bs | Lazy.length bs == 16 = Just $ decode bs
275+
236− | otherwise = Nothing
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
237
280
238−-- |Encode a UUID into a 'ByteString' in network order.
239−toByteString :: UUID -> Lazy.ByteString
240−toByteString uu = encode uu
241
281
242-- My goal with this instance was to make it work just enough to do what
282-- My goal with this instance was to make it work just enough to do what
243-- I want when used with the HStringTemplate library.
283-- I want when used with the HStringTemplate library.
@@ -246,6 +286,7 @@ instance Data UUID where
246 gunfold _ _ = error "gunfold"
286 gunfold _ _ = error "gunfold"
247 dataTypeOf _ = uuidType
287 dataTypeOf _ = uuidType
248
288
289+uuidType :: DataType
249uuidType = mkNoRepType "Data.UUID.UUID"
290uuidType = mkNoRepType "Data.UUID.UUID"
250
291
251#if !(MIN_VERSION_base(4,2,0))
292#if !(MIN_VERSION_base(4,2,0))
@@ -253,72 +294,3 @@ mkNoRepType :: String -> DataType
253mkNoRepType = mkNorepType
294mkNoRepType = mkNorepType
254#endif
295#endif
255
296
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−
Data/UUID/V1.hs+24−25
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -fno-cse #-}
1{-# OPTIONS_GHC -fno-cse #-}
2+{-# LANGUAGE TypeFamilies #-}
2
3
3-- |
4-- |
4-- Module : Data.UUID.V1
5-- Module : Data.UUID.V1
@@ -19,15 +20,15 @@ import Data.Time
19
20
20import Data.Bits
21import Data.Bits
21import Data.Word
22import Data.Word
22−import Data.Binary
23
23
24import Data.IORef
24import Data.IORef
25import System.IO
25import System.IO
26import System.IO.Unsafe
26import System.IO.Unsafe
27
27
28−import System.Info.MAC
28+import qualified System.Info.MAC as SysMAC
29import Data.MAC
29import Data.MAC
30
30
31+import Data.UUID.Builder
31import Data.UUID.Internal
32import Data.UUID.Internal
32
33
33-- | Returns a new UUID derived from the local hardware MAC
34-- | Returns a new UUID derived from the local hardware MAC
@@ -40,37 +41,41 @@ import Data.UUID.Internal
40nextUUID :: IO (Maybe UUID)
41nextUUID :: IO (Maybe UUID)
41nextUUID = do
42nextUUID = do
42 res <- stepTime
43 res <- stepTime
43− mac <- mac
44+ mac <- SysMAC.mac
44 case (res, mac) of
45 case (res, mac) of
45− (Just (c, t), Just (MAC a' b' c' d' e' f')) -> do
46+ (Just (c, t), Just m) -> return $ Just $ makeUUID t c m
46− let
47− (tL, tM, tH) = word64ToTimePieces t
48− (cL, cH) = word16ToClockSeqPieces c
49− return $ Just $ UUID tL tM tH cH cL $ Node a' b' c' d' e' f'
50 _ -> return Nothing
47 _ -> return Nothing
51
48
52
49
53−-- |The bit layout and version number here used are described in clause 13 of
50+makeUUID :: Word64 -> Word16 -> MAC -> UUID
54−-- ITU X.667, from September 2004.
51+makeUUID time clock mac =
55−word64ToTimePieces :: Word64 -> (Word32, Word16, Word16)
52+ buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac)
56−word64ToTimePieces w = (lo, mi, hi)
53+ where tLow = (fromIntegral time) :: Word32
57− where
58− lo = fromIntegral $ (w)
59− mi = fromIntegral $ (w `shiftR` 32)
54+ tMid = (fromIntegral (time `shiftR` 32)) :: Word16
60− hi = fromIntegral $ (w `shiftR` 48 .&. 0x0fff .|. 0x1000)
55+ tHigh = (fromIntegral (time `shiftR` 48)) :: Word16
56+
57+newtype MACSource = MACSource MAC
58+instance ByteSource MACSource where
59+ z /-/ (MACSource (MAC a b c d e f)) = z a b c d e f
60+type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)
61
61
62
62
63+-- |Approximates the clock algorithm in RFC 4122, section 4.2
64+-- Isn't system wide or thread safe, nor does it properly randomize
65+-- the clock value on initialization.
66+stepTime :: IO (Maybe (Word16, Word64))
63stepTime = do
67stepTime = do
64 State c0 h0 <- readIORef state
68 State c0 h0 <- readIORef state
65 h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
69 h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
66− if h1 > h0
70+ if h1 > h0
67 then do
71 then do
68 writeIORef state $ State c0 h1
72 writeIORef state $ State c0 h1
69 return $ Just (c0, h1)
73 return $ Just (c0, h1)
70 else do
74 else do
71 let
75 let
72 c1 = succ c0
76 c1 = succ c0
73− if c1 < 2^14
77+ if c1 <= 0x3fff -- when clock is initially randomized,
78+ -- then this test will need to change
74 then do
79 then do
75 writeIORef state $ State c1 h1
80 writeIORef state $ State c1 h1
76 return $ Just (c1, h1)
81 return $ Just (c1, h1)
@@ -79,6 +84,7 @@ stepTime = do
79
84
80
85
81{-# NOINLINE state #-}
86{-# NOINLINE state #-}
87+state :: IORef State
82state = unsafePerformIO $ do
88state = unsafePerformIO $ do
83 h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
89 h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
84 newIORef $ State 0 h0 -- the 0 should be a random number
90 newIORef $ State 0 h0 -- the 0 should be a random number
@@ -98,11 +104,4 @@ hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
98 dt = t `diffUTCTime` gregorianReform
104 dt = t `diffUTCTime` gregorianReform
99
105
100
106
101−-- |Per clause 13 of ITU X.667, from September 2004.
102−word16ToClockSeqPieces :: Word16 -> (Word8, Word8)
103−word16ToClockSeqPieces w = (lo, hi)
104− where
105− lo = fromIntegral $ (w `shiftL` 8) `shiftR` 8
106− hi = (fromIntegral $ w `shiftR` 8) `setBit` 7
107−
108
107
Data/UUID/V5.hs+9−39
@@ -7,8 +7,8 @@
7-- Maintainer : aslatter@gmail.com
7-- Maintainer : aslatter@gmail.com
8-- Stability : experimental
8-- Stability : experimental
9-- Portability : portable
9-- Portability : portable
10−--
10+--
11−--
11+--
12-- This module implements Version 5 UUIDs as specified
12-- This module implements Version 5 UUIDs as specified
13-- in RFC 4122.
13-- in RFC 4122.
14--
14--
@@ -25,16 +25,13 @@ module Data.UUID.V5
25 ,namespaceOID
25 ,namespaceOID
26 ,namespaceX500
26 ,namespaceX500
27 ) where
27 ) where
28−
29
28
30import Data.UUID.Internal
29import Data.UUID.Internal
31
30
32import Data.Binary
31import Data.Binary
33−import Data.Bits
34import Data.Maybe
32import Data.Maybe
35
33
36import qualified Data.ByteString.Lazy as BS
34import qualified Data.ByteString.Lazy as BS
37−import Data.ByteString.Lazy (ByteString)
38
35
39import qualified Data.Digest.SHA1 as SHA1
36import qualified Data.Digest.SHA1 as SHA1
40
37
@@ -42,46 +39,17 @@ import qualified Data.Digest.SHA1 as SHA1
42-- |Generate a 'UUID' within the specified namespace out of the given
39-- |Generate a 'UUID' within the specified namespace out of the given
43-- object.
40-- object.
44--
41--
45−-- Uses a SHA1 hash.
42+-- Uses a SHA1 hash. The UUID is built from first 128 bits of the hash of
43+-- the namespace UUID and the name (as a series of Word8).
46generateNamed :: UUID -- ^Namespace
44generateNamed :: UUID -- ^Namespace
47 -> [Word8] -- ^Object
45 -> [Word8] -- ^Object
48 -> UUID
46 -> UUID
49generateNamed namespace object =
47generateNamed namespace object =
50− let chunk = BS.unpack (encode namespace) ++ object
48+ let chunk = BS.unpack (toByteString namespace) ++ object
51− SHA1.Word160 w1 w2 w3 w4 w5 = SHA1.hash chunk
49+ SHA1.Word160 w1 w2 w3 w4 _w5 = SHA1.hash chunk
52−
50+ in buildFromWords 5 w1 w2 w3 w4
53− tl = w1
54− tm = high16 w2
55− th = (versionSHA .|.) $ (versionMask .&.) $ low16 w2
56− ch = (reserved .|.) $ (reservedMask .&.) $ high8 $ high16 w3
57− cl = low8 $ high16 w3
58− node = Node (high8 (low16 w3))
59− (low8 (low16 w3))
60− (high8 (high16 w4))
61− (low8 (high16 w4))
62− (high8 (low16 w4))
63− (low8 (low16 w4))
64− in UUID tl tm th ch cl node
65−
66−-- HASH 0 1 - 2 3 : w1
67−-- 4 5 - 6 7 : w2
68−-- 8 9 - 10 11 : w3
69−-- 12 13 - 14 15 : w4
70−-- 16 17 - 18 19 : w5
71−
72−low16 :: Word32 -> Word16
73−low16 = fromIntegral . (.&. 0x0000FFFF)
74−
75−high16 :: Word32 -> Word16
76−high16 = fromIntegral . flip shiftR 16
77−
78−low8 :: Word16 -> Word8
79−low8 = fromIntegral . (.&. 0x00FF)
80
51
81−high8 :: Word16 -> Word8
82−high8 = fromIntegral . flip shiftR 8
83
52
84−versionSHA = 5 `shiftL` 12
85
53
86unsafeFromString :: String -> UUID
54unsafeFromString :: String -> UUID
87unsafeFromString = fromJust . fromString
55unsafeFromString = fromJust . fromString
@@ -94,8 +62,10 @@ namespaceDNS = unsafeFromString "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
94namespaceURL :: UUID
62namespaceURL :: UUID
95namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
63namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
96
64
65+-- |The namespace for ISO OIDs
97namespaceOID :: UUID
66namespaceOID :: UUID
98namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
67namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
99
68
69+-- |The namespace for X.500 DNs
100namespaceX500 :: UUID
70namespaceX500 :: UUID
101namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
71namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
tests/BenchUUID.hs+1−7
@@ -1,4 +1,3 @@
1−import Control.Monad (replicateM)
2import Control.Parallel.Strategies
1import Control.Parallel.Strategies
3import Criterion.Main
2import Criterion.Main
4import Data.Char (ord)
3import Data.Char (ord)
@@ -7,7 +6,6 @@ import Data.Word
7import qualified Data.Set as Set
6import qualified Data.Set as Set
8import qualified Data.ByteString.Lazy as BL
7import qualified Data.ByteString.Lazy as BL
9import qualified Data.ByteString.Lazy.Internal as BL
8import qualified Data.ByteString.Lazy.Internal as BL
10−import qualified Data.UUID as U
11import qualified Data.UUID.Internal as U
9import qualified Data.UUID.Internal as U
12import qualified Data.UUID.V1 as U
10import qualified Data.UUID.V1 as U
13import qualified Data.UUID.V5 as U
11import qualified Data.UUID.V5 as U
@@ -19,12 +17,8 @@ instance NFData BL.ByteString where
19 rnf (BL.Chunk _ ts) = rnf ts
17 rnf (BL.Chunk _ ts) = rnf ts
20
18
21instance NFData U.UUID where
19instance NFData U.UUID where
22− rnf (U.UUID tl tm th ch cl node) =
20+ rnf u = ()
23− rnf tl `seq` rnf tm `seq` rnf th `seq` rnf ch `seq` rnf cl `seq` rnf node
24
21
25−instance NFData U.Node where
26− rnf (U.Node w1 w2 w3 w4 w5 w6) =
27− rnf w1 `seq` rnf w2 `seq` rnf w3 `seq` rnf w4 `seq` rnf w5 `seq` rnf w6
28
22
29
23
30
24
tests/TestUUID.hs+13−4
@@ -29,18 +29,21 @@ instance Arbitrary U.UUID where
29instance Arbitrary Word8 where
29instance Arbitrary Word8 where
30 arbitrary = (fromIntegral . fst . randomR (0,255::Int)) `fmap` rand
30 arbitrary = (fromIntegral . fst . randomR (0,255::Int)) `fmap` rand
31 coarbitrary = undefined
31 coarbitrary = undefined
32−
33
32
33+
34+test_null :: Test
34test_null = TestList [
35test_null = TestList [
35 "nil is null" ~: assertBool "" (U.null U.nil),
36 "nil is null" ~: assertBool "" (U.null U.nil),
36 "namespaceDNS is not null" ~: assertBool "" (not $ U.null U.namespaceDNS)
37 "namespaceDNS is not null" ~: assertBool "" (not $ U.null U.namespaceDNS)
37 ]
38 ]
38
39
40+test_nil :: Test
39test_nil = TestList [
41test_nil = TestList [
40 "nil string" ~: U.toString U.nil @?= "00000000-0000-0000-0000-000000000000",
42 "nil string" ~: U.toString U.nil @?= "00000000-0000-0000-0000-000000000000",
41 "nil bytes" ~: U.toByteString U.nil @?= B.pack (replicate 16 0)
43 "nil bytes" ~: U.toByteString U.nil @?= B.pack (replicate 16 0)
42 ]
44 ]
43
45
46+test_conv :: Test
44test_conv = TestList [
47test_conv = TestList [
45 "conv bytes to string" ~:
48 "conv bytes to string" ~:
46 maybe "" (U.toString) (U.fromByteString b16) @?= s16,
49 maybe "" (U.toString) (U.fromByteString b16) @?= s16,
@@ -50,6 +53,7 @@ test_conv = TestList [
50 where b16 = B.pack [1..16]
53 where b16 = B.pack [1..16]
51 s16 = "01020304-0506-0708-090a-0b0c0d0e0f10"
54 s16 = "01020304-0506-0708-090a-0b0c0d0e0f10"
52
55
56+test_v1 :: [Maybe U.UUID] -> Test
53test_v1 v1s = TestList [
57test_v1 v1s = TestList [
54 "V1 unique" ~: nub (v1s \\ nub v1s) @?= [],
58 "V1 unique" ~: nub (v1s \\ nub v1s) @?= [],
55 "V1 not null" ~: TestList $ map (testUUID (not . U.null)) v1s,
59 "V1 not null" ~: TestList $ map (testUUID (not . U.null)) v1s,
@@ -58,6 +62,7 @@ test_v1 v1s = TestList [
58 where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test
62 where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test
59 testUUID p u = maybe False p u ~? show u
63 testUUID p u = maybe False p u ~? show u
60
64
65+test_v5 :: Test
61test_v5 = TestList [
66test_v5 = TestList [
62 "V5 computation" ~:
67 "V5 computation" ~:
63 U.generateNamed U.namespaceDNS name @?= uV5
68 U.generateNamed U.namespaceDNS name @?= uV5
@@ -66,19 +71,23 @@ test_v5 = TestList [
66 -- uV3 = fromJust $ U.fromString "3d813cbb-47fb-32ba-91df-831e1593ac29"
71 -- uV3 = fromJust $ U.fromString "3d813cbb-47fb-32ba-91df-831e1593ac29"
67 uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"
72 uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"
68
73
74+prop_stringRoundTrip :: Property
69prop_stringRoundTrip = label "String round trip" stringRoundTrip
75prop_stringRoundTrip = label "String round trip" stringRoundTrip
70 where stringRoundTrip :: U.UUID -> Bool
76 where stringRoundTrip :: U.UUID -> Bool
71 stringRoundTrip u = maybe False (== u) $ U.fromString (U.toString u)
77 stringRoundTrip u = maybe False (== u) $ U.fromString (U.toString u)
72
78
79+prop_byteStringRoundTrip :: Property
73prop_byteStringRoundTrip = label "ByteString round trip" byteStringRoundTrip
80prop_byteStringRoundTrip = label "ByteString round trip" byteStringRoundTrip
74 where byteStringRoundTrip :: U.UUID -> Bool
81 where byteStringRoundTrip :: U.UUID -> Bool
75 byteStringRoundTrip u = maybe False (== u)
82 byteStringRoundTrip u = maybe False (== u)
76 $ U.fromByteString (U.toByteString u)
83 $ U.fromByteString (U.toByteString u)
77
84
85+prop_stringLength :: Property
78prop_stringLength = label "String length" stringLength
86prop_stringLength = label "String length" stringLength
79 where stringLength :: U.UUID -> Bool
87 where stringLength :: U.UUID -> Bool
80 stringLength u = length (U.toString u) == 36
88 stringLength u = length (U.toString u) == 36
81
89
90+prop_byteStringLength :: Property
82prop_byteStringLength = label "ByteString length" byteStringLength
91prop_byteStringLength = label "ByteString length" byteStringLength
83 where byteStringLength :: U.UUID -> Bool
92 where byteStringLength :: U.UUID -> Bool
84 byteStringLength u = B.length (U.toByteString u) == 16
93 byteStringLength u = B.length (U.toByteString u) == 16
@@ -92,7 +101,7 @@ prop_randomNotNull :: Property
92prop_randomNotNull = label "Random not null" randomNotNull
101prop_randomNotNull = label "Random not null" randomNotNull
93 where randomNotNull :: U.UUID -> Bool
102 where randomNotNull :: U.UUID -> Bool
94 randomNotNull = not. U.null
103 randomNotNull = not. U.null
95−
104+
96prop_randomsValid :: Property
105prop_randomsValid :: Property
97prop_randomsValid = label "Random valid" randomsValid
106prop_randomsValid = label "Random valid" randomsValid
98 where randomsValid :: U.UUID -> Bool
107 where randomsValid :: U.UUID -> Bool
@@ -101,12 +110,12 @@ prop_randomsValid = label "Random valid" randomsValid
101prop_v5NotNull :: Property
110prop_v5NotNull :: Property
102prop_v5NotNull = label "V5 not null" v5NotNull
111prop_v5NotNull = label "V5 not null" v5NotNull
103 where v5NotNull :: [Word8] -> Bool
112 where v5NotNull :: [Word8] -> Bool
104− v5NotNull = not . U.null . U.generateNamed U.namespaceDNS
113+ v5NotNull = not . U.null . U.generateNamed U.namespaceDNS
105
114
106prop_v5Valid :: Property
115prop_v5Valid :: Property
107prop_v5Valid = label "V5 valid" v5Valid
116prop_v5Valid = label "V5 valid" v5Valid
108 where v5Valid :: [Word8] -> Bool
117 where v5Valid :: [Word8] -> Bool
109− v5Valid = isValidVersion 5 . U.generateNamed U.namespaceDNS
118+ v5Valid = isValidVersion 5 . U.generateNamed U.namespaceDNS
110
119
111
120
112main :: IO ()
121main :: IO ()
uuid.cabal+8
@@ -38,9 +38,13 @@ Library
38 Data.UUID.V5
38 Data.UUID.V5
39
39
40 Other-Modules:
40 Other-Modules:
41+ Data.UUID.Builder
41 Data.UUID.Internal
42 Data.UUID.Internal
42
43
43 Extensions: DeriveDataTypeable
44 Extensions: DeriveDataTypeable
45+ Ghc-Prof-Options: -auto-all -caf-all
46+ Ghc-Shared-Options:
47+ Ghc-Options: -Wall
44
48
45Executable benchuuid
49Executable benchuuid
46 Main-Is: BenchUUID.hs
50 Main-Is: BenchUUID.hs
@@ -58,6 +62,10 @@ Executable testuuid
58 Main-Is: TestUUID.hs
62 Main-Is: TestUUID.hs
59 HS-Source-Dirs: tests .
63 HS-Source-Dirs: tests .
60 Extensions: DeriveDataTypeable
64 Extensions: DeriveDataTypeable
65+ Ghc-Prof-Options: -auto-all -caf-all
66+ Ghc-Shared-Options:
67+ Ghc-Options: -Wall -fno-warn-orphans
68+
61 If flag(test)
69 If flag(test)
62 Buildable: True
70 Buildable: True
63 Build-Depends: random, binary, bytestring, Crypto, maccatcher,
71 Build-Depends: random, binary, bytestring, Crypto, maccatcher,