git.iko.soy/typeable/uuid
on 3124bcc help sign in
typeable/uuid/Data/UUID.hs
405 lines 12 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
3-- |
4-- Module : Data.UUID
5-- Copyright : (c) 2008 Antoine Latter
6--
7-- License : BSD-style
8--
9-- Maintainer : aslatter@gmail.com
10-- Stability : experimental
11-- Portability : portable
12--
13--
14-- This library is useful for creating, comparing, parsing and
15-- printing Universally Unique Identifiers.
16-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
18module Data.UUID(UUID
19 ,fromString
20 ,toString
21 ,toStringUpper
22 ,toStringLower
23 ,generate
24 ,generateRandom
25 ,generateTime
26 ,generateNamed
27 ,namespaceDNS
28 ,namespaceURL
29 ,namespaceOID
30 ,namespaceX500
31 ,null
32 )
33where
35import Data.Word
36import System.Random
37import Data.Maybe
39import Data.Char
41import Data.Typeable
42import Data.Generics.Basics
44import Data.Bits
46import Text.Printf
48import Prelude hiding (null)
49import qualified Prelude
51import Data.List (splitAt, foldl', unfoldr)
53import Foreign.Ptr
54import Foreign.Storable
56import Data.Binary
57import Data.Binary.Put
58import Data.Binary.Get
60import qualified Data.ByteString.Lazy as BS
61import Data.ByteString.Lazy (ByteString)
63import qualified Data.Digest.SHA1 as SHA1
65data 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)
74instance 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)
85 randomR _ = random -- range is ignored
87versionMask :: Word16 -- 0000 1111 1111 1111
88versionMask = 0x0FFF
90versionRandom :: Word16
91versionRandom = shiftL 12 4
93versionSHA :: Word16
94versionSHA = shiftL 12 5
96reservedMask :: Word8 -- 0011 1111
97reservedMask = 0x3F
99reserved :: Word8
100reserved = bit 7
102data 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)
111instance 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
122nodeToList :: Node -> [Word8]
123nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
125listToNode :: [Word8] -> Maybe Node
126listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
127listToNode _ = Nothing
129instance Show UUID where
130 show = toString
132instance Read UUID where
133 readsPrec _ str = case fromString (take 36 str) of
134 Nothing -> []
135 Just u -> [(u,drop 36 str)]
138instance Storable UUID where
139 sizeOf _ = 16
140 alignment _ = 4 -- not sure what to put here
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
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
159instance Storable Node where
160 sizeOf _ = 6
161 alignment _ = 1 -- ???
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
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
180-- Binary instance in network byte-order
181instance 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
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
199instance 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
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
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.
220instance Data UUID where
221 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
222 gunfold _ _ = error "gunfold"
223 dataTypeOf _ = uuidType
225uuidType = mkNorepType "Data.UUID.UUID"
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.
231generate :: IO UUID
232generate = generateRandom
234-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
235-- Otherwise a psuedorandom generator will be used.
236generateRandom :: IO UUID
237generateRandom = randomIO -- not a good solution, as someone could have changed the global generator
239-- |Create a new 'UUID'. The UUID will be generated based on the
240-- current time and the hardware MAC address, if available.
241generateTime :: IO UUID
242generateTime = error "Data.UUID.generateTime: not yet implemented"
244-- |Generate a 'UUID' within the specified namespace out of the given
245-- object.
246--
247-- Uses a SHA1 hash.
248generateNamed :: UUID -- ^Namespace
249 -> [Word8] -- ^Object
250 -> UUID
251generateNamed namespace object =
252 let chunk = BS.unpack (encode namespace) ++ object
253 SHA1.Word160 w1 w2 w3 w4 w5 = SHA1.hash chunk
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
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
274low16 :: Word32 -> Word16
275low16 = fromIntegral . (.&. 0x0000FFFF)
277high16 :: Word32 -> Word16
278high16 = fromIntegral . flip shiftR 16
280low8 :: Word16 -> Word8
281low8 = fromIntegral . (.&. 0x00FF)
283high8 :: Word16 -> Word8
284high8 = fromIntegral . flip shiftR 4
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 #-}
294unsafeFromString :: String -> UUID
295unsafeFromString = fromJust . fromString
297-- |The namespace for DNS addresses
298namespaceDNS :: UUID
299namespaceDNS = unsafeFromString "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
301-- |The namespace for URLs
302namespaceURL :: UUID
303namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
305namespaceOID :: UUID
306namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
308namespaceX500 :: UUID
309namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
311-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
312null :: UUID -> Bool
313null = (== nullUuid)
314 where nullUuid = UUID 0 0 0 0 0 $ Node 0 0 0 0 0 0
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.
326fromString :: String -> Maybe UUID
327fromString 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)
339-- | Convert a string to a hex value, assuming the string is already validated.
340hexVal :: Num a => String -> a
341hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
343digitToInteger :: Char -> Integer
344digitToInteger = fromIntegral . digitToInt
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.
349toString :: UUID -> String
350toString = toStringLower
353-- | Convert a UUID into a hypenated string using upper-case letters.
354-- example: toStringUpper $ fromString "550e8400-e29b-41d4-a716-446655440000"
355toStringUpper :: UUID -> String
356toStringUpper (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
360-- | Convert a UUID into a hypenated string using lower-case letters.
361-- example: toStringLower $ fromString "550e8400-e29b-41d4-a716-446655440000"
362toStringLower :: UUID -> String
363toStringLower (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
367-- remove all occurances of the input element in the inpt list.
368-- non of the sub-lists are empty.
369splitList :: Eq a => a -> [a] -> [[a]]
370splitList c xs = let ys = dropWhile (== c) xs
371 in case span (/= c) ys of
372 ([],_) -> []
373 (sub,rest) -> sub : splitList c rest
375unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
376unfoldUntil p f n = unfoldr g n
377 where g m | p m = Nothing
378 | otherwise = Just $ f m
380-- I'm not sure how fast these instances are, but they'll do for now.
382instance Random Word8 where
383 random g = randomBoundedIntegral g
384 randomR r g = randomRIntegral r g
386instance Random Word16 where
387 random g = randomBoundedIntegral g
388 randomR r g = randomRIntegral r g
390instance Random Word32 where
391 random g = randomBoundedIntegral g
392 randomR r g = randomRIntegral r g
394randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
395randomBoundedIntegral 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)
402randomRIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)
403randomRIntegral (l, u) g = let (val, g1) = randomR (fromIntegral l, fromIntegral u) g
404 _ = val :: Integer
405 in (fromIntegral val, g1)