git.iko.soy/typeable/uuid
on 7589b09 help sign in
typeable/uuid/Data/UUID/Internal.hs
283 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
32import Data.Generics.Basics
34import Foreign.Ptr
35import Foreign.Storable
37import Data.Binary
38import Data.Binary.Put
39import Data.Binary.Get
41import System.Random
43import Text.Printf
45#ifndef STRICT
46#define SLOT(x) x
47#else
48#define SLOT(x) {-# UNPACK #-} !x
49#endif
51-- |The UUID type. A 'Random' instance is provided which produces
52-- version 3 UUIDs as specified in RFC 4122. The 'Storable' and
53-- 'Binary' instances are compatable with RFC 4122. The 'Binary'
54-- instance serializes to network byte order.
55data UUID = UUID
56 {uuid_timeLow :: SLOT(Word32)
57 ,uuid_timeMid :: SLOT(Word16)
58 ,uuid_timeHigh :: SLOT(Word16) -- includes version number
59 ,uuid_clockSeqHi :: SLOT(Word8) -- includes reserved field
60 ,uuid_clokcSeqLow :: SLOT(Word8)
61 ,uuid_node :: SLOT(Node)
62 } deriving (Eq, Ord, Typeable)
64instance Random UUID where
65 random g = let (timeLow, g1) = randomBoundedIntegral g
66 (timeMid, g2) = randomBoundedIntegral g1
67 (timeHigh, g3) = randomBoundedIntegral g2
68 (seqHigh, g4) = randomBoundedIntegral g3
69 (seqLow, g5) = randomBoundedIntegral g4
70 (node, g6) = random g5
71 seqHighReserved = (seqHigh .&. reservedMask) .|. reserved
72 timeHighVersion = (timeHigh .&. versionMask) .|. versionRandom
73 in (UUID timeLow timeMid timeHighVersion seqHighReserved seqLow node, g6)
75 randomR _ = random -- range is ignored
77versionMask :: Word16 -- 0000 1111 1111 1111
78versionMask = 0x0FFF
80versionRandom :: Word16
81versionRandom = 4 `shiftL` 12
83reservedMask :: Word8 -- 0011 1111
84reservedMask = 0x3F
86reserved :: Word8
87reserved = bit 7
89data Node = Node
90 SLOT(Word8)
91 SLOT(Word8)
92 SLOT(Word8)
93 SLOT(Word8)
94 SLOT(Word8)
95 SLOT(Word8)
96 deriving (Eq, Ord, Typeable)
98instance Random Node where
99 random g = let (w1, g1) = randomBoundedIntegral g
100 (w2, g2) = randomBoundedIntegral g1
101 (w3, g3) = randomBoundedIntegral g2
102 (w4, g4) = randomBoundedIntegral g3
103 (w5, g5) = randomBoundedIntegral g4
104 (w6, g6) = randomBoundedIntegral g5
105 in (Node w1 w2 w3 w4 w5 w6, g6)
106 randomR _ = random -- neglect range
109nodeToList :: Node -> [Word8]
110nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
112listToNode :: [Word8] -> Maybe Node
113listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
114listToNode _ = Nothing
116instance Show UUID where
117 show = toString
119instance Read UUID where
120 readsPrec _ str = case fromString (take 36 str) of
121 Nothing -> []
122 Just u -> [(u,drop 36 str)]
125instance Storable UUID where
126 sizeOf _ = 16
127 alignment _ = 4 -- not sure what to put here
129 peek p = do
130 tl <- peek $ castPtr p
131 tm <- peekByteOff p 4
132 th <- peekByteOff p 6
133 ch <- peekByteOff p 8
134 cl <- peekByteOff p 9
135 node <- peekByteOff p 10
136 return $ UUID tl tm th ch cl node
138 poke p (UUID tl tm th ch cl node) = do
139 poke (castPtr p) tl
140 pokeByteOff p 4 tm
141 pokeByteOff p 6 th
142 pokeByteOff p 8 ch
143 pokeByteOff p 9 cl
144 pokeByteOff p 10 node
146instance Storable Node where
147 sizeOf _ = 6
148 alignment _ = 1 -- ???
150 peek p = do
151 w1 <- peek $ castPtr p
152 w2 <- peekByteOff p 1
153 w3 <- peekByteOff p 2
154 w4 <- peekByteOff p 3
155 w5 <- peekByteOff p 4
156 w6 <- peekByteOff p 5
157 return $ Node w1 w2 w3 w4 w5 w6
159 poke p (Node w1 w2 w3 w4 w5 w6) = do
160 poke (castPtr p) w1
161 pokeByteOff p 1 w2
162 pokeByteOff p 2 w3
163 pokeByteOff p 3 w4
164 pokeByteOff p 4 w5
165 pokeByteOff p 5 w6
167-- Binary instance in network byte-order
168instance Binary UUID where
169 put (UUID tl tm th ch cl n) = do
170 putWord32be tl
171 putWord16be tm
172 putWord16be th
173 putWord8 ch
174 putWord8 cl
175 put n
177 get = do
178 tl <- getWord32be
179 tm <- getWord16be
180 th <- getWord16be
181 ch <- getWord8
182 cl <- getWord8
183 node <- get
184 return $ UUID tl tm th ch cl node
186instance Binary Node where
187 put (Node w1 w2 w3 w4 w5 w6) = do
188 putWord8 w1
189 putWord8 w2
190 putWord8 w3
191 putWord8 w4
192 putWord8 w5
193 putWord8 w6
195 get = do
196 w1 <- getWord8
197 w2 <- getWord8
198 w3 <- getWord8
199 w4 <- getWord8
200 w5 <- getWord8
201 w6 <- getWord8
202 return $ Node w1 w2 w3 w4 w5 w6
205-- My goal with this instance was to make it work just enough to do what
206-- I want when used with the HStringTemplate library.
207instance Data UUID where
208 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
209 gunfold _ _ = error "gunfold"
210 dataTypeOf _ = uuidType
212uuidType = mkNorepType "Data.UUID.UUID"
217-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
218-- The hyphens may not be omitted.
219-- Example:
220--
221-- @
222-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
223-- @
224--
225-- Hex digits may be upper or lower-case.
226fromString :: String -> Maybe UUID
227fromString xs | validFmt = Just uuid
228 | otherwise = Nothing
229 where validFmt = length ws == 5 &&
230 map length ws == [8,4,4,4,12] &&
231 all isHexDigit (concat ws) &&
232 isJust node
233 ws = splitList '-' xs
234 [tl, tm, th, c, n] = ws
235 ns = unfoldUntil Prelude.null (splitAt 2) n :: [String]
236 node = listToNode $ map hexVal ns :: Maybe Node
237 uuid = UUID (hexVal tl) (hexVal tm) (hexVal th) (hexVal $ take 2 c) (hexVal $ drop 2 c) (fromJust $ node)
239-- | Convert a string to a hex value, assuming the string is already validated.
240hexVal :: Num a => String -> a
241hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
243digitToInteger :: Char -> Integer
244digitToInteger = fromIntegral . digitToInt
247-- | Convert a UUID into a hypenated string using lower-case letters.
248-- Example:
249--
250-- @
251-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
252-- @
253toString :: UUID -> String
254toString (UUID tl tm th ch cl n) = printf "%08x-%04x-%04x-%02x%02x-%s" tl tm th ch cl ns
255 where ns = concatMap hexb $ nodeToList n
256 hexb x = printf "%02x" x :: String
259-- remove all occurances of the input element in the inpt list.
260-- non of the sub-lists are empty.
261splitList :: Eq a => a -> [a] -> [[a]]
262splitList c xs = let ys = dropWhile (== c) xs
263 in case span (/= c) ys of
264 ([],_) -> []
265 (sub,rest) -> sub : splitList c rest
267unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
268unfoldUntil p f n = unfoldr g n
269 where g m | p m = Nothing
270 | otherwise = Just $ f m
273-- no random intance for Data.Word types :-(
274-- this will work, though
276randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
277randomBoundedIntegral g = let (n, g1) = randomR (fromIntegral l, fromIntegral u) g
278 _ = n :: Integer
279 retVal = fromIntegral n `asTypeOf` (l `asTypeOf` u)
280 u = maxBound
281 l = minBound
282 in (retVal, g1)