Data/UUID/Internal.hs · typeable/uuid

git.iko.soy/typeable/uuid

on 8ee7175 help sign in

typeable/uuid/Data/UUID/Internal.hs

296 lines 9.5 kB history raw

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

3-- |

4-- Module : Data.UUID

6--

7-- License : BSD-style

8--

9-- Maintainer : aslatter@gmail.com

10-- Stability : experimental

11-- Portability : portable

13module Data.UUID.Internal

14 (UUID(..)

15 ,null

16 ,nil

17 ,fromByteString

18 ,toByteString

19 ,fromString

20 ,toString

21 ,buildFromBytes

22 ,buildFromWords

23 ) where

25import Prelude hiding (null)

26import qualified Prelude

28import Control.Monad (liftM4)

29import Data.Char

30import Data.Maybe

31import Data.Bits

32import Data.List (elemIndices)

34#if MIN_VERSION_base(4,0,0)

35import Data.Data

36#else

37import Data.Generics.Basics

38#endif

40import Foreign.Storable

42import Data.Binary

43import Data.Binary.Put

44import Data.Binary.Get

45import qualified Data.ByteString.Lazy as Lazy

47import Data.UUID.Builder

49import System.Random

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

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

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

55-- in network order as 16 bytes.

56data UUID = UUID !Word32 !Word32 !Word32 !Word32

57 deriving (Eq, Ord, Typeable)

58{-

59 Other representations that we tried are:

60 Mimic V1 structure: !Word32 !Word16 !Word16 !Word16

61 !Word8 !Word8 !Word8 !Word8 !Word8 !Word8

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

63 Simple list of bytes: [Word8]

64 ByteString (strict) ByteString

65 Immutable array: UArray Int Word8

66 Vector: UArr Word8

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

68-}

71--

72-- UTILITIES

73--

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

76word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32

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

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

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

80 .|. (fromIntegral d )

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

83byte :: Int -> Word32 -> Word8

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

87-- |Make a UUID from sixteen Word8 values

88makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8

89 -> Word8 -> Word8 -> Word8 -> Word8

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

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

92 -> UUID

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

94 = UUID w0 w1 w2 w3

95 where w0 = word b0 b1 b2 b3

96 w1 = word b4 b5 b6 b7

97 w2 = word b8 b9 ba bb

98 w3 = word bc bd be bf

100-- |Make a UUID from four Word32 values

101makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID

102makeFromWords = UUID

103

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

105buildFromBytes :: Word8

106 -> Word8 -> Word8 -> Word8 -> Word8

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

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

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

110 -> UUID

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

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

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

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

115

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

117buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID

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

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

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

121

122

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

124toList :: UUID -> [Word8]

125toList (UUID w0 w1 w2 w3) =

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

127 byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,

128 byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,

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

130

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

132-- exactly sixteen bytes long

133fromList :: [Word8] -> Maybe UUID

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

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

136fromList _ = Nothing

137

138

139--

140-- UUID API

141--

142

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

144null :: UUID -> Bool

145null = (== nil)

146 -- Note: This actually faster than:

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

148 -- null _ = False

149

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

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

152nil :: UUID

153nil = UUID 0 0 0 0

154

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

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

157fromByteString :: Lazy.ByteString -> Maybe UUID

158fromByteString = fromList . Lazy.unpack

159

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

161toByteString :: UUID -> Lazy.ByteString

162toByteString = Lazy.pack . toList

163

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

165-- The hyphens may not be omitted.

166-- Example:

167--

168-- @

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

170-- @

171--

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

173fromString :: String -> Maybe UUID

174fromString xs | validFmt = fromString' xs

175 | otherwise = Nothing

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

177

178fromString' :: String -> Maybe UUID

179fromString' s0 = do

180 (w0, s1) <- hexWord s0

181 (w1, s2) <- hexWord s1

182 (w2, s3) <- hexWord s2

183 (w3, s4) <- hexWord s3

184 if s4 /= "" then Nothing

185 else Just $ UUID w0 w1 w2 w3

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

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

188 >>= hexByte >>= hexByte

189

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

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

192 hexByte (w, hi:lo:ds)

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

194 | otherwise = Nothing

195 where bothHex = isHexDigit hi && isHexDigit lo

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

197 hexByte _ = Nothing

198

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

200-- Example:

201--

202-- @

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

204-- @

205toString :: UUID -> String

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

207 where hexw :: Word32 -> String -> String

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

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

210

211 hexw' :: Word32 -> String -> String

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

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

214

215 hexn :: Word32 -> Int -> Char

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

217

218

219--

220-- Class Instances

221--

222

223instance Random UUID where

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

225 where (w0, g0) = next g

226 (w1, g1) = next g0

227 (w2, g2) = next g1

228 (w3, g3) = next g2

229 (w4, g4) = next g3

230 randomR _ = random -- range is ignored

231

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

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

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

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

236fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID

237fromGenNext w0 w1 w2 w3 w4 =

238 buildFromBytes 4 /-/ (ThreeByte w0)

239 /-/ (ThreeByte w1)

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

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

242 /-/ (ThreeByte w3)

243 /-/ (ThreeByte w4)

244

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

246-- only returns 31 bits of randomness.

247type instance ByteSink ThreeByte g = Takes3Bytes g

248newtype ThreeByte = ThreeByte Int

249instance ByteSource ThreeByte where

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

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

252 b2 = fromIntegral (w `shiftR` 8)

253 b3 = fromIntegral w

254

255

256instance Show UUID where

257 show = toString

258

259instance Read UUID where

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

261 Nothing -> []

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

263

264

265instance Storable UUID where

266 sizeOf _ = 16

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

268

269 peekByteOff p off =

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

271

272 pokeByteOff p off u =

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

274

275

276instance Binary UUID where

277 put (UUID w0 w1 w2 w3) =

278 putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3

279 get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be

280

281

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

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

284instance Data UUID where

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

286 gunfold _ _ = error "gunfold"

287 dataTypeOf _ = uuidType

288

289uuidType :: DataType

290uuidType = mkNoRepType "Data.UUID.UUID"

291

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

293mkNoRepType :: String -> DataType

294mkNoRepType = mkNorepType

295#endif

296