@@ -20,9 +20,14 @@ module Data.UUID(UUID
2020 ,toString
2121 ,toStringUpper
2222 ,toStringLower
23− ,generate
23+ ,generate
2424 ,generateRandom
2525 ,generateTime
26+ ,generateNamed
27+ ,namespaceDNS
28+ ,namespaceURL
29+ ,namespaceOID
30+ ,namespaceX500
2631 ,null
2732 )
2833where
@@ -48,6 +53,14 @@ import Data.List (splitAt, foldl', unfoldr)
4853import Foreign.Ptr
4954import Foreign.Storable
5055
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
5164
5265data UUID = UUID
5366 {uuid_timeLow :: {-# UNPACK #-} !Word32
@@ -77,6 +90,9 @@ versionMask = 0x0FFF
7790versionRandom :: Word16
7891versionRandom = shiftL 12 4
7992
93+versionSHA :: Word16
94+versionSHA = shiftL 12 5
95+
8096reservedMask :: Word8 -- 0011 1111
8197reservedMask = 0x3F
8298
@@ -102,6 +118,7 @@ instance Random Node where
102118 in (Node w1 w2 w3 w4 w5 w6, g6)
103119 randomR _ = random -- neglect range
104120
121+
105122nodeToList :: Node -> [Word8]
106123nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
107124
@@ -160,6 +177,44 @@ instance Storable Node where
160177 pokeByteOff p 4 w5
161178 pokeByteOff p 5 w6
162179
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+
163218-- My goal with this instance was to make it work just enough to do what
164219-- I want when used with the HStringTemplate library.
165220instance Data UUID where
@@ -186,6 +241,73 @@ generateRandom = randomIO -- not a good solution, as someone could have changed
186241generateTime :: IO UUID
187242generateTime = error "Data.UUID.generateTime: not yet implemented"
188243
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+
189311-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
190312null :: UUID -> Bool
191313null = (== nullUuid)
@@ -252,9 +374,8 @@ splitList c xs = let ys = dropWhile (== c) xs
252374
253375unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
254376unfoldUntil p f n = unfoldr g n
255− where g m = case p m of
256− True -> Nothing
257− False -> Just $ f m
377+ where g m | p m = Nothing
378+ | otherwise = Just $ f m
258379
259380-- I'm not sure how fast these instances are, but they'll do for now.
260381