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