ToEncodedUrlPiece

http-api-data.cabal

@@ -41,6 +41,7 @@ library
                    , bytestring
                    , containers
                    , hashable
+                   , http-types
                    , text               >= 0.5
                    , time
                    , time-locale-compat >=0.1.1.0 && <0.2

src/Web/Internal/HttpApiData.hs

@@ -55,6 +55,9 @@ import qualified Data.UUID.Types as UUID
 
 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)
@@ -70,6 +73,12 @@ class ToHttpApiData a where
   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,79 +396,113 @@ parseBounded reader input = do
     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 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 Bool     where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
+instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
+
+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))
 
 -- |
 -- >>> 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
+  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 (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 (Last a) where
+  toUrlPiece = toUrlPiece . getLast
+  toEncodedUrlPiece = toEncodedUrlPiece . getLast
 
 -- |
 -- >>> toUrlPiece (Just "Hello")
@@ -590,6 +633,7 @@ instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b)
 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

test/Web/Internal/HttpApiDataSpec.hs

@@ -9,6 +9,7 @@ import Data.Time
 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 @@ import Web.Internal.TestInstances
 (<=>) :: 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 @@ checkUrlPiece' gen name = prop name $ forAll gen (toUrlPiece <=> parseUrlPiece)
 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 @@ spec = do
     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)
 
@@ -88,6 +138,7 @@ spec = do
   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