diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.3.1 +--- + +* Minor changes + * Add instances for `Data.UUID` + 0.3 --- * Major changes: diff --git a/http-api-data.cabal b/http-api-data.cabal --- a/http-api-data.cabal +++ b/http-api-data.cabal @@ -1,5 +1,5 @@ name: http-api-data -version: 0.3 +version: 0.3.1 license: BSD3 license-file: LICENSE author: Nickolay Kudasov @@ -33,6 +33,7 @@ , time-locale-compat >=0.1.1.0 && <0.2 , unordered-containers , uri-bytestring + , uuid-types >= 1.0.2 && <1.1 if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW build-depends: text-show >= 2 @@ -58,12 +59,14 @@ , hspec >= 1.3 , base >= 4 && < 5 , bytestring - , QuickCheck + , QuickCheck >=2.9 + , quickcheck-instances >= 0.3.12 , unordered-containers , http-api-data , text , time , bytestring + , uuid test-suite doctest ghc-options: -Wall diff --git a/src/Web/Internal/HttpApiData.hs b/src/Web/Internal/HttpApiData.hs --- a/src/Web/Internal/HttpApiData.hs +++ b/src/Web/Internal/HttpApiData.hs @@ -46,6 +46,8 @@ import TextShow (TextShow, showt) #endif +import qualified Data.UUID.Types as UUID + -- $setup -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p @@ -577,3 +579,10 @@ Left _ y = y x _ = x +instance ToHttpApiData UUID.UUID where + toUrlPiece = UUID.toText + toHeader = UUID.toASCIIBytes + +instance FromHttpApiData UUID.UUID where + parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText + parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes diff --git a/test/Web/Internal/HttpApiDataSpec.hs b/test/Web/Internal/HttpApiDataSpec.hs --- a/test/Web/Internal/HttpApiDataSpec.hs +++ b/test/Web/Internal/HttpApiDataSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.HttpApiDataSpec (spec) where +import Control.Applicative import Data.Int import Data.Word import Data.Time @@ -9,6 +10,7 @@ import qualified Data.Text.Lazy as L import qualified Data.ByteString as BS import Data.Version +import qualified Data.UUID as UUID import Data.Proxy @@ -30,6 +32,10 @@ checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec checkUrlPiece _ name = prop name (toUrlPiece <=> parseUrlPiece :: a -> Bool) +-- | Check with given generator +checkUrlPiece' :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a) => Gen a -> String -> Spec +checkUrlPiece' gen name = prop name $ forAll gen (toUrlPiece <=> parseUrlPiece) + -- | Check case insensitivity for @parseUrlPiece@. checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a)) @@ -56,11 +62,12 @@ checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict" checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy" checkUrlPiece (Proxy :: Proxy Day) "Day" - checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime" - checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime" - checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime" - checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime" + checkUrlPiece' localTimeGen "LocalTime" + checkUrlPiece' zonedTimeGen "ZonedTime" + checkUrlPiece' utcTimeGen "UTCTime" + checkUrlPiece' nominalDiffTimeGen "NominalDiffTime" checkUrlPiece (Proxy :: Proxy Version) "Version" + checkUrlPiece' uuidGen "UUID" checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String" checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer" @@ -80,3 +87,23 @@ it "invalid utf8 is handled" $ do parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text) + +uuidGen :: Gen UUID.UUID +uuidGen = UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +-- TODO: this generators don't generate full range items +localTimeGen :: Gen LocalTime +localTimeGen = LocalTime + <$> arbitrary + <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60)) + +zonedTimeGen :: Gen ZonedTime +zonedTimeGen = ZonedTime + <$> localTimeGen -- Note: not arbitrary! + <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z'])) + +utcTimeGen :: Gen UTCTime +utcTimeGen = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400)) + +nominalDiffTimeGen :: Gen NominalDiffTime +nominalDiffTimeGen = fromInteger <$> arbitrary diff --git a/test/Web/Internal/TestInstances.hs b/test/Web/Internal/TestInstances.hs --- a/test/Web/Internal/TestInstances.hs +++ b/test/Web/Internal/TestInstances.hs @@ -9,57 +9,21 @@ ) where import Control.Applicative -import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Char import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T -import qualified Data.Text.Lazy as L import Data.Time -import Data.Version import GHC.Exts (fromList) import GHC.Generics import Test.QuickCheck +import Test.QuickCheck.Instances () import Web.Internal.FormUrlEncoded import Web.Internal.HttpApiData -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary L.Text where - arbitrary = L.pack <$> arbitrary - -instance Arbitrary BSL.ByteString where - arbitrary = BSL.pack <$> arbitrary - -instance Arbitrary Day where - arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary - -instance Arbitrary LocalTime where - arbitrary = LocalTime - <$> arbitrary - <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60)) - instance Eq ZonedTime where ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y - -instance Arbitrary ZonedTime where - arbitrary = ZonedTime - <$> arbitrary - <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z'])) - -instance Arbitrary UTCTime where - arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400)) - -instance Arbitrary NominalDiffTime where - arbitrary = fromInteger <$> arbitrary - -instance Arbitrary Version where - arbitrary = (version . map abs) <$> nonempty - where - version branch = Version branch [] - nonempty = liftA2 (:) arbitrary arbitrary instance Arbitrary Form where arbitrary = fromList <$> arbitrary