uuid-types 1.0.3 → 1.0.4
raw patch · 11 files changed
+924/−890 lines, 11 filesdep +ghc-byteorderdep −HUnitdep −containersdep −criteriondep ~QuickCheckdep ~basedep ~binarynew-uploader
Dependencies added: ghc-byteorder
Dependencies removed: HUnit, containers, criterion
Dependency ranges changed: QuickCheck, base, binary, bytestring, deepseq, hashable, random, tasty, tasty-hunit, tasty-quickcheck, text
Files
- CHANGES +0/−15
- ChangeLog.md +23/−0
- Data/UUID/Types.hs +0/−39
- Data/UUID/Types/Internal.hs +0/−550
- Data/UUID/Types/Internal/Builder.hs +0/−89
- src/Data/UUID/Types.hs +51/−0
- src/Data/UUID/Types/Internal.hs +621/−0
- src/Data/UUID/Types/Internal/Builder.hs +107/−0
- tests/BenchUUID.hs +0/−117
- tests/TestUUID.hs +42/−15
- uuid-types.cabal +80/−65
− CHANGES
@@ -1,15 +0,0 @@-1.0.3--- Bump package dependencies--1.0.2--- Add toText/fromText--1.0.1--- Update dependencies in tests and benchmarks.--1.0.0--- Initial split from "uuid-1.3.8"
+ ChangeLog.md view
@@ -0,0 +1,23 @@+## 1.0.4.0++- Declare `Data.UUID.Types` module "`Trustworthy`" with respect to SafeHaskell.+- Use more compact heap object representation which saves 16 bytes on 64bit platforms.+- Add `toWords64`/`fromWords64` functions+- Drop support for GHC < 7.+- Add support for `random-1.2`, i.e. idiomatic `Random` and added `Uniform` instances.++## 1.0.3++- Bump package dependencies.++## 1.0.2++- Add `toText`/`fromText` functions.++## 1.0.1++- Update dependencies in tests and benchmarks.++## 1.0.0++- Initial split from "`uuid-1.3.8`" package.
− Data/UUID/Types.hs
@@ -1,39 +0,0 @@-{- |-Module : Data.UUID.Types-Copyright : (c) 2008,2012 Antoine Latter--License : BSD-style--Maintainer : aslatter@gmail.com-Stability : experimental-Portability : portable---This library is useful for comparing, parsing and-printing Universally Unique Identifiers.-See <http://en.wikipedia.org/wiki/UUID> for the general idea.-See <http://tools.ietf.org/html/rfc4122> for the specification.---}-module Data.UUID.Types(UUID- ,toString- ,fromString- ,toText- ,fromText- ,toASCIIBytes- ,fromASCIIBytes- ,toLazyASCIIBytes- ,fromLazyASCIIBytes- ,toByteString- ,fromByteString- ,toWords- ,fromWords- ,null- ,nil- ) where--import Prelude () -- we need to hide Prelude.null-import Data.UUID.Types.Internal---- Everything is really implemented in Data.UUID.Types.Internal, but I--- don't want to export the constructors out of the package.
− Data/UUID/Types/Internal.hs
@@ -1,550 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, TypeFamilies, CPP #-}-{-# OPTIONS_HADDOCK hide #-}---- |--- Module : Data.UUID.Types.Internal--- Copyright : (c) 2008-2009, 2012 Antoine Latter--- (c) 2009 Mark Lentczner------ License : BSD-style------ Maintainer : aslatter@gmail.com--- Stability : experimental--- Portability : portable--module Data.UUID.Types.Internal- (UUID(..)- ,null- ,nil- ,fromByteString- ,toByteString- ,fromString- ,toString- ,fromText- ,toText- ,fromWords- ,toWords- ,toList- ,buildFromBytes- ,buildFromWords- ,fromASCIIBytes- ,toASCIIBytes- ,fromLazyASCIIBytes- ,toLazyASCIIBytes- ,UnpackedUUID(..)- ,pack- ,unpack- ) where--import Prelude hiding (null)--import Control.Applicative ((<*>))-import Control.DeepSeq (NFData(..))-import Control.Monad (liftM4, guard)-import Data.Functor ((<$>))-import Data.Char-import Data.Bits-import Data.Hashable-import Data.List (elemIndices)-import Foreign.Ptr (Ptr)--#if MIN_VERSION_base(4,0,0)-import Data.Data-#else-import Data.Generics.Basics-#endif--import Foreign.Storable--import Data.Binary-import Data.Binary.Put-import Data.Binary.Get-import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Unsafe as BU-import Data.Text (Text)-import qualified Data.Text as T--import Data.UUID.Types.Internal.Builder--import System.Random----- |The UUID type. A 'Random' instance is provided which produces--- version 4 UUIDs as specified in RFC 4122. The 'Storable' and--- 'Binary' instances are compatible with RFC 4122, storing the fields--- in network order as 16 bytes.-data UUID- = UUID- {-# UNPACK #-} !Word32- {-# UNPACK #-} !Word32- {-# UNPACK #-} !Word32- {-# UNPACK #-} !Word32- deriving (Eq, Ord, Typeable)-{-- Other representations that we tried are:- Mimic V1 structure: !Word32 !Word16 !Word16 !Word16- !Word8 !Word8 !Word8 !Word8 !Word8 !Word8- Sixteen bytes: !Word8 ... (x 16)- Simple list of bytes: [Word8]- ByteString (strict) ByteString- Immutable array: UArray Int Word8- Vector: UArr Word8- None was as fast, overall, as the representation used here.--}---- | Covert a 'UUID' into a sequence of 'Word32' values.--- Useful for when you need to serialize a UUID and--- neither 'Storable' nor 'Binary' are appropriate.--- Introduced in version 1.2.2.-toWords :: UUID -> (Word32, Word32, Word32, Word32)-toWords (UUID w1 w2 w3 w4) = (w1, w2, w3, w4)---- | Create a 'UUID' from a sequence of 'Word32'. The--- opposite of 'toWords'. Useful when you need a total--- function for constructing 'UUID' values.--- Introduced in version 1.2.2.-fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID-fromWords = UUID--data UnpackedUUID =- UnpackedUUID {- time_low :: Word32 -- 0-3- , time_mid :: Word16 -- 4-5- , time_hi_and_version :: Word16 -- 6-7- , clock_seq_hi_res :: Word8 -- 8- , clock_seq_low :: Word8 -- 9- , node_0 :: Word8- , node_1 :: Word8- , node_2 :: Word8- , node_3 :: Word8- , node_4 :: Word8- , node_5 :: Word8- }- deriving (Read, Show, Eq, Ord)--unpack :: UUID -> UnpackedUUID-unpack (UUID w0 w1 w2 w3) =- build /-/ w0 /-/ w1 /-/ w2 /-/ w3-- where- build x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF =- UnpackedUUID {- time_low = word x0 x1 x2 x3- , time_mid = w8to16 x4 x5- , time_hi_and_version = w8to16 x6 x7- , clock_seq_hi_res = x8- , clock_seq_low = x9- , node_0 = xA- , node_1 = xB- , node_2 = xC- , node_3 = xD- , node_4 = xE- , node_5 = xF- }--pack :: UnpackedUUID -> UUID-pack unpacked =- makeFromBytes /-/ (time_low unpacked)- /-/ (time_mid unpacked)- /-/ (time_hi_and_version unpacked)- /-/ (clock_seq_hi_res unpacked)- /-/ (clock_seq_low unpacked)- /-/ (node_0 unpacked) /-/ (node_1 unpacked)- /-/ (node_2 unpacked) /-/ (node_3 unpacked)- /-/ (node_4 unpacked) /-/ (node_5 unpacked)-------- UTILITIES------- |Build a Word32 from four Word8 values, presented in big-endian order-word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32-word a b c d = (fromIntegral a `shiftL` 24)- .|. (fromIntegral b `shiftL` 16)- .|. (fromIntegral c `shiftL` 8)- .|. (fromIntegral d )---- |Extract a Word8 from a Word32. Bytes, high to low, are numbered from 3 to 0,-byte :: Int -> Word32 -> Word8-byte i w = fromIntegral (w `shiftR` (i * 8))---- |Build a Word16 from two Word8 values, presented in big-endian order.-w8to16 :: Word8 -> Word8 -> Word16-w8to16 w0s w1s =- (w0 `shiftL` 8) .|. w1- where- w0 = fromIntegral w0s- w1 = fromIntegral w1s----- |Make a UUID from sixteen Word8 values-makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> UUID-makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf- = UUID w0 w1 w2 w3- where w0 = word b0 b1 b2 b3- w1 = word b4 b5 b6 b7- w2 = word b8 b9 ba bb- w3 = word bc bd be bf---- |Make a UUID from four Word32 values-makeFromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID-makeFromWords = UUID---- |A Builder for constructing a UUID of a given version.-buildFromBytes :: Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8- -> UUID-buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =- makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf- where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)- b8' = b8 .&. 0x3f .|. 0x80---- |Build a UUID of a given version from Word32 values.-buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID-buildFromWords v w0 w1 w2 w3 = makeFromWords w0 w1' w2' w3- where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)- w2' = w2 .&. 0x3fffffff .|. 0x80000000----- |Return the bytes that make up the UUID-toList :: UUID -> [Word8]-toList (UUID w0 w1 w2 w3) =- [byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,- byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1,- byte 3 w2, byte 2 w2, byte 1 w2, byte 0 w2,- byte 3 w3, byte 2 w3, byte 1 w3, byte 0 w3]---- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't--- exactly sixteen bytes long-fromList :: [Word8] -> Maybe UUID-fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =- Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf-fromList _ = Nothing-------- UUID API------- |Returns true if the passed-in UUID is the 'nil' UUID.-null :: UUID -> Bool-null = (== nil)- -- Note: This actually faster than:- -- null (UUID 0 0 0 0) = True- -- null _ = False---- |The nil UUID, as defined in RFC 4122.--- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.-nil :: UUID-nil = UUID 0 0 0 0---- |Extract a UUID from a 'ByteString' in network byte order.--- The argument must be 16 bytes long, otherwise 'Nothing' is returned.-fromByteString :: BL.ByteString -> Maybe UUID-fromByteString = fromList . BL.unpack---- |Encode a UUID into a 'ByteString' in network order.-toByteString :: UUID -> BL.ByteString-toByteString = BL.pack . toList---- |If the passed in 'String' can be parsed as a 'UUID', it will be.--- The hyphens may not be omitted.--- Example:------ @--- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"--- @------ Hex digits may be upper or lower-case.-fromString :: String -> Maybe UUID-fromString xs | validFmt = fromString' xs- | otherwise = Nothing- where validFmt = elemIndices '-' xs == [8,13,18,23]--fromString' :: String -> Maybe UUID-fromString' s0 = do- (w0, s1) <- hexWord s0- (w1, s2) <- hexWord s1- (w2, s3) <- hexWord s2- (w3, s4) <- hexWord s3- if s4 /= "" then Nothing- else Just $ UUID w0 w1 w2 w3- where hexWord :: String -> Maybe (Word32, String)- hexWord s = Just (0, s) >>= hexByte >>= hexByte- >>= hexByte >>= hexByte-- hexByte :: (Word32, String) -> Maybe (Word32, String)- hexByte (w, '-':ds) = hexByte (w, ds)- hexByte (w, hi:lo:ds)- | bothHex = Just ((w `shiftL` 8) .|. octet, ds)- | otherwise = Nothing- where bothHex = isHexDigit hi && isHexDigit lo- octet = fromIntegral (16 * digitToInt hi + digitToInt lo)- hexByte _ = Nothing---- | Convert a UUID into a hypenated string using lower-case letters.--- Example:------ @--- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"--- @-toString :: UUID -> String-toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""- where hexw :: Word32 -> String -> String- hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16- : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s-- hexw' :: Word32 -> String -> String- hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16- : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s-- hexn :: Word32 -> Int -> Char- hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)---- | If the passed in `Text` can be parsed as an ASCII representation of--- a `UUID`, it will be. The hyphens may not be omitted.-fromText :: Text -> Maybe UUID-fromText = fromString . T.unpack---- | Convert a UUID into a hyphentated string using lower-case letters.-toText :: UUID -> Text-toText = T.pack . toString---- | Convert a UUID into a hyphentated string using lower-case letters, packed--- as ASCII bytes into `B.ByteString`.------ This should be equivalent to `toString` with `Data.ByteString.Char8.pack`.-toASCIIBytes :: UUID -> B.ByteString-toASCIIBytes uuid = BI.unsafeCreate 36 (pokeASCII uuid)---- | Helper function for `toASCIIBytes`-pokeASCII :: UUID -> Ptr Word8 -> IO ()-pokeASCII uuid ptr = do- pokeDash 8- pokeDash 13- pokeDash 18- pokeDash 23- pokeSingle 0 w0- pokeDouble 9 w1- pokeDouble 19 w2- pokeSingle 28 w3- where- (w0, w1, w2, w3) = toWords uuid-- -- ord '-' ==> 45- pokeDash ix = pokeElemOff ptr ix 45-- pokeSingle ix w = do- pokeWord ix w 28- pokeWord (ix + 1) w 24- pokeWord (ix + 2) w 20- pokeWord (ix + 3) w 16- pokeWord (ix + 4) w 12- pokeWord (ix + 5) w 8- pokeWord (ix + 6) w 4- pokeWord (ix + 7) w 0-- -- We skip the dash in the middle- pokeDouble ix w = do- pokeWord ix w 28- pokeWord (ix + 1) w 24- pokeWord (ix + 2) w 20- pokeWord (ix + 3) w 16- pokeWord (ix + 5) w 12- pokeWord (ix + 6) w 8- pokeWord (ix + 7) w 4- pokeWord (ix + 8) w 0-- pokeWord ix w r =- pokeElemOff ptr ix (fromIntegral (toDigit ((w `shiftR` r) .&. 0xf)))-- toDigit :: Word32 -> Word32- toDigit w = if w < 10 then 48 + w else 97 + w - 10---- | If the passed in `B.ByteString` can be parsed as an ASCII representation of--- a `UUID`, it will be. The hyphens may not be omitted.------ This should be equivalent to `fromString` with `Data.ByteString.Char8.unpack`.-fromASCIIBytes :: B.ByteString -> Maybe UUID-fromASCIIBytes bs = do- guard wellFormed- fromWords <$> single 0 <*> double 9 14 <*> double 19 24 <*> single 28- where- -- ord '-' ==> 45- dashIx bs' ix = BU.unsafeIndex bs' ix == 45-- -- Important: check the length first, given the `unsafeIndex` later.- wellFormed =- B.length bs == 36 && dashIx bs 8 && dashIx bs 13 &&- dashIx bs 18 && dashIx bs 23-- single ix = combine <$> octet ix <*> octet (ix + 2)- <*> octet (ix + 4) <*> octet (ix + 6)- double ix0 ix1 = combine <$> octet ix0 <*> octet (ix0 + 2)- <*> octet ix1 <*> octet (ix1 + 2)-- combine o0 o1 o2 o3 = shiftL o0 24 .|. shiftL o1 16 .|. shiftL o2 8 .|. o3-- octet ix = do- hi <- fromIntegral <$> toDigit (BU.unsafeIndex bs ix)- lo <- fromIntegral <$> toDigit (BU.unsafeIndex bs (ix + 1))- return (16 * hi + lo)-- toDigit :: Word8 -> Maybe Word8- toDigit w- -- Digit- | w >= 48 && w <= 57 = Just (w - 48)- -- Uppercase- | w >= 65 && w <= 70 = Just (10 + w - 65)- -- Lowercase- | w >= 97 && w <= 102 = Just (10 + w - 97)- | otherwise = Nothing---- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.-toLazyASCIIBytes :: UUID -> BL.ByteString-toLazyASCIIBytes =-#if MIN_VERSION_bytestring(0,10,0)- BL.fromStrict-#else- BL.fromChunks . return-#endif- . toASCIIBytes---- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.-fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID-fromLazyASCIIBytes bs =- if BL.length bs == 36 then fromASCIIBytes (-#if MIN_VERSION_bytestring(0,10,0)- BL.toStrict bs-#else- B.concat $ BL.toChunks bs-#endif- ) else Nothing------- Class Instances-----instance Random UUID where- random g = (fromGenNext w0 w1 w2 w3 w4, g4)- where (w0, g0) = next g- (w1, g1) = next g0- (w2, g2) = next g1- (w3, g3) = next g2- (w4, g4) = next g3- randomR _ = random -- range is ignored---- |Build a UUID from the results of five calls to next on a StdGen.--- While next on StdGet returns an Int, it doesn't provide 32 bits of--- randomness. This code relies on at last 28 bits of randomness in the--- and optimizes its use so as to make only five random values, not six.-fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID-fromGenNext w0 w1 w2 w3 w4 =- buildFromBytes 4 /-/ (ThreeByte w0)- /-/ (ThreeByte w1)- /-/ w2 -- use all 4 bytes because we know the version- -- field will "cover" the upper, non-random bits- /-/ (ThreeByte w3)- /-/ (ThreeByte w4)---- |A ByteSource to extract only three bytes from an Int, since next on StdGet--- only returns 31 bits of randomness.-type instance ByteSink ThreeByte g = Takes3Bytes g-newtype ThreeByte = ThreeByte Int-instance ByteSource ThreeByte where- f /-/ (ThreeByte w) = f b1 b2 b3- where b1 = fromIntegral (w `shiftR` 16)- b2 = fromIntegral (w `shiftR` 8)- b3 = fromIntegral w--instance NFData UUID where- rnf = rnf . toWords--instance Hashable UUID where- hash (UUID w0 w1 w2 w3) =- hash w0 `hashWithSalt` w1- `hashWithSalt` w2- `hashWithSalt` w3- hashWithSalt s (UUID w0 w1 w2 w3) =- s `hashWithSalt` w0- `hashWithSalt` w1- `hashWithSalt` w2- `hashWithSalt` w3--instance Show UUID where- show = toString--instance Read UUID where- readsPrec _ str =- let noSpaces = dropWhile isSpace str- in case fromString (take 36 noSpaces) of- Nothing -> []- Just u -> [(u,drop 36 noSpaces)]---instance Storable UUID where- sizeOf _ = 16- alignment _ = 4-- peekByteOff p off =- pack <$>- (UnpackedUUID- <$> peekByteOff p off -- Word32- <*> peekByteOff p (off+4) -- Word16- <*> peekByteOff p (off+6) -- Word16- <*> peekByteOff p (off+8) -- Word8- <*> peekByteOff p (off+9) -- Word8- <*> peekByteOff p (off+10) -- Word8- <*> peekByteOff p (off+11) -- Word8- <*> peekByteOff p (off+12) -- Word8- <*> peekByteOff p (off+13) -- Word8- <*> peekByteOff p (off+14) -- Word8- <*> peekByteOff p (off+15) -- Word8- )-- pokeByteOff p off u =- case unpack u of- (UnpackedUUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->- do- pokeByteOff p off x0- pokeByteOff p (off+4) x1- pokeByteOff p (off+6) x2- pokeByteOff p (off+8) x3- pokeByteOff p (off+9) x4- pokeByteOff p (off+10) x5- pokeByteOff p (off+11) x6- pokeByteOff p (off+12) x7- pokeByteOff p (off+13) x8- pokeByteOff p (off+14) x9- pokeByteOff p (off+15) x10--instance Binary UUID where- put (UUID w0 w1 w2 w3) =- putWord32be w0 >> putWord32be w1 >> putWord32be w2 >> putWord32be w3- get = liftM4 UUID getWord32be getWord32be getWord32be getWord32be----- My goal with this instance was to make it work just enough to do what--- I want when used with the HStringTemplate library.-instance Data UUID where- toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")- gunfold _ _ = error "gunfold"- dataTypeOf _ = uuidType--uuidType :: DataType-uuidType = mkNoRepType "Data.UUID.Types.UUID"--#if !(MIN_VERSION_base(4,2,0))-mkNoRepType :: String -> DataType-mkNoRepType = mkNorepType-#endif
− Data/UUID/Types/Internal/Builder.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_HADDOCK hide #-}---- Module : Data.UUID.Types.Internal.Builder--- Copyright : (c) 2009 Mark Lentczner------ License : BSD-style------ Maintainer : markl@glyphic.com--- Stability : experimental--- Portability : portable------ This module provides a system that can call a function that takes--- a sequence of some number of Word8 arguments.------ The twist is that the Word8 arguments can be supplied directly--- from Word8s, or from other sources that may provide more than--- one Word8 apiece. Examples are Word16 and Word32 that supply--- two and four Word8s respectively. Other ByteSource instances--- can be defined.------ This module is admittedly overkill. There are only three places--- in the uuid package that need to call buildFromBytes with 16--- Word8 values, but each place uses Words of different lengths:--- version 1 uuids: 32-16-16-16-8-8-8-8-8-8--- version 4 uuids: 24-24-32-24-24--- version 5 uuids: 32-32-32-32--- Originally, these three constructions were hand coded but the--- code was ungainly. Using this module makes the code very--- concise, and turns out to optimize to just as fast, or faster!--module Data.UUID.Types.Internal.Builder- (ByteSource(..)- ,ByteSink- ,Takes1Byte- ,Takes2Bytes- ,Takes3Bytes- ,Takes4Bytes- ) where--import Data.Bits-import Data.Word----type Takes1Byte g = Word8 -> g-type Takes2Bytes g = Word8 -> Word8 -> g-type Takes3Bytes g = Word8 -> Word8 -> Word8 -> g-type Takes4Bytes g = Word8 -> Word8 -> Word8 -> Word8 -> g---- | Type of function that a given ByteSource needs.--- This function must take as many Word8 arguments as the ByteSource provides-type family ByteSink w g-type instance ByteSink Word8 g = Takes1Byte g-type instance ByteSink Word16 g = Takes2Bytes g-type instance ByteSink Word32 g = Takes4Bytes g-type instance ByteSink Int g = Takes4Bytes g----- | Class of types that can add Word8s to a Builder.--- Instances for Word8, Word16, Word32 and Int provide 1, 2, 4 and 4 bytes,--- respectively, into a ByteSink-class ByteSource w where- -- | Apply the source's bytes to the sink- (/-/) :: ByteSink w g -> w -> g--infixl 6 /-/--instance ByteSource Word8 where- f /-/ w = f w--instance ByteSource Word16 where- f /-/ w = f b1 b2- where b1 = fromIntegral (w `shiftR` 8)- b2 = fromIntegral w--instance ByteSource Word32 where- f /-/ w = f b1 b2 b3 b4- where b1 = fromIntegral (w `shiftR` 24)- b2 = fromIntegral (w `shiftR` 16)- b3 = fromIntegral (w `shiftR` 8)- b4 = fromIntegral w--instance ByteSource Int where- f /-/ w = f b1 b2 b3 b4- where b1 = fromIntegral (w `shiftR` 24)- b2 = fromIntegral (w `shiftR` 16)- b3 = fromIntegral (w `shiftR` 8)- b4 = fromIntegral w
+ src/Data/UUID/Types.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++{- |+Module : Data.UUID.Types+Copyright : (c) 2017-2018 Herbert Valerio Riedel+ (c) 2008,2012 Antoine Latter++License : BSD-style++Maintainer : hvr@gnu.org+Portability : portable++This library is useful for comparing, parsing and+printing <http://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)>.+See <http://tools.ietf.org/html/rfc4122 RFC 4122> for the specification.++-}+module Data.UUID.Types+ ( -- * The 'UUID' Type+ UUID+ -- * Nil UUID+ , nil+ , null+ -- * Textual Representation+ , toString+ , fromString+ , toText+ , fromText+ , toASCIIBytes+ , fromASCIIBytes+ , toLazyASCIIBytes+ , fromLazyASCIIBytes+ -- * Binary Representation+ , toByteString+ , fromByteString+ -- * Integer Representation+ , toWords+ , fromWords+ , toWords64+ , fromWords64+ ) where++import Data.UUID.Types.Internal+import Prelude ()++-- Everything is really implemented in Data.UUID.Types.Internal, but I+-- don't want to export the constructors out of the package.
+ src/Data/UUID/Types/Internal.hs view
@@ -0,0 +1,621 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Unsafe #-}+#endif++{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module : Data.UUID.Types.Internal+-- Copyright : (c) 2017-2018 Herbert Valerio Riedel+-- (c) 2008-2009, 2012 Antoine Latter+-- (c) 2009 Mark Lentczner+--+-- License : BSD-style+--+-- Maintainer : hvr@gnu.org+-- Portability : portable++module Data.UUID.Types.Internal+ ( UUID(..)+ , null+ , nil+ , fromByteString+ , toByteString+ , fromString+ , toString+ , fromText+ , toText+ , fromWords+ , toWords+ , fromWords64+ , toWords64+ , toList+ , buildFromBytes+ , buildFromWords+ , fromASCIIBytes+ , toASCIIBytes+ , fromLazyASCIIBytes+ , toLazyASCIIBytes+ , UnpackedUUID(..)+ , pack+ , unpack+ ) where++import Prelude hiding (null)++import Control.Applicative ((<*>))+import Control.DeepSeq (NFData (..))+import Control.Monad (guard, liftM2)+import Data.Bits+import Data.Char+import Data.Data+import Data.Functor ((<$>))+import Data.Hashable+import Data.List (elemIndices)+import Foreign.Ptr (Ptr)++import Foreign.Storable++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Unsafe as BU+import Data.Text (Text)+import qualified Data.Text.Encoding as T++import Data.UUID.Types.Internal.Builder++#if MIN_VERSION_random(1,2,0)+import System.Random (Random (..), uniform)+import System.Random.Stateful (Uniform (..), uniformWord64)+#else+import System.Random (Random (..), next)+#endif+++-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in+-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.+data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+ deriving (Eq, Ord, Typeable)+{-+ Prior to uuid-types-1.0.4:+ !Word32 !Word32 !Word32 !Word32+ Other representations that we tried are:+ Mimic V1 structure: !Word32 !Word16 !Word16 !Word16+ !Word8 !Word8 !Word8 !Word8 !Word8 !Word8+ Sixteen bytes: !Word8 ... (x 16)+ Simple list of bytes: [Word8]+ ByteString (strict) ByteString+ Immutable array: UArray Int Word8+ Vector: UArr Word8+ None was as fast, overall, as the representation used here.+-}++-- | Convert a 'UUID' into a sequence of 'Word32' values.+-- Useful for when you need to serialize a UUID and+-- neither 'Storable' nor 'Binary' are appropriate.+--+-- >>> toWords <$> fromString "550e8400-e29b-41d4-a716-446655440000"+-- Just (1427014656,3801825748,2803254374,1430519808)+--+-- See also 'toWords64'.+--+-- /Since: @uuid-1.2.2@/+--+-- @since 1.0.0+toWords :: UUID -> (Word32, Word32, Word32, Word32)+toWords (UUID w12 w34) = (w1, w2, w3, w4)+ where+ w1 = fromIntegral (w12 `unsafeShiftR` 32)+ w2 = fromIntegral w12+ w3 = fromIntegral (w34 `unsafeShiftR` 32)+ w4 = fromIntegral w34++-- | Create a 'UUID' from a sequence of 'Word32'. The+-- inverse of 'toWords'. Useful when you need a total+-- function for constructing 'UUID' values.+--+-- See also 'fromWords64'.+--+-- /Since: @uuid-1.2.2@/+--+-- @since 1.0.0+fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID+fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)++-- | Convert a 'UUID' into a pair of 'Word64's.+--+-- >>> toWords64 <$> fromString "550e8400-e29b-41d4-a716-446655440000"+-- Just (6128981282234515924,12039885860129472512)+--+-- See also 'toWords'.+--+-- @since 1.0.4+toWords64 :: UUID -> (Word64, Word64)+toWords64 (UUID w12 w34) = (w12,w34)++-- | Create a 'UUID' from a pair of 'Word64's.+--+-- Inverse of 'toWords64'. See also 'fromWords'.+--+-- @since 1.0.4+fromWords64 :: Word64 -> Word64 -> UUID+fromWords64 = UUID++data UnpackedUUID =+ UnpackedUUID {+ time_low :: Word32 -- 0-3+ , time_mid :: Word16 -- 4-5+ , time_hi_and_version :: Word16 -- 6-7+ , clock_seq_hi_res :: Word8 -- 8+ , clock_seq_low :: Word8 -- 9+ , node_0 :: Word8+ , node_1 :: Word8+ , node_2 :: Word8+ , node_3 :: Word8+ , node_4 :: Word8+ , node_5 :: Word8+ }+ deriving (Read, Show, Eq, Ord)++unpack :: UUID -> UnpackedUUID+unpack (UUID w0 w1) = build /-/ w0 /-/ w1+ where+ build x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC xD xE xF =+ UnpackedUUID {+ time_low = word x0 x1 x2 x3+ , time_mid = w8to16 x4 x5+ , time_hi_and_version = w8to16 x6 x7+ , clock_seq_hi_res = x8+ , clock_seq_low = x9+ , node_0 = xA+ , node_1 = xB+ , node_2 = xC+ , node_3 = xD+ , node_4 = xE+ , node_5 = xF+ }++pack :: UnpackedUUID -> UUID+pack unpacked =+ makeFromBytes /-/ (time_low unpacked)+ /-/ (time_mid unpacked)+ /-/ (time_hi_and_version unpacked)+ /-/ (clock_seq_hi_res unpacked)+ /-/ (clock_seq_low unpacked)+ /-/ (node_0 unpacked) /-/ (node_1 unpacked)+ /-/ (node_2 unpacked) /-/ (node_3 unpacked)+ /-/ (node_4 unpacked) /-/ (node_5 unpacked)+++--+-- UTILITIES+--++-- |Build a Word32 from four Word8 values, presented in big-endian order+word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+word a b c d = (fromIntegral a `unsafeShiftL` 24)+ .|. (fromIntegral b `unsafeShiftL` 16)+ .|. (fromIntegral c `unsafeShiftL` 8)+ .|. (fromIntegral d )++-- |Extract a Word8 from a Word64. Bytes, high to low, are numbered from 7 to 0,+byte :: Int -> Word64 -> Word8+byte i w = fromIntegral (w `shiftR` (i * 8))++-- |Build a Word16 from two Word8 values, presented in big-endian order.+w8to16 :: Word8 -> Word8 -> Word16+w8to16 w0s w1s =+ (w0 `unsafeShiftL` 8) .|. w1+ where+ w0 = fromIntegral w0s+ w1 = fromIntegral w1s++-- | Construct 'Word64' from low/high 'Word32's+w32to64 :: Word32 -> Word32 -> Word64+w32to64 w0 w1 = (fromIntegral w0 `unsafeShiftL` 32) .|. (fromIntegral w1)++-- |Make a UUID from sixteen Word8 values+makeFromBytes :: Word8 -> Word8 -> Word8 -> Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> UUID+makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf+ = fromWords w0 w1 w2 w3+ where w0 = word b0 b1 b2 b3+ w1 = word b4 b5 b6 b7+ w2 = word b8 b9 ba bb+ w3 = word bc bd be bf++-- |A Builder for constructing a UUID of a given version.+buildFromBytes :: Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> Word8 -> Word8 -> Word8 -> Word8+ -> UUID+buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =+ makeFromBytes b0 b1 b2 b3 b4 b5 b6' b7 b8' b9 ba bb bc bd be bf+ where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)+ b8' = b8 .&. 0x3f .|. 0x80++-- |Build a UUID of a given version from 'Word32' values.+buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID+buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3+ where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)+ w2' = w2 .&. 0x3fffffff .|. 0x80000000+++-- |Return the bytes that make up the UUID+toList :: UUID -> [Word8]+toList (UUID w0 w1) =+ [byte 7 w0, byte 6 w0, byte 5 w0, byte 4 w0,+ byte 3 w0, byte 2 w0, byte 1 w0, byte 0 w0,+ byte 7 w1, byte 6 w1, byte 5 w1, byte 4 w1,+ byte 3 w1, byte 2 w1, byte 1 w1, byte 0 w1]++-- |Construct a UUID from a list of Word8. Returns Nothing if the list isn't+-- exactly sixteen bytes long+fromList :: [Word8] -> Maybe UUID+fromList [b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf] =+ Just $ makeFromBytes b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf+fromList _ = Nothing+++--+-- UUID API+--++-- |Returns true if the passed-in UUID is the 'nil' UUID.+null :: UUID -> Bool+null = (== nil)+ -- Note: This actually faster than:+ -- null (UUID 0 0 0 0) = True+ -- null _ = False++-- |The 'nil' UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.+-- It is a UUID of all zeros. @'null' u@ /iff/ @'u' == 'nil'@.+nil :: UUID+nil = UUID 0 0++-- |Extract a UUID from a 'ByteString' in network byte order.+-- The argument must be 16 bytes long, otherwise 'Nothing' is returned.+fromByteString :: BL.ByteString -> Maybe UUID+fromByteString = fromList . BL.unpack++-- |Encode a UUID into a 'ByteString' in network order.+--+-- This uses the same encoding as the 'Binary' instance.+toByteString :: UUID -> BL.ByteString+toByteString = BL.pack . toList++-- |If the passed in 'String' can be parsed as a 'UUID', it will be.+-- The hyphens may not be omitted.+-- Example:+--+-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"+-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c+--+-- Hex digits may be upper or lower-case.+fromString :: String -> Maybe UUID+fromString xs | validFmt = fromString' xs+ | otherwise = Nothing+ where validFmt = elemIndices '-' xs == [8,13,18,23]++fromString' :: String -> Maybe UUID+fromString' s0 = do+ (w0, s1) <- hexWord s0+ (w1, s2) <- hexWord s1+ (w2, s3) <- hexWord s2+ (w3, s4) <- hexWord s3+ if s4 /= "" then Nothing+ else Just $ fromWords w0 w1 w2 w3+ where hexWord :: String -> Maybe (Word32, String)+ hexWord s = Just (0, s) >>= hexByte >>= hexByte+ >>= hexByte >>= hexByte++ hexByte :: (Word32, String) -> Maybe (Word32, String)+ hexByte (w, '-':ds) = hexByte (w, ds)+ hexByte (w, hi:lo:ds)+ | bothHex = Just ((w `shiftL` 8) .|. octet, ds)+ | otherwise = Nothing+ where bothHex = isHexDigit hi && isHexDigit lo+ octet = fromIntegral (16 * digitToInt hi + digitToInt lo)+ hexByte _ = Nothing++-- | Convert a UUID into a hypenated string using lower-case letters.+-- Example:+--+-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"+-- Just "550e8400-e29b-41d4-a716-446655440000"+--+--+toString :: UUID -> String+toString uuid = hexw0 w0 $ hexw1 w1 ""+ where hexw0 :: Word64 -> String -> String+ hexw0 w s = hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48+ : hexn w 44 : hexn w 40 : hexn w 36 : hexn w 32+ : '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16+ : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0+ : s++ hexw1 :: Word64 -> String -> String+ hexw1 w s = '-' : hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48+ : '-' : hexn w 44 : hexn w 40 : hexn w 36 : hexn w 32+ : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16+ : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0+ : s++ hexn :: Word64 -> Int -> Char+ hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)++ (w0,w1) = toWords64 uuid++-- | If the passed in `Text` can be parsed as an ASCII representation of+-- a `UUID`, it will be. The hyphens may not be omitted.+fromText :: Text -> Maybe UUID+fromText = fromASCIIBytes . T.encodeUtf8++-- | Convert a UUID into a hyphentated string using lower-case letters.+toText :: UUID -> Text+toText = T.decodeLatin1 . toASCIIBytes++-- | Convert a UUID into a hyphentated string using lower-case letters, packed+-- as ASCII bytes into `B.ByteString`.+--+-- This should be equivalent to `toString` with `Data.ByteString.Char8.pack`.+toASCIIBytes :: UUID -> B.ByteString+toASCIIBytes uuid = BI.unsafeCreate 36 (pokeASCII uuid)++-- | Helper function for `toASCIIBytes`+pokeASCII :: UUID -> Ptr Word8 -> IO ()+pokeASCII uuid ptr = do+ pokeDash 8+ pokeDash 13+ pokeDash 18+ pokeDash 23+ pokeSingle 0 w0+ pokeDouble 9 w1+ pokeDouble 19 w2+ pokeSingle 28 w3+ where+ (w0, w1, w2, w3) = toWords uuid++ -- ord '-' ==> 45+ pokeDash ix = pokeElemOff ptr ix 45++ pokeSingle ix w = do+ pokeWord ix w 28+ pokeWord (ix + 1) w 24+ pokeWord (ix + 2) w 20+ pokeWord (ix + 3) w 16+ pokeWord (ix + 4) w 12+ pokeWord (ix + 5) w 8+ pokeWord (ix + 6) w 4+ pokeWord (ix + 7) w 0++ -- We skip the dash in the middle+ pokeDouble ix w = do+ pokeWord ix w 28+ pokeWord (ix + 1) w 24+ pokeWord (ix + 2) w 20+ pokeWord (ix + 3) w 16+ pokeWord (ix + 5) w 12+ pokeWord (ix + 6) w 8+ pokeWord (ix + 7) w 4+ pokeWord (ix + 8) w 0++ pokeWord ix w r =+ pokeElemOff ptr ix (fromIntegral (toDigit ((w `shiftR` r) .&. 0xf)))++ toDigit :: Word32 -> Word32+ toDigit w = if w < 10 then 48 + w else 97 + w - 10++-- | If the passed in `B.ByteString` can be parsed as an ASCII representation of+-- a `UUID`, it will be. The hyphens may not be omitted.+--+-- This should be equivalent to `fromString` with `Data.ByteString.Char8.unpack`.+fromASCIIBytes :: B.ByteString -> Maybe UUID+fromASCIIBytes bs = do+ guard wellFormed+ fromWords <$> single 0 <*> double 9 14 <*> double 19 24 <*> single 28+ where+ -- ord '-' ==> 45+ dashIx bs' ix = BU.unsafeIndex bs' ix == 45++ -- Important: check the length first, given the `unsafeIndex` later.+ wellFormed =+ B.length bs == 36 && dashIx bs 8 && dashIx bs 13 &&+ dashIx bs 18 && dashIx bs 23++ single ix = combine <$> octet ix <*> octet (ix + 2)+ <*> octet (ix + 4) <*> octet (ix + 6)+ double ix0 ix1 = combine <$> octet ix0 <*> octet (ix0 + 2)+ <*> octet ix1 <*> octet (ix1 + 2)++ combine o0 o1 o2 o3 = shiftL o0 24 .|. shiftL o1 16 .|. shiftL o2 8 .|. o3++ octet ix = do+ hi <- fromIntegral <$> toDigit (BU.unsafeIndex bs ix)+ lo <- fromIntegral <$> toDigit (BU.unsafeIndex bs (ix + 1))+ return (16 * hi + lo)++ toDigit :: Word8 -> Maybe Word8+ toDigit w+ -- Digit+ | w >= 48 && w <= 57 = Just (w - 48)+ -- Uppercase+ | w >= 65 && w <= 70 = Just (10 + w - 65)+ -- Lowercase+ | w >= 97 && w <= 102 = Just (10 + w - 97)+ | otherwise = Nothing++-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.+toLazyASCIIBytes :: UUID -> BL.ByteString+toLazyASCIIBytes =+#if MIN_VERSION_bytestring(0,10,0)+ BL.fromStrict+#else+ BL.fromChunks . return+#endif+ . toASCIIBytes++-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.+fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID+fromLazyASCIIBytes bs =+ if BL.length bs == 36 then fromASCIIBytes (+#if MIN_VERSION_bytestring(0,10,0)+ BL.toStrict bs+#else+ B.concat $ BL.toChunks bs+#endif+ ) else Nothing++--+-- Class Instances+--++-- | This 'Random' instance produces __insecure__ version 4 UUIDs as+-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.+#if MIN_VERSION_random(1,2,0)+instance Random UUID where+ random = uniform+ randomR _ = random -- range is ignored++-- @since 1.0.4+instance Uniform UUID where+ uniformM gen = do+ w0 <- uniformWord64 gen+ w1 <- uniformWord64 gen+ pure $ buildFromBytes 4 /-/ w0 /-/ w1+#else+instance Random UUID where+ random g = (fromGenNext w0 w1 w2 w3 w4, g4)+ where (w0, g0) = next g+ (w1, g1) = next g0+ (w2, g2) = next g1+ (w3, g3) = next g2+ (w4, g4) = next g3+ randomR _ = random -- range is ignored++-- |Build a UUID from the results of five calls to next on a StdGen.+-- While next on StdGet returns an Int, it doesn't provide 32 bits of+-- randomness. This code relies on at last 28 bits of randomness in the+-- and optimizes its use so as to make only five random values, not six.+fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID+fromGenNext w0 w1 w2 w3 w4 =+ buildFromBytes 4 /-/ (ThreeByte w0)+ /-/ (ThreeByte w1)+ /-/ w2 -- use all 4 bytes because we know the version+ -- field will "cover" the upper, non-random bits+ /-/ (ThreeByte w3)+ /-/ (ThreeByte w4)+#endif++-- |A ByteSource to extract only three bytes from an Int, since next on StdGet+-- only returns 31 bits of randomness.+type instance ByteSink ThreeByte g = Takes3Bytes g+newtype ThreeByte = ThreeByte Int+instance ByteSource ThreeByte where+ f /-/ (ThreeByte w) = f b1 b2 b3+ where b1 = fromIntegral (w `unsafeShiftR` 16)+ b2 = fromIntegral (w `unsafeShiftR` 8)+ b3 = fromIntegral w++instance NFData UUID where+ rnf = flip seq ()++instance Hashable UUID where+ hash (toWords -> (w0,w1,w2,w3)) =+ hash w0 `hashWithSalt` w1+ `hashWithSalt` w2+ `hashWithSalt` w3+ hashWithSalt s (toWords -> (w0,w1,w2,w3)) =+ s `hashWithSalt` w0+ `hashWithSalt` w1+ `hashWithSalt` w2+ `hashWithSalt` w3++-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.+--+-- >>> show nil+-- "00000000-0000-0000-0000-000000000000"+--+instance Show UUID where+ show = toString++instance Read UUID where+ readsPrec _ str =+ let noSpaces = dropWhile isSpace str+ in case fromString (take 36 noSpaces) of+ Nothing -> []+ Just u -> [(u,drop 36 noSpaces)]++-- | This 'Storable' instance uses the memory layout as described in <http://tools.ietf.org/html/rfc4122 RFC 4122>, but in contrast to the 'Binary' instance, __the fields are stored in host byte order__.+instance Storable UUID where+ sizeOf _ = 16+ alignment _ = 4++ peekByteOff p off =+ pack <$>+ (UnpackedUUID+ <$> peekByteOff p off -- Word32+ <*> peekByteOff p (off+4) -- Word16+ <*> peekByteOff p (off+6) -- Word16+ <*> peekByteOff p (off+8) -- Word8+ <*> peekByteOff p (off+9) -- Word8+ <*> peekByteOff p (off+10) -- Word8+ <*> peekByteOff p (off+11) -- Word8+ <*> peekByteOff p (off+12) -- Word8+ <*> peekByteOff p (off+13) -- Word8+ <*> peekByteOff p (off+14) -- Word8+ <*> peekByteOff p (off+15) -- Word8+ )++ pokeByteOff p off u =+ case unpack u of+ (UnpackedUUID x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->+ do+ pokeByteOff p off x0+ pokeByteOff p (off+4) x1+ pokeByteOff p (off+6) x2+ pokeByteOff p (off+8) x3+ pokeByteOff p (off+9) x4+ pokeByteOff p (off+10) x5+ pokeByteOff p (off+11) x6+ pokeByteOff p (off+12) x7+ pokeByteOff p (off+13) x8+ pokeByteOff p (off+14) x9+ pokeByteOff p (off+15) x10++-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.+instance Binary UUID where+ put (UUID w0 w1) = putWord64be w0 >> putWord64be w1+ get = liftM2 UUID getWord64be getWord64be+++-- My goal with this instance was to make it work just enough to do what+-- I want when used with the HStringTemplate library.+instance Data UUID where+ toConstr uu = mkConstr uuidType (show uu) [] (error "fixity")+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = uuidType++uuidType :: DataType+uuidType = mkNoRepType "Data.UUID.Types.UUID"++#if !MIN_VERSION_base(4,5,0)+unsafeShiftR, unsafeShiftL :: Bits w => w -> Int -> w+{-# INLINE unsafeShiftR #-}+unsafeShiftR = shiftR+{-# INLINE unsafeShiftL #-}+unsafeShiftL = shiftL+#endif
+ src/Data/UUID/Types/Internal/Builder.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Unsafe #-}+#endif++{-# OPTIONS_HADDOCK hide #-}++-- | Module : Data.UUID.Types.Internal.Builder+-- Copyright : (c) 2009 Mark Lentczner+--+-- License : BSD-style+--+-- Maintainer : markl@glyphic.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides a system that can call a function that takes+-- a sequence of some number of Word8 arguments.+--+-- The twist is that the Word8 arguments can be supplied directly+-- from Word8s, or from other sources that may provide more than+-- one Word8 apiece. Examples are Word16 and Word32 that supply+-- two and four Word8s respectively. Other ByteSource instances+-- can be defined.+--+-- This module is admittedly overkill. There are only three places+-- in the uuid package that need to call buildFromBytes with 16+-- Word8 values, but each place uses Words of different lengths:+-- version 1 uuids: 32-16-16-16-8-8-8-8-8-8+-- version 4 uuids: 24-24-32-24-24+-- version 5 uuids: 32-32-32-32+-- Originally, these three constructions were hand coded but the+-- code was ungainly. Using this module makes the code very+-- concise, and turns out to optimize to just as fast, or faster!++module Data.UUID.Types.Internal.Builder+ (ByteSource(..)+ ,ByteSink+ ,Takes1Byte+ ,Takes2Bytes+ ,Takes3Bytes+ ,Takes4Bytes+ ) where++import Data.Bits+import Data.Word++++type Takes1Byte g = Word8 -> g+type Takes2Bytes g = Word8 -> Word8 -> g+type Takes3Bytes g = Word8 -> Word8 -> Word8 -> g+type Takes4Bytes g = Word8 -> Word8 -> Word8 -> Word8 -> g+type Takes8Bytes g = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> g++-- | Type of function that a given ByteSource needs.+-- This function must take as many Word8 arguments as the ByteSource provides+type family ByteSink w g+type instance ByteSink Word8 g = Takes1Byte g+type instance ByteSink Word16 g = Takes2Bytes g+type instance ByteSink Word32 g = Takes4Bytes g+type instance ByteSink Word64 g = Takes8Bytes g+type instance ByteSink Int g = Takes4Bytes g+++-- | Class of types that can add Word8s to a Builder.+-- Instances for Word8, Word16, Word32 and Int provide 1, 2, 4 and 4 bytes,+-- respectively, into a ByteSink+class ByteSource w where+ -- | Apply the source's bytes to the sink+ (/-/) :: ByteSink w g -> w -> g++infixl 6 /-/++instance ByteSource Word8 where+ f /-/ w = f w++instance ByteSource Word16 where+ f /-/ w = f b1 b2+ where b1 = fromIntegral (w `shiftR` 8)+ b2 = fromIntegral w++instance ByteSource Word32 where+ f /-/ w = f b1 b2 b3 b4+ where b1 = fromIntegral (w `shiftR` 24)+ b2 = fromIntegral (w `shiftR` 16)+ b3 = fromIntegral (w `shiftR` 8)+ b4 = fromIntegral w++instance ByteSource Word64 where+ f /-/ w = f b1 b2 b3 b4 b5 b6 b7 b8+ where b1 = fromIntegral (w `shiftR` 56)+ b2 = fromIntegral (w `shiftR` 48)+ b3 = fromIntegral (w `shiftR` 40)+ b4 = fromIntegral (w `shiftR` 32)+ b5 = fromIntegral (w `shiftR` 24)+ b6 = fromIntegral (w `shiftR` 16)+ b7 = fromIntegral (w `shiftR` 8)+ b8 = fromIntegral w++instance ByteSource Int where+ f /-/ w = f b1 b2 b3 b4+ where b1 = fromIntegral (w `shiftR` 24)+ b2 = fromIntegral (w `shiftR` 16)+ b3 = fromIntegral (w `shiftR` 8)+ b4 = fromIntegral w
− tests/BenchUUID.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE CPP #-}--#if !(MIN_VERSION_bytestring(0,10,0))--- Needed for NFData instance-import Control.DeepSeq-import qualified Data.ByteString.Lazy.Internal as BL-#endif-import Criterion.Main-import Data.Maybe (fromJust)-import qualified Data.Set as Set-import qualified Data.ByteString.Lazy as BL-import qualified Data.UUID.Types as U-import Foreign (alloca, peek, poke)-import System.Random--#if !(MIN_VERSION_bytestring(0,10,0))-instance NFData BL.ByteString where- rnf BL.Empty = ()- rnf (BL.Chunk _ ts) = rnf ts-#endif--main :: IO ()-main = do- u1 <- randomIO- let s1 = U.toString u1- b1 = U.toByteString u1- nil2 = fromJust $- U.fromString "00000000-0000-0000-0000-000000000000"- u2a = fromJust $ U.fromString "169a5a43-c051-4a16-98f4-08447ddd5dc0"- u2b = fromJust $ U.fromByteString $- BL.pack [0x16, 0x9a, 0x5a, 0x43, 0xc0, 0x51, 0x4a, 0x16,- 0x98, 0xf4, 0x08, 0x44, 0x7d, 0xdd, 0x5d, 0xc0]- u3 = fromJust $ U.fromString "dea6f619-1038-438b-b4af-f1cdec1e6e23"-- -- setup for Storable benchmark- alloca $ \ uuidPtr -> do-- poke uuidPtr u1-- defaultMain [- bgroup "testing" [- bench "null non-nil" $ whnf U.null u1,- bench "null nil" $ whnf U.null U.nil,- bench "null nil2" $ whnf U.null nil2,- bench "eq same" $ whnf (==u2a) u2b,- bench "eq differ" $ whnf (==u2a) u3- ],- bgroup "conversion" [- bench "toString" $ nf U.toString u1,- bench "fromString" $ nf U.fromString s1,- bench "toByteString" $ nf U.toByteString u1,- bench "fromByteString" $ nf U.fromByteString b1- ],- bench "set making" $ nf Set.fromList uuids,-- bgroup "storable" [- bench "peek" $ nfIO (peek uuidPtr),- bench "poke" $ whnfIO $ poke uuidPtr u1- ]- ]---- 50 uuids, so tests can be repeatable-uuids :: [U.UUID]-uuids- = map (fromJust . U.fromString)- [- "35d42593-1fca-4465-b588-a2e78cb996ba",- "1e97e407-eca7-4c5d-a947-6fbe9dc168b6",- "a41fd7ce-a053-4c0a-a742-77c95b85da2a",- "f7e3913a-0fd7-4355-a92f-d73f9b046efa",- "8961a35d-55c2-42f3-8680-08fce3986647",- "96246c58-d0b4-4e56-a543-356bd59686a9",- "72c46194-648c-4b1e-a9fb-2eba060ab43b",- "0fc252d4-a37b-4eca-9309-e3d2a59a3a22",- "a8aceb5a-6a8e-43f3-85bb-9653a3c1ebcd",- "b23d1118-6bc8-4add-9d56-99634d78949f",- "5f8c7896-9c4f-4d7e-a4d2-961bda298012",- "219a4137-7bc5-42b1-ac95-490948a978e1",- "5af5024f-fbe9-45ab-991d-49b655994437",- "569dfb33-185d-4a3c-99c4-bc2b83250a7c",- "43a58442-aa51-4a5d-8e00-b8a83b5fc5b0",- "2865ced1-b54d-4725-8f01-b408f4617424",- "b8cfaff0-4dee-4f32-af2f-0469b3e535fc",- "63f45bc0-f303-4f1a-b0d6-76f876be626d",- "d171eaf3-f20d-45d6-9268-0cc22dfbe887",- "7c28f457-ad27-494a-8642-6e47e7f3efb8",- "f8de9193-66ff-49e8-9826-fc50858d7855",- "2af85f28-cace-4740-b8bb-2b5860f5fdb3",- "b12a7a22-edb3-4694-b8f4-0532eaad6112",- "5e052a08-8e49-4668-bbe7-77cdbc4679a3",- "42d5a68d-3f08-4e39-9b8c-71cc17c538ed",- "ba2b1487-b3a4-4a19-98cc-59530f36613f",- "e4a5c569-b8ac-4851-8ad2-fbdb89986be2",- "35b4a1b6-b5ca-4646-803b-c337ee730d9a",- "f0df1206-05d9-49d6-a726-d49fb253e645",- "9656a0f0-89b2-4cec-bb1c-fdf5633e1cd7",- "d13382f5-04a1-422d-94d6-e47219425816",- "b8d0c762-4c6b-4bd0-ad0b-f68988a87166",- "06360e85-f18a-44f6-aa72-45f1e60b6b77",- "347491ca-62b3-48e8-ac94-6ffebe1318ed",- "014339d0-7b2d-4dda-914b-14ee5cb4391b",- "dc57931b-4744-41be-b3c4-e24dbeeb606a",- "2c9fdcf0-e1d6-4a2d-951d-4766b99032cb",- "b6bde422-eea8-4231-bf1c-ee0e56699511",- "921073c5-f7c1-4583-ac03-aeb7aef8662b",- "eff6a517-aeb1-453e-9810-1b4b324c5a1e",- "eadaae8c-cbf8-4e0b-ab80-e34284b07dad",- "4d307c36-70d9-453f-8455-ec7e2ba405ed",- "53ddef9a-2413-4f7f-8363-cff56ee17c6c",- "4dd4c27a-b300-4a00-ab87-eef505275492",- "4a5d7001-f0c1-4e2f-8362-8833bda2114b",- "0c46f438-9365-406a-b04e-34436806ec25",- "b35469cf-05f8-40ff-a38b-117604347957",- "f1c54df0-5f59-4891-b3c6-82bac0d814ca",- "8091837c-6456-42c3-a686-f4731a41d4f9",- "2a0e2efb-a11c-4a44-81ee-3efc37379b48"- ]
tests/TestUUID.hs view
@@ -1,22 +1,28 @@ {-# LANGUAGE ViewPatterns #-} -import qualified Data.ByteString.Lazy as BL+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Data.Binary (encode)+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8-import qualified Data.ByteString.Char8 as BC8-import Data.Char (ord)-import Data.Functor ((<$>))-import Data.Word-import qualified Data.UUID.Types as U-import Foreign (alloca, peek, poke)-import System.IO.Unsafe (unsafePerformIO)+import Data.Char (ord)+import Data.Functor ((<$>))+import qualified Data.UUID.Types as U+import Data.Word+import Foreign (alloca, castPtr, peek, poke,+ sizeOf)+import GHC.ByteOrder (ByteOrder(..), targetByteOrder)+import System.IO.Unsafe (unsafePerformIO) -import Test.QuickCheck ( Arbitrary(arbitrary), choose )+import Test.QuickCheck (Arbitrary (arbitrary), choose) -import Test.Tasty ( defaultMain, TestTree, testGroup )-import Test.Tasty.HUnit ( assertBool, (@?=), (@=?), testCase )-import Test.Tasty.QuickCheck ( testProperty )+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@=?), (@?=))+import Test.Tasty.QuickCheck (testProperty) +-- orphan instance Arbitrary U.UUID where -- the UUID random instance ignores bounds arbitrary = choose (U.nil, U.nil)@@ -49,14 +55,33 @@ test_fromByteString = testCase "UUID fromByteString" $ Just inputUUID @=?- U.fromByteString (BL8.pack "\165\202\133f\217\197H5\153\200\225\241>s\181\226")+ U.fromByteString (BL8.pack "\xa5\xca\x85\x66\xd9\xc5\x48\x35\x99\xc8\xe1\xf1\x3e\x73\xb5\xe2") -- | Test fromWords with a fixed-input test_fromWords :: Test test_fromWords = testCase "UUID fromWords" $- inputUUID @=? U.fromWords 2781513062 3653584949 2580079089 1047770594+ inputUUID @=? U.fromWords 0xa5ca8566 0xd9c54835 0x99c8e1f1 0x3e73b5e2 ++test_Storeable :: Test+test_Storeable =+ testCase "UUID Storeable(poke)" $+ case targetByteOrder of+ LittleEndian -> BC8.pack "\x66\x85\xca\xa5\xc5\xd9\x35\x48\x99\xc8\xe1\xf1\x3e\x73\xb5\xe2" @=? pokeAsBS inputUUID+ BigEndian -> BC8.pack "\xa5\xca\x85\x66\xd9\xc5\x48\x35\x99\xc8\xe1\xf1\x3e\x73\xb5\xe2" @=? pokeAsBS inputUUID+ where+ pokeAsBS :: U.UUID -> BC8.ByteString+ pokeAsBS uuid = unsafePerformIO $ do+ alloca $ \ptr -> do+ poke ptr uuid+ BC8.packCStringLen (castPtr ptr, sizeOf uuid)++test_Binary :: Test+test_Binary =+ testCase "UUID Binary(encode)" $+ (BL8.pack "\xa5\xca\x85\x66\xd9\xc5\x48\x35\x99\xc8\xe1\xf1\x3e\x73\xb5\xe2") @=? encode inputUUID+ inputUUID :: U.UUID inputUUID = read "a5ca8566-d9c5-4835-99c8-e1f13e73b5e2" @@ -153,7 +178,9 @@ test_nil, test_conv, test_fromByteString,- test_fromWords+ test_fromWords,+ test_Storeable,+ test_Binary ] , [ prop_stringRoundTrip, prop_readShowRoundTrip,
uuid-types.cabal view
@@ -1,77 +1,92 @@-Name: uuid-types-Version: 1.0.3-Copyright: (c) 2008-2014 Antoine Latter-Author: Antoine Latter-Maintainer: aslatter@gmail.com-License: BSD3-License-file: LICENSE--Category: Data-Build-Type: Simple-Cabal-Version: >= 1.8+cabal-version: 1.12+name: uuid-types+version: 1.0.4+copyright:+ (c) 2017-2018 Herbert Valerio Riedel+ (c) 2008-2014 Antoine Latter -Description:- This library contains type definitions for Universally Unique Identifiers- and basic conversion functions.+author: Antoine Latter+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD3+license-file: LICENSE+category: Data+build-type: Simple+tested-with:+ GHC ==7.4.2+ || ==7.6.3+ || ==7.8.4+ || ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.4+ || ==8.8.4+ || ==8.10.3 - See <http://en.wikipedia.org/wiki/UUID> for the general idea.+synopsis: Type definitions for Universally Unique Identifiers+description:+ This library contains type definitions for+ <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)>+ (as specified in+ <http://tools.ietf.org/html/rfc4122 RFC 4122>)+ and basic conversion functions.+ .+ See also the <https://hackage.haskell.org/package/uuid 'uuid' package>+ providing a high-level API for managing the different UUID versions. -Synopsis: Type definitions for Universally Unique Identifiers+homepage: https://github.com/haskell-hvr/uuid+bug-reports: https://github.com/haskell-hvr/uuid/issues+extra-source-files: ChangeLog.md -Homepage: https://github.com/aslatter/uuid-Bug-Reports: https://github.com/aslatter/uuid/issues+source-repository head+ type: git+ location: https://github.com/haskell-hvr/uuid.git+ subdir: uuid-types -Extra-Source-Files:- CHANGES+library+ build-depends:+ base >=4.5 && <5+ , binary >=0.5.1.0 && <0.9+ , bytestring >=0.9.2.1 && <0.12+ , deepseq >=1.3.0.0 && <1.5+ , hashable >=1.2.7.0 && <1.4+ , random >=1.1 && <1.3+ , text >=1.2.3.0 && <1.3 + exposed-modules: Data.UUID.Types -Library- Build-Depends: base >=3 && < 5,- binary >= 0.4 && < 0.9,- bytestring >= 0.9 && < 0.11,- deepseq >= 1.3 && < 1.5,- hashable (>= 1.1.1.0 && < 1.2.0) || (>= 1.2.1 && < 1.3),- random >= 1.0.1 && < 1.2,- text >= 1 && < 1.3+ -- Exposed for companion projects; *NOT* part of the official API:+ exposed-modules:+ Data.UUID.Types.Internal+ Data.UUID.Types.Internal.Builder - Exposed-Modules:- Data.UUID.Types- -- Exposed for companion projects; *NOT* part of the official API:- Data.UUID.Types.Internal.Builder- Data.UUID.Types.Internal+ default-language: Haskell2010+ other-extensions:+ DeriveDataTypeable+ TypeFamilies - Extensions: DeriveDataTypeable- Ghc-Options: -Wall+ ghc-options: -Wall+ hs-source-dirs: src -source-repository head- type: git- location: https://github.com/aslatter/uuid.git+test-suite testuuid+ type: exitcode-stdio-1.0+ main-is: TestUUID.hs+ hs-source-dirs: tests+ default-language: Haskell2010+ other-extensions: ViewPatterns+ ghc-options: -Wall -Test-Suite testuuid- Type: exitcode-stdio-1.0- Main-is: TestUUID.hs- Hs-source-dirs: tests- Extensions: DeriveDataTypeable- Ghc-Options: -Wall -fno-warn-orphans- Build-Depends: base >= 3 && < 5,- uuid-types,- bytestring >= 0.9 && < 0.11,- HUnit >=1.2 && < 1.4,- QuickCheck >=2.4 && < 2.9,- tasty >= 0.10 && < 0.12,- tasty-hunit == 0.9.*,- tasty-quickcheck == 0.8.*+ -- inherited constraints+ build-depends:+ base+ , binary+ , bytestring+ , uuid-types -benchmark benchmark- Type: exitcode-stdio-1.0- Main-is: BenchUUID.hs- Hs-source-dirs: tests- Extensions: DeriveDataTypeable, CPP- Ghc-Options: -Wall -fno-warn-orphans- Build-depends: base == 4.*,- uuid-types,- bytestring >= 0.9 && < 0.11,- containers >= 0.4 && < 0.6,- criterion >= 0.4 && < 1.2,- deepseq >= 1.1 && < 1.5,- random >= 1.0.1 && < 1.2+ -- deps w/o inherited constraints+ build-depends:+ ghc-byteorder >=4.11 && <4.12+ , QuickCheck >=2.14.2 && <2.15+ , tasty >=1.4.0.1 && <1.5+ , tasty-hunit >=0.10 && <0.11+ , tasty-quickcheck >=0.10 && <0.11