git.iko.soy/typeable/uuid
on 165abb7 help sign in
typeable/uuid/Data/UUID/Internal.hs
290 lines 8.0 kB history raw
1{-# LANGUAGE DeriveDataTypeable, CPP #-}
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
13module Data.UUID.Internal
14 (UUID(..)
15 ,Node(..)
16 ,nodeToList
17 ,listToNode
18 ,fromString
19 ,toString
20 ,versionMask
21 ,reservedMask
22 ,reserved
23 ) where
25import Data.Word
26import Data.Char
27import Data.Maybe
28import Data.Bits
29import Data.List (splitAt, foldl', unfoldr)
31import Data.Typeable
33#if __GLASGOW_HASKELL__ >= 610
34import Data.Data
35#else
36import Data.Generics.Basics
37#endif
39import Foreign.Ptr
40import Foreign.Storable
42import Data.Binary
43import Data.Binary.Put
44import Data.Binary.Get
46import System.Random
48import Text.Printf
50#ifndef STRICT
51#define SLOT(x) x
52#else
53#define SLOT(x) {-# UNPACK #-} !x
54#endif
56-- |The UUID type. A 'Random' instance is provided which produces
57-- version 3 UUIDs as specified in RFC 4122. The 'Storable' and
58-- 'Binary' instances are compatable with RFC 4122. The 'Binary'
59-- instance serializes to network byte order.
60data UUID = UUID
61 {uuid_timeLow :: SLOT(Word32)
62 ,uuid_timeMid :: SLOT(Word16)
63 ,uuid_timeHigh :: SLOT(Word16) -- includes version number
64 ,uuid_clockSeqHi :: SLOT(Word8) -- includes reserved field
65 ,uuid_clokcSeqLow :: SLOT(Word8)
66 ,uuid_node :: SLOT(Node)
67 } deriving (Eq, Ord, Typeable)
69instance Random UUID where
70 random g = let (timeLow, g1) = randomBoundedIntegral g
71 (timeMid, g2) = randomBoundedIntegral g1
72 (timeHigh, g3) = randomBoundedIntegral g2
73 (seqHigh, g4) = randomBoundedIntegral g3
74 (seqLow, g5) = randomBoundedIntegral g4
75 (node, g6) = random g5
76 seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
77 timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
78 in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
80 randomR _ = random -- range is ignored
82versionMask :: Word16 -- 0000 1111 1111 1111
83versionMask = 0x0FFF
85versionRandom :: Word16
86versionRandom = 4 `shiftL` 12
88reservedMask :: Word8 -- 0011 1111
89reservedMask = 0x3F
91reserved :: Word8
92reserved = bit 7
94data Node = Node
95 SLOT(Word8)
96 SLOT(Word8)
97 SLOT(Word8)
98 SLOT(Word8)
99 SLOT(Word8)
100 SLOT(Word8)
101 deriving (Eq, Ord, Typeable)
103instance Random Node where
104 random g = let (w1, g1) = randomBoundedIntegral g
105 (w2, g2) = randomBoundedIntegral g1
106 (w3, g3) = randomBoundedIntegral g2
107 (w4, g4) = randomBoundedIntegral g3
108 (w5, g5) = randomBoundedIntegral g4
109 (w6, g6) = randomBoundedIntegral g5
110 in (Node w1 w2 w3 w4 w5 w6, g6)
111 randomR _ = random -- neglect range
114nodeToList :: Node -> [Word8]
115nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
117listToNode :: [Word8] -> Maybe Node
118listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
119listToNode _ = Nothing
121instance Show UUID where
122 show = toString
124instance Read UUID where
125 readsPrec _ str = case fromString (take 36 str) of
126 Nothing -> []
127 Just u -> [(u,drop 36 str)]
130instance Storable UUID where
131 sizeOf _ = 16
132 alignment _ = 4 -- not sure what to put here
134 peek p = do
135 tl <- peek $ castPtr p
136 tm <- peekByteOff p 4
137 th <- peekByteOff p 6
138 ch <- peekByteOff p 8
139 cl <- peekByteOff p 9
140 node <- peekByteOff p 10
141 return $ UUID tl tm th ch cl node
143 poke p (UUID tl tm th ch cl node) = do
144 poke (castPtr p) tl
145 pokeByteOff p 4 tm
146 pokeByteOff p 6 th
147 pokeByteOff p 8 ch
148 pokeByteOff p 9 cl
149 pokeByteOff p 10 node
151instance Storable Node where
152 sizeOf _ = 6
153 alignment _ = 1 -- ???
155 peek p = do
156 w1 <- peek $ castPtr p
157 w2 <- peekByteOff p 1
158 w3 <- peekByteOff p 2
159 w4 <- peekByteOff p 3
160 w5 <- peekByteOff p 4
161 w6 <- peekByteOff p 5
162 return $ Node w1 w2 w3 w4 w5 w6
164 poke p (Node w1 w2 w3 w4 w5 w6) = do
165 poke (castPtr p) w1
166 pokeByteOff p 1 w2
167 pokeByteOff p 2 w3
168 pokeByteOff p 3 w4
169 pokeByteOff p 4 w5
170 pokeByteOff p 5 w6
172-- Binary instance in network byte-order
173instance Binary UUID where
174 put (UUID tl tm th ch cl n) = do
175 putWord32be tl
176 putWord16be tm
177 putWord16be th
178 putWord8 ch
179 putWord8 cl
180 put n
182 get = do
183 tl <- getWord32be
184 tm <- getWord16be
185 th <- getWord16be
186 ch <- getWord8
187 cl <- getWord8
188 node <- get
189 return $ UUID tl tm th ch cl node
191instance Binary Node where
192 put (Node w1 w2 w3 w4 w5 w6) = do
193 putWord8 w1
194 putWord8 w2
195 putWord8 w3
196 putWord8 w4
197 putWord8 w5
198 putWord8 w6
200 get = do
201 w1 <- getWord8
202 w2 <- getWord8
203 w3 <- getWord8
204 w4 <- getWord8
205 w5 <- getWord8
206 w6 <- getWord8
207 return $ Node w1 w2 w3 w4 w5 w6
210-- My goal with this instance was to make it work just enough to do what
211-- I want when used with the HStringTemplate library.
212instance Data UUID where
213 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
214 gunfold _ _ = error "gunfold"
215 dataTypeOf _ = uuidType
217uuidType = mkNorepType "Data.UUID.UUID"
222-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
223-- The hyphens may not be omitted.
224-- Example:
225--
226-- @
227-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
228-- @
229--
230-- Hex digits may be upper or lower-case.
231fromString :: String -> Maybe UUID
232fromString xs | validFmt = Just uuid
233 | otherwise = Nothing
234 where validFmt = length ws == 5 &&
235 map length ws == [8,4,4,4,12] &&
236 all isHexDigit (concat ws) &&
237 isJust node
238 ws = splitList '-' xs
239 [tl, tm, th, c, n] = ws
240 ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
241 node = listToNode $ map hexVal ns :: Maybe Node
242 uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
244-- | Convert a string to a hex value, assuming the string is already validated.
245hexVal :: Num a => String -> a
246hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
248digitToInteger :: Char -> Integer
249digitToInteger = fromIntegral . digitToInt
252-- | Convert a UUID into a hypenated string using lower-case letters.
253-- Example:
254--
255-- @
256-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
257-- @
258toString :: UUID -> String
259toString (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
260 where ns = concatMap hexb $ nodeToList n
261 hexb x = printf "%02x" x :: String
264-- remove all occurances of the input element in the inpt list.
265-- none of the sub-lists are empty.
266splitList :: Eq a => a -> [a] -> [[a]]
267splitList c xs = let ys = dropWhile (== c) xs
268 in case span (/= c) ys of
269 ([],_) -> []
270 (sub,rest) -> sub : splitList c rest
272-- the passed-in predicate signals when to stop unfolding
273unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
274unfoldUntil p f n = unfoldr g n
275 where g m | p m = Nothing
276 | otherwise = Just $ f m
279-- no random intance for Data.Word types :-(
280-- this will work, though
282randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
283randomBoundedIntegral g =
284 let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
285 _ = n :: Integer
286 retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
287 u = maxBound
288 l = minBound
289 in (retVal, g1)