Data/UUID/Internal.hs · typeable/uuid

git.iko.soy/typeable/uuid

on b68d95c help sign in

typeable/uuid/Data/UUID/Internal.hs

310 lines 10 kB history raw

1{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-}

3-- |

4-- Module : Data.UUID

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 = UUID !Word32 !Word32 !Word32 !Word32

59 deriving (Eq, Ord, Typeable)

60{-

61 Other representations that we tried are:

62 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16

63 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8

64 Sixteen bytes: !Word8 ... (x 16)

65 Simple list of bytes: [Word8]

66 ByteString (strict) ByteString

67 Immutable array: UArray Int Word8

68 Vector: UArr Word8

69 None was as fast, overall, as the representation used here.

70-}

72-- | Covert a 'UUID' into a sequence of 'Word32' values.

73-- Usefull for when you need to serialize a UUID and

74-- neither 'Storable' nor 'Binary' are appropriate.

75toWords :: UUID -> (Word32, Word32, Word32, Word32)

76toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)

78-- | Create a 'UUID' from a sequence of 'Word32'. The

79-- opposite of 'toWords'.

80fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID

81fromWords = UUID

83--

84-- UTILITIES

85--

87-- |Build a Word32 from four Word8 values, presented in big-endian order

88word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32

89word a b c d = (fromIntegral a `shiftL` 24)

90 .|. (fromIntegral b `shiftL` 16)

91 .|. (fromIntegral c `shiftL` 8)

92 .|. (fromIntegral d )

94-- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,

95byte :: Int -> Word32 -> Word8

96byte i w = fromIntegral (w `shiftR` (i * 8))

99-- |Make a UUID from sixteen Word8 values

100makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8

101 -> Word8 -> Word8 -> Word8 -> Word8

102 -> Word8 -> Word8 -> Word8 -> Word8

103 -> Word8 -> Word8 -> Word8 -> Word8

104 -> UUID

105makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf

106 = UUID w0 w1 w2 w3

107 where w0 = word b0 b1 b2 b3

108 w1 = word b4 b5 b6 b7

109 w2 = word b8 b9 ba bb

110 w3 = word bc bd be bf

111

112-- |Make a UUID from four Word32 values

113makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID

114makeFromWords = UUID

115

116-- |A Builder for constructing a UUID of a given version.

117buildFromBytes :: Word8

118 -> Word8 -> Word8 -> Word8 -> Word8

119 -> Word8 -> Word8 -> Word8 -> Word8

120 -> Word8 -> Word8 -> Word8 -> Word8

121 -> Word8 -> Word8 -> Word8 -> Word8

122 -> UUID

123buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =

124 makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf

125 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)

126 b8' = b8 .&. 0x3f .|. 0x80

127

128-- |Build a UUID of a given version from Word32 values.

129buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID

130buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3

131 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)

132 w2' = w2 .&. 0x3fffffff .|. 0x80000000

133

134

135-- |Return the bytes that make up the UUID

136toList :: UUID -> [Word8]

137toList (UUID w0 w1 w2 w3) =

138 [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,

139 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,

140 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,

141 byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]

142

143-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't

144-- exactly sixteen bytes long

145fromList :: [Word8] -> Maybe UUID

146fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =

147 Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf

148fromList _ = Nothing

149

150

151--

152-- UUID API

153--

154

155-- |Returns true if the passed-in UUID is the 'nil' UUID.

156null :: UUID -> Bool

157null = (== nil)

158 -- Note: This actually faster than:

159 -- null (UUID 0 0 0 0) = True

160 -- null _ = False

161

162-- |The nil UUID, as defined in RFC 4122.

163-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.

164nil :: UUID

165nil = UUID 0 0 0 0

166

167-- |Extract a UUID from a 'ByteString' in network byte order.

168-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.

169fromByteString :: Lazy.ByteString -> Maybe UUID

170fromByteString = fromList . Lazy.unpack

171

172-- |Encode a UUID into a 'ByteString' in network order.

173toByteString :: UUID -> Lazy.ByteString

174toByteString = Lazy.pack . toList

175

176-- |If the passed in 'String' can be parsed as a 'UUID', it will be.

177-- The hyphens may not be omitted.

178-- Example:

179--

180-- @

181-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"

182-- @

183--

184-- Hex digits may be upper or lower-case.

185fromString :: String -> Maybe UUID

186fromString xs | validFmt = fromString' xs

187 | otherwise = Nothing

188 where validFmt = elemIndices '-' xs == [8,13,18,23]

189

190fromString' :: String -> Maybe UUID

191fromString' s0 = do

192 (w0, s1) <- hexWord s0

193 (w1, s2) <- hexWord s1

194 (w2, s3) <- hexWord s2

195 (w3, s4) <- hexWord s3

196 if s4 /= "" then Nothing

197 else Just $ UUID w0 w1 w2 w3

198 where hexWord :: String -> Maybe (Word32, String)

199 hexWord s = Just (0, s) >>= hexByte >>= hexByte

200 >>= hexByte >>= hexByte

201

202 hexByte :: (Word32, String) -> Maybe (Word32, String)

203 hexByte (w, '-':ds) = hexByte (w, ds)

204 hexByte (w, hi:lo:ds)

205 | bothHex = Just ((w `shiftL` 8) .|. octet, ds)

206 | otherwise = Nothing

207 where bothHex = isHexDigit hi && isHexDigit lo

208 octet = fromIntegral (16 * digitToInt hi + digitToInt lo)

209 hexByte _ = Nothing

210

211-- | Convert a UUID into a hypenated string using lower-case letters.

212-- Example:

213--

214-- @

215-- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\"

216-- @

217toString :: UUID -> String

218toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""

219 where hexw :: Word32 -> String -> String

220 hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16

221 : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s

222

223 hexw' :: Word32 -> String -> String

224 hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16

225 : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s

226

227 hexn :: Word32 -> Int -> Char

228 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)

229

230

231--

232-- Class Instances

233--

234

235instance Random UUID where

236 random g = (fromGenNext w0 w1 w2 w3 w4, g4)

237 where (w0, g0) = next g

238 (w1, g1) = next g0

239 (w2, g2) = next g1

240 (w3, g3) = next g2

241 (w4, g4) = next g3

242 randomR _ = random -- range is ignored

243

244-- |Build a UUID from the results of five calls to next on a StdGen.

245-- While next on StdGet returns an Int, it doesn't provide 32 bits of

246-- randomness. This code relies on at last 28 bits of randomness in the

247-- and optimizes its use so as to make only five random values, not six.

248fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID

249fromGenNext w0 w1 w2 w3 w4 =

250 buildFromBytes 4 /-/ (ThreeByte w0)

251 /-/ (ThreeByte w1)

252 /-/ w2 -- use all 4 bytes because we know the version

253 -- field will "cover" the upper, non-random bits

254 /-/ (ThreeByte w3)

255 /-/ (ThreeByte w4)

256

257-- |A ByteSource to extract only three bytes from an Int, since next on StdGet

258-- only returns 31 bits of randomness.

259type instance ByteSink ThreeByte g = Takes3Bytes g

260newtype ThreeByte = ThreeByte Int

261instance ByteSource ThreeByte where

262 f /-/ (ThreeByte w) = f b1 b2 b3

263 where b1 = fromIntegral (w `shiftR` 16)

264 b2 = fromIntegral (w `shiftR` 8)

265 b3 = fromIntegral w

266

267

268instance Show UUID where

269 show = toString

270

271instance Read UUID where

272 readsPrec _ str =

273 let noSpaces = dropWhile isSpace str

274 in case fromString (take 36 noSpaces) of

275 Nothing -> []

276 Just u -> [(u,drop 36 noSpaces)]

277

278

279instance Storable UUID where

280 sizeOf _ = 16

281 alignment _ = 1 -- UUIDs are stored as individual octets

282

283 peekByteOff p off =

284 mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList

285

286 pokeByteOff p off u =

287 sequence_ $ zipWith (pokeByteOff p) [off..] (toList u)

288

289

290instance Binary UUID where

291 put (UUID w0 w1 w2 w3) =

292 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3

293 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be

294

295

296-- My goal with this instance was to make it work just enough to do what

297-- I want when used with the HStringTemplate library.

298instance Data UUID where

299 toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")

300 gunfold _ _ = error "gunfold"

301 dataTypeOf _ = uuidType

302

303uuidType :: DataType

304uuidType = mkNoRepType "Data.UUID.UUID"

305

306#if !(MIN_VERSION_base(4,2,0))

307mkNoRepType :: String -> DataType

308mkNoRepType = mkNorepType

309#endif

310