git.iko.soy/typeable/uuid
on 817ec9d help sign in
typeable/uuid/Data/UUID/Internal.hs
277 lines 8.0 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
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-- |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.
49data 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)
58instance 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)
69 randomR _ = random -- range is ignored
71versionMask :: Word16 -- 0000 1111 1111 1111
72versionMask = 0x0FFF
74versionRandom :: Word16
75versionRandom = shiftL 12 4
77reservedMask :: Word8 -- 0011 1111
78reservedMask = 0x3F
80reserved :: Word8
81reserved = bit 7
83data 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)
92instance 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
103nodeToList :: Node -> [Word8]
104nodeToList (Node w1 w2 w3 w4 w5 w6) = [w1, w2, w3, w4, w5, w6]
106listToNode :: [Word8] -> Maybe Node
107listToNode [w1, w2, w3, w4, w5, w6] = return $ Node w1 w2 w3 w4 w5 w6
108listToNode _ = Nothing
110instance Show UUID where
111 show = toString
113instance Read UUID where
114 readsPrec _ str = case fromString (take 36 str) of
115 Nothing -> []
116 Just u -> [(u,drop 36 str)]
119instance Storable UUID where
120 sizeOf _ = 16
121 alignment _ = 4 -- not sure what to put here
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
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
140instance Storable Node where
141 sizeOf _ = 6
142 alignment _ = 1 -- ???
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
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
161-- Binary instance in network byte-order
162instance 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
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
180instance 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
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
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.
201instance Data UUID where
202 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
203 gunfold _ _ = error "gunfold"
204 dataTypeOf _ = uuidType
206uuidType = mkNorepType "Data.UUID.UUID"
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.
220fromString :: String -> Maybe UUID
221fromString 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)
233-- | Convert a string to a hex value, assuming the string is already validated.
234hexVal :: Num a => String -> a
235hexVal = fromInteger . foldl' (\n c -> 16*n + digitToInteger c) 0
237digitToInteger :: Char -> Integer
238digitToInteger = fromIntegral . digitToInt
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-- @
247toString :: UUID -> String
248toString (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
253-- remove all occurances of the input element in the inpt list.
254-- non of the sub-lists are empty.
255splitList :: Eq a => a -> [a] -> [[a]]
256splitList c xs = let ys = dropWhile (== c) xs
257 in case span (/= c) ys of
258 ([],_) -> []
259 (sub,rest) -> sub : splitList c rest
261unfoldUntil :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
262unfoldUntil p f n = unfoldr g n
263 where g m | p m = Nothing
264 | otherwise = Just $ f m
267-- no random intance for Data.Word types :-(
268-- this will work, though
270randomBoundedIntegral :: (RandomGen g, Bounded a, Integral a) => g -> (a, g)
271randomBoundedIntegral 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)