git.iko.soy/typeable/uuid
on master help sign in
first try add adding version 5 UUID generation
3124bccaslatter
Data/UUID.hs+125−4
compare with master
unifiedsplit
@@ -20,9 +20,14 @@ module Data.UUID(UUID
20 ,toString
20 ,toString
21 ,toStringUpper
21 ,toStringUpper
22 ,toStringLower
22 ,toStringLower
23− ,generate
23+ ,generate
24 ,generateRandom
24 ,generateRandom
25 ,generateTime
25 ,generateTime
26+ ,generateNamed
27+ ,namespaceDNS
28+ ,namespaceURL
29+ ,namespaceOID
30+ ,namespaceX500
26 ,null
31 ,null
27 )
32 )
28where
33where
@@ -48,6 +53,14 @@ import Data.List (splitAt, foldl', unfoldr)
48import Foreign.Ptr
53import Foreign.Ptr
49import Foreign.Storable
54import Foreign.Storable
50
55
56+import Data.Binary
57+import Data.Binary.Put
58+import Data.Binary.Get
59+
60+import qualified Data.ByteString.Lazy as BS
61+import Data.ByteString.Lazy (ByteString)
62+
63+import qualified Data.Digest.SHA1 as SHA1
51
64
52data UUID = UUID
65data UUID = UUID
53 {uuid_timeLow :: {-# UNPACK #-} !Word32
66 {uuid_timeLow :: {-# UNPACK #-} !Word32
@@ -77,6 +90,9 @@ versionMask = 0x0FFF
77versionRandom :: Word16
90versionRandom :: Word16
78versionRandom = shiftL 12 4
91versionRandom = shiftL 12 4
79
92
93+versionSHA :: Word16
94+versionSHA = shiftL 12 5
95+
80reservedMask :: Word8 -- 0011 1111
96reservedMask :: Word8 -- 0011 1111
81reservedMask = 0x3F
97reservedMask = 0x3F
82
98
@@ -102,6 +118,7 @@ instance Random Node where
102 in (Node w1 w2 w3 w4 w5 w6, g6)
118 in (Node w1 w2 w3 w4 w5 w6, g6)
103 randomR _ = random -- neglect range
119 randomR _ = random -- neglect range
104
120
121+
105nodeToList :: Node -> [Word8]
122nodeToList :: Node -> [Word8]
106nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
123nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
107
124
@@ -160,6 +177,44 @@ instance Storable Node where
160 pokeByteOff p 4 w5
177 pokeByteOff p 4 w5
161 pokeByteOff p 5 w6
178 pokeByteOff p 5 w6
162
179
180+-- Binary instance in network byte-order
181+instance Binary UUID where
182+ put (UUID tl tm th ch cl n) = do
183+ putWord32be tl
184+ putWord16be tm
185+ putWord16be th
186+ putWord8 ch
187+ putWord8 cl
188+ put n
189+
190+ get = do
191+ tl <- getWord32be
192+ tm <- getWord16be
193+ th <- getWord16be
194+ ch <- getWord8
195+ cl <- getWord8
196+ node <- get
197+ return $ UUID tl tm th ch cl node
198+
199+instance Binary Node where
200+ put (Node w1 w2 w3 w4 w5 w6) = do
201+ putWord8 w1
202+ putWord8 w2
203+ putWord8 w3
204+ putWord8 w4
205+ putWord8 w5
206+ putWord8 w6
207+
208+ get = do
209+ w1 <- getWord8
210+ w2 <- getWord8
211+ w3 <- getWord8
212+ w4 <- getWord8
213+ w5 <- getWord8
214+ w6 <- getWord8
215+ return $ Node w1 w2 w3 w4 w5 w6
216+
217+
163-- My goal with this instance was to make it work just enough to do what
218-- My goal with this instance was to make it work just enough to do what
164-- I want when used with the HStringTemplate library.
219-- I want when used with the HStringTemplate library.
165instance Data UUID where
220instance Data UUID where
@@ -186,6 +241,73 @@ generateRandom = randomIO -- not a good solution, as someone could have changed
186generateTime :: IO UUID
241generateTime :: IO UUID
187generateTime = error "Data.UUID.generateTime: not yet implemented"
242generateTime = error "Data.UUID.generateTime: not yet implemented"
188
243
244+-- |Generate a 'UUID' within the specified namespace out of the given
245+-- object.
246+--
247+-- Uses a SHA1 hash.
248+generateNamed :: UUID -- ^Namespace
249+ -> [Word8] -- ^Object
250+ -> UUID
251+generateNamed namespace object =
252+ let chunk = BS.unpack (encode namespace) ++ object
253+ SHA1.Word160 w1 w2 w3 w4 w5 = SHA1.hash chunk
254+
255+ tl = w1
256+ tm = low16 w2
257+ th = (versionSHA .|.) $ (versionMask .&.) $ high16 w2
258+ ch = (reserved .|.) $ (reservedMask .&.) $ high8 $ high16 w3
259+ cl = low8 $ high16 w3
260+ node = Node (high8 (low16 w3))
261+ (low8 (low16 w3))
262+ (high8 (high16 w4))
263+ (low8 (high16 w4))
264+ (high8 (low16 w4))
265+ (low8 (low16 w4))
266+ in UUID tl tm th ch cl node
267+
268+-- HASH 0 1 - 2 3 : w1
269+-- 4 5 - 6 7 : w2
270+-- 8 9 - 10 11 : w3
271+-- 12 13 - 14 15 : w4
272+-- 16 17 - 18 19 : w5
273+
274+low16 :: Word32 -> Word16
275+low16 = fromIntegral . (.&. 0x0000FFFF)
276+
277+high16 :: Word32 -> Word16
278+high16 = fromIntegral . flip shiftR 16
279+
280+low8 :: Word16 -> Word8
281+low8 = fromIntegral . (.&. 0x00FF)
282+
283+high8 :: Word16 -> Word8
284+high8 = fromIntegral . flip shiftR 4
285+
286+-- this may be overkill ...
287+{-# RULES
288+ "low8/low16" forall x . low8 (low16 x) = fromIntegral (x .&. 0x000000FF)
289+ "high8/low16" forall x . high8 (low16 x) = fromIntegral (shiftR (x .&. 0x0000FF00) 4)
290+ "low8/high16" forall x . low8 (high16 x) = fromIntegral (shiftR (x .&. 0x00FF0000) 8)
291+ "high8/high16" forall x . high8 (high16 x) = fromIntegral (shiftR x 12)
292+ #-}
293+
294+unsafeFromString :: String -> UUID
295+unsafeFromString = fromJust . fromString
296+
297+-- |The namespace for DNS addresses
298+namespaceDNS :: UUID
299+namespaceDNS = unsafeFromString "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
300+
301+-- |The namespace for URLs
302+namespaceURL :: UUID
303+namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
304+
305+namespaceOID :: UUID
306+namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
307+
308+namespaceX500 :: UUID
309+namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
310+
189-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
311-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
190null :: UUID -> Bool
312null :: UUID -> Bool
191null = (== nullUuid)
313null = (== nullUuid)
@@ -252,9 +374,8 @@ splitList c xs = let ys = dropWhile (== c) xs
252
374
253unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
375unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
254unfoldUntil p f n = unfoldr g n
376unfoldUntil p f n = unfoldr g n
255− where g m = case p m of
377+ where g m | p m = Nothing
256− True -> Nothing
257− False -> Just $ f m
378+ | otherwise = Just $ f m
258
379
259-- I'm not sure how fast these instances are, but they'll do for now.
380-- I'm not sure how fast these instances are, but they'll do for now.
260
381
uuid.cabal+1−1
@@ -26,7 +26,7 @@ Synopsis: For creating, comparing, parsing and printing Universally Unique Ident
26Homepage: http://community.haskell.org/~aslatter/code/uuid/
26Homepage: http://community.haskell.org/~aslatter/code/uuid/
27
27
28Library
28Library
29− Build-Depends: base, random
29+ Build-Depends: base, random, binary, bytestring, Crypto
30
30
31 Exposed-Modules:
31 Exposed-Modules:
32 Data.UUID
32 Data.UUID