diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -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" diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/Data/UUID/Types.hs b/Data/UUID/Types.hs deleted file mode 100644 --- a/Data/UUID/Types.hs +++ /dev/null @@ -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 for the general idea. -See 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. diff --git a/Data/UUID/Types/Internal.hs b/Data/UUID/Types/Internal.hs deleted file mode 100644 --- a/Data/UUID/Types/Internal.hs +++ /dev/null @@ -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 diff --git a/Data/UUID/Types/Internal/Builder.hs b/Data/UUID/Types/Internal/Builder.hs deleted file mode 100644 --- a/Data/UUID/Types/Internal/Builder.hs +++ /dev/null @@ -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 diff --git a/src/Data/UUID/Types.hs b/src/Data/UUID/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/UUID/Types.hs @@ -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 . +See 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. diff --git a/src/Data/UUID/Types/Internal.hs b/src/Data/UUID/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/UUID/Types/Internal.hs @@ -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 as specified in +-- . +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 . +-- 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 . +#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 , 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 , 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 diff --git a/src/Data/UUID/Types/Internal/Builder.hs b/src/Data/UUID/Types/Internal/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Data/UUID/Types/Internal/Builder.hs @@ -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 diff --git a/tests/BenchUUID.hs b/tests/BenchUUID.hs deleted file mode 100644 --- a/tests/BenchUUID.hs +++ /dev/null @@ -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" - ] diff --git a/tests/TestUUID.hs b/tests/TestUUID.hs --- a/tests/TestUUID.hs +++ b/tests/TestUUID.hs @@ -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, diff --git a/uuid-types.cabal b/uuid-types.cabal --- a/uuid-types.cabal +++ b/uuid-types.cabal @@ -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 +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 for the general idea. +synopsis: Type definitions for Universally Unique Identifiers +description: + This library contains type definitions for + + (as specified in + ) + and basic conversion functions. + . + See also the + 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