Data/UUID/Internal.hs · typeable/uuid

git.iko.soy/typeable/uuid

on 8917b68 help sign in

typeable/uuid/Data/UUID/Internal.hs

309 lines 10.0 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)

29import qualified Prelude

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

60 deriving (Eq, Ord, Typeable)

61{-

62 Other representations that we tried are:

63 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16

64 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8

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

66 Simple list of bytes: [Word8]

67 ByteString (strict) ByteString

68 Immutable array: UArray Int Word8

69 Vector: UArr Word8

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

71-}

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

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

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

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

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

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

80-- opposite of 'toWords'.

81fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID

82fromWords = UUID

84--

85-- UTILITIES

86--

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

89word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32

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

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

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

93 .|. (fromIntegral d )

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

96byte :: Int -> Word32 -> Word8

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

100-- |Make a UUID from sixteen Word8 values

101makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8

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

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

104 -> Word8 -> Word8 -> Word8 -> Word8

105 -> UUID

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

107 = UUID w0 w1 w2 w3

108 where w0 = word b0 b1 b2 b3

109 w1 = word b4 b5 b6 b7

110 w2 = word b8 b9 ba bb

111 w3 = word bc bd be bf

112

113-- |Make a UUID from four Word32 values

114makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID

115makeFromWords = UUID

116

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

118buildFromBytes :: Word8

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

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

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

122 -> Word8 -> Word8 -> Word8 -> Word8

123 -> UUID

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

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

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

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

128

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

130buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID

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

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

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

134

135

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

137toList :: UUID -> [Word8]

138toList (UUID w0 w1 w2 w3) =

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

140 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,

141 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,

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

143

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

145-- exactly sixteen bytes long

146fromList :: [Word8] -> Maybe UUID

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

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

149fromList _ = Nothing

150

151

152--

153-- UUID API

154--

155

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

157null :: UUID -> Bool

158null = (== nil)

159 -- Note: This actually faster than:

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

161 -- null _ = False

162

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

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

165nil :: UUID

166nil = UUID 0 0 0 0

167

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

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

170fromByteString :: Lazy.ByteString -> Maybe UUID

171fromByteString = fromList . Lazy.unpack

172

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

174toByteString :: UUID -> Lazy.ByteString

175toByteString = Lazy.pack . toList

176

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

178-- The hyphens may not be omitted.

179-- Example:

180--

181-- @

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

183-- @

184--

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

186fromString :: String -> Maybe UUID

187fromString xs | validFmt = fromString' xs

188 | otherwise = Nothing

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

190

191fromString' :: String -> Maybe UUID

192fromString' s0 = do

193 (w0, s1) <- hexWord s0

194 (w1, s2) <- hexWord s1

195 (w2, s3) <- hexWord s2

196 (w3, s4) <- hexWord s3

197 if s4 /= "" then Nothing

198 else Just $ UUID w0 w1 w2 w3

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

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

201 >>= hexByte >>= hexByte

202

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

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

205 hexByte (w, hi:lo:ds)

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

207 | otherwise = Nothing

208 where bothHex = isHexDigit hi && isHexDigit lo

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

210 hexByte _ = Nothing

211

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

213-- Example:

214--

215-- @

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

217-- @

218toString :: UUID -> String

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

220 where hexw :: Word32 -> String -> String

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

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

223

224 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

227

228 hexn :: Word32 -> Int -> Char

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

230

231

232--

233-- Class Instances

234--

235

236instance Random UUID where

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

238 where (w0, g0) = next g

239 (w1, g1) = next g0

240 (w2, g2) = next g1

241 (w3, g3) = next g2

242 (w4, g4) = next g3

243 randomR _ = random -- range is ignored

244

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

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

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

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

249fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID

250fromGenNext w0 w1 w2 w3 w4 =

251 buildFromBytes 4 /-/ (ThreeByte w0)

252 /-/ (ThreeByte w1)

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

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

255 /-/ (ThreeByte w3)

256 /-/ (ThreeByte w4)

257

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

259-- only returns 31 bits of randomness.

260type instance ByteSink ThreeByte g = Takes3Bytes g

261newtype ThreeByte = ThreeByte Int

262instance ByteSource ThreeByte where

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

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

265 b2 = fromIntegral (w `shiftR` 8)

266 b3 = fromIntegral w

267

268

269instance Show UUID where

270 show = toString

271

272instance Read UUID where

273 readsPrec _ str = case fromString (take 36 str) of

274 Nothing -> []

275 Just u -> [(u,drop 36 str)]

276

277

278instance Storable UUID where

279 sizeOf _ = 16

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

281

282 peekByteOff p off =

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

284

285 pokeByteOff p off u =

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

287

288

289instance Binary UUID where

290 put (UUID w0 w1 w2 w3) =

291 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3

292 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be

293

294

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

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

297instance Data UUID where

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

299 gunfold _ _ = error "gunfold"

300 dataTypeOf _ = uuidType

301

302uuidType :: DataType

303uuidType = mkNoRepType "Data.UUID.UUID"

304

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

306mkNoRepType :: String -> DataType

307mkNoRepType = mkNorepType

308#endif

309