@@ -1,5 +1,3 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−
31-- |
42-- Module : Data.UUID
53-- Copyright : (c) 2008 Antoine Latter
@@ -11,395 +9,23 @@
119-- Portability : portable
1210--
1311--
14−-- This library is useful for creating, comparing, parsing and
12+-- This library is useful for comparing, parsing and
1513-- printing Universally Unique Identifiers.
1614-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
1715
1816module Data.UUID(UUID
19− ,fromString
2017 ,toString
21− ,toStringUpper
22− ,toStringLower
23− ,generate
24− ,generateRandom
25− ,generateTime
26− ,generateNamed
27− ,namespaceDNS
28− ,namespaceURL
29− ,namespaceOID
30− ,namespaceX500
18+ ,fromString
3119 ,null
32− )
33−where
34−
35−import Data.Word
36−import System.Random
37−import Data.Maybe
38−
39−import Data.Char
20+ ,module Data.UUID.V5
21+ ) where
4022
41−import Data.Typeable
42−import Data.Generics.Basics
43−
44−import Data.Bits
45−
46−import Text.Printf
23+import Data.UUID.Internal
24+import Data.UUID.V5
4725
4826import Prelude hiding (null)
49−import qualified Prelude
50−
51−import Data.List (splitAt, foldl', unfoldr)
52−
53−import Foreign.Ptr
54−import Foreign.Storable
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
64−
65−data UUID = UUID
66− {uuid_timeLow :: {-# UNPACK #-} !Word32
67− ,uuid_timeMid :: {-# UNPACK #-} !Word16
68− ,uuid_timeHigh :: {-# UNPACK #-} !Word16 -- includes version number
69− ,uuid_clockSeqHi :: {-# UNPACK #-} !Word8 -- includes reserved field
70− ,uuid_clokcSeqLow :: {-# UNPACK #-} !Word8
71− ,uuid_node :: {-# UNPACK #-} !Node
72− } deriving (Eq, Ord, Typeable)
73−
74−instance Random UUID where
75− random g = let (timeLow, g1) = random g
76− (timeMid, g2) = random g1
77− (timeHigh, g3) = random g2
78− (seqHigh, g4) = random g3
79− (seqLow, g5) = random g4
80− (node, g6) = random g5
81− seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
82− timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
83− in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
84−
85− randomR _ = random -- range is ignored
86−
87−versionMask :: Word16 -- 0000 1111 1111 1111
88−versionMask = 0x0FFF
89−
90−versionRandom :: Word16
91−versionRandom = shiftL 12 4
92−
93−versionSHA :: Word16
94−versionSHA = shiftL 12 5
95−
96−reservedMask :: Word8 -- 0011 1111
97−reservedMask = 0x3F
98−
99−reserved :: Word8
100−reserved = bit 7
101−
102−data Node = Node
103− {-# UNPACK #-} !Word8
104− {-# UNPACK #-} !Word8
105− {-# UNPACK #-} !Word8
106− {-# UNPACK #-} !Word8
107− {-# UNPACK #-} !Word8
108− {-# UNPACK #-} !Word8
109− deriving (Eq, Ord, Typeable)
110−
111−instance Random Node where
112− random g = let (w1, g1) = random g
113− (w2, g2) = random g1
114− (w3, g3) = random g2
115− (w4, g4) = random g3
116− (w5, g5) = random g4
117− (w6, g6) = random g5
118− in (Node w1 w2 w3 w4 w5 w6, g6)
119− randomR _ = random -- neglect range
120−
121−
122−nodeToList :: Node -> [Word8]
123−nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
124−
125−listToNode :: [Word8] -> Maybe Node
126−listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
127−listToNode _ = Nothing
128−
129−instance Show UUID where
130− show = toString
131−
132−instance Read UUID where
133− readsPrec _ str = case fromString (take 36 str) of
134− Nothing -> []
135− Just u -> [(u,drop 36 str)]
136−
137−
138−instance Storable UUID where
139− sizeOf _ = 16
140− alignment _ = 4 -- not sure what to put here
141−
142− peek p = do
143− tl <- peek $ castPtr p
144− tm <- peekByteOff p 4
145− th <- peekByteOff p 6
146− ch <- peekByteOff p 8
147− cl <- peekByteOff p 9
148− node <- peekByteOff p 10
149− return $ UUID tl tm th ch cl node
150−
151− poke p (UUID tl tm th ch cl node) = do
152− poke (castPtr p) tl
153− pokeByteOff p 4 tm
154− pokeByteOff p 6 th
155− pokeByteOff p 8 ch
156− pokeByteOff p 9 cl
157− pokeByteOff p 10 node
158−
159−instance Storable Node where
160− sizeOf _ = 6
161− alignment _ = 1 -- ???
162−
163− peek p = do
164− w1 <- peek $ castPtr p
165− w2 <- peekByteOff p 1
166− w3 <- peekByteOff p 2
167− w4 <- peekByteOff p 3
168− w5 <- peekByteOff p 4
169− w6 <- peekByteOff p 5
170− return $ Node w1 w2 w3 w4 w5 w6
171−
172− poke p (Node w1 w2 w3 w4 w5 w6) = do
173− poke (castPtr p) w1
174− pokeByteOff p 1 w2
175− pokeByteOff p 2 w3
176− pokeByteOff p 3 w4
177− pokeByteOff p 4 w5
178− pokeByteOff p 5 w6
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−
218−-- My goal with this instance was to make it work just enough to do what
219−-- I want when used with the HStringTemplate library.
220−instance Data UUID where
221− toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
222− gunfold _ _ = error "gunfold"
223− dataTypeOf _ = uuidType
224−
225−uuidType = mkNorepType "Data.UUID.UUID"
226−
227−
228−-- |Creates a new 'UUID'. If \/dev\/urandom is available, it will be used.
229−-- Otherwise a UUID will be generated based on the current time and the
230−-- hardware MAC address, if available.
231−generate :: IO UUID
232−generate = generateRandom
233−
234−-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
235−-- Otherwise a psuedorandom generator will be used.
236−generateRandom :: IO UUID
237−generateRandom = randomIO -- not a good solution, as someone could have changed the global generator
238−
239−-- |Create a new 'UUID'. The UUID will be generated based on the
240−-- current time and the hardware MAC address, if available.
241−generateTime :: IO UUID
242−generateTime = error "Data.UUID.generateTime: not yet implemented"
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) 8)
290− "low8/high16" forall x . low8 (high16 x) = fromIntegral (shiftR (x .&. 0x00FF0000) 16)
291− "high8/high16" forall x . high8 (high16 x) = fromIntegral (shiftR x 24)
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"
31027
31128-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
31229null :: UUID -> Bool
31330null = (== nullUuid)
31431 where nullUuid = UUID 0 0 0 0 0 $ Node 0 0 0 0 0 0
315−
316−
317−-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
318−-- The hyphens may not be omitted.
319−-- Example:
320−--
321−-- @
322−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
323−-- @
324−--
325−-- Hex digits may be upper or lower-case.
326−fromString :: String -> Maybe UUID
327−fromString xs | validFmt = Just uuid
328− | otherwise = Nothing
329− where validFmt = length ws == 5 &&
330− map length ws == [8,4,4,4,12] &&
331− all isHexDigit (concat ws) &&
332− isJust node
333− ws = splitList '-' xs
334− [tl, tm, th, c, n] = ws
335− ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
336− node = listToNode $ map hexVal ns :: Maybe Node
337− uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
338−
339−-- | Convert a string to a hex value, assuming the string is already validated.
340−hexVal :: Num a => String -> a
341−hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
342−
343−digitToInteger :: Char -> Integer
344−digitToInteger = fromIntegral . digitToInt
345−
346−-- |Returns a 'String' representation of the passed in 'UUID'.
347−-- Hex digits occuring in the output will be either upper or
348−-- lower-case depending on system defaults and locale.
349−toString :: UUID -> String
350−toString = toStringLower
351−
352−
353−-- | Convert a UUID into a hypenated string using upper-case letters.
354−-- example: toStringUpper $ fromString "550e8400-e29b-41d4-a716-446655440000"
355−toStringUpper :: UUID -> String
356−toStringUpper (UUID tl tm th ch cl n) = printf "%08X-%04X-%04X-%02X%02X-%s" tl tm th ch cl ns
357− where ns = concatMap hexb $ nodeToList n
358− hexb x = printf "%02X" x :: String
359−
360−-- | Convert a UUID into a hypenated string using lower-case letters.
361−-- example: toStringLower $ fromString "550e8400-e29b-41d4-a716-446655440000"
362−toStringLower :: UUID -> String
363−toStringLower (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
364− where ns = concatMap hexb $ nodeToList n
365− hexb x = printf "%02x" x :: String
366−
367−-- remove all occurances of the input element in the inpt list.
368−-- non of the sub-lists are empty.
369−splitList :: Eq a => a -> [a] -> [[a]]
370−splitList c xs = let ys = dropWhile (== c) xs
371− in case span (/= c) ys of
372− ([],_) -> []
373− (sub,rest) -> sub : splitList c rest
374−
375−unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
376−unfoldUntil p f n = unfoldr g n
377− where g m | p m = Nothing
378− | otherwise = Just $ f m
379−
380−-- I'm not sure how fast these instances are, but they'll do for now.
381−
382−instance Random Word8 where
383− random g = randomBoundedIntegral g
384− randomR r g = randomRIntegral r g
385−
386−instance Random Word16 where
387− random g = randomBoundedIntegral g
388− randomR r g = randomRIntegral r g
389−
390−instance Random Word32 where
391− random g = randomBoundedIntegral g
392− randomR r g = randomRIntegral r g
393−
394−randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
395−randomBoundedIntegral g = let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
396− _ = n :: Integer
397− retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
398− u = maxBound
399− l = minBound
400− in (retVal, g1)
401−
402−randomRIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)
403−randomRIntegral (l, u) g = let (val, g1) = randomR (fromIntegral l, fromIntegral u) g
404− _ = val :: Integer
405− in (fromIntegral val, g1)