Data/UUID/Internal.hs · typeable/uuid

git.iko.soy/typeable/uuid

on 3f28637 help sign in

typeable/uuid/Data/UUID/Internal.hs

297 lines 9.5 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 ,buildFromBytes

23 ,buildFromWords

24 ) where

26import Prelude hiding (null)

27import qualified Prelude

29import Control.Monad (liftM4)

30import Data.Char

31import Data.Maybe

32import Data.Bits

33import Data.List (elemIndices)

35#if MIN_VERSION_base(4,0,0)

36import Data.Data

37#else

38import Data.Generics.Basics

39#endif

41import Foreign.Storable

43import Data.Binary

44import Data.Binary.Put

45import Data.Binary.Get

46import qualified Data.ByteString.Lazy as Lazy

48import Data.UUID.Builder

50import System.Random

53-- |The UUID type. A 'Random' instance is provided which produces

54-- version 4 UUIDs as specified in RFC 4122. The 'Storable' and

55-- 'Binary' instances are compatible with RFC 4122, storing the fields

56-- in network order as 16 bytes.

57data UUID = UUID !Word32 !Word32 !Word32 !Word32

58 deriving (Eq, Ord, Typeable)

59{-

60 Other representations that we tried are:

61 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16

62 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8

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

64 Simple list of bytes: [Word8]

65 ByteString (strict) ByteString

66 Immutable array: UArray Int Word8

67 Vector: UArr Word8

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

69-}

72--

73-- UTILITIES

74--

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

77word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32

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

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

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

81 .|. (fromIntegral d )

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

84byte :: Int -> Word32 -> Word8

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

88-- |Make a UUID from sixteen Word8 values

89makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8

90 -> Word8 -> Word8 -> Word8 -> Word8

91 -> Word8 -> Word8 -> Word8 -> Word8

92 -> Word8 -> Word8 -> Word8 -> Word8

93 -> UUID

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

95 = UUID w0 w1 w2 w3

96 where w0 = word b0 b1 b2 b3

97 w1 = word b4 b5 b6 b7

98 w2 = word b8 b9 ba bb

99 w3 = word bc bd be bf

100

101-- |Make a UUID from four Word32 values

102makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID

103makeFromWords = UUID

104

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

106buildFromBytes :: Word8

107 -> Word8 -> Word8 -> Word8 -> Word8

108 -> Word8 -> Word8 -> Word8 -> Word8

109 -> Word8 -> Word8 -> Word8 -> Word8

110 -> Word8 -> Word8 -> Word8 -> Word8

111 -> UUID

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

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

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

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

116

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

118buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID

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

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

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

122

123

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

125toList :: UUID -> [Word8]

126toList (UUID w0 w1 w2 w3) =

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

128 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,

129 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,

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

131

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

133-- exactly sixteen bytes long

134fromList :: [Word8] -> Maybe UUID

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

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

137fromList _ = Nothing

138

139

140--

141-- UUID API

142--

143

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

145null :: UUID -> Bool

146null = (== nil)

147 -- Note: This actually faster than:

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

149 -- null _ = False

150

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

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

153nil :: UUID

154nil = UUID 0 0 0 0

155

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

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

158fromByteString :: Lazy.ByteString -> Maybe UUID

159fromByteString = fromList . Lazy.unpack

160

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

162toByteString :: UUID -> Lazy.ByteString

163toByteString = Lazy.pack . toList

164

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

166-- The hyphens may not be omitted.

167-- Example:

168--

169-- @

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

171-- @

172--

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

174fromString :: String -> Maybe UUID

175fromString xs | validFmt = fromString' xs

176 | otherwise = Nothing

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

178

179fromString' :: String -> Maybe UUID

180fromString' s0 = do

181 (w0, s1) <- hexWord s0

182 (w1, s2) <- hexWord s1

183 (w2, s3) <- hexWord s2

184 (w3, s4) <- hexWord s3

185 if s4 /= "" then Nothing

186 else Just $ UUID w0 w1 w2 w3

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

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

189 >>= hexByte >>= hexByte

190

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

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

193 hexByte (w, hi:lo:ds)

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

195 | otherwise = Nothing

196 where bothHex = isHexDigit hi && isHexDigit lo

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

198 hexByte _ = Nothing

199

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

201-- Example:

202--

203-- @

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

205-- @

206toString :: UUID -> String

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

208 where hexw :: Word32 -> String -> String

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

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

211

212 hexw' :: Word32 -> String -> String

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

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

215

216 hexn :: Word32 -> Int -> Char

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

218

219

220--

221-- Class Instances

222--

223

224instance Random UUID where

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

226 where (w0, g0) = next g

227 (w1, g1) = next g0

228 (w2, g2) = next g1

229 (w3, g3) = next g2

230 (w4, g4) = next g3

231 randomR _ = random -- range is ignored

232

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

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

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

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

237fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID

238fromGenNext w0 w1 w2 w3 w4 =

239 buildFromBytes 4 /-/ (ThreeByte w0)

240 /-/ (ThreeByte w1)

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

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

243 /-/ (ThreeByte w3)

244 /-/ (ThreeByte w4)

245

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

247-- only returns 31 bits of randomness.

248type instance ByteSink ThreeByte g = Takes3Bytes g

249newtype ThreeByte = ThreeByte Int

250instance ByteSource ThreeByte where

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

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

253 b2 = fromIntegral (w `shiftR` 8)

254 b3 = fromIntegral w

255

256

257instance Show UUID where

258 show = toString

259

260instance Read UUID where

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

262 Nothing -> []

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

264

265

266instance Storable UUID where

267 sizeOf _ = 16

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

269

270 peekByteOff p off =

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

272

273 pokeByteOff p off u =

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

275

276

277instance Binary UUID where

278 put (UUID w0 w1 w2 w3) =

279 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3

280 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be

281

282

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

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

285instance Data UUID where

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

287 gunfold _ _ = error "gunfold"

288 dataTypeOf _ = uuidType

289

290uuidType :: DataType

291uuidType = mkNoRepType "Data.UUID.UUID"

292

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

294mkNoRepType :: String -> DataType

295mkNoRepType = mkNorepType

296#endif

297