diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.3.6 +--- + +* Minor change: + * Add `toEncodedUrlPiece` class method for URL-encoded path segments (see [#50](https://github.com/fizruk/http-api-data/pull/50)); use efficient encoding for types whose values don't need URL-encoding. + 0.3.5 --- 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.5 +version: 0.3.6 license: BSD3 license-file: LICENSE author: Nickolay Kudasov @@ -41,6 +41,7 @@ , bytestring , containers , hashable + , http-types , text >= 0.5 , time , time-locale-compat >=0.1.1.0 && <0.2 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 @@ -55,7 +55,10 @@ import Data.Typeable (Typeable) import Data.Data (Data) +import qualified Data.ByteString.Builder as BS +import qualified Network.HTTP.Types as H + -- $setup -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p @@ -70,6 +73,12 @@ toUrlPiece :: a -> Text toUrlPiece = toQueryParam + -- | Convert to a URL path piece, making sure to encode any special chars. + -- The default definition uses 'H.encodePathSegmentsRelative', + -- but this may be overriden with a more efficient version. + toEncodedUrlPiece :: a -> BS.Builder + toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece + -- | Convert to HTTP header value. toHeader :: a -> ByteString toHeader = encodeUtf8 . toUrlPiece @@ -387,46 +396,58 @@ l = toInteger (minBound :: a) h = toInteger (maxBound :: a) +-- | Convert to a URL-encoded path piece using 'toUrlPiece'. +-- /Note/: this function does not check if the result contains unescaped characters! +-- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation +-- when the resulting URL piece /never/ has to be escaped. +unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder +unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece + -- | -- >>> toUrlPiece () -- "_" instance ToHttpApiData () where toUrlPiece () = "_" + toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Char where toUrlPiece = T.singleton +instance ToHttpApiData Char where + toUrlPiece = T.singleton -- | -- >>> toUrlPiece (Version [1, 2, 3] []) -- "1.2.3" instance ToHttpApiData Version where toUrlPiece = T.pack . showVersion + toEncodedUrlPiece = unsafeToEncodedUrlPiece #if MIN_VERSION_base(4,8,0) instance ToHttpApiData Void where toUrlPiece = absurd -instance ToHttpApiData Natural where toUrlPiece = showt +instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece #endif -instance ToHttpApiData Bool where toUrlPiece = showTextData -instance ToHttpApiData Ordering where toUrlPiece = showTextData +instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Double where toUrlPiece = showt -instance ToHttpApiData Float where toUrlPiece = showt -instance ToHttpApiData Int where toUrlPiece = showt -instance ToHttpApiData Int8 where toUrlPiece = showt -instance ToHttpApiData Int16 where toUrlPiece = showt -instance ToHttpApiData Int32 where toUrlPiece = showt -instance ToHttpApiData Int64 where toUrlPiece = showt -instance ToHttpApiData Integer where toUrlPiece = showt -instance ToHttpApiData Word where toUrlPiece = showt -instance ToHttpApiData Word8 where toUrlPiece = showt -instance ToHttpApiData Word16 where toUrlPiece = showt -instance ToHttpApiData Word32 where toUrlPiece = showt -instance ToHttpApiData Word64 where toUrlPiece = showt +instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece (fromGregorian 2015 10 03) -- "2015-10-03" -instance ToHttpApiData Day where toUrlPiece = T.pack . show +instance ToHttpApiData Day where + toUrlPiece = T.pack . show + toEncodedUrlPiece = unsafeToEncodedUrlPiece timeToUrlPiece :: FormatTime t => String -> t -> Text timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt)) @@ -434,33 +455,55 @@ -- | -- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01) -- "2015-10-03T14:55:01" -instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S" +instance ToHttpApiData LocalTime where + toUrlPiece = timeToUrlPiece "%H:%M:%S" + toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)) utc -- "2015-10-03T14:55:01+0000" -instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%z" +instance ToHttpApiData ZonedTime where + toUrlPiece = timeToUrlPiece "%H:%M:%S%z" + toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864 -- "2015-10-03T00:14:24Z" -instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%SZ" +instance ToHttpApiData UTCTime where + toUrlPiece = timeToUrlPiece "%H:%M:%SZ" + toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer) +instance ToHttpApiData NominalDiffTime where + toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer) + toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData String where toUrlPiece = T.pack instance ToHttpApiData Text where toUrlPiece = id instance ToHttpApiData L.Text where toUrlPiece = L.toStrict -instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll -instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny +instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll; toEncodedUrlPiece = toEncodedUrlPiece . getAll +instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny; toEncodedUrlPiece = toEncodedUrlPiece . getAny -instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = toUrlPiece . getDual -instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = toUrlPiece . getSum -instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct -instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = toUrlPiece . getFirst -instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPiece . getLast +instance ToHttpApiData a => ToHttpApiData (Dual a) where + toUrlPiece = toUrlPiece . getDual + toEncodedUrlPiece = toEncodedUrlPiece . getDual +instance ToHttpApiData a => ToHttpApiData (Sum a) where + toUrlPiece = toUrlPiece . getSum + toEncodedUrlPiece = toEncodedUrlPiece . getSum + +instance ToHttpApiData a => ToHttpApiData (Product a) where + toUrlPiece = toUrlPiece . getProduct + toEncodedUrlPiece = toEncodedUrlPiece . getProduct + +instance ToHttpApiData a => ToHttpApiData (First a) where + toUrlPiece = toUrlPiece . getFirst + toEncodedUrlPiece = toEncodedUrlPiece . getFirst + +instance ToHttpApiData a => ToHttpApiData (Last a) where + toUrlPiece = toUrlPiece . getLast + toEncodedUrlPiece = toEncodedUrlPiece . getLast + -- | -- >>> toUrlPiece (Just "Hello") -- "just Hello" @@ -508,7 +551,7 @@ parseUrlPiece s = do n <- runReader (signed decimal) s if n < 0 - then Left ("undeflow: " <> s <> " (should be a non-negative integer)") + then Left ("underflow: " <> s <> " (should be a non-negative integer)") else Right (fromInteger n) #endif @@ -590,6 +633,7 @@ instance ToHttpApiData UUID.UUID where toUrlPiece = UUID.toText toHeader = UUID.toASCIIBytes + toEncodedUrlPiece = unsafeToEncodedUrlPiece instance FromHttpApiData UUID.UUID where parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText 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 @@ -9,6 +9,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) import Data.Version import qualified Data.UUID as UUID @@ -29,6 +30,10 @@ (<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool (f <=> g) x = g (f x) == Right x +encodedUrlPieceProp :: ToHttpApiData a => a -> Bool +encodedUrlPieceProp x = toLazyByteString (toEncodedUrlPiece (toUrlPiece x)) == toLazyByteString (toEncodedUrlPiece x) + + 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) @@ -40,6 +45,15 @@ checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a)) +-- | Check that 'toEncodedUrlPiece' is equivallent to default implementation. +checkEncodedUrlPiece :: forall a. (Show a, ToHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec +checkEncodedUrlPiece _ = checkEncodedUrlPiece' (arbitrary :: Gen a) + +-- | Check that 'toEncodedUrlPiece' is equivallent to default implementation. +-- Use a given generator. +checkEncodedUrlPiece' :: forall a. (Show a, ToHttpApiData a) => Gen a -> String -> Spec +checkEncodedUrlPiece' gen name = prop name $ forAll gen encodedUrlPieceProp + spec :: Spec spec = do describe "toUrlPiece <=> parseUrlPiece" $ do @@ -78,6 +92,42 @@ checkUrlPiece (Proxy :: Proxy Natural) "Natural" #endif + describe "toEncodedUrlPiece encodes correctly" $ do + checkEncodedUrlPiece (Proxy :: Proxy ()) "()" + checkEncodedUrlPiece (Proxy :: Proxy Char) "Char" + checkEncodedUrlPiece (Proxy :: Proxy Bool) "Bool" + checkEncodedUrlPiece (Proxy :: Proxy Ordering) "Ordering" + checkEncodedUrlPiece (Proxy :: Proxy Int) "Int" + checkEncodedUrlPiece (Proxy :: Proxy Int8) "Int8" + checkEncodedUrlPiece (Proxy :: Proxy Int16) "Int16" + checkEncodedUrlPiece (Proxy :: Proxy Int32) "Int32" + checkEncodedUrlPiece (Proxy :: Proxy Int64) "Int64" + checkEncodedUrlPiece (Proxy :: Proxy Integer) "Integer" + checkEncodedUrlPiece (Proxy :: Proxy Word) "Word" + checkEncodedUrlPiece (Proxy :: Proxy Word8) "Word8" + checkEncodedUrlPiece (Proxy :: Proxy Word16) "Word16" + checkEncodedUrlPiece (Proxy :: Proxy Word32) "Word32" + checkEncodedUrlPiece (Proxy :: Proxy Word64) "Word64" + checkEncodedUrlPiece (Proxy :: Proxy String) "String" + checkEncodedUrlPiece (Proxy :: Proxy T.Text) "Text.Strict" + checkEncodedUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy" + checkEncodedUrlPiece (Proxy :: Proxy Day) "Day" + checkEncodedUrlPiece' localTimeGen "LocalTime" + checkEncodedUrlPiece' zonedTimeGen "ZonedTime" + checkEncodedUrlPiece' utcTimeGen "UTCTime" + checkEncodedUrlPiece' nominalDiffTimeGen "NominalDiffTime" + checkEncodedUrlPiece (Proxy :: Proxy Version) "Version" + checkEncodedUrlPiece' uuidGen "UUID" + + checkEncodedUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String" + checkEncodedUrlPiece (Proxy :: Proxy (Maybe Integer)) "Maybe Integer" + checkEncodedUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text" + checkEncodedUrlPiece (Proxy :: Proxy (Either Version Day)) "Either Version Day" + +#if MIN_VERSION_base(4,8,0) + checkEncodedUrlPiece (Proxy :: Proxy Natural) "Natural" +#endif + it "bad integers are rejected" $ do parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int) @@ -87,6 +137,7 @@ 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