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