git.iko.soy/typeable/uuid
on 80c83cb help sign in
typeable/uuid/Data/UUID.hs
284 lines 9.2 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 ,null
27 )
28where
30import Data.Word
31import System.Random
32import Data.Maybe
34import Data.Char
36import Data.Typeable
37import Data.Generics.Basics
39import Data.Bits
41import Text.Printf
43import Prelude hiding (null)
44import qualified Prelude
46import Data.List (splitAt, foldl', unfoldr)
48import Foreign.Ptr
49import Foreign.Storable
52data UUID = UUID
53 {uuid_timeLow :: {-# UNPACK #-} !Word32
54 ,uuid_timeMid :: {-# UNPACK #-} !Word16
55 ,uuid_timeHigh :: {-# UNPACK #-} !Word16 -- includes version number
56 ,uuid_clockSeqHi :: {-# UNPACK #-} !Word8 -- includes reserved field
57 ,uuid_clokcSeqLow :: {-# UNPACK #-} !Word8
58 ,uuid_node :: {-# UNPACK #-} !Node
59 } deriving (Eq, Ord, Typeable)
61instance Random UUID where
62 random g = let (timeLow, g1) = random g
63 (timeMid, g2) = random g1
64 (timeHigh, g3) = random g2
65 (seqHigh, g4) = random g3
66 (seqLow, g5) = random g4
67 (node, g6) = random g5
68 seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
69 timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
70 in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
72 randomR _ = random -- range is ignored
74versionMask :: Word16 -- 0000 1111 1111 1111
75versionMask = 0x0FFF
77versionRandom :: Word16
78versionRandom = shiftL 12 4
80reservedMask :: Word8 -- 0011 1111
81reservedMask = 0x3F
83reserved :: Word8
84reserved = bit 7
86data Node = Node
87 {-# UNPACK #-} !Word8
88 {-# UNPACK #-} !Word8
89 {-# UNPACK #-} !Word8
90 {-# UNPACK #-} !Word8
91 {-# UNPACK #-} !Word8
92 {-# UNPACK #-} !Word8
93 deriving (Eq, Ord, Typeable)
95instance Random Node where
96 random g = let (w1, g1) = random g
97 (w2, g2) = random g1
98 (w3, g3) = random g2
99 (w4, g4) = random g3
100 (w5, g5) = random g4
101 (w6, g6) = random g5
102 in (Node w1 w2 w3 w4 w5 w6, g6)
103 randomR _ = random -- neglect range
105nodeToList :: Node -> [Word8]
106nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
108listToNode :: [Word8] -> Maybe Node
109listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
110listToNode _ = Nothing
112instance Show UUID where
113 show = toString
115instance Read UUID where
116 readsPrec _ str = case fromString (take 36 str) of
117 Nothing -> []
118 Just u -> [(u,drop 36 str)]
121instance Storable UUID where
122 sizeOf _ = 16
123 alignment _ = 4 -- not sure what to put here
125 peek p = do
126 tl <- peek $ castPtr p
127 tm <- peekByteOff (castPtr p) 4
128 th <- peekByteOff (castPtr p) 6
129 ch <- peekByteOff (castPtr p) 8
130 cl <- peekByteOff (castPtr p) 9
131 node <- peekByteOff (castPtr p) 10
132 return $ UUID tl tm th ch cl node
134 poke p (UUID tl tm th ch cl node) = do
135 poke (castPtr p) tl
136 pokeByteOff (castPtr p) 4 tm
137 pokeByteOff (castPtr p) 6 th
138 pokeByteOff (castPtr p) 8 ch
139 pokeByteOff (castPtr p) 9 cl
140 pokeByteOff (castPtr p) 10 node
142instance Storable Node where
143 sizeOf _ = 6
144 alignment _ = 1 -- ???
146 peek p = do
147 w1 <- peek $ castPtr p
148 w2 <- peekByteOff (castPtr p) 1
149 w3 <- peekByteOff (castPtr p) 2
150 w4 <- peekByteOff (castPtr p) 3
151 w5 <- peekByteOff (castPtr p) 4
152 w6 <- peekByteOff (castPtr p) 5
153 return $ Node w1 w2 w3 w4 w5 w6
155 poke p (Node w1 w2 w3 w4 w5 w6) = do
156 poke (castPtr p) w1
157 pokeByteOff (castPtr p) 1 w2
158 pokeByteOff (castPtr p) 2 w3
159 pokeByteOff (castPtr p) 3 w4
160 pokeByteOff (castPtr p) 4 w5
161 pokeByteOff (castPtr p) 5 w6
163-- My goal with this instance was to make it work just enough to do what
164-- I want when used with the HStringTemplate library.
165instance Data UUID where
166 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
167 gunfold _ _ = error "gunfold"
168 dataTypeOf _ = uuidType
170uuidType = mkNorepType "Data.UUID.UUID"
173-- |Creates a new 'UUID'. If \/dev\/urandom is available, it will be used.
174-- Otherwise a UUID will be generated based on the current time and the
175-- hardware MAC address, if available.
176generate :: IO UUID
177generate = generateRandom
179-- |Create a new 'UUID'. If \/dev\/urandom is available, it will be used.
180-- Otherwise a psuedorandom generator will be used.
181generateRandom :: IO UUID
182generateRandom = randomIO -- not a good solution, as someone could have changed the global generator
184-- |Create a new 'UUID'. The UUID will be generated based on the
185-- current time and the hardware MAC address, if available.
186generateTime :: IO UUID
187generateTime = error "Data.UUID.generateTime: not yet implemented"
189-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
190null :: UUID -> Bool
191null = (== nullUuid)
192 where nullUuid = UUID 0 0 0 0 0 $ Node 0 0 0 0 0 0
195-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
196-- The hyphens may not be omitted.
197-- Example:
198--
199-- @
200-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
201-- @
202--
203-- Hex digits may be upper or lower-case.
204fromString :: String -> Maybe UUID
205fromString xs | validFmt = Just uuid
206 | otherwise = Nothing
207 where validFmt = length ws == 5 &&
208 map length ws == [8,4,4,4,12] &&
209 all isHexDigit (concat ws) &&
210 isJust node
211 ws = splitList '-' xs
212 [tl, tm, th, c, n] = ws
213 ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
214 node = listToNode $ map hexVal ns :: Maybe Node
215 uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
217-- | Convert a string to a hex value, assuming the string is already validated.
218hexVal :: Num a => String -> a
219hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
221digitToInteger :: Char -> Integer
222digitToInteger = fromIntegral . digitToInt
224-- |Returns a 'String' representation of the passed in 'UUID'.
225-- Hex digits occuring in the output will be either upper or
226-- lower-case depending on system defaults and locale.
227toString :: UUID -> String
228toString = toStringLower
231-- | Convert a UUID into a hypenated string using upper-case letters.
232-- example: toStringUpper $ fromString "550e8400-e29b-41d4-a716-446655440000"
233toStringUpper :: UUID -> String
234toStringUpper (UUID tl tm th ch cl n) = printf "%08X-%04X-%04X-%02X%02X-%s" tl tm th ch cl ns
235 where ns = concatMap hexb $ nodeToList n
236 hexb x = printf "%02X" x :: String
238-- | Convert a UUID into a hypenated string using lower-case letters.
239-- example: toStringLower $ fromString "550e8400-e29b-41d4-a716-446655440000"
240toStringLower :: UUID -> String
241toStringLower (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
242 where ns = concatMap hexb $ nodeToList n
243 hexb x = printf "%02x" x :: String
245-- remove all occurances of the input element in the inpt list.
246-- non of the sub-lists are empty.
247splitList :: Eq a => a -> [a] -> [[a]]
248splitList c xs = let ys = dropWhile (== c) xs
249 in case span (/= c) ys of
250 ([],_) -> []
251 (sub,rest) -> sub : splitList c rest
253unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
254unfoldUntil p f n = unfoldr g n
255 where g m = case p m of
256 True -> Nothing
257 False -> Just $ f m
259-- I'm not sure how fast these instances are, but they'll do for now.
261instance Random Word8 where
262 random g = randomBoundedIntegral g
263 randomR r g = randomRIntegral r g
265instance Random Word16 where
266 random g = randomBoundedIntegral g
267 randomR r g = randomRIntegral r g
269instance Random Word32 where
270 random g = randomBoundedIntegral g
271 randomR r g = randomRIntegral r g
273randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
274randomBoundedIntegral g = let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
275 _ = n :: Integer
276 retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
277 u = maxBound
278 l = minBound
279 in (retVal, g1)
281randomRIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)
282randomRIntegral (l, u) g = let (val, g1) = randomR (fromIntegral l, fromIntegral u) g
283 _ = val :: Integer
284 in (fromIntegral val, g1)