diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,6 +1,11 @@ -1.2.14.1 +1.3.0 -- Maintainance release for supporting GHC 7.4 through GHC 8.6 +- New functions for parsing and printing UUIDs to and from ASCII BytesStrings +- New module Data.UUID.Util. This module includes the type 'UnpackedUUID', + whose fields correspond to the UUID fields described in RFC 4122. +- The Storable instance now stores a UUID in host byte-order instead of + big endian. +- There is now an instance for 'Hashable UUID'. 1.2.13 diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -7,3 +7,5 @@ Neil Mitchell Bas van Dijk Sergei Trofimovich +davean +Francesco Mazzoli diff --git a/Data/UUID.hs b/Data/UUID.hs --- a/Data/UUID.hs +++ b/Data/UUID.hs @@ -27,6 +27,10 @@ module Data.UUID(UUID ,toString ,fromString + ,toASCIIBytes + ,fromASCIIBytes + ,toLazyASCIIBytes + ,fromLazyASCIIBytes ,toByteString ,fromByteString ,toWords diff --git a/Data/UUID/Internal.hs b/Data/UUID/Internal.hs --- a/Data/UUID/Internal.hs +++ b/Data/UUID/Internal.hs @@ -24,15 +24,26 @@ ,toList ,buildFromBytes ,buildFromWords + ,fromASCIIBytes + ,toASCIIBytes + ,fromLazyASCIIBytes + ,toLazyASCIIBytes + ,UnpackedUUID(..) + ,pack + ,unpack ) where import Prelude hiding (null) -import Control.Monad (liftM4) +import Control.Applicative ((<*>)) +import Control.DeepSeq (NFData(..)) +import Control.Monad (liftM4, guard) +import Data.Functor ((<$>)) import Data.Char -import Data.Maybe import Data.Bits +import Data.Hashable import Data.List (elemIndices) +import Foreign.Ptr (Ptr) #if MIN_VERSION_base(4,0,0) import Data.Data @@ -45,9 +56,13 @@ import Data.Binary import Data.Binary.Put import Data.Binary.Get -import qualified Data.ByteString.Lazy as Lazy +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.Builder +import Data.Word.Util import System.Random @@ -89,6 +104,54 @@ 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 -- @@ -175,12 +238,12 @@ -- |Extract a UUID from a 'ByteString' in network byte order. -- The argument must be 16 bytes long, otherwise 'Nothing' is returned. -fromByteString :: Lazy.ByteString -> Maybe UUID -fromByteString = fromList . Lazy.unpack +fromByteString :: BL.ByteString -> Maybe UUID +fromByteString = fromList . BL.unpack -- |Encode a UUID into a 'ByteString' in network order. -toByteString :: UUID -> Lazy.ByteString -toByteString = Lazy.pack . toList +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. @@ -221,7 +284,7 @@ -- Example: -- -- @ --- toString $ fromString \"550e8400-e29b-41d4-a716-446655440000\" +-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\" -- @ toString :: UUID -> String toString (UUID w0 w1 w2 w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 "" @@ -236,8 +299,106 @@ 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 = BL.fromStrict . 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 (BL.toStrict bs) else Nothing + +-- -- Class Instances -- @@ -273,7 +434,20 @@ 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 @@ -287,14 +461,39 @@ instance Storable UUID where sizeOf _ = 16 - alignment _ = 1 -- UUIDs are stored as individual octets + alignment _ = 4 peekByteOff p off = - mapM (peekByteOff p) [off..(off+15)] >>= return . fromJust . fromList + 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 = - sequence_ $ zipWith (pokeByteOff p) [off..] (toList 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) = diff --git a/Data/UUID/Util.hs b/Data/UUID/Util.hs new file mode 100644 --- /dev/null +++ b/Data/UUID/Util.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.UUID.Util ( + UnpackedUUID(..) + , unpack, pack + , version + , extractMac + , extractTime + , setTime + ) where + +import Prelude hiding (null) +import Data.Word +import Data.Word.Util +import Data.Bits +import Data.UUID.Internal +import Network.Info +import Data.Int (Int64) + +version :: UUID -> Int +version uuid = + fromEnum ((time_hi_and_version unpacked `shiftR` 12) .&. 0xF) + where + unpacked = unpack uuid + +-- Note UUID time is in 10^-7 seconds. +setTime :: (Integral a, Bits a) => UUID -> a -> Maybe UUID +setTime uuid t = + if version uuid == 1 + then Just $ pack $ (unpack uuid){time_low = new_low_bits, time_mid = new_mid_bits, time_hi_and_version = new_hi_and_version_bits} + else Nothing + where new_low_bits = fromIntegral $ t .&. 0xFFFFFFFF + new_mid_bits = fromIntegral $ (t `shiftR` 32) .&. 0xFFFF + new_hi_and_version_bits = fromIntegral $ 0x1000 .|. ((t `shiftR` 48) .&. 0x0FFF) + +extractTime :: UUID -> Maybe Int64 +extractTime uuid = + if version uuid == 1 + then Just $ fromIntegral $ w32to64 (w16to32 (timeAndVersionToTime $ time_hi_and_version unpacked) $ time_mid unpacked) (time_low unpacked) + else Nothing + where + unpacked = unpack uuid + +timeAndVersionToTime :: Word16 -> Word16 +timeAndVersionToTime tv = tv .&. 0x0FFF + +extractMac :: UUID -> Maybe MAC +extractMac uuid = + if version uuid == 1 + then Just $ + MAC (node_0 unpacked) (node_1 unpacked) (node_2 unpacked) (node_3 unpacked) (node_4 unpacked) (node_5 unpacked) + else Nothing + where + unpacked = unpack uuid + diff --git a/Data/UUID/V1.hs b/Data/UUID/V1.hs --- a/Data/UUID/V1.hs +++ b/Data/UUID/V1.hs @@ -25,9 +25,10 @@ module Data.UUID.V1(nextUUID) where -import Data.Time import Data.Bits +import Data.Maybe +import Data.Time import Data.Word import Control.Applicative ((<$>),(<*>)) @@ -36,8 +37,7 @@ import qualified System.Random as R -import qualified System.Info.MAC as SysMAC -import Data.MAC +import Network.Info import Data.UUID.Builder import Data.UUID.Internal @@ -52,13 +52,13 @@ nextUUID = do res <- stepTime case res of - Just (mac, c, t) -> return $ Just $ makeUUID t c mac + Just (mac', c, t) -> return $ Just $ makeUUID t c mac' _ -> return Nothing makeUUID :: Word64 -> Word16 -> MAC -> UUID -makeUUID time clock mac = - buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac) +makeUUID time clock mac' = + buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac') where tLow = (fromIntegral time) :: Word32 tMid = (fromIntegral (time `shiftR` 32)) :: Word16 tHigh = (fromIntegral (time `shiftR` 48)) :: Word16 @@ -75,17 +75,17 @@ stepTime :: IO (Maybe (MAC, Word16, Word64)) stepTime = do h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime - modifyMVar state $ \s@(State mac c0 h0) -> + modifyMVar state $ \s@(State mac' c0 h0) -> if h1 > h0 then - return (State mac c0 h1, Just (mac, c0, h1)) + return (State mac' c0 h1, Just (mac', c0, h1)) else let c1 = succ c0 in if c1 <= 0x3fff -- when clock is initially randomized, -- then this test will need to change then - return (State mac c1 h1, Just (mac, c1, h1)) + return (State mac' c1 h1, Just (mac', c1, h1)) else return (s, Nothing) @@ -94,16 +94,17 @@ state :: MVar State state = unsafePerformIO $ do h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime - mac <- getMac - newMVar $ State mac 0 h0 -- the 0 should be a random number + mac' <- getMac + newMVar $ State mac' 0 h0 -- the 0 should be a random number -- SysMAC.mac can fail on some machines. -- In those cases we fake it with a random -- 6 bytes seed. getMac :: IO MAC getMac = - SysMAC.mac >>= \macM -> - case macM of + getNetworkInterfaces >>= + return . listToMaybe . filter (minBound /=) . map mac >>= + \macM -> case macM of Just m -> return m Nothing -> randomMac @@ -112,7 +113,7 @@ -- I'm too lazy to thread through -- the random state ... MAC - <$> R.randomIO + <$> (R.randomIO >>= return . (1 .|.)) -- We must set the multicast bit to True. See section 4.5 of the RFC. <*> R.randomIO <*> R.randomIO <*> R.randomIO diff --git a/Data/Word/Util.hs b/Data/Word/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Word/Util.hs @@ -0,0 +1,36 @@ + +-- | Internal utilites +module Data.Word.Util where + +import Data.Bits +import Data.Word + +w8to32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 +w8to32 w0s w1s w2s w3s = + (w0 `shiftL` 24) .|. (w1 `shiftL` 16) .|. (w2 `shiftL` 8) .|. w3 + where + w0 = fromIntegral w0s + w1 = fromIntegral w1s + w2 = fromIntegral w2s + w3 = fromIntegral w3s + +w8to16 :: Word8 -> Word8 -> Word16 +w8to16 w0s w1s = + (w0 `shiftL` 8) .|. w1 + where + w0 = fromIntegral w0s + w1 = fromIntegral w1s + +w16to32 :: Word16 -> Word16 -> Word32 +w16to32 w0s w1s = + (w0 `shiftL` 16) .|. w1 + where + w0 = fromIntegral w0s + w1 = fromIntegral w1s + +w32to64 :: Word32 -> Word32 -> Word64 +w32to64 w0s w1s = + (w0 `shiftL` 32) .|. w1 + where + w0 = fromIntegral w0s + w1 = fromIntegral w1s diff --git a/tests/BenchByteString.hs b/tests/BenchByteString.hs new file mode 100644 --- /dev/null +++ b/tests/BenchByteString.hs @@ -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 + +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) + ] + ] + ] diff --git a/tests/BenchUUID.hs b/tests/BenchUUID.hs --- a/tests/BenchUUID.hs +++ b/tests/BenchUUID.hs @@ -1,6 +1,10 @@ {-# 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.Char (ord) import Data.IORef @@ -8,11 +12,11 @@ import Data.Word import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Internal as BL import qualified Data.UUID as U import qualified Data.UUID.V1 as U import qualified Data.UUID.V3 as U3 import qualified Data.UUID.V5 as U5 +import Foreign (alloca, peek, poke) import System.Random import System.Random.Mersenne.Pure64 @@ -22,9 +26,6 @@ rnf (BL.Chunk _ ts) = rnf ts #endif -instance NFData U.UUID where - - main :: IO () main = do u1 <- randomIO @@ -47,6 +48,11 @@ writeIORef randomState state' return uuid + -- setup for Storable benchmark + alloca $ \ uuidPtr -> do + + poke uuidPtr u1 + defaultMain [ bgroup "testing" [ bench "null non-nil" $ whnf U.null u1, @@ -67,7 +73,12 @@ bench "V3" $ nf (U3.generateNamed U3.namespaceURL) n1, bench "V5" $ nf (U5.generateNamed U5.namespaceURL) n1 ], - bench "set making" $ nf Set.fromList uuids + 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 diff --git a/tests/TestUUID.hs b/tests/TestUUID.hs --- a/tests/TestUUID.hs +++ b/tests/TestUUID.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE ViewPatterns #-} import Control.Monad (replicateM) import Data.Bits -import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC8 import Data.Char (ord) +import Data.Functor ((<$>)) import Data.List (nub, (\\)) import Data.Maybe import Data.Word @@ -9,21 +12,22 @@ import qualified Data.UUID.V1 as U import qualified Data.UUID.V3 as U3 import qualified Data.UUID.V5 as U5 +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 (defaultMain, Test) import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.Framework.Providers.QuickCheck2 (testProperty) -import System.IO isValidVersion :: Int -> U.UUID -> Bool isValidVersion v u = lenOK && variantOK && versionOK where bs = U.toByteString u - lenOK = B.length bs == 16 - variantOK = (B.index bs 8) .&. 0xc0 == 0x80 - versionOK = (B.index bs 6) .&. 0xf0 == fromIntegral (v `shiftL` 4) + lenOK = BL.length bs == 16 + variantOK = (BL.index bs 8) .&. 0xc0 == 0x80 + versionOK = (BL.index bs 6) .&. 0xf0 == fromIntegral (v `shiftL` 4) instance Arbitrary U.UUID where @@ -40,7 +44,7 @@ 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 @?= B.pack (replicate 16 0) + "nil bytes" ~: U.toByteString U.nil @?= BL.pack (replicate 16 0) ] test_conv :: H.Test @@ -48,9 +52,9 @@ "conv bytes to string" ~: maybe "" (U.toString) (U.fromByteString b16) @?= s16, "conv string to bytes" ~: - maybe B.empty (U.toByteString) (U.fromString s16) @?= b16 + maybe BL.empty (U.toByteString) (U.fromString s16) @?= b16 ] - where b16 = B.pack [1..16] + where b16 = BL.pack [1..16] s16 = "01020304-0506-0708-090a-0b0c0d0e0f10" test_v1 :: [Maybe U.UUID] -> H.Test @@ -97,7 +101,7 @@ prop_byteStringLength :: Test prop_byteStringLength = testProperty "ByteString length" byteStringLength where byteStringLength :: U.UUID -> Bool - byteStringLength u = B.length (U.toByteString u) == 16 + byteStringLength u = BL.length (U.toByteString u) == 16 prop_randomsDiffer :: Test prop_randomsDiffer = testProperty "Randoms differ" randomsDiffer @@ -141,6 +145,40 @@ 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) + +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 v1s <- replicateM 100 U.nextUUID @@ -157,6 +195,7 @@ , [ prop_stringRoundTrip, prop_readShowRoundTrip, prop_byteStringRoundTrip, + prop_storableRoundTrip, prop_stringLength, prop_byteStringLength, prop_randomsDiffer, @@ -167,4 +206,10 @@ prop_v5NotNull, prop_v5Valid ] - ] + , [ 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 + ] + ] diff --git a/uuid.cabal b/uuid.cabal --- a/uuid.cabal +++ b/uuid.cabal @@ -1,43 +1,44 @@ -Cabal-Version: 1.12 Name: uuid -Version: 1.2.14.1 - +Version: 1.3.0 Copyright: (c) 2008-2013 Antoine Latter Author: Antoine Latter -Maintainer: hvr@gnu.org +Maintainer: aslatter@gmail.com License: BSD3 License-file: LICENSE Category: Data Build-Type: Simple +Cabal-Version: >= 1.8 Description: This library is useful for creating, comparing, parsing and printing Universally Unique Identifiers. - . See for the general idea. Synopsis: For creating, comparing, parsing and printing Universally Unique Identifiers -Homepage: https://github.com/hvr/uuid -Bug-Reports: https://github.com/hvr/uuid/issues +Homepage: http://projects.haskell.org/uuid/ +Bug-Reports: mailto:aslatter@gmail.com Extra-Source-Files: CHANGES CONTRIBUTORS + Library - Build-Depends: base >= 4.5 && < 4.13 - , binary >= 0.4 && < 0.9 - , bytestring >= 0.9 && < 0.11 - , cryptohash-md5 >= 0.11.100 && < 0.12 - , cryptohash-sha1 >= 0.11.100 && < 0.12 - , maccatcher >= 1.0 && < 2.2 - , random >= 1.0.1 && < 1.1 - , time >= 1.1 && < 1.9 + Build-Depends: base >=3 && < 5, + binary >= 0.4 && < 0.8, + bytestring >= 0.9 && < 1.1, + cryptohash >= 0.7 && < 0.12, + deepseq == 1.3.*, + hashable == 1.2.*, + network-info == 0.2.*, + random >= 1.0.1 && < 1.1, + time >= 1.1 && < 1.5 Exposed-Modules: Data.UUID + Data.UUID.Util Data.UUID.V1 Data.UUID.V3 Data.UUID.V4 @@ -47,44 +48,55 @@ Data.UUID.Builder Data.UUID.Internal Data.UUID.Named + Data.Word.Util - Default-Language: Haskell2010 - Default-Extensions: DeriveDataTypeable + Extensions: DeriveDataTypeable Ghc-Options: -Wall -Source-Repository head - Type: git - Location: https://github.com/hvr/uuid.git - Subdir: uuid - -Benchmark benchmark - Type: exitcode-stdio-1.0 - Main-is: BenchUUID.hs - Hs-source-dirs: tests - Default-Language: Haskell2010 - Default-Extensions: DeriveDataTypeable, CPP - Build-depends: base, - uuid, - bytestring, - containers >= 0.4 && < 0.6, - criterion >= 0.4 && < 0.9, - deepseq >= 1.1 && < 1.5, - mersenne-random-pure64, - random +source-repository head + type: darcs + location: http://code.haskell.org/uuid Test-Suite testuuid Type: exitcode-stdio-1.0 Main-is: TestUUID.hs Hs-source-dirs: tests - Default-Language: Haskell2010 - Default-Extensions: DeriveDataTypeable + Extensions: DeriveDataTypeable Ghc-Options: -Wall -fno-warn-orphans - Build-Depends: base, + Build-Depends: base >= 3 && < 5, uuid, - bytestring, - HUnit == 1.6.*, - QuickCheck == 2.7.*, - random, + bytestring >= 0.9 && < 1.1, + HUnit >=1.2 && < 1.3, + QuickCheck >=2.4 && < 2.7, + random >= 1.0.1 && < 1.1, 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, + bytestring >= 0.9 && < 1.1, + containers >= 0.4 && < 0.6, + criterion >= 0.4 && < 0.9, + deepseq >= 1.1 && < 1.4, + mersenne-random-pure64, + random >= 1.0.1 && < 1.1 + +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 + , bytestring >= 0.10 + , criterion >= 0.8 + , random >= 1.0 + , QuickCheck >= 2 +