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