uuid-types (empty) → 1.0.0
raw patch · 11 files changed
+1171/−0 lines, 11 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, binary, bytestring, containers, criterion, deepseq, hashable, random, test-framework, test-framework-hunit, test-framework-quickcheck2, uuid-types
Files
- CHANGES +3/−0
- CONTRIBUTORS +13/−0
- Data/UUID/Types.hs +37/−0
- Data/UUID/Types/Internal.hs +537/−0
- Data/UUID/Types/Internal/Builder.hs +89/−0
- LICENSE +28/−0
- Setup.hs +4/−0
- tests/BenchByteString.hs +82/−0
- tests/BenchUUID.hs +117/−0
- tests/TestUUID.hs +172/−0
- uuid-types.cabal +89/−0
+ CHANGES view
@@ -0,0 +1,3 @@+1.0.0++- Initial split from "uuid-1.3.8"
+ CONTRIBUTORS view
@@ -0,0 +1,13 @@+In order of appearance:++Antoine Latter+Jason Dusek+Tim Newsham+Mark Lentczner+Neil Mitchell+Bas van Dijk+Sergei Trofimovich+davean+Francesco Mazzoli+Michael Snoyman+Bardur Arantsson
+ Data/UUID/Types.hs view
@@ -0,0 +1,37 @@+{- |+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+ ,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 view
@@ -0,0 +1,537 @@+{-# 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+ ,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.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)++-- | 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 view
@@ -0,0 +1,89 @@+{-# 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
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2008, Antoine Latter++All rights reserved.++Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met:++ * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution.+ * The names of the authors may not be used to endorse or promote +products derived from this software without specific prior written +permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+main :: IO ()+main = defaultMain+
+ tests/BenchByteString.hs view
@@ -0,0 +1,82 @@+import Control.Applicative ((<*>))+import Data.Functor ((<$>))++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BC8+import System.Random+import Test.QuickCheck++import Criterion+import Criterion.Main++import Data.UUID.Types++instance Arbitrary UUID where+ arbitrary =+ fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++-- Testing what we do in the codebase+fromASCIIBytes_naive :: ByteString -> Maybe UUID+fromASCIIBytes_naive = fromString . BC8.unpack++toASCIIBytes_naive :: UUID -> ByteString+toASCIIBytes_naive = BC8.pack . toString++randomUUIDs :: IO [UUID]+randomUUIDs = sample' arbitrary++randomCorrect :: IO [String]+randomCorrect = map toString <$> randomUUIDs++randomSlightlyWrong :: IO [String]+randomSlightlyWrong = mapM screw =<< randomCorrect+ where+ screw s = do+ ix <- randomRIO (0, length s - 1)+ return (take ix s ++ "x" ++ drop (ix + 1) s)++randomVeryWrong :: IO [String]+randomVeryWrong = sample' arbitrary++main :: IO ()+main = do+ uuids <- randomUUIDs+ correct <- randomCorrect+ let correctBytes = map BC8.pack correct+ slightlyWrong <- randomSlightlyWrong+ let slightlyWrongBytes = map BC8.pack slightlyWrong+ veryWrong <- randomVeryWrong+ let veryWrongBytes = map BC8.pack veryWrong++ defaultMain+ [ bgroup "decoding"+ [ bcompare+ [ bgroup "correct"+ [ bench "fromASCIIBytes" (nf (map fromASCIIBytes) correctBytes)+ , bench "fromString" (nf (map fromString) correct)+ , bench "fromASCIIBytes_naive" (nf (map fromASCIIBytes_naive) correctBytes)+ ]+ ]+ , bcompare+ [ bgroup "slightly wrong"+ [ bench "fromASCIIBytes" (nf (map fromASCIIBytes) slightlyWrongBytes)+ , bench "fromString" (nf (map fromString) slightlyWrong)+ , bench "fromASCIIBytes_naive" (nf (map fromASCIIBytes_naive) slightlyWrongBytes)+ ]+ ]+ , bcompare+ [ bgroup "very wrong"+ [ bench "fromASCIIBytes" (nf (map fromASCIIBytes) veryWrongBytes)+ , bench "fromString" (nf (map fromString) veryWrong)+ , bench "fromASCIIBytes_naive" (nf (map fromASCIIBytes_naive) veryWrongBytes)+ ]+ ]+ ]+ , bcompare+ [ bgroup "encoding"+ [ bench "toASCIIBytes" (nf (map toASCIIBytes) uuids)+ , bench "toString" (nf (map toString) uuids)+ , bench "toASCIIBytes_naive" (nf (map toASCIIBytes_naive) uuids)+ ]+ ]+ ]
+ tests/BenchUUID.hs view
@@ -0,0 +1,117 @@+{-# 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" $ 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
@@ -0,0 +1,172 @@+{-# LANGUAGE ViewPatterns #-}+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 qualified Test.HUnit as H+import Test.HUnit hiding (Test)+import Test.QuickCheck hiding ((.&.))+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import Test.Framework.Providers.QuickCheck2 (testProperty)+++instance Arbitrary U.UUID where+ -- the UUID random instance ignores bounds+ arbitrary = choose (U.nil, U.nil)+++test_null :: H.Test+test_null = H.TestList [+ "nil is null" ~: assertBool "" (U.null U.nil)+ ]++test_nil :: H.Test+test_nil = H.TestList [+ "nil string" ~: U.toString U.nil @?= "00000000-0000-0000-0000-000000000000",+ "nil bytes" ~: U.toByteString U.nil @?= BL.pack (replicate 16 0)+ ]++test_conv :: H.Test+test_conv = H.TestList [+ "conv bytes to string" ~:+ maybe "" (U.toString) (U.fromByteString b16) @?= s16,+ "conv string to bytes" ~:+ maybe BL.empty (U.toByteString) (U.fromString s16) @?= b16+ ]+ where b16 = BL.pack [1..16]+ s16 = "01020304-0506-0708-090a-0b0c0d0e0f10"++-- | Test fromByteString with a fixed-input.+test_fromByteString :: H.Test+test_fromByteString =+ "UUID fromByteString" ~:+ Just inputUUID @=?+ U.fromByteString (BL8.pack "\165\202\133f\217\197H5\153\200\225\241>s\181\226")++-- | Test fromWords with a fixed-input+test_fromWords :: H.Test+test_fromWords =+ "UUID fromWords" ~:+ inputUUID @=? U.fromWords 2781513062 3653584949 2580079089 1047770594++inputUUID :: U.UUID+inputUUID = read "a5ca8566-d9c5-4835-99c8-e1f13e73b5e2"++prop_stringRoundTrip :: Test+prop_stringRoundTrip = testProperty "String round trip" stringRoundTrip+ where stringRoundTrip :: U.UUID -> Bool+ stringRoundTrip u = maybe False (== u) $ U.fromString (U.toString u)++prop_byteStringRoundTrip :: Test+prop_byteStringRoundTrip = testProperty "ByteString round trip" byteStringRoundTrip+ where byteStringRoundTrip :: U.UUID -> Bool+ byteStringRoundTrip u = maybe False (== u)+ $ U.fromByteString (U.toByteString u)++prop_stringLength :: Test+prop_stringLength = testProperty "String length" stringLength+ where stringLength :: U.UUID -> Bool+ stringLength u = length (U.toString u) == 36++prop_byteStringLength :: Test+prop_byteStringLength = testProperty "ByteString length" byteStringLength+ where byteStringLength :: U.UUID -> Bool+ byteStringLength u = BL.length (U.toByteString u) == 16++prop_randomsDiffer :: Test+prop_randomsDiffer = testProperty "Randoms differ" randomsDiffer+ where randomsDiffer :: (U.UUID, U.UUID) -> Bool+ randomsDiffer (u1, u2) = u1 /= u2++prop_randomNotNull :: Test+prop_randomNotNull = testProperty "Random not null" randomNotNull+ where randomNotNull :: U.UUID -> Bool+ randomNotNull = not. U.null++prop_readShowRoundTrip :: Test+prop_readShowRoundTrip = testProperty "Read/Show round-trip" prop+ where -- we're using 'Maybe UUID' to add a bit of+ -- real-world complexity.+ prop :: U.UUID -> Bool+ prop uuid = read (show (Just uuid)) == Just uuid++-- Mostly going to test for wrong UUIDs+fromASCIIBytes_fromString1 :: String -> Bool+fromASCIIBytes_fromString1 s =+ if all (\c -> ord c < 256) s+ then U.fromString s == U.fromASCIIBytes (BC8.pack s)+ else True++fromASCIIBytes_fromString2 :: U.UUID -> Bool+fromASCIIBytes_fromString2 (U.toString -> s) =+ U.fromString s == U.fromASCIIBytes (BC8.pack s)++toASCIIBytes_toString :: U.UUID -> Bool+toASCIIBytes_toString uuid =+ U.toString uuid == BC8.unpack (U.toASCIIBytes uuid)++fromASCIIBytes_toASCIIBytes :: U.UUID -> Bool+fromASCIIBytes_toASCIIBytes (BC8.pack . U.toString -> bs) =+ Just bs == (U.toASCIIBytes <$> U.fromASCIIBytes bs)++toASCIIBytes_fromASCIIBytes :: U.UUID -> Bool+toASCIIBytes_fromASCIIBytes uuid =+ Just uuid == U.fromASCIIBytes (U.toASCIIBytes uuid)++toWords_fromWords :: U.UUID -> Bool+toWords_fromWords uuid =+ uuid == myUncurry4 U.fromWords (U.toWords uuid)++fromWords_toWords :: (Word32, Word32, Word32, Word32) -> Bool+fromWords_toWords wds =+ wds == U.toWords (myUncurry4 U.fromWords wds)++myUncurry4 :: (x1 -> x2 -> x3 -> x4 -> y) -> (x1, x2, x3, x4) -> y+myUncurry4 f (a,b,c,d) = f a b c d++prop_storableRoundTrip :: Test+prop_storableRoundTrip =+ testProperty "Storeable round-trip" $ unsafePerformIO . prop+ where+ prop :: U.UUID -> IO Bool+ prop uuid =+ alloca $ \ptr -> do+ poke ptr uuid+ uuid2 <- peek ptr+ return $ uuid == uuid2++main :: IO ()+main = do+ defaultMain $+ concat $+ [ hUnitTestToTests $ H.TestList [+ test_null,+ test_nil,+ test_conv,+ test_fromByteString,+ test_fromWords+ ]+ , [ prop_stringRoundTrip,+ prop_readShowRoundTrip,+ prop_byteStringRoundTrip,+ prop_storableRoundTrip,+ prop_stringLength,+ prop_byteStringLength,+ prop_randomsDiffer,+ prop_randomNotNull+ ]+ , [ testProperty "fromASCIIBytes_fromString1" fromASCIIBytes_fromString1+ , testProperty "fromASCIIBytes_fromString2" fromASCIIBytes_fromString2+ , testProperty "fromASCIIBytes_toString" toASCIIBytes_toString+ , testProperty "fromASCIIBytes_toASCIIBytes" fromASCIIBytes_toASCIIBytes+ , testProperty "toASCIIBytes_fromASCIIBytes" toASCIIBytes_fromASCIIBytes+ , testProperty "toWords_fromWords" toWords_fromWords+ , testProperty "fromWords_toWords" fromWords_toWords+ ]+ ]
+ uuid-types.cabal view
@@ -0,0 +1,89 @@+Name: uuid-types+Version: 1.0.0+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++Description:+ This library contains type definitions for Universally Unique Identifiers+ and basic conversion functions.++ See <http://en.wikipedia.org/wiki/UUID> for the general idea.++Synopsis: Type definitions for Universally Unique Identifiers++Homepage: https://github.com/aslatter/uuid+Bug-Reports: https://github.com/aslatter/uuid/issues++Extra-Source-Files:+ CHANGES+ CONTRIBUTORS+++Library+ Build-Depends: base >=3 && < 5,+ binary >= 0.4 && < 0.8,+ 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++ Exposed-Modules:+ Data.UUID.Types+ -- Exposed for companion projects; *NOT* part of the official API:+ Data.UUID.Types.Internal.Builder+ Data.UUID.Types.Internal++ Extensions: DeriveDataTypeable+ Ghc-Options: -Wall++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+ Extensions: DeriveDataTypeable+ Ghc-Options: -Wall -fno-warn-orphans+ Build-Depends: base >= 3 && < 5,+ uuid-types,+ bytestring >= 0.9 && < 0.11,+ HUnit >=1.2 && < 1.3,+ QuickCheck >=2.4 && < 2.8,+ test-framework == 0.8.*,+ test-framework-hunit == 0.3.*,+ test-framework-quickcheck2 == 0.3.*++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 && < 0.9,+ deepseq >= 1.1 && < 1.4,+ random >= 1.0.1 && < 1.2++benchmark benchbytestring+ Type: exitcode-stdio-1.0+ Hs-Source-Dirs: tests+ Main-Is: BenchByteString.hs+ Ghc-Options: -threaded -rtsopts -Wall -O2 -fno-warn-orphans+ Build-Depends: base >= 4 && < 5+ , uuid-types+ , bytestring >= 0.10+ , criterion >= 0.8+ , random >= 1.0+ , QuickCheck >= 2