master..07cfb8f · typeable/uuid

.github/workflows/haskell-ci-bench.yml+6−11

@@ -8,9 +8,9 @@

88#

99# For more information, see https://github.com/haskell-CI/haskell-ci

1010#

11−# version: 0.19.20240702

11+# version: 0.19.20240514

1212#

13−# REGENDATA ("0.19.20240702",["github","--project","cabal.bench.project","-o",".github/workflows/haskell-ci-bench.yml","--github-action-name","Benchmarks"])

13+# REGENDATA ("0.19.20240514",["github","--project","cabal.bench.project","-o",".github/workflows/haskell-ci-bench.yml","--github-action-name","Benchmarks"])

1414#

1515name: Benchmarks

1616on:

@@ -32,19 +32,14 @@ jobs:

3232 strategy:

3333 matrix:

3434 include:

35− - compiler: ghc-9.10.1

36− compilerKind: ghc

37− compilerVersion: 9.10.1

38− setup-method: ghcup

39− allow-failure: false

4035 - compiler: ghc-9.8.2

4136 compilerKind: ghc

4237 compilerVersion: 9.8.2

4338 setup-method: ghcup

4439 allow-failure: false

45− - compiler: ghc-9.6.6

40+ - compiler: ghc-9.6.4

4641 compilerKind: ghc

47− compilerVersion: 9.6.6

42+ compilerVersion: 9.6.4

4843 setup-method: ghcup

4944 allow-failure: false

5045 - compiler: ghc-9.4.8

@@ -87,7 +82,7 @@ jobs:

8782 curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"

8883 chmod a+x "$HOME/.ghcup/bin/ghcup"

8984 "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)

90− "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)

85+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)

9186 env:

9287 HCKIND: ${{ matrix.compilerKind }}

9388 HCNAME: ${{ matrix.compiler }}

@@ -105,7 +100,7 @@ jobs:

105100 echo "HC=$HC" >> "$GITHUB_ENV"

106101 echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"

107102 echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"

108− echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"

103+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"

109104 HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')

110105 echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

111106 echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

.github/workflows/haskell-ci.yml+25−35

@@ -8,9 +8,9 @@

88#

99# For more information, see https://github.com/haskell-CI/haskell-ci

1010#

11−# version: 0.19.20241223

11+# version: 0.19.20240514

1212#

13−# REGENDATA ("0.19.20241223",["github","cabal.project"])

13+# REGENDATA ("0.19.20240514",["github","cabal.project"])

1414#

1515name: Haskell-CI

1616on:

@@ -32,24 +32,19 @@ jobs:

3232 strategy:

3333 matrix:

3434 include:

35− - compiler: ghc-9.12.1

36− compilerKind: ghc

37− compilerVersion: 9.12.1

38− setup-method: ghcup

39− allow-failure: false

4035 - compiler: ghc-9.10.1

4136 compilerKind: ghc

4237 compilerVersion: 9.10.1

4338 setup-method: ghcup

4439 allow-failure: false

45− - compiler: ghc-9.8.4

40+ - compiler: ghc-9.8.2

4641 compilerKind: ghc

47− compilerVersion: 9.8.4

42+ compilerVersion: 9.8.2

4843 setup-method: ghcup

4944 allow-failure: false

50− - compiler: ghc-9.6.6

45+ - compiler: ghc-9.6.5

5146 compilerKind: ghc

52− compilerVersion: 9.6.6

47+ compilerVersion: 9.6.5

5348 setup-method: ghcup

5449 allow-failure: false

5550 - compiler: ghc-9.4.8

@@ -84,29 +79,15 @@ jobs:

8479 allow-failure: false

8580 fail-fast: false

8681 steps:

87− - name: apt-get install

82+ - name: apt

8883 run: |

8984 apt-get update

9085 apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5

91− - name: Install GHCup

92− run: |

9386 mkdir -p "$HOME/.ghcup/bin"

94− curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"

87+ curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"

9588 chmod a+x "$HOME/.ghcup/bin/ghcup"

96− - name: Install cabal-install

97− run: |

98− "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)

99− echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"

100− - name: Install GHC (GHCup)

101− if: matrix.setup-method == 'ghcup'

102− run: |

10389 "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)

104− HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")

105− HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')

106− HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')

107− echo "HC=$HC" >> "$GITHUB_ENV"

108− echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"

109− echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"

90+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)

11091 env:

11192 HCKIND: ${{ matrix.compilerKind }}

11293 HCNAME: ${{ matrix.compiler }}

@@ -117,12 +98,21 @@ jobs:

11798 echo "LANG=C.UTF-8" >> "$GITHUB_ENV"

11899 echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"

119100 echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"

101+ HCDIR=/opt/$HCKIND/$HCVER

102+ HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")

103+ HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')

104+ HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')

105+ echo "HC=$HC" >> "$GITHUB_ENV"

106+ echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"

107+ echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"

108+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"

120109 HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')

121110 echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

122111 echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

123112 echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"

124113 echo "HEADHACKAGE=false" >> "$GITHUB_ENV"

125114 echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"

115+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"

126116 env:

127117 HCKIND: ${{ matrix.compilerKind }}

128118 HCNAME: ${{ matrix.compiler }}

@@ -179,7 +169,7 @@ jobs:

179169 run: |

180170 touch cabal.project

181171 echo "packages: $GITHUB_WORKSPACE/source/uuid-types" >> cabal.project

182− echo "packages: $GITHUB_WORKSPACE/source/uuid" >> cabal.project

172+ if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: $GITHUB_WORKSPACE/source/uuid" >> cabal.project ; fi

183173 cat cabal.project

184174 - name: sdist

185175 run: |

@@ -199,11 +189,11 @@ jobs:

199189 touch cabal.project

200190 touch cabal.project.local

201191 echo "packages: ${PKGDIR_uuid_types}" >> cabal.project

202− echo "packages: ${PKGDIR_uuid}" >> cabal.project

192+ if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "packages: ${PKGDIR_uuid}" >> cabal.project ; fi

203193 echo "package uuid-types" >> cabal.project

204194 echo " ghc-options: -Werror=missing-methods" >> cabal.project

205− echo "package uuid" >> cabal.project

206− echo " ghc-options: -Werror=missing-methods" >> cabal.project

195+ if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo "package uuid" >> cabal.project ; fi

196+ if [ $((HCNUMVER < 91000)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi

207197 cat >> cabal.project <<EOF

208198 EOF

209199 $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(uuid|uuid-types)$/; }' >> cabal.project.local

@@ -236,8 +226,8 @@ jobs:

236226 run: |

237227 cd ${PKGDIR_uuid_types} || false

238228 ${CABAL} -vnormal check

239− cd ${PKGDIR_uuid} || false

240− ${CABAL} -vnormal check

229+ if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cd ${PKGDIR_uuid} || false ; fi

230+ if [ $((HCNUMVER < 91000)) -ne 0 ] ; then ${CABAL} -vnormal check ; fi

241231 - name: haddock

242232 run: |

243233 $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all

@@ -255,8 +245,8 @@ jobs:

255245 $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='random==1.2.*' --dependencies-only -j2 all

256246 $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='random==1.2.*' all

257247 - name: save cache

258− if: always()

259248 uses: actions/cache/save@v4

249+ if: always()

260250 with:

261251 key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}

262252 path: ~/.cabal/store

cabal.haskell-ci+1−1

@@ -1,5 +1,5 @@

11branches: master

2−-- jobs-selection: any

2+jobs-selection: any

33head-hackage: False

44

55constraint-set random-1.2

uuid-bench/bench/uuid-benchmark.hs+1

@@ -3,6 +3,7 @@ import Data.Char (ord)

33import Data.IORef

44import Data.Word

55import qualified Data.UUID as U

6+import qualified Data.UUID.V1 as U

67import qualified Data.UUID.V4 as U

78import qualified Data.UUID.V3 as U3

89import qualified Data.UUID.V5 as U5

uuid-bench/uuid-bench.cabal+7−7

@@ -20,9 +20,8 @@ tested-with:

2020 || ==9.0.2

2121 || ==9.2.8

2222 || ==9.4.8

23− || ==9.6.6

23+ || ==9.6.4

2424 || ==9.8.2

25− || ==9.10.1

2625

2726synopsis: UUID benchmarks

2827description:

@@ -47,10 +46,10 @@ library

4746 , cryptohash-sha1 >=0.11.100 && <0.12

4847 , deepseq >=1.4.4.0 && <1.6

4948 , entropy >=0.3.7 && <0.5

50− , hashable >=1.4.4.0 && <1.6

49+ , hashable >=1.4.4.0 && <1.5

5150 , network-info >=0.2 && <0.3

5251 , random >=1.2.1.2 && <1.3

53− , template-haskell >=2.14.0.0 && <2.23

52+ , template-haskell >=2.14.0.0 && <2.22

5453 , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2

5554 , time >=1.4 && <1.13

5655

@@ -58,6 +57,7 @@ library

5857 exposed-modules:

5958 Data.UUID

6059 Data.UUID.Util

60+ Data.UUID.V1

6161 Data.UUID.V3

6262 Data.UUID.V4

6363 Data.UUID.V5

@@ -99,13 +99,13 @@ benchmark uuid-types-benchmark

9999

100100 -- deps w/o inherited constraints

101101 build-depends:

102− containers >=0.5 && <0.8

102+ containers >=0.5 && <0.7

103103 , criterion >=1.5 && <1.7

104104 , unordered-containers >=0.2.7 && <0.3

105105

106106benchmark uuid-benchmark

107107 type: exitcode-stdio-1.0

108− main-is: uuid-benchmark.hs

108+ main-is: uuid-benchmark.hs

109109 hs-source-dirs: bench

110110 default-language: Haskell2010

111111 default-extensions:

@@ -118,7 +118,7 @@ benchmark uuid-benchmark

118118 build-depends:

119119 base

120120 , random

121− , uuid-bench

121+ , uuid

122122

123123 -- deps w/o inherited constraints

124124 build-depends:

uuid-types/src/Data/UUID/Types/Internal.hs+3−1

@@ -46,11 +46,13 @@ module Data.UUID.Types.Internal

4646

4747import Prelude hiding (null)

4848

49+import Control.Applicative ((<*>))

4950import Control.DeepSeq (NFData (..))

5051import Control.Monad (guard, liftM2)

5152import Data.Bits

5253import Data.Char

5354import Data.Data

55+import Data.Functor ((<$>))

5456import Data.Hashable

5557import Data.List (elemIndices)

5658import Foreign.Ptr (Ptr)

@@ -77,7 +79,7 @@ import Language.Haskell.TH.Syntax (Lift)

7779-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in

7880-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.

7981data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64

80− deriving (Eq, Ord)

82+ deriving (Eq, Ord, Typeable)

8183{-

8284 Prior to uuid-types-1.0.4:

8385 !Word32 !Word32 !Word32 !Word32

uuid-types/uuid-types.cabal+6−10

@@ -1,7 +1,6 @@

11cabal-version: 1.12

22name: uuid-types

33version: 1.0.6

4−x-revision: 2

54copyright:

@@ -19,10 +18,9 @@ tested-with:

1918 || ==9.0.2

2019 || ==9.2.8

2120 || ==9.4.8

22− || ==9.6.6

23− || ==9.8.4

21+ || ==9.6.5

22+ || ==9.8.2

2423 || ==9.10.1

25− || ==9.12.1

2624

2725synopsis: Type definitions for Universally Unique Identifiers

2826description:

@@ -50,9 +48,9 @@ library

5048 , binary >=0.8.6.0 && <0.9

5149 , bytestring >=0.10.8.2 && <0.13

5250 , deepseq >=1.4.4.0 && <1.6

53− , hashable >=1.4.4.0 && <1.6

51+ , hashable >=1.4.4.0 && <1.5

5452 , random >=1.2.1.2 && <1.3

55− , template-haskell >=2.14.0.0 && <2.24

53+ , template-haskell >=2.14.0.0 && <2.23

5654 , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2

5755

5856 exposed-modules: Data.UUID.Types

@@ -77,8 +75,6 @@ test-suite testuuid

7775 default-language: Haskell2010

7876 other-extensions: ViewPatterns

7977 ghc-options: -Wall

80− if impl(ghc >= 8.10)

81− ghc-options: -Wunused-packages

8278

8379 -- inherited constraints

8480 build-depends:

@@ -90,10 +86,10 @@ test-suite testuuid

9086

9187 -- deps w/o inherited constraints

9288 build-depends:

93− QuickCheck >=2.14.2 && <2.16

89+ QuickCheck >=2.14.2 && <2.15

9490 , tasty >=1.4.0.1 && <1.6

9591 , tasty-hunit >=0.10 && <0.11

96− , tasty-quickcheck >=0.10 && <0.12

92+ , tasty-quickcheck >=0.10 && <0.11

9793

9894 if !impl(ghc >=8.4)

9995 build-depends: ghc-byteorder >=4.11 && <4.12

uuid/CHANGES.md−4

@@ -1,7 +1,3 @@

1−1.3.16

2−

3−- Support GHC-8.6.5...9.10.1

4−

511.3.15

62

73- Add (Template Haskell) `Lift UUID` instance

uuid/src/Data/UUID.hs+3

@@ -18,6 +18,9 @@ See <http://tools.ietf.org/html/rfc4122> for the specification.

1818favorite instance of 'System.Random.Random' for faster but insecure

1919generation of UUIDs.

2020

21+* We have an implementation of generating a UUID from the hardware

22+MAC address and current system time in "Data.UUID.V1".

23+

2124* For name-based generation of UUIDs using SHA-1 hashing see

2225"Data.UUID.V5".

2326-}

uuid/src/Data/UUID/Util.hs+11

@@ -3,6 +3,7 @@ module Data.UUID.Util (

33 UnpackedUUID(..)

44 , unpack, pack

55 , version

6+ , extractMac

67 , extractTime

78 , setTime

89 ) where

@@ -12,6 +13,7 @@ import Data.Word

1213import Data.Word.Util

1314import Data.Bits

1415import Data.UUID.Types.Internal

16+import Network.Info

1517import Data.Int (Int64)

1618

1719version :: UUID -> Int

@@ -40,3 +42,12 @@ extractTime uuid =

4042

4143timeAndVersionToTime :: Word16 -> Word16

4244timeAndVersionToTime tv = tv .&. 0x0FFF

45+

46+extractMac :: UUID -> Maybe MAC

47+extractMac uuid =

48+ if version uuid == 1

49+ then Just $

50+ MAC (node_0 unpacked) (node_1 unpacked) (node_2 unpacked) (node_3 unpacked) (node_4 unpacked) (node_5 unpacked)

51+ else Nothing

52+ where

53+ unpacked = unpack uuid

uuid/src/Data/UUID/V1.hsnew file+135

@@ -0,0 +1,135 @@

1+{-# OPTIONS_GHC -fno-cse #-}

2+{-# LANGUAGE TypeFamilies #-}

3+

4+{- |

5+Module : Data.UUID.V1

9+

10+License : BSD-style

11+

12+Maintainer : aslatter@gmail.com

13+Stability : experimental

14+Portability : portable

15+

16+RFC 4122 Version 1 UUID state machine.

17+

18+The generated UUID is based on the hardware MAC

19+address and the system clock.

20+

21+If we cannot lookup the MAC address we seed the

22+generator with a pseudo-random number.

23+-}

24+

25+module Data.UUID.V1(nextUUID)

26+where

27+

28+

29+import Data.Bits

30+import Data.Maybe

31+import Data.Time

32+import Data.Word

33+

34+import Control.Applicative ((<$>),(<*>))

35+import Control.Concurrent.MVar

36+import System.IO.Unsafe

37+

38+import qualified System.Random as R

39+

40+import Network.Info

41+

42+import Data.UUID.Types.Internal.Builder

43+import Data.UUID.Types.Internal

44+

45+-- | Returns a new UUID derived from the local hardware MAC

46+-- address and the current system time.

47+-- Is generated according to the Version 1 UUID specified in

48+-- RFC 4122.

49+--

50+-- Returns 'Nothing' if you request UUIDs too quickly.

51+nextUUID :: IO (Maybe UUID)

52+nextUUID = do

53+ res <- stepTime

54+ case res of

55+ Just (mac', c, t) -> return $ Just $ makeUUID t c mac'

56+ _ -> return Nothing

57+

58+

59+makeUUID :: Word64 -> Word16 -> MAC -> UUID

60+makeUUID time clock mac' =

61+ buildFromBytes 1 /-/ tLow /-/ tMid /-/ tHigh /-/ clock /-/ (MACSource mac')

62+ where tLow = (fromIntegral time) :: Word32

63+ tMid = (fromIntegral (time `shiftR` 32)) :: Word16

64+ tHigh = (fromIntegral (time `shiftR` 48)) :: Word16

65+

66+newtype MACSource = MACSource MAC

67+instance ByteSource MACSource where

68+ z /-/ (MACSource (MAC a b c d e f)) = z a b c d e f

69+type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)

70+

71+

72+-- |Approximates the clock algorithm in RFC 4122, section 4.2

73+-- Isn't system wide or thread safe, nor does it properly randomize

74+-- the clock value on initialization.

75+stepTime :: IO (Maybe (MAC, Word16, Word64))

76+stepTime = do

77+ h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime

78+ modifyMVar state $ \s@(State mac' c0 h0) ->

79+ if h1 > h0

80+ then

81+ return (State mac' c0 h1, Just (mac', c0, h1))

82+ else

83+ let

84+ c1 = succ c0

85+ in if c1 <= 0x3fff -- when clock is initially randomized,

86+ -- then this test will need to change

87+ then

88+ return (State mac' c1 h1, Just (mac', c1, h1))

89+ else

90+ return (s, Nothing)

91+

92+

93+{-# NOINLINE state #-}

94+state :: MVar State

95+state = unsafePerformIO $ do

96+ h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime

97+ mac' <- getMac

98+ newMVar $ State mac' 0 h0 -- the 0 should be a random number

99+

100+-- SysMAC.mac can fail on some machines.

101+-- In those cases we fake it with a random

102+-- 6 bytes seed.

103+getMac :: IO MAC

104+getMac =

105+ getNetworkInterfaces >>=

106+ return . listToMaybe . filter (minBound /=) . map mac >>=

107+ \macM -> case macM of

108+ Just m -> return m

109+ Nothing -> randomMac

110+

111+randomMac :: IO MAC

112+randomMac =

113+ -- I'm too lazy to thread through

114+ -- the random state ...

115+ MAC

116+ <$> (R.randomIO >>= return . (1 .|.)) -- We must set the multicast bit to True. See section 4.5 of the RFC.

117+ <*> R.randomIO

118+ <*> R.randomIO

119+ <*> R.randomIO

120+ <*> R.randomIO

121+ <*> R.randomIO

122+

123+data State = State

124+ {-# UNPACK #-} !MAC

125+ {-# UNPACK #-} !Word16

126+ {-# UNPACK #-} !Word64

127+ deriving (Show)

128+

129+

130+

131+hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64

132+hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt

133+ where

134+ gregorianReform = UTCTime (fromGregorian 1582 10 15) 0

135+ dt = t `diffUTCTime` gregorianReform

uuid/tests/TestUUID.hs+20−4

@@ -1,15 +1,18 @@

11{-# LANGUAGE ViewPatterns #-}

22

3+import Control.Monad (replicateM)

34import Data.Bits

45import qualified Data.ByteString.Lazy as BL

56import Data.Char (ord)

7+import Data.List (nub, (\\))

68import Data.Maybe

79import Data.Word

810import qualified Data.UUID as U

11+import qualified Data.UUID.V1 as U

912import qualified Data.UUID.V3 as U3

1013import qualified Data.UUID.V5 as U5

1114

12−import Test.QuickCheck ( Arbitrary(arbitrary) )

15+import Test.QuickCheck ( Arbitrary(arbitrary), choose )

1316import Test.Tasty ( TestTree, testGroup, defaultMain )

1417import Test.Tasty.HUnit

1518 ( assertBool, (@?=), testCase )

@@ -21,13 +24,13 @@ isValidVersion :: Int -> U.UUID -> Bool

2124isValidVersion v u = lenOK && variantOK && versionOK

2225 where bs = U.toByteString u

2326 lenOK = BL.length bs == 16

24− variantOK = BL.index bs 8 .&. 0xc0 == 0x80

25− versionOK = BL.index bs 6 .&. 0xf0 == fromIntegral (v `shiftL` 4)

27+ variantOK = (BL.index bs 8) .&. 0xc0 == 0x80

28+ versionOK = (BL.index bs 6) .&. 0xf0 == fromIntegral (v `shiftL` 4)

2629

2730

2831instance Arbitrary U.UUID where

2932 -- the UUID random instance ignores bounds

30− arbitrary = pure U.nil

33+ arbitrary = choose (U.nil, U.nil)

3134

3235

3336test_null :: Test

@@ -35,6 +38,17 @@ test_null =

3538 testCase "namespaceDNS is not null" $

3639 assertBool "" (not $ U.null U3.namespaceDNS)

3740

41+test_v1 :: [Maybe U.UUID] -> Test

42+test_v1 v1s = testGroup "version 1" [

43+ testCase "V1 unique" $ nub (v1s \\ nub v1s) @?= [],

44+ testGroup "V1 not null" $ map (testUUID (not . U.null)) v1s,

45+ testGroup "V1 valid" $ map (testUUID (isValidVersion 1)) v1s

46+ ]

47+ where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test

48+ testUUID p u =

49+ testCase (show u) $

50+ assertBool "" $ maybe False p u

51+

3852test_v3 :: Test

3953test_v3 =

4054 testCase "V3 computation" $

@@ -79,11 +93,13 @@ prop_v5Valid = testProperty "V5 valid" v5Valid

7993

8094main :: IO ()

8195main = do

96+ v1s <- replicateM 100 U.nextUUID

8297 defaultMain $

8398 testGroup "tests" $

8499 concat $

85100 [ [

86101 test_null,

102+ test_v1 v1s,

87103 test_v3,

88104 test_v5

89105 ]

uuid/uuid.cabal+10−11

@@ -1,7 +1,6 @@

11cabal-version: 1.12

22name: uuid

33version: 1.3.16

4−x-revision: 2

65author: Antoine Latter

76maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>

@@ -16,10 +15,8 @@ tested-with:

1615 || ==9.0.2

1716 || ==9.2.8

1817 || ==9.4.8

19− || ==9.6.6

20− || ==9.8.4

21− || ==9.10.1

22− || ==9.12.1

18+ || ==9.6.5

19+ || ==9.8.2

2320

2421synopsis:

2522 For creating, comparing, parsing and printing Universally Unique Identifiers

@@ -47,6 +44,10 @@ library

4744 , cryptohash-md5 >=0.11.100 && <0.12

4845 , cryptohash-sha1 >=0.11.100 && <0.12

4946 , entropy >=0.3.7 && <0.5

47+ , network-info >=0.2 && <0.3

48+ , random >=1.2.1.2 && <1.3

49+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2

50+ , time >=1.4 && <1.13

5051

5152 -- strict dependency on uuid-types,

5253 -- as we re-rexport datatype, thus leak instances etc.

@@ -54,6 +55,7 @@ library

5455 exposed-modules:

5556 Data.UUID

5657 Data.UUID.Util

58+ Data.UUID.V1

5759 Data.UUID.V3

5860 Data.UUID.V4

5961 Data.UUID.V5

@@ -66,8 +68,6 @@ library

6668 default-extensions: DeriveDataTypeable

6769 other-extensions: TypeFamilies

6870 ghc-options: -Wall

69− if impl(ghc >= 8.10)

70− ghc-options: -Wunused-packages

7171 hs-source-dirs: src

7272

7373test-suite testuuid

@@ -78,18 +78,17 @@ test-suite testuuid

7878 default-extensions: DeriveDataTypeable

7979 other-extensions: ViewPatterns

8080 ghc-options: -Wall -fno-warn-orphans

81− if impl(ghc >= 8.10)

82− ghc-options: -Wunused-packages

8381

8482 -- inherited constraints

8583 build-depends:

8684 base

8785 , bytestring

86+ , random

8887 , uuid

8988

9089 -- deps w/o inherited constraints

9190 build-depends:

92− QuickCheck >=2.14.2 && <2.16

91+ QuickCheck >=2.14.2 && <2.15

9392 , tasty >=1.4.0.1 && <1.6

9493 , tasty-hunit >=0.10 && <0.11

95− , tasty-quickcheck >=0.10 && <0.12

94+ , tasty-quickcheck >=0.10 && <0.11