git.iko.soy/typeable/uuid
on 486f14d help sign in
typeable/uuid/Data/UUID/Internal.hs
316 lines 10 kB history raw
1{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-}
3-- |
4-- Module : Data.UUID
5-- Copyright : (c) 2008-2009, 2012 Antoine Latter
6-- (c) 2009 Mark Lentczner
7--
8-- License : BSD-style
9--
10-- Maintainer : aslatter@gmail.com
11-- Stability : experimental
12-- Portability : portable
14module Data.UUID.Internal
15 (UUID(..)
16 ,null
17 ,nil
18 ,fromByteString
19 ,toByteString
20 ,fromString
21 ,toString
22 ,fromWords
23 ,toWords
24 ,toList
25 ,buildFromBytes
26 ,buildFromWords
27 ) where
29import Prelude hiding (null)
31import Control.Monad (liftM4)
32import Data.Char
33import Data.Maybe
34import Data.Bits
35import Data.List (elemIndices)
37#if MIN_VERSION_base(4,0,0)
38import Data.Data
39#else
40import Data.Generics.Basics
41#endif
43import Foreign.Storable
45import Data.Binary
46import Data.Binary.Put
47import Data.Binary.Get
48import qualified Data.ByteString.Lazy as Lazy
50import Data.UUID.Builder
52import System.Random
55-- |The UUID type. A 'Random' instance is provided which produces
56-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and
57-- 'Binary' instances are compatible with RFC 4122, storing the fields
58-- in network order as 16 bytes.
59data UUID
60 = UUID
61 {-# UNPACK #-} !Word32
62 {-# UNPACK #-} !Word32
63 {-# UNPACK #-} !Word32
64 {-# UNPACK #-} !Word32
65 deriving (Eq, Ord, Typeable)
66{-
67 Other representations that we tried are:
68 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16
69 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8
70 Sixteen bytes: !Word8 ... (x 16)
71 Simple list of bytes: [Word8]
72 ByteString (strict) ByteString
73 Immutable array: UArray Int Word8
74 Vector: UArr Word8
75 None was as fast, overall, as the representation used here.
76-}
78-- | Covert a 'UUID' into a sequence of 'Word32' values.
79-- Usefull for when you need to serialize a UUID and
80-- neither 'Storable' nor 'Binary' are appropriate.
81toWords :: UUID -> (Word32, Word32, Word32, Word32)
82toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)
84-- | Create a 'UUID' from a sequence of 'Word32'. The
85-- opposite of 'toWords'.
86fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
87fromWords = UUID
89--
90-- UTILITIES
91--
93-- |Build a Word32 from four Word8 values, presented in big-endian order
94word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
95word a b c d = (fromIntegral a `shiftL` 24)
96 .|. (fromIntegral b `shiftL` 16)
97 .|. (fromIntegral c `shiftL` 8)
98 .|. (fromIntegral d )
100-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,
101byte :: Int -> Word32 -> Word8
102byte i w = fromIntegral (w `shiftR` (i * 8))
105-- |Make a UUID from sixteen Word8 values
106makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8
107 -> Word8 -> Word8 -> Word8 -> Word8
108 -> Word8 -> Word8 -> Word8 -> Word8
109 -> Word8 -> Word8 -> Word8 -> Word8
110 -> UUID
111makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
112 = UUID w0 w1 w2 w3
113 where w0 = word b0 b1 b2 b3
114 w1 = word b4 b5 b6 b7
115 w2 = word b8 b9 ba bb
116 w3 = word bc bd be bf
118-- |Make a UUID from four Word32 values
119makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
120makeFromWords = UUID
122-- |A Builder for constructing a UUID of a given version.
123buildFromBytes :: Word8
124 -> Word8 -> Word8 -> Word8 -> Word8
125 -> Word8 -> Word8 -> Word8 -> Word8
126 -> Word8 -> Word8 -> Word8 -> Word8
127 -> Word8 -> Word8 -> Word8 -> Word8
128 -> UUID
129buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
130 makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf
131 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
132 b8' = b8 .&. 0x3f .|. 0x80
134-- |Build a UUID of a given version from Word32 values.
135buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
136buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3
137 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
138 w2' = w2 .&. 0x3fffffff .|. 0x80000000
141-- |Return the bytes that make up the UUID
142toList :: UUID -> [Word8]
143toList (UUID w0 w1 w2 w3) =
144 [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,
145 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,
146 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,
147 byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]
149-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't
150-- exactly sixteen bytes long
151fromList :: [Word8] -> Maybe UUID
152fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =
153 Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
154fromList _ = Nothing
157--
158-- UUID API
159--
161-- |Returns true if the passed-in UUID is the 'nil' UUID.
162null :: UUID -> Bool
163null = (== nil)
164 -- Note: This actually faster than:
165 -- null (UUID 0 0 0 0) = True
166 -- null _ = False
168-- |The nil UUID, as defined in RFC 4122.
169-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
170nil :: UUID
171nil = UUID 0 0 0 0
173-- |Extract a UUID from a 'ByteString' in network byte order.
174-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
175fromByteString :: Lazy.ByteString -> Maybe UUID
176fromByteString = fromList . Lazy.unpack
178-- |Encode a UUID into a 'ByteString' in network order.
179toByteString :: UUID -> Lazy.ByteString
180toByteString = Lazy.pack . toList
182-- |If the passed in 'String' can be parsed as a 'UUID', it will be.
183-- The hyphens may not be omitted.
184-- Example:
185--
186-- @
187-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
188-- @
189--
190-- Hex digits may be upper or lower-case.
191fromString :: String -> Maybe UUID
192fromString xs | validFmt = fromString' xs
193 | otherwise = Nothing
194 where validFmt = elemIndices '-' xs == [8,13,18,23]
196fromString' :: String -> Maybe UUID
197fromString' s0 = do
198 (w0, s1) <- hexWord s0
199 (w1, s2) <- hexWord s1
200 (w2, s3) <- hexWord s2
201 (w3, s4) <- hexWord s3
202 if s4 /= "" then Nothing
203 else Just $ UUID w0 w1 w2 w3
204 where hexWord :: String -> Maybe (Word32, String)
205 hexWord s = Just (0, s) >>= hexByte >>= hexByte
206 >>= hexByte >>= hexByte
208 hexByte :: (Word32, String) -> Maybe (Word32, String)
209 hexByte (w, '-':ds) = hexByte (w, ds)
210 hexByte (w, hi:lo:ds)
211 | bothHex = Just ((w `shiftL` 8) .|. octet, ds)
212 | otherwise = Nothing
213 where bothHex = isHexDigit hi && isHexDigit lo
214 octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
215 hexByte _ = Nothing
217-- | Convert a UUID into a hypenated string using lower-case letters.
218-- Example:
219--
220-- @
221-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"
222-- @
223toString :: UUID -> String
224toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
225 where hexw :: Word32 -> String -> String
226 hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
227 : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
229 hexw' :: Word32 -> String -> String
230 hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
231 : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
233 hexn :: Word32 -> Int -> Char
234 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
237--
238-- Class Instances
239--
241instance Random UUID where
242 random g = (fromGenNext w0 w1 w2 w3 w4, g4)
243 where (w0, g0) = next g
244 (w1, g1) = next g0
245 (w2, g2) = next g1
246 (w3, g3) = next g2
247 (w4, g4) = next g3
248 randomR _ = random -- range is ignored
250-- |Build a UUID from the results of five calls to next on a StdGen.
251-- While next on StdGet returns an Int, it doesn't provide 32 bits of
252-- randomness. This code relies on at last 28 bits of randomness in the
253-- and optimizes its use so as to make only five random values, not six.
254fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
255fromGenNext w0 w1 w2 w3 w4 =
256 buildFromBytes 4 /-/ (ThreeByte w0)
257 /-/ (ThreeByte w1)
258 /-/ w2 -- use all 4 bytes because we know the version
259 -- field will "cover" the upper, non-random bits
260 /-/ (ThreeByte w3)
261 /-/ (ThreeByte w4)
263-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
264-- only returns 31 bits of randomness.
265type instance ByteSink ThreeByte g = Takes3Bytes g
266newtype ThreeByte = ThreeByte Int
267instance ByteSource ThreeByte where
268 f /-/ (ThreeByte w) = f b1 b2 b3
269 where b1 = fromIntegral (w `shiftR` 16)
270 b2 = fromIntegral (w `shiftR` 8)
271 b3 = fromIntegral w
274instance Show UUID where
275 show = toString
277instance Read UUID where
278 readsPrec _ str =
279 let noSpaces = dropWhile isSpace str
280 in case fromString (take 36 noSpaces) of
281 Nothing -> []
282 Just u -> [(u,drop 36 noSpaces)]
285instance Storable UUID where
286 sizeOf _ = 16
287 alignment _ = 1 -- UUIDs are stored as individual octets
289 peekByteOff p off =
290 mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList
292 pokeByteOff p off u =
293 sequence_ $ zipWith (pokeByteOff p) [off..] (toList u)
296instance Binary UUID where
297 put (UUID w0 w1 w2 w3) =
298 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3
299 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be
302-- My goal with this instance was to make it work just enough to do what
303-- I want when used with the HStringTemplate library.
304instance Data UUID where
305 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")
306 gunfold _ _ = error "gunfold"
307 dataTypeOf _ = uuidType
309uuidType :: DataType
310uuidType = mkNoRepType "Data.UUID.UUID"
312#if !(MIN_VERSION_base(4,2,0))
313mkNoRepType :: String -> DataType
314mkNoRepType = mkNorepType
315#endif