git.iko.soy/typeable/uuid
on master help sign in
reorganized library structure
278b6fbaslatter
Data/UUID.hs+6−380
compare with master
unifiedsplit
@@ -1,5 +1,3 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−
3-- |
1-- |
4-- Module : Data.UUID
2-- Module : Data.UUID
5-- Copyright : (c) 2008 Antoine Latter
3-- Copyright : (c) 2008 Antoine Latter
@@ -11,395 +9,23 @@
11-- Portability : portable
9-- Portability : portable
12--
10--
13--
11--
14−-- This library is useful for creating, comparing, parsing and
12+-- This library is useful for comparing, parsing and
15-- printing Universally Unique Identifiers.
13-- printing Universally Unique Identifiers.
16-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
14-- See <http://en.wikipedia.org/wiki/UUID> for the general idea.
17
15
18module Data.UUID(UUID
16module Data.UUID(UUID
19− ,fromString
20 ,toString
17 ,toString
21− ,toStringUpper
18+ ,fromString
22− ,toStringLower
23− ,generate
24− ,generateRandom
25− ,generateTime
26− ,generateNamed
27− ,namespaceDNS
28− ,namespaceURL
29− ,namespaceOID
30− ,namespaceX500
31 ,null
19 ,null
32− )
20+ ,module Data.UUID.V5
33−where
21+ ) where
34−
35−import Data.Word
36−import System.Random
37−import Data.Maybe
38−
39−import Data.Char
40
22
41−import Data.Typeable
23+import Data.UUID.Internal
42−import Data.Generics.Basics
43−
44−import Data.Bits
24+import Data.UUID.V5
45−
46−import Text.Printf
47
25
48import Prelude hiding (null)
26import 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"
310
27
311-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
28-- |Returns 'True' if the passed-in 'UUID' is the null UUID.
312null :: UUID -> Bool
29null :: UUID -> Bool
313null = (== nullUuid)
30null = (== nullUuid)
314 where nullUuid = UUID 0 0 0 0 0 $ Node 0 0 0 0 0 0
31 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)
Data/UUID/Internal.hsnew file+277
@@ -0,0 +1,277 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
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+module Data.UUID.Internal
14+ (UUID(..)
15+ ,Node(..)
16+ ,nodeToList
17+ ,listToNode
18+ ,fromString
19+ ,toString
20+ ,versionMask
21+ ,reservedMask
22+ ,reserved
23+ ) where
24+
25+import Data.Word
26+import Data.Char
27+import Data.Maybe
28+import Data.Bits
29+import Data.List (splitAt, foldl', unfoldr)
30+
31+import Data.Typeable
32+import Data.Generics.Basics
33+
34+import Foreign.Ptr
35+import Foreign.Storable
36+
37+import Data.Binary
38+import Data.Binary.Put
39+import Data.Binary.Get
40+
41+import System.Random
42+
43+import Text.Printf
44+
45+-- |The UUID type. A 'Random' instance is provided which produces
46+-- version 3 UUIDs as specified in RFC 4122. The 'Storable' and
47+-- 'Binary' instances are compatable with RFC 4122. The 'Binary'
48+-- instance serializes to network byte order.
49+data UUID = UUID
50+ {uuid_timeLow :: {-# UNPACK #-} !Word32
51+ ,uuid_timeMid :: {-# UNPACK #-} !Word16
52+ ,uuid_timeHigh :: {-# UNPACK #-} !Word16 -- includes version number
53+ ,uuid_clockSeqHi :: {-# UNPACK #-} !Word8 -- includes reserved field
54+ ,uuid_clokcSeqLow :: {-# UNPACK #-} !Word8
55+ ,uuid_node :: {-# UNPACK #-} !Node
56+ } deriving (Eq, Ord, Typeable)
57+
58+instance Random UUID where
59+ random g = let (timeLow, g1) = randomBoundedIntegral g
60+ (timeMid, g2) = randomBoundedIntegral g1
61+ (timeHigh, g3) = randomBoundedIntegral g2
62+ (seqHigh, g4) = randomBoundedIntegral g3
63+ (seqLow, g5) = randomBoundedIntegral g4
64+ (node, g6) = random g5
65+ seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
66+ timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
67+ in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
68+
69+ randomR _ = random -- range is ignored
70+
71+versionMask :: Word16 -- 0000 1111 1111 1111
72+versionMask = 0x0FFF
73+
74+versionRandom :: Word16
75+versionRandom = shiftL 12 4
76+
77+reservedMask :: Word8 -- 0011 1111
78+reservedMask = 0x3F
79+
80+reserved :: Word8
81+reserved = bit 7
82+
83+data Node = Node
84+ {-# UNPACK #-} !Word8
85+ {-# UNPACK #-} !Word8
86+ {-# UNPACK #-} !Word8
87+ {-# UNPACK #-} !Word8
88+ {-# UNPACK #-} !Word8
89+ {-# UNPACK #-} !Word8
90+ deriving (Eq, Ord, Typeable)
91+
92+instance Random Node where
93+ random g = let (w1, g1) = randomBoundedIntegral g
94+ (w2, g2) = randomBoundedIntegral g1
95+ (w3, g3) = randomBoundedIntegral g2
96+ (w4, g4) = randomBoundedIntegral g3
97+ (w5, g5) = randomBoundedIntegral g4
98+ (w6, g6) = randomBoundedIntegral g5
99+ in (Node w1 w2 w3 w4 w5 w6, g6)
100+ randomR _ = random -- neglect range
101+
102+
103+nodeToList :: Node -> [Word8]
104+nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
105+
106+listToNode :: [Word8] -> Maybe Node
107+listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
108+listToNode _ = Nothing
109+
110+instance Show UUID where
111+ show = toString
112+
113+instance Read UUID where
114+ readsPrec _ str = case fromString (take 36 str) of
115+ Nothing -> []
116+ Just u -> [(u,drop 36 str)]
117+
118+
119+instance Storable UUID where
120+ sizeOf _ = 16
121+ alignment _ = 4 -- not sure what to put here
122+
123+ peek p = do
124+ tl <- peek $ castPtr p
125+ tm <- peekByteOff p 4
126+ th <- peekByteOff p 6
127+ ch <- peekByteOff p 8
128+ cl <- peekByteOff p 9
129+ node <- peekByteOff p 10
130+ return $ UUID tl tm th ch cl node
131+
132+ poke p (UUID tl tm th ch cl node) = do
133+ poke (castPtr p) tl
134+ pokeByteOff p 4 tm
135+ pokeByteOff p 6 th
136+ pokeByteOff p 8 ch
137+ pokeByteOff p 9 cl
138+ pokeByteOff p 10 node
139+
140+instance Storable Node where
141+ sizeOf _ = 6
142+ alignment _ = 1 -- ???
143+
144+ peek p = do
145+ w1 <- peek $ castPtr p
146+ w2 <- peekByteOff p 1
147+ w3 <- peekByteOff p 2
148+ w4 <- peekByteOff p 3
149+ w5 <- peekByteOff p 4
150+ w6 <- peekByteOff p 5
151+ return $ Node w1 w2 w3 w4 w5 w6
152+
153+ poke p (Node w1 w2 w3 w4 w5 w6) = do
154+ poke (castPtr p) w1
155+ pokeByteOff p 1 w2
156+ pokeByteOff p 2 w3
157+ pokeByteOff p 3 w4
158+ pokeByteOff p 4 w5
159+ pokeByteOff p 5 w6
160+
161+-- Binary instance in network byte-order
162+instance Binary UUID where
163+ put (UUID tl tm th ch cl n) = do
164+ putWord32be tl
165+ putWord16be tm
166+ putWord16be th
167+ putWord8 ch
168+ putWord8 cl
169+ put n
170+
171+ get = do
172+ tl <- getWord32be
173+ tm <- getWord16be
174+ th <- getWord16be
175+ ch <- getWord8
176+ cl <- getWord8
177+ node <- get
178+ return $ UUID tl tm th ch cl node
179+
180+instance Binary Node where
181+ put (Node w1 w2 w3 w4 w5 w6) = do
182+ putWord8 w1
183+ putWord8 w2
184+ putWord8 w3
185+ putWord8 w4
186+ putWord8 w5
187+ putWord8 w6
188+
189+ get = do
190+ w1 <- getWord8
191+ w2 <- getWord8
192+ w3 <- getWord8
193+ w4 <- getWord8
194+ w5 <- getWord8
195+ w6 <- getWord8
196+ return $ Node w1 w2 w3 w4 w5 w6
197+
198+
199+-- My goal with this instance was to make it work just enough to do what
200+-- I want when used with the HStringTemplate library.
201+instance Data UUID where
202+ toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
203+ gunfold _ _ = error "gunfold"
204+ dataTypeOf _ = uuidType
205+
206+uuidType = mkNorepType "Data.UUID.UUID"
207+
208+
209+
210+
211+-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
212+-- The hyphens may not be omitted.
213+-- Example:
214+--
215+-- @
216+-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
217+-- @
218+--
219+-- Hex digits may be upper or lower-case.
220+fromString :: String -> Maybe UUID
221+fromString xs | validFmt = Just uuid
222+ | otherwise = Nothing
223+ where validFmt = length ws == 5 &&
224+ map length ws == [8,4,4,4,12] &&
225+ all isHexDigit (concat ws) &&
226+ isJust node
227+ ws = splitList '-' xs
228+ [tl, tm, th, c, n] = ws
229+ ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
230+ node = listToNode $ map hexVal ns :: Maybe Node
231+ uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
232+
233+-- | Convert a string to a hex value, assuming the string is already validated.
234+hexVal :: Num a => String -> a
235+hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
236+
237+digitToInteger :: Char -> Integer
238+digitToInteger = fromIntegral . digitToInt
239+
240+
241+-- | Convert a UUID into a hypenated string using lower-case letters.
242+-- Example:
243+--
244+-- @
245+-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
246+-- @
247+toString :: UUID -> String
248+toString (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
249+ where ns = concatMap hexb $ nodeToList n
250+ hexb x = printf "%02x" x :: String
251+
252+
253+-- remove all occurances of the input element in the inpt list.
254+-- non of the sub-lists are empty.
255+splitList :: Eq a => a -> [a] -> [[a]]
256+splitList c xs = let ys = dropWhile (== c) xs
257+ in case span (/= c) ys of
258+ ([],_) -> []
259+ (sub,rest) -> sub : splitList c rest
260+
261+unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
262+unfoldUntil p f n = unfoldr g n
263+ where g m | p m = Nothing
264+ | otherwise = Just $ f m
265+
266+
267+-- no random intance for Data.Word types :-(
268+-- this will work, though
269+
270+randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
271+randomBoundedIntegral g = let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
272+ _ = n :: Integer
273+ retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
274+ u = maxBound
275+ l = minBound
276+ in (retVal, g1)
277+
Data/UUID/V5.hsnew file+101
@@ -0,0 +1,101 @@
1+-- |
2+-- Module : Data.UUID
3+-- Copyright : (c) 2008 Antoine Latter
4+--
5+-- License : BSD-style
6+--
7+-- Maintainer : aslatter@gmail.com
8+-- Stability : experimental
9+-- Portability : portable
10+--
11+--
12+-- This module implements Version 5 UUIDs as specified
13+-- in RFC 4122.
14+--
15+-- These UUIDs identify an object within a namespace,
16+-- and are deterministic.
17+--
18+-- The namespace is identified by a UUID. Several sample
19+-- namespaces are enclosed.
20+
21+module Data.UUID.V5
22+ (generateNamed
23+ ,namespaceDNS
24+ ,namespaceURL
25+ ,namespaceOID
26+ ,namespaceX500
27+ ) where
28+
29+
30+import Data.UUID.Internal
31+
32+import Data.Binary
33+import Data.Bits
34+import Data.Maybe
35+
36+import qualified Data.ByteString.Lazy as BS
37+import Data.ByteString.Lazy (ByteString)
38+
39+import qualified Data.Digest.SHA1 as SHA1
40+
41+
42+-- |Generate a 'UUID' within the specified namespace out of the given
43+-- object.
44+--
45+-- Uses a SHA1 hash.
46+generateNamed :: UUID -- ^Namespace
47+ -> [Word8] -- ^Object
48+ -> UUID
49+generateNamed namespace object =
50+ let chunk = BS.unpack (encode namespace) ++ object
51+ SHA1.Word160 w1 w2 w3 w4 w5 = SHA1.hash chunk
52+
53+ tl = w1
54+ tm = low16 w2
55+ th = (versionSHA .|.) $ (versionMask .&.) $ high16 w2
56+ ch = (reserved .|.) $ (reservedMask .&.) $ high8 $ high16 w3
57+ cl = low8 $ high16 w3
58+ node = Node (high8 (low16 w3))
59+ (low8 (low16 w3))
60+ (high8 (high16 w4))
61+ (low8 (high16 w4))
62+ (high8 (low16 w4))
63+ (low8 (low16 w4))
64+ in UUID tl tm th ch cl node
65+
66+-- HASH 0 1 - 2 3 : w1
67+-- 4 5 - 6 7 : w2
68+-- 8 9 - 10 11 : w3
69+-- 12 13 - 14 15 : w4
70+-- 16 17 - 18 19 : w5
71+
72+low16 :: Word32 -> Word16
73+low16 = fromIntegral . (.&. 0x0000FFFF)
74+
75+high16 :: Word32 -> Word16
76+high16 = fromIntegral . flip shiftR 16
77+
78+low8 :: Word16 -> Word8
79+low8 = fromIntegral . (.&. 0x00FF)
80+
81+high8 :: Word16 -> Word8
82+high8 = fromIntegral . flip shiftR 4
83+
84+versionSHA = shiftL 12 5
85+
86+unsafeFromString :: String -> UUID
87+unsafeFromString = fromJust . fromString
88+
89+-- |The namespace for DNS addresses
90+namespaceDNS :: UUID
91+namespaceDNS = unsafeFromString "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
92+
93+-- |The namespace for URLs
94+namespaceURL :: UUID
95+namespaceURL = unsafeFromString "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
96+
97+namespaceOID :: UUID
98+namespaceOID = unsafeFromString "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
99+
100+namespaceX500 :: UUID
101+namespaceX500 = unsafeFromString "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
uuid.cabal+2−1
@@ -1,5 +1,5 @@
1Name: uuid
1Name: uuid
2−Version: 0.1.2
2+Version: 1.0.0
3Copyright: (c) 2008 Antoine Latter
3Copyright: (c) 2008 Antoine Latter
4Author: Antoine Latter
4Author: Antoine Latter
5Maintainer: aslatter@gmail.com
5Maintainer: aslatter@gmail.com
@@ -30,6 +30,7 @@ Library
30
30
31 Exposed-Modules:
31 Exposed-Modules:
32 Data.UUID
32 Data.UUID
33+ Data.UUID.V5
33
34
34 Extensions: DeriveDataTypeable
35 Extensions: DeriveDataTypeable
35
36