diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.3 +--- +* Major changes: + * Add `Web.FormUrlEncoded` to work with form data (see [#32](https://github.com/fizruk/http-api-data/pull/32)). + +* Minor changes: + * Add instances for `Numeric.Natural` (see [`d944721`](https://github.com/fizruk/http-api-data/commit/d944721ac94929a7ed9e66f25e23221799c08d83)). + 0.2.4 --- * Make `parseHeader` total (instead of throwing exceptions on invalid Unicode, see [#30](https://github.com/fizruk/http-api-data/pull/30)). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,9 @@ # http-api-data -[![Hackage package](http://img.shields.io/hackage/v/http-api-data.svg)](http://hackage.haskell.org/package/http-api-data) [![Build Status](https://secure.travis-ci.org/fizruk/http-api-data.png?branch=master)](http://travis-ci.org/fizruk/http-api-data) +[![Hackage package](http://img.shields.io/hackage/v/http-api-data.svg)](http://hackage.haskell.org/package/http-api-data) +[![Stackage LTS](http://stackage.org/package/http-api-data/badge/lts)](http://stackage.org/lts/package/http-api-data) +[![Stackage Nightly](http://stackage.org/package/http-api-data/badge/nightly)](http://stackage.org/nightly/package/http-api-data) This package defines typeclasses used for converting Haskell data types to and from HTTP API data. 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.2.4 +version: 0.3 license: BSD3 license-file: LICENSE author: Nickolay Kudasov @@ -9,9 +9,10 @@ homepage: http://github.com/fizruk/http-api-data category: Web stability: unstable -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Custom extra-source-files: + include/overlapping-compat.h test/*.hs CHANGELOG.md README.md @@ -22,28 +23,43 @@ library hs-source-dirs: src/ + include-dirs: include/ build-depends: base >= 4.6 && < 4.10 - , text >= 0.5 , bytestring + , containers + , hashable + , text >= 0.5 , time , time-locale-compat >=0.1.1.0 && <0.2 + , unordered-containers + , uri-bytestring if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW build-depends: text-show >= 2 exposed-modules: Web.HttpApiData - Web.HttpApiData.Internal + Web.FormUrlEncoded + Web.Internal.FormUrlEncoded + Web.Internal.HttpApiData ghc-options: -Wall + default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs - hs-source-dirs: test/ + other-modules: + Web.Internal.FormUrlEncodedSpec + Web.Internal.HttpApiDataSpec + Web.Internal.TestInstances + hs-source-dirs: test ghc-options: -Wall + default-language: Haskell2010 build-depends: HUnit , hspec >= 1.3 , base >= 4 && < 5 + , bytestring , QuickCheck + , unordered-containers , http-api-data , text , time diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/src/Web/FormUrlEncoded.hs b/src/Web/FormUrlEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Web/FormUrlEncoded.hs @@ -0,0 +1,41 @@ +-- | +-- Convert Haskell values to and from @application/xxx-form-urlencoded@ format. +module Web.FormUrlEncoded ( + -- * Classes + ToForm (..), + FromForm (..), + + -- ** Keys for 'Form' entries + ToFormKey(..), + FromFormKey(..), + + -- * Encoding and decoding @'Form'@s + urlEncodeAsForm, + urlDecodeAsForm, + + urlEncodeForm, + urlDecodeForm, + + -- * 'Generic's + genericToForm, + genericFromForm, + + -- ** Encoding options + FormOptions(..), + defaultFormOptions, + + -- * Helpers + toEntriesByKey, + fromEntriesByKey, + + lookupAll, + lookupMaybe, + lookupUnique, + + parseAll, + parseMaybe, + parseUnique, +) where + +import Web.Internal.FormUrlEncoded + diff --git a/src/Web/HttpApiData.hs b/src/Web/HttpApiData.hs --- a/src/Web/HttpApiData.hs +++ b/src/Web/HttpApiData.hs @@ -40,7 +40,7 @@ readTextData, ) where -import Web.HttpApiData.Internal +import Web.Internal.HttpApiData -- $setup -- @@ -69,7 +69,7 @@ -- "45.2" -- >>> parseQueryParam "452" :: Either Text Int -- Right 452 --- >>> toQueryParams [1..5] +-- >>> toQueryParams [1..5] :: [Text] -- ["1","2","3","4","5"] -- >>> parseQueryParams ["127", "255"] :: Either Text [Int8] -- Left "out of bounds: `255' (should be between -128 and 127)" diff --git a/src/Web/HttpApiData/Internal.hs b/src/Web/HttpApiData/Internal.hs deleted file mode 100644 --- a/src/Web/HttpApiData/Internal.hs +++ /dev/null @@ -1,570 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Convert Haskell values to and from HTTP API data --- such as URL pieces, headers and query parameters. -module Web.HttpApiData.Internal where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -import Data.Traversable (Traversable(traverse)) -#endif -import Control.Arrow ((&&&), left) -import Control.Monad ((<=<)) - -import Data.Monoid -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS - -import Data.Int -import Data.Word - -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8, decodeUtf8') -import Data.Text.Read (signed, decimal, rational, Reader) -import qualified Data.Text as T -import qualified Data.Text.Lazy as L - -import Data.Time.Locale.Compat -import Data.Time -import Data.Version - -#if MIN_VERSION_base(4,8,0) -import Data.Void -#endif - -import Text.Read (readMaybe) -import Text.ParserCombinators.ReadP (readP_to_S) - -#if USE_TEXT_SHOW -import TextShow (TextShow, showt) -#endif - --- | Convert value to HTTP API data. --- --- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated --- instance will loop indefinitely. -class ToHttpApiData a where - {-# MINIMAL toUrlPiece | toQueryParam #-} - -- | Convert to URL path piece. - toUrlPiece :: a -> Text - toUrlPiece = toQueryParam - - -- | Convert to HTTP header value. - toHeader :: a -> ByteString - toHeader = encodeUtf8 . toUrlPiece - - -- | Convert to query param value. - toQueryParam :: a -> Text - toQueryParam = toUrlPiece - --- | Parse value from HTTP API data. --- --- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated --- instance will loop indefinitely. -class FromHttpApiData a where - {-# MINIMAL parseUrlPiece | parseQueryParam #-} - -- | Parse URL path piece. - parseUrlPiece :: Text -> Either Text a - parseUrlPiece = parseQueryParam - - -- | Parse HTTP header value. - parseHeader :: ByteString -> Either Text a - parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8') - - -- | Parse query param value. - parseQueryParam :: Text -> Either Text a - parseQueryParam = parseUrlPiece - --- | Convert multiple values to a list of URL pieces. --- --- >>> toUrlPieces [1, 2, 3] --- ["1","2","3"] -toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text -toUrlPieces = fmap toUrlPiece - --- | Parse multiple URL pieces. --- --- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool] --- Right [True,False] --- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int] --- Left "could not parse: `hello' (input does not start with a digit)" -parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) -parseUrlPieces = traverse parseUrlPiece - --- | Convert multiple values to a list of query parameter values. --- --- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] --- ["2015-10-03","2015-12-01"] -toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text -toQueryParams = fmap toQueryParam - --- | Parse multiple query parameters. --- --- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int] --- Right [1,2,3] --- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8] --- Left "out of bounds: `256' (should be between 0 and 255)" -parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) -parseQueryParams = traverse parseQueryParam - --- | Parse URL path piece in a @'Maybe'@. --- --- >>> parseUrlPieceMaybe "12" :: Maybe Int --- Just 12 -parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a -parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece - --- | Parse HTTP header value in a @'Maybe'@. --- --- >>> parseHeaderMaybe "hello" :: Maybe Text --- Just "hello" -parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a -parseHeaderMaybe = either (const Nothing) Just . parseHeader - --- | Parse query param value in a @'Maybe'@. --- --- >>> parseQueryParamMaybe "true" :: Maybe Bool --- Just True -parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a -parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam - --- | Default parsing error. -defaultParseError :: Text -> Either Text a -defaultParseError input = Left ("could not parse: `" <> input <> "'") - --- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message. -parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a) -parseMaybeTextData parse input = - case parse input of - Nothing -> defaultParseError input - Just val -> Right val - -#if USE_TEXT_SHOW --- | /Lower case/. --- --- Convert to URL piece using @'TextShow'@ instance. --- The result is always lower cased. --- --- >>> showTextData True --- "true" --- --- This can be used as a default implementation for enumeration types: --- --- @ --- data MyData = Foo | Bar | Baz deriving (Generic) --- --- instance TextShow MyData where --- showt = genericShowt --- --- instance ToHttpApiData MyData where --- toUrlPiece = showTextData --- @ -showTextData :: TextShow a => a -> Text -showTextData = T.toLower . showt -#else --- | /Lower case/. --- --- Convert to URL piece using @'Show'@ instance. --- The result is always lower cased. --- --- >>> showTextData True --- "true" --- --- This can be used as a default implementation for enumeration types: --- --- >>> data MyData = Foo | Bar | Baz deriving (Show) --- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData --- >>> toUrlPiece Foo --- "foo" -showTextData :: Show a => a -> Text -showTextData = T.toLower . showt - --- | Like @'show'@, but returns @'Text'@. -showt :: Show a => a -> Text -showt = T.pack . show -#endif - --- | /Case insensitive/. --- --- Parse given text case insensitive and then parse the rest of the input --- using @'parseUrlPiece'@. --- --- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int --- Right 10 --- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool --- Left "could not parse: `left'" --- --- This can be used to implement @'FromHttpApiData'@ for single field constructors: --- --- >>> data Foo = Foo Int deriving (Show) --- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s --- >>> parseUrlPiece "foo 1" :: Either Text Foo --- Right (Foo 1) -parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a -parseUrlPieceWithPrefix pattern input - | T.toLower pattern == T.toLower prefix = parseUrlPiece rest - | otherwise = defaultParseError input - where - (prefix, rest) = T.splitAt (T.length pattern) input - --- $setup --- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) --- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p - --- | Parse given bytestring then parse the rest of the input using @'parseHeader'@. --- --- @ --- data BasicAuthToken = BasicAuthToken Text deriving (Show) --- --- instance FromHttpApiData BasicAuthToken where --- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h --- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p --- @ --- --- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken --- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==") -parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a -parseHeaderWithPrefix pattern input - | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input) - | otherwise = defaultParseError (showt input) - --- | /Case insensitive/. --- --- Parse given text case insensitive and then parse the rest of the input --- using @'parseQueryParam'@. --- --- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int --- Right 10 -parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a -parseQueryParamWithPrefix pattern input - | T.toLower pattern == T.toLower prefix = parseQueryParam rest - | otherwise = defaultParseError input - where - (prefix, rest) = T.splitAt (T.length pattern) input - -#if USE_TEXT_SHOW --- | /Case insensitive/. --- --- Parse values case insensitively based on @'TextShow'@ instance. --- --- >>> parseBoundedTextData "true" :: Either Text Bool --- Right True --- >>> parseBoundedTextData "FALSE" :: Either Text Bool --- Right False --- --- This can be used as a default implementation for enumeration types: --- --- @ --- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic) --- --- instance TextShow MyData where --- showt = genericShowt --- --- instance FromHttpApiData MyData where --- parseUrlPiece = parseBoundedTextData --- @ -parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a -#else --- | /Case insensitive/. --- --- Parse values case insensitively based on @'Show'@ instance. --- --- >>> parseBoundedTextData "true" :: Either Text Bool --- Right True --- >>> parseBoundedTextData "FALSE" :: Either Text Bool --- Right False --- --- This can be used as a default implementation for enumeration types: --- --- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum) --- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData --- >>> parseUrlPiece "foo" :: Either Text MyData --- Right Foo -parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a -#endif -parseBoundedTextData = parseBoundedEnumOfI showTextData - --- | Lookup values based on a precalculated mapping of their representations. -lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a -lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound]) - --- | Parse values based on a precalculated mapping of their @'Text'@ representation. --- --- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool --- Right True --- --- For case sensitive parser see 'parseBoundedEnumOfI'. -parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a -parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf - --- | /Case insensitive/. --- --- Parse values case insensitively based on a precalculated mapping --- of their @'Text'@ representations. --- --- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool --- Right False --- --- For case sensitive parser see 'parseBoundedEnumOf'. -parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a -parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower - --- | /Case insensitive/. --- --- Parse values case insensitively based on @'ToHttpApiData'@ instance. --- Uses @'toUrlPiece'@ to get possible values. -parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a -parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece - --- | /Case insensitive/. --- --- Parse values case insensitively based on @'ToHttpApiData'@ instance. --- Uses @'toQueryParam'@ to get possible values. -parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a -parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam - --- | Parse values based on @'ToHttpApiData'@ instance. --- Uses @'toHeader'@ to get possible values. -parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a -parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of - Nothing -> defaultParseError $ T.pack $ show bs - Just x -> return x - --- | Parse URL piece using @'Read'@ instance. --- --- Use for types which do not involve letters: --- --- >>> readTextData "1991-06-02" :: Either Text Day --- Right 1991-06-02 --- --- This parser is case sensitive and will not match @'showTextData'@ --- in presense of letters: --- --- >>> readTextData (showTextData True) :: Either Text Bool --- Left "could not parse: `true'" --- --- See @'parseBoundedTextData'@. -readTextData :: Read a => Text -> Either Text a -readTextData = parseMaybeTextData (readMaybe . T.unpack) - --- | Run @'Reader'@ as HTTP API data parser. -runReader :: Reader a -> Text -> Either Text a -runReader reader input = - case reader input of - Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")") - Right (x, rest) - | T.null rest -> Right x - | otherwise -> defaultParseError input - --- | Run @'Reader'@ to parse bounded integral value with bounds checking. --- --- >>> parseBounded decimal "256" :: Either Text Word8 --- Left "out of bounds: `256' (should be between 0 and 255)" -parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a -parseBounded reader input = do - n <- runReader reader input - if (n > h || n < l) - then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")") - else Right (fromInteger n) - where - l = toInteger (minBound :: a) - h = toInteger (maxBound :: a) - --- | --- >>> toUrlPiece () --- "_" -instance ToHttpApiData () where - toUrlPiece () = "_" - -instance ToHttpApiData Char where toUrlPiece = T.singleton - --- | --- >>> toUrlPiece (Version [1, 2, 3] []) --- "1.2.3" -instance ToHttpApiData Version where - toUrlPiece = T.pack . showVersion - -#if MIN_VERSION_base(4,8,0) -instance ToHttpApiData Void where - toUrlPiece = absurd -#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 - --- | --- >>> toUrlPiece (fromGregorian 2015 10 03) --- "2015-10-03" -instance ToHttpApiData Day where toUrlPiece = T.pack . show - -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" - --- | --- >>> 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" - --- | --- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864 --- "2015-10-03T00:14:24Z" -instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%SZ" - -instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer) - -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 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 - --- | --- >>> toUrlPiece (Just "Hello") --- "just Hello" -instance ToHttpApiData a => ToHttpApiData (Maybe a) where - toUrlPiece (Just x) = "just " <> toUrlPiece x - toUrlPiece Nothing = "nothing" - --- | --- >>> toUrlPiece (Left "err" :: Either String Int) --- "left err" --- >>> toUrlPiece (Right 3 :: Either String Int) --- "right 3" -instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where - toUrlPiece (Left x) = "left " <> toUrlPiece x - toUrlPiece (Right x) = "right " <> toUrlPiece x - --- | --- >>> parseUrlPiece "_" :: Either Text () --- Right () -instance FromHttpApiData () where - parseUrlPiece "_" = pure () - parseUrlPiece s = defaultParseError s - -instance FromHttpApiData Char where - parseUrlPiece s = - case T.uncons s of - Just (c, s') | T.null s' -> pure c - _ -> defaultParseError s - --- | --- >>> showVersion <$> parseUrlPiece "1.2.3" --- Right "1.2.3" -instance FromHttpApiData Version where - parseUrlPiece s = - case reverse (readP_to_S parseVersion (T.unpack s)) of - ((x, ""):_) -> pure x - _ -> defaultParseError s - -#if MIN_VERSION_base(4,8,0) --- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors. -instance FromHttpApiData Void where - parseUrlPiece _ = Left "Void cannot be parsed!" -#endif - -instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece -instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece -instance FromHttpApiData Double where parseUrlPiece = runReader rational -instance FromHttpApiData Float where parseUrlPiece = runReader rational -instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal) -instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal) -instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal) -instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal) -instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal) -instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal) -instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal -instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal -instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal -instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal -instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal -instance FromHttpApiData String where parseUrlPiece = Right . T.unpack -instance FromHttpApiData Text where parseUrlPiece = Right -instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict - --- | --- >>> toGregorian <$> parseUrlPiece "2016-12-01" --- Right (2016,12,1) -instance FromHttpApiData Day where parseUrlPiece = readTextData - -timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t -timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack) - where - timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt)) - --- | --- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime --- Right 2015-10-03 14:55:01 -instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S" - --- | --- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime --- Right 2015-10-03 14:55:01 +0000 -instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z" - --- | --- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime --- Right 2015-10-03 00:14:24 UTC -instance FromHttpApiData UTCTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ" - -instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece - -instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece -instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece - -instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece - --- | --- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int) --- Right (Just 123) -instance FromHttpApiData a => FromHttpApiData (Maybe a) where - parseUrlPiece s - | T.toLower (T.take 7 s) == "nothing" = pure Nothing - | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s - --- | --- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int) --- Right (Right 123) -instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where - parseUrlPiece s = - Right <$> parseUrlPieceWithPrefix "Right " s - Left <$> parseUrlPieceWithPrefix "Left " s - where - infixl 3 - Left _ y = y - x _ = x - diff --git a/src/Web/Internal/FormUrlEncoded.hs b/src/Web/Internal/FormUrlEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Web/Internal/FormUrlEncoded.hs @@ -0,0 +1,714 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#include "overlapping-compat.h" +module Web.Internal.FormUrlEncoded where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +import Data.Traversable +#endif + + +import Control.Arrow ((***)) +import Control.Monad ((<=<)) +import Data.ByteString.Builder (toLazyByteString, shortByteString) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Data.Foldable as F +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Int +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List (intersperse) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import Data.Text.Encoding as Text +import Data.Text.Encoding.Error (lenientDecode) + +import Data.Time +import Data.Proxy +import Data.Word + +#if MIN_VERSION_base(4,8,0) +import Data.Void +import Numeric.Natural +#endif + +import GHC.Exts (IsList (..), Constraint) +import GHC.Generics +import GHC.TypeLits +import URI.ByteString (urlEncodeQuery, urlDecodeQuery) + +import Web.Internal.HttpApiData + +-- $setup +-- >>> :set -XDeriveGeneric +-- >>> :set -XOverloadedLists +-- >>> :set -XOverloadedStrings +-- >>> :set -XFlexibleContexts +-- >>> :set -XScopedTypeVariables +-- >>> :set -XTypeFamilies +-- >>> import Data.Char (toLower) +-- +-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic) +-- >>> instance ToForm Person +-- >>> instance FromForm Person +-- +-- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show) +-- >>> instance ToForm Post +-- >>> instance FromForm Post +-- +-- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show) +-- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) } +-- >>> instance ToForm Project where toForm = genericToForm myOptions +-- >>> instance FromForm Project where fromForm = genericFromForm myOptions + +-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map'). +class ToFormKey k where + -- | Render a key for a 'Form'. + toFormKey :: k -> Text + +instance ToFormKey () where toFormKey = toQueryParam +instance ToFormKey Char where toFormKey = toQueryParam + +instance ToFormKey Bool where toFormKey = toQueryParam +instance ToFormKey Ordering where toFormKey = toQueryParam + +instance ToFormKey Double where toFormKey = toQueryParam +instance ToFormKey Float where toFormKey = toQueryParam +instance ToFormKey Int where toFormKey = toQueryParam +instance ToFormKey Int8 where toFormKey = toQueryParam +instance ToFormKey Int16 where toFormKey = toQueryParam +instance ToFormKey Int32 where toFormKey = toQueryParam +instance ToFormKey Int64 where toFormKey = toQueryParam +instance ToFormKey Integer where toFormKey = toQueryParam +instance ToFormKey Word where toFormKey = toQueryParam +instance ToFormKey Word8 where toFormKey = toQueryParam +instance ToFormKey Word16 where toFormKey = toQueryParam +instance ToFormKey Word32 where toFormKey = toQueryParam +instance ToFormKey Word64 where toFormKey = toQueryParam + +instance ToFormKey Day where toFormKey = toQueryParam +instance ToFormKey LocalTime where toFormKey = toQueryParam +instance ToFormKey ZonedTime where toFormKey = toQueryParam +instance ToFormKey UTCTime where toFormKey = toQueryParam +instance ToFormKey NominalDiffTime where toFormKey = toQueryParam + +instance ToFormKey String where toFormKey = toQueryParam +instance ToFormKey Text where toFormKey = toQueryParam +instance ToFormKey Lazy.Text where toFormKey = toQueryParam + +instance ToFormKey All where toFormKey = toQueryParam +instance ToFormKey Any where toFormKey = toQueryParam + +instance ToFormKey a => ToFormKey (Dual a) where toFormKey = toFormKey . getDual +instance ToFormKey a => ToFormKey (Sum a) where toFormKey = toFormKey . getSum +instance ToFormKey a => ToFormKey (Product a) where toFormKey = toFormKey . getProduct + +#if MIN_VERSION_base(4,8,0) +instance ToFormKey Void where toFormKey = toQueryParam +instance ToFormKey Natural where toFormKey = toQueryParam +#endif + +-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'. +class FromFormKey k where + -- | Parse a key of a 'Form'. + parseFormKey :: Text -> Either Text k + +instance FromFormKey () where parseFormKey = parseQueryParam +instance FromFormKey Char where parseFormKey = parseQueryParam + +instance FromFormKey Bool where parseFormKey = parseQueryParam +instance FromFormKey Ordering where parseFormKey = parseQueryParam + +instance FromFormKey Double where parseFormKey = parseQueryParam +instance FromFormKey Float where parseFormKey = parseQueryParam +instance FromFormKey Int where parseFormKey = parseQueryParam +instance FromFormKey Int8 where parseFormKey = parseQueryParam +instance FromFormKey Int16 where parseFormKey = parseQueryParam +instance FromFormKey Int32 where parseFormKey = parseQueryParam +instance FromFormKey Int64 where parseFormKey = parseQueryParam +instance FromFormKey Integer where parseFormKey = parseQueryParam +instance FromFormKey Word where parseFormKey = parseQueryParam +instance FromFormKey Word8 where parseFormKey = parseQueryParam +instance FromFormKey Word16 where parseFormKey = parseQueryParam +instance FromFormKey Word32 where parseFormKey = parseQueryParam +instance FromFormKey Word64 where parseFormKey = parseQueryParam + +instance FromFormKey Day where parseFormKey = parseQueryParam +instance FromFormKey LocalTime where parseFormKey = parseQueryParam +instance FromFormKey ZonedTime where parseFormKey = parseQueryParam +instance FromFormKey UTCTime where parseFormKey = parseQueryParam +instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam + +instance FromFormKey String where parseFormKey = parseQueryParam +instance FromFormKey Text where parseFormKey = parseQueryParam +instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam + +instance FromFormKey All where parseFormKey = parseQueryParam +instance FromFormKey Any where parseFormKey = parseQueryParam + +instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = fmap Dual . parseFormKey +instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = fmap Sum . parseFormKey +instance FromFormKey a => FromFormKey (Product a) where parseFormKey = fmap Product . parseFormKey + +#if MIN_VERSION_base(4,8,0) +instance FromFormKey Void where parseFormKey = parseQueryParam +instance FromFormKey Natural where parseFormKey = parseQueryParam +#endif + +-- | The contents of a form, not yet URL-encoded. +-- +-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'. +newtype Form = Form { unForm :: HashMap Text [Text] } + deriving (Eq, Read, Generic, Monoid) + +instance Show Form where + showsPrec d form = showParen (d > 10) $ + showString "fromList " . shows (toList form) + +instance IsList Form where + type Item Form = (Text, Text) + fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) + toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm + +-- | Convert a value into 'Form'. +-- +-- An example type and instance: +-- +-- @ +-- {-\# LANGUAGE OverloadedLists \#-} +-- +-- data Person = Person +-- { name :: String +-- , age :: Int } +-- +-- instance 'ToForm' Person where +-- 'toForm' person = +-- [ (\"name\", 'toQueryParam' (name person)) +-- , (\"age\", 'toQueryParam' (age person)) ] +-- @ +-- +-- Instead of manually writing @'ToForm'@ instances you can +-- use a default generic implementation of @'toForm'@. +-- +-- To do that, simply add @deriving 'Generic'@ clause to your datatype +-- and declare a 'ToForm' instance for your datatype without +-- giving definition for 'toForm'. +-- +-- For instance, the previous example can be simplified into this: +-- +-- @ +-- data Person = Person +-- { name :: String +-- , age :: Int +-- } deriving ('Generic') +-- +-- instance 'ToForm' Person +-- @ +-- +-- The default implementation of 'toForm' is 'genericToForm'. +class ToForm a where + -- | Convert a value into 'Form'. + toForm :: a -> Form + default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form + toForm = genericToForm defaultFormOptions + +instance ToForm Form where toForm = id + +instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where + toForm = fromList . map (toFormKey *** toQueryParam) + +instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where + toForm = fromEntriesByKey . Map.toList + +instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where + toForm = fromEntriesByKey . HashMap.toList + +instance ToHttpApiData v => ToForm (IntMap [v]) where + toForm = fromEntriesByKey . IntMap.toList + +-- | Convert a list of entries groupped by key into a 'Form'. +-- +-- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])] +-- fromList [("color","red"),("color","blue"),("name","Nick")] +fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form +fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam) + +data Proxy3 a b c = Proxy3 + +type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where +#if __GLASGOW_HASKELL__ < 800 + -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family + NotSupported cls a "this type family is actually empty" = () +#else + NotSupported cls a reason = TypeError + ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$: + 'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$: + 'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$: + 'Text "(i.e. product types with named fields)." ) +#endif + +-- | A 'Generic'-based implementation of 'toForm'. +-- This is used as a default implementation in 'ToForm'. +-- +-- Note that this only works for records (i.e. product data types with named fields): +-- +-- @ +-- data Person = Person +-- { name :: String +-- , age :: Int +-- } deriving ('Generic') +-- @ +-- +-- In this implementation each field's value gets encoded using `toQueryParam`. +-- Two field types are exceptions: +-- +-- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@ +-- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form'; +-- +-- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list; +-- if the list is empty no entries are added to the 'Form'; +-- +-- Here's an example: +-- +-- @ +-- data Post = Post +-- { title :: String +-- , subtitle :: Maybe String +-- , comments :: [String] +-- } deriving ('Generic', 'Show') +-- +-- instance 'ToForm' Post +-- @ +-- +-- >>> urlEncodeAsForm Post { title = "Test", subtitle = Nothing, comments = ["Nice post!", "+1"] } +-- "comments=Nice%20post%21&comments=%2B1&title=Test" +genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form +genericToForm opts = gToForm (Proxy :: Proxy a) opts . from + +class GToForm t (f :: * -> *) where + gToForm :: Proxy t -> FormOptions -> f x -> Form + +instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where + gToForm p opts (a :*: b) = gToForm p opts a <> gToForm p opts b + +instance (GToForm t f) => GToForm t (M1 D x f) where + gToForm p opts (M1 a) = gToForm p opts a + +instance (GToForm t f) => GToForm t (M1 C x f) where + gToForm p opts (M1 a) = gToForm p opts a + +instance OVERLAPPABLE_ (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where + gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)] + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where + gToForm _ opts (M1 (K1 c)) = + case c of + Nothing -> mempty + Just x -> fromList [(key, toQueryParam x)] + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i [c])) where + gToForm _ opts (M1 (K1 cs)) = fromList (map (\c -> (key, toQueryParam c)) cs) + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance OVERLAPPING_ (Selector s) => GToForm t (M1 S s (K1 i String)) where + gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)] + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible" + +-- | Parse 'Form' into a value. +-- +-- An example type and instance: +-- +-- @ +-- data Person = Person +-- { name :: String +-- , age :: Int } +-- +-- instance 'FromForm' Person where +-- 'fromForm' (Form m) = Person +-- '<$>' 'parseUnique' "name" m +-- '<*>' 'parseUnique' "age" m +-- @ +-- +-- Instead of manually writing @'FromForm'@ instances you can +-- use a default generic implementation of @'fromForm'@. +-- +-- To do that, simply add @deriving 'Generic'@ clause to your datatype +-- and declare a 'FromForm' instance for your datatype without +-- giving definition for 'fromForm'. +-- +-- For instance, the previous example can be simplified into this: +-- +-- @ +-- data Person = Person +-- { name :: String +-- , age :: Int +-- } deriving ('Generic') +-- +-- instance 'FromForm' Person +-- @ +-- +-- The default implementation of 'fromForm' is 'genericFromForm'. +-- It only works for records and it will use 'parseQueryParam' for each field's value. +class FromForm a where + -- | Parse 'Form' into a value. + fromForm :: Form -> Either Text a + default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a + fromForm = genericFromForm defaultFormOptions + +instance FromForm Form where fromForm = pure + +instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where + fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey + +instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where + fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey + +instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where + fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey + +instance FromHttpApiData v => FromForm (IntMap [v]) where + fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey + +-- | Parse a 'Form' into a list of entries groupped by key. +-- +-- >>> toEntriesByKey [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])] +-- Right [("color",["red","white"]),("name",["Nick"])] +toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] +toEntriesByKey = traverse parseGroup . HashMap.toList . unForm + where + parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs + +-- | A 'Generic'-based implementation of 'fromForm'. +-- This is used as a default implementation in 'FromForm'. +-- +-- Note that this only works for records (i.e. product data types with named fields): +-- +-- @ +-- data Person = Person +-- { name :: String +-- , age :: Int +-- } deriving ('Generic') +-- @ +-- +-- In this implementation each field's value gets decoded using `parseQueryParam`. +-- Two field types are exceptions: +-- +-- - for values of type @'Maybe' a@ an entry is parsed if present in the 'Form' +-- and the is decoded with 'parseQueryParam'; if no entry is present result is 'Nothing'; +-- +-- - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values; +-- +-- Here's an example: +-- +-- @ +-- data Post = Post +-- { title :: String +-- , subtitle :: Maybe String +-- , comments :: [String] +-- } deriving ('Generic', 'Show') +-- +-- instance 'FromForm' Post +-- @ +-- +-- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post +-- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]}) +genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a +genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f + +class GFromForm t (f :: * -> *) where + gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x) + +instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where + gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f + +instance GFromForm t f => GFromForm t (M1 D x f) where + gFromForm p opts f = M1 <$> gFromForm p opts f + +instance GFromForm t f => GFromForm t (M1 C x f) where + gFromForm p opts f = M1 <$> gFromForm p opts f + +instance OVERLAPPABLE_ (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where + gFromForm _ opts form = M1 . K1 <$> parseUnique key form + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where + gFromForm _ opts form = M1 . K1 <$> parseMaybe key form + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where + gFromForm _ opts form = M1 . K1 <$> parseAll key form + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where + gFromForm _ opts form = M1 . K1 <$> parseUnique key form + where + key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) + +instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible" + +-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. +-- +-- Key-value pairs get encoded to @key=value@ and separated by @&@: +-- +-- >>> urlEncodeForm [("name", "Julian"), ("lastname", "Arni")] +-- "lastname=Arni&name=Julian" +-- +-- Keys with empty values get encoded to just @key@ (without the @=@ sign): +-- +-- >>> urlEncodeForm [("is_test", "")] +-- "is_test" +-- +-- Empty keys are allowed too: +-- +-- >>> urlEncodeForm [("", "foobar")] +-- "=foobar" +-- +-- However, if not key and value are empty, the key-value pair is ignored. +-- (This prevents @'urlDecodeForm' . 'urlEncodeForm'@ from being a true isomorphism). +-- +-- >>> urlEncodeForm [("", "")] +-- "" +-- +-- Everything is escaped with @'escapeURIString' 'isUnreserved'@: +-- +-- >>> urlEncodeForm [("fullname", "Andres Löh")] +-- "fullname=Andres%20L%C3%B6h" +urlEncodeForm :: Form -> BSL.ByteString +urlEncodeForm = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair . toList + where + escape = urlEncodeQuery . Text.encodeUtf8 + + encodePair (k, "") = escape k + encodePair (k, v) = escape k <> shortByteString "=" <> escape v + + +-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'. +-- +-- Key-value pairs get decoded normally: +-- +-- >>> urlDecodeForm "name=Greg&lastname=Weber" +-- Right (fromList [("lastname","Weber"),("name","Greg")]) +-- +-- Keys with no values get decoded to pairs with empty values. +-- +-- >>> urlDecodeForm "is_test" +-- Right (fromList [("is_test","")]) +-- +-- Empty keys are allowed: +-- +-- >>> urlDecodeForm "=foobar" +-- Right (fromList [("","foobar")]) +-- +-- The empty string gets decoded into an empty 'Form': +-- +-- >>> urlDecodeForm "" +-- Right (fromList []) +-- +-- Everything is un-escaped with 'unEscapeString': +-- +-- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h" +-- Right (fromList [("fullname","Andres L\246h")]) +-- +-- Improperly formed strings result in an error: +-- +-- >>> urlDecodeForm "this=has=too=many=equals" +-- Left "not a valid pair: this=has=too=many=equals" +urlDecodeForm :: BSL.ByteString -> Either Text Form +urlDecodeForm bs = toForm <$> traverse parsePair pairs + where + pairs = map (BSL8.split '=') (BSL8.split '&' bs) + + unescape = Text.decodeUtf8With lenientDecode . urlDecodeQuery . BSL.toStrict + + parsePair p = + case map unescape p of + [k, v] -> return (k, v) + [k] -> return (k, "") + xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs + +-- | This is a convenience function for decoding a +-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype +-- that has an instance of 'FromForm'. +-- +-- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@. +-- +-- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person +-- Right (Person {name = "Dennis", age = 22}) +urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a +urlDecodeAsForm = fromForm <=< urlDecodeForm + +-- | This is a convenience function for encoding a datatype that has instance +-- of 'ToForm' directly to a @application/x-www-form-urlencoded@ +-- 'BSL.ByteString'. +-- +-- This is effectively @'urlEncodeForm' . 'toForm'@. +-- +-- >>> urlEncodeAsForm Person {name = "Dennis", age = 22} +-- "age=22&name=Dennis" +urlEncodeAsForm :: ToForm a => a -> BSL.ByteString +urlEncodeAsForm = urlEncodeForm . toForm + +-- | Find all values corresponding to a given key in a 'Form'. +-- +-- >>> lookupAll "name" [] +-- [] +-- >>> lookupAll "name" [("name", "Oleg")] +-- ["Oleg"] +-- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")] +-- ["Oleg","David"] +lookupAll :: Text -> Form -> [Text] +lookupAll key = F.concat . HashMap.lookup key . unForm + +-- | Lookup an optional value for a key. +-- Fail if there is more than one value. +-- +-- >>> lookupMaybe "name" [] +-- Right Nothing +-- >>> lookupMaybe "name" [("name", "Oleg")] +-- Right (Just "Oleg") +-- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")] +-- Left "Duplicate key \"name\"" +lookupMaybe :: Text -> Form -> Either Text (Maybe Text) +lookupMaybe key form = + case lookupAll key form of + [] -> pure Nothing + [v] -> pure (Just v) + _ -> Left $ "Duplicate key " <> Text.pack (show key) + +-- | Lookup a unique value for a key. +-- Fail if there is zero or more than one value. +-- +-- >>> lookupUnique "name" [] +-- Left "Could not find key \"name\"" +-- >>> lookupUnique "name" [("name", "Oleg")] +-- Right "Oleg" +-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")] +-- Left "Duplicate key \"name\"" +lookupUnique :: Text -> Form -> Either Text Text +lookupUnique key form = do + mv <- lookupMaybe key form + case mv of + Just v -> pure v + Nothing -> Left $ "Could not find key " <> Text.pack (show key) + +-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'. +-- +-- >>> parseAll "age" [] :: Either Text [Word8] +-- Right [] +-- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8] +-- Left "could not parse: `seven' (input does not start with a digit)" +-- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8] +-- Left "out of bounds: `777' (should be between 0 and 255)" +-- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8] +-- Right [12,25] +parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v] +parseAll key = parseQueryParams . lookupAll key + +-- | Lookup an optional value for a given key and parse it with 'parseQueryParam'. +-- Fail if there is more than one value for the key. +-- +-- >>> parseMaybe "age" [] :: Either Text (Maybe Word8) +-- Right Nothing +-- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8) +-- Left "Duplicate key \"age\"" +-- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8) +-- Left "could not parse: `seven' (input does not start with a digit)" +-- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8) +-- Left "out of bounds: `777' (should be between 0 and 255)" +-- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8) +-- Right (Just 7) +parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v) +parseMaybe key = parseQueryParams <=< lookupMaybe key + +-- | Lookup a unique value for a given key and parse it with 'parseQueryParam'. +-- Fail if there is zero or more than one value for the key. +-- +-- >>> parseUnique "age" [] :: Either Text Word8 +-- Left "Could not find key \"age\"" +-- >>> parseUnique "age" [("age", "12"), ("age", "25")] :: Either Text Word8 +-- Left "Duplicate key \"age\"" +-- >>> parseUnique "age" [("age", "seven")] :: Either Text Word8 +-- Left "could not parse: `seven' (input does not start with a digit)" +-- >>> parseUnique "age" [("age", "777")] :: Either Text Word8 +-- Left "out of bounds: `777' (should be between 0 and 255)" +-- >>> parseUnique "age" [("age", "7")] :: Either Text Word8 +-- Right 7 +parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v +parseUnique key form = lookupUnique key form >>= parseQueryParam + +-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'. +-- +-- A common use case for non-default 'FormOptions' +-- is to strip a prefix off of field labels: +-- +-- @ +-- data Project = Project +-- { projectName :: String +-- , projectSize :: Int +-- } deriving ('Generic', 'Show') +-- +-- myOptions :: 'FormOptions' +-- myOptions = 'FormOptions' +-- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") } +-- +-- instance 'ToForm' Project where +-- 'toForm' = 'genericToForm' myOptions +-- +-- instance 'FromForm' Project where +-- 'fromForm' = 'genericFromForm' myOptions +-- @ +-- +-- >>> urlEncodeAsForm Project { projectName = "http-api-data", projectSize = 172 } +-- "size=172&name=http-api-data" +-- >>> urlDecodeAsForm "name=http-api-data&size=172" :: Either Text Project +-- Right (Project {projectName = "http-api-data", projectSize = 172}) +data FormOptions = FormOptions + { -- | Function applied to field labels. Handy for removing common record prefixes for example. + fieldLabelModifier :: String -> String + } + +-- | Default encoding 'FormOptions'. +-- +-- @ +-- 'FormOptions' +-- { 'fieldLabelModifier' = id +-- } +-- @ +defaultFormOptions :: FormOptions +defaultFormOptions = FormOptions + { fieldLabelModifier = id + } diff --git a/src/Web/Internal/HttpApiData.hs b/src/Web/Internal/HttpApiData.hs new file mode 100644 --- /dev/null +++ b/src/Web/Internal/HttpApiData.hs @@ -0,0 +1,579 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Convert Haskell values to and from HTTP API data +-- such as URL pieces, headers and query parameters. +module Web.Internal.HttpApiData where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +import Data.Traversable (Traversable(traverse)) +#endif + +import Control.Arrow ((&&&), left) +import Control.Monad ((<=<)) + +import Data.Monoid +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + +import Data.Int +import Data.Word + +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8') +import Data.Text.Read (signed, decimal, rational, Reader) +import qualified Data.Text as T +import qualified Data.Text.Lazy as L + +import Data.Time.Locale.Compat +import Data.Time +import Data.Version + +#if MIN_VERSION_base(4,8,0) +import Data.Void +import Numeric.Natural +#endif + +import Text.Read (readMaybe) +import Text.ParserCombinators.ReadP (readP_to_S) + +#if USE_TEXT_SHOW +import TextShow (TextShow, showt) +#endif + +-- $setup +-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) +-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p + +-- | Convert value to HTTP API data. +-- +-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated +-- instance will loop indefinitely. +class ToHttpApiData a where + {-# MINIMAL toUrlPiece | toQueryParam #-} + -- | Convert to URL path piece. + toUrlPiece :: a -> Text + toUrlPiece = toQueryParam + + -- | Convert to HTTP header value. + toHeader :: a -> ByteString + toHeader = encodeUtf8 . toUrlPiece + + -- | Convert to query param value. + toQueryParam :: a -> Text + toQueryParam = toUrlPiece + +-- | Parse value from HTTP API data. +-- +-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated +-- instance will loop indefinitely. +class FromHttpApiData a where + {-# MINIMAL parseUrlPiece | parseQueryParam #-} + -- | Parse URL path piece. + parseUrlPiece :: Text -> Either Text a + parseUrlPiece = parseQueryParam + + -- | Parse HTTP header value. + parseHeader :: ByteString -> Either Text a + parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8') + + -- | Parse query param value. + parseQueryParam :: Text -> Either Text a + parseQueryParam = parseUrlPiece + +-- | Convert multiple values to a list of URL pieces. +-- +-- >>> toUrlPieces [1, 2, 3] :: [Text] +-- ["1","2","3"] +toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text +toUrlPieces = fmap toUrlPiece + +-- | Parse multiple URL pieces. +-- +-- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool] +-- Right [True,False] +-- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int] +-- Left "could not parse: `hello' (input does not start with a digit)" +parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) +parseUrlPieces = traverse parseUrlPiece + +-- | Convert multiple values to a list of query parameter values. +-- +-- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text] +-- ["2015-10-03","2015-12-01"] +toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text +toQueryParams = fmap toQueryParam + +-- | Parse multiple query parameters. +-- +-- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int] +-- Right [1,2,3] +-- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8] +-- Left "out of bounds: `256' (should be between 0 and 255)" +parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) +parseQueryParams = traverse parseQueryParam + +-- | Parse URL path piece in a @'Maybe'@. +-- +-- >>> parseUrlPieceMaybe "12" :: Maybe Int +-- Just 12 +parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a +parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece + +-- | Parse HTTP header value in a @'Maybe'@. +-- +-- >>> parseHeaderMaybe "hello" :: Maybe Text +-- Just "hello" +parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a +parseHeaderMaybe = either (const Nothing) Just . parseHeader + +-- | Parse query param value in a @'Maybe'@. +-- +-- >>> parseQueryParamMaybe "true" :: Maybe Bool +-- Just True +parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a +parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam + +-- | Default parsing error. +defaultParseError :: Text -> Either Text a +defaultParseError input = Left ("could not parse: `" <> input <> "'") + +-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message. +parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a) +parseMaybeTextData parse input = + case parse input of + Nothing -> defaultParseError input + Just val -> Right val + +#if USE_TEXT_SHOW +-- | /Lower case/. +-- +-- Convert to URL piece using @'TextShow'@ instance. +-- The result is always lower cased. +-- +-- >>> showTextData True +-- "true" +-- +-- This can be used as a default implementation for enumeration types: +-- +-- @ +-- data MyData = Foo | Bar | Baz deriving (Generic) +-- +-- instance TextShow MyData where +-- showt = genericShowt +-- +-- instance ToHttpApiData MyData where +-- toUrlPiece = showTextData +-- @ +showTextData :: TextShow a => a -> Text +showTextData = T.toLower . showt +#else +-- | /Lower case/. +-- +-- Convert to URL piece using @'Show'@ instance. +-- The result is always lower cased. +-- +-- >>> showTextData True +-- "true" +-- +-- This can be used as a default implementation for enumeration types: +-- +-- >>> data MyData = Foo | Bar | Baz deriving (Show) +-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData +-- >>> toUrlPiece Foo +-- "foo" +showTextData :: Show a => a -> Text +showTextData = T.toLower . showt + +-- | Like @'show'@, but returns @'Text'@. +showt :: Show a => a -> Text +showt = T.pack . show +#endif + +-- | /Case insensitive/. +-- +-- Parse given text case insensitive and then parse the rest of the input +-- using @'parseUrlPiece'@. +-- +-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int +-- Right 10 +-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool +-- Left "could not parse: `left'" +-- +-- This can be used to implement @'FromHttpApiData'@ for single field constructors: +-- +-- >>> data Foo = Foo Int deriving (Show) +-- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s +-- >>> parseUrlPiece "foo 1" :: Either Text Foo +-- Right (Foo 1) +parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a +parseUrlPieceWithPrefix pattern input + | T.toLower pattern == T.toLower prefix = parseUrlPiece rest + | otherwise = defaultParseError input + where + (prefix, rest) = T.splitAt (T.length pattern) input + +-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@. +-- +-- @ +-- data BasicAuthToken = BasicAuthToken Text deriving (Show) +-- +-- instance FromHttpApiData BasicAuthToken where +-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h +-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p +-- @ +-- +-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken +-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==") +parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a +parseHeaderWithPrefix pattern input + | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input) + | otherwise = defaultParseError (showt input) + +-- | /Case insensitive/. +-- +-- Parse given text case insensitive and then parse the rest of the input +-- using @'parseQueryParam'@. +-- +-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int +-- Right 10 +parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a +parseQueryParamWithPrefix pattern input + | T.toLower pattern == T.toLower prefix = parseQueryParam rest + | otherwise = defaultParseError input + where + (prefix, rest) = T.splitAt (T.length pattern) input + +#if USE_TEXT_SHOW +-- | /Case insensitive/. +-- +-- Parse values case insensitively based on @'TextShow'@ instance. +-- +-- >>> parseBoundedTextData "true" :: Either Text Bool +-- Right True +-- >>> parseBoundedTextData "FALSE" :: Either Text Bool +-- Right False +-- +-- This can be used as a default implementation for enumeration types: +-- +-- @ +-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic) +-- +-- instance TextShow MyData where +-- showt = genericShowt +-- +-- instance FromHttpApiData MyData where +-- parseUrlPiece = parseBoundedTextData +-- @ +parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a +#else +-- | /Case insensitive/. +-- +-- Parse values case insensitively based on @'Show'@ instance. +-- +-- >>> parseBoundedTextData "true" :: Either Text Bool +-- Right True +-- >>> parseBoundedTextData "FALSE" :: Either Text Bool +-- Right False +-- +-- This can be used as a default implementation for enumeration types: +-- +-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum) +-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData +-- >>> parseUrlPiece "foo" :: Either Text MyData +-- Right Foo +parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a +#endif +parseBoundedTextData = parseBoundedEnumOfI showTextData + +-- | Lookup values based on a precalculated mapping of their representations. +lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a +lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound]) + +-- | Parse values based on a precalculated mapping of their @'Text'@ representation. +-- +-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool +-- Right True +-- +-- For case sensitive parser see 'parseBoundedEnumOfI'. +parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a +parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf + +-- | /Case insensitive/. +-- +-- Parse values case insensitively based on a precalculated mapping +-- of their @'Text'@ representations. +-- +-- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool +-- Right False +-- +-- For case sensitive parser see 'parseBoundedEnumOf'. +parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a +parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower + +-- | /Case insensitive/. +-- +-- Parse values case insensitively based on @'ToHttpApiData'@ instance. +-- Uses @'toUrlPiece'@ to get possible values. +parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a +parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece + +-- | /Case insensitive/. +-- +-- Parse values case insensitively based on @'ToHttpApiData'@ instance. +-- Uses @'toQueryParam'@ to get possible values. +parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a +parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam + +-- | Parse values based on @'ToHttpApiData'@ instance. +-- Uses @'toHeader'@ to get possible values. +parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a +parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of + Nothing -> defaultParseError $ T.pack $ show bs + Just x -> return x + +-- | Parse URL piece using @'Read'@ instance. +-- +-- Use for types which do not involve letters: +-- +-- >>> readTextData "1991-06-02" :: Either Text Day +-- Right 1991-06-02 +-- +-- This parser is case sensitive and will not match @'showTextData'@ +-- in presense of letters: +-- +-- >>> readTextData (showTextData True) :: Either Text Bool +-- Left "could not parse: `true'" +-- +-- See @'parseBoundedTextData'@. +readTextData :: Read a => Text -> Either Text a +readTextData = parseMaybeTextData (readMaybe . T.unpack) + +-- | Run @'Reader'@ as HTTP API data parser. +runReader :: Reader a -> Text -> Either Text a +runReader reader input = + case reader input of + Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")") + Right (x, rest) + | T.null rest -> Right x + | otherwise -> defaultParseError input + +-- | Run @'Reader'@ to parse bounded integral value with bounds checking. +-- +-- >>> parseBounded decimal "256" :: Either Text Word8 +-- Left "out of bounds: `256' (should be between 0 and 255)" +parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a +parseBounded reader input = do + n <- runReader reader input + if (n > h || n < l) + then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")") + else Right (fromInteger n) + where + l = toInteger (minBound :: a) + h = toInteger (maxBound :: a) + +-- | +-- >>> toUrlPiece () +-- "_" +instance ToHttpApiData () where + toUrlPiece () = "_" + +instance ToHttpApiData Char where toUrlPiece = T.singleton + +-- | +-- >>> toUrlPiece (Version [1, 2, 3] []) +-- "1.2.3" +instance ToHttpApiData Version where + toUrlPiece = T.pack . showVersion + +#if MIN_VERSION_base(4,8,0) +instance ToHttpApiData Void where toUrlPiece = absurd +instance ToHttpApiData Natural where toUrlPiece = showt +#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 + +-- | +-- >>> toUrlPiece (fromGregorian 2015 10 03) +-- "2015-10-03" +instance ToHttpApiData Day where toUrlPiece = T.pack . show + +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" + +-- | +-- >>> 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" + +-- | +-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864 +-- "2015-10-03T00:14:24Z" +instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%SZ" + +instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer) + +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 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 + +-- | +-- >>> toUrlPiece (Just "Hello") +-- "just Hello" +instance ToHttpApiData a => ToHttpApiData (Maybe a) where + toUrlPiece (Just x) = "just " <> toUrlPiece x + toUrlPiece Nothing = "nothing" + +-- | +-- >>> toUrlPiece (Left "err" :: Either String Int) +-- "left err" +-- >>> toUrlPiece (Right 3 :: Either String Int) +-- "right 3" +instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where + toUrlPiece (Left x) = "left " <> toUrlPiece x + toUrlPiece (Right x) = "right " <> toUrlPiece x + +-- | +-- >>> parseUrlPiece "_" :: Either Text () +-- Right () +instance FromHttpApiData () where + parseUrlPiece "_" = pure () + parseUrlPiece s = defaultParseError s + +instance FromHttpApiData Char where + parseUrlPiece s = + case T.uncons s of + Just (c, s') | T.null s' -> pure c + _ -> defaultParseError s + +-- | +-- >>> showVersion <$> parseUrlPiece "1.2.3" +-- Right "1.2.3" +instance FromHttpApiData Version where + parseUrlPiece s = + case reverse (readP_to_S parseVersion (T.unpack s)) of + ((x, ""):_) -> pure x + _ -> defaultParseError s + +#if MIN_VERSION_base(4,8,0) +-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors. +instance FromHttpApiData Void where + parseUrlPiece _ = Left "Void cannot be parsed!" + +instance FromHttpApiData Natural where + parseUrlPiece s = do + n <- runReader (signed decimal) s + if n < 0 + then Left ("undeflow: " <> s <> " (should be a non-negative integer)") + else Right (fromInteger n) +#endif + +instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece +instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece +instance FromHttpApiData Double where parseUrlPiece = runReader rational +instance FromHttpApiData Float where parseUrlPiece = runReader rational +instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal) +instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal) +instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal) +instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal) +instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal) +instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal) +instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal +instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal +instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal +instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal +instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal +instance FromHttpApiData String where parseUrlPiece = Right . T.unpack +instance FromHttpApiData Text where parseUrlPiece = Right +instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict + +-- | +-- >>> toGregorian <$> parseUrlPiece "2016-12-01" +-- Right (2016,12,1) +instance FromHttpApiData Day where parseUrlPiece = readTextData + +timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t +timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack) + where + timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt)) + +-- | +-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime +-- Right 2015-10-03 14:55:01 +instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S" + +-- | +-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime +-- Right 2015-10-03 14:55:01 +0000 +instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z" + +-- | +-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime +-- Right 2015-10-03 00:14:24 UTC +instance FromHttpApiData UTCTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ" + +instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece + +instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece +instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece + +instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece +instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece +instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece +instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece +instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece + +-- | +-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int) +-- Right (Just 123) +instance FromHttpApiData a => FromHttpApiData (Maybe a) where + parseUrlPiece s + | T.toLower (T.take 7 s) == "nothing" = pure Nothing + | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s + +-- | +-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int) +-- Right (Right 123) +instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where + parseUrlPiece s = + Right <$> parseUrlPieceWithPrefix "Right " s + Left <$> parseUrlPieceWithPrefix "Left " s + where + infixl 3 + Left _ y = y + x _ = x + diff --git a/test/DocTest.hs b/test/DocTest.hs --- a/test/DocTest.hs +++ b/test/DocTest.hs @@ -11,6 +11,7 @@ main :: IO () main = getSources >>= \sources -> doctest $ "-isrc" + : "-Iinclude" : ("-i" ++ autogen_dir) : "-optP-include" : ("-optP" ++ autogen_dir ++ "/cabal_macros.h") diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,132 +1,1 @@ -{-# Language ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where - -import Control.Applicative - -import Data.Int -import Data.Char -import Data.Word -import Data.Time -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified Data.ByteString as BS -import Data.Version - -import Test.Hspec -import Test.Hspec.QuickCheck(prop) -import Test.QuickCheck - -import Web.HttpApiData - -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary L.Text where - arbitrary = L.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 - -main :: IO () -main = hspec spec - -(<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool -(f <=> g) x = g (f x) == Right x - -data Proxy a = Proxy - -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) - -data RandomCase a = RandomCase [Bool] a - -instance ToHttpApiData a => Show (RandomCase a) where - show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")" - -instance Eq a => Eq (RandomCase a) where - RandomCase _ x == RandomCase _ y = x == y - -instance Arbitrary a => Arbitrary (RandomCase a) where - arbitrary = liftA2 RandomCase nonempty arbitrary - where - nonempty = liftA2 (:) arbitrary arbitrary - -instance ToHttpApiData a => ToHttpApiData (RandomCase a) where - toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x))) - -instance FromHttpApiData a => FromHttpApiData (RandomCase a) where - parseUrlPiece s = RandomCase [] <$> parseUrlPiece s - --- | Check case insensitivity for @parseUrlPiece@. -checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec -checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a)) - -spec :: Spec -spec = do - describe "toUrlPiece <=> parseUrlPiece" $ do - checkUrlPiece (Proxy :: Proxy ()) "()" - checkUrlPiece (Proxy :: Proxy Char) "Char" - checkUrlPieceI (Proxy :: Proxy Bool) "Bool" - checkUrlPieceI (Proxy :: Proxy Ordering) "Ordering" - checkUrlPiece (Proxy :: Proxy Int) "Int" - checkUrlPiece (Proxy :: Proxy Int8) "Int8" - checkUrlPiece (Proxy :: Proxy Int16) "Int16" - checkUrlPiece (Proxy :: Proxy Int32) "Int32" - checkUrlPiece (Proxy :: Proxy Int64) "Int64" - checkUrlPiece (Proxy :: Proxy Integer) "Integer" - checkUrlPiece (Proxy :: Proxy Word) "Word" - checkUrlPiece (Proxy :: Proxy Word8) "Word8" - checkUrlPiece (Proxy :: Proxy Word16) "Word16" - checkUrlPiece (Proxy :: Proxy Word32) "Word32" - checkUrlPiece (Proxy :: Proxy Word64) "Word64" - checkUrlPiece (Proxy :: Proxy String) "String" - 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 (Proxy :: Proxy Version) "Version" - - checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String" - checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer" - checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text" - checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day" - - it "bad integers are rejected" $ do - parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int) - - it "bounds checking works" $ do - parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8) - parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word) - - it "invalid utf8 is handled" $ do - parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text) - +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Web/Internal/FormUrlEncodedSpec.hs b/test/Web/Internal/FormUrlEncodedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Internal/FormUrlEncodedSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Web.Internal.FormUrlEncodedSpec (spec) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +import Data.Monoid +#endif + +import Control.Monad ((<=<)) +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text, unpack) +import Test.Hspec +import Test.QuickCheck + +import GHC.Exts (fromList) + +import Web.Internal.FormUrlEncoded +import Web.Internal.HttpApiData +import Web.Internal.TestInstances + +spec :: Spec +spec = do + genericSpec + urlEncoding + +genericSpec :: Spec +genericSpec = describe "Default (generic) instances" $ do + + context "ToForm" $ do + + it "contains the record names" $ property $ \(x :: SimpleRec) -> do + let f = unForm $ toForm x + HashMap.member "rec1" f `shouldBe` True + HashMap.member "rec2" f `shouldBe` True + + it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do + let f = unForm $ toForm x + HashMap.lookup "rec1" f `shouldBe` Just [rec1 x] + (parseQueryParams <$> HashMap.lookup "rec2" f) `shouldBe` Just (Right [rec2 x]) + + context "FromForm" $ do + + it "is the right inverse of ToForm" $ property $ \x (y :: Int) -> do + let f1 = fromList [("rec1", x), ("rec2", toQueryParam y)] + Right r1 = fromForm f1 :: Either Text SimpleRec + toForm r1 `shouldBe` f1 + + it "returns the underlying error" $ do + let f = fromList [("rec1", "anything"), ("rec2", "bad")] + Left e = fromForm f :: Either Text SimpleRec + unpack e `shouldContain` "input does not start with a digit" + +urlEncoding :: Spec +urlEncoding = describe "urlEncoding" $ do + + it "urlDecodeForm (urlEncodeForm x) == Right x" $ property $ \(NoEmptyKeyForm x) -> do + urlDecodeForm (urlEncodeForm x) `shouldBe` Right x + + it "urlDecodeAsForm == (fromForm <=< urlDecodeForm)" $ property $ \(x :: BSL.ByteString) -> do + (urlDecodeAsForm x :: Either Text Form) `shouldBe` (fromForm <=< urlDecodeForm) x + + it "urlEncodeAsForm == urlEncodeForm . toForm" $ property $ \(x :: Form) -> do + urlEncodeAsForm x `shouldBe` (urlEncodeForm . toForm) x + + it "urlDecodeForm \"\" == Right mempty" $ do + urlDecodeForm "" `shouldBe` Right mempty diff --git a/test/Web/Internal/HttpApiDataSpec.hs b/test/Web/Internal/HttpApiDataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Internal/HttpApiDataSpec.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Web.Internal.HttpApiDataSpec (spec) where + +import Data.Int +import Data.Word +import Data.Time +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.ByteString as BS +import Data.Version + +import Data.Proxy + +#if MIN_VERSION_base(4,8,0) +import Numeric.Natural +#endif + +import Test.Hspec +import Test.Hspec.QuickCheck(prop) +import Test.QuickCheck + +import Web.Internal.HttpApiData + +import Web.Internal.TestInstances + +(<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool +(f <=> g) x = g (f x) == Right 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) + +-- | 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)) + +spec :: Spec +spec = do + describe "toUrlPiece <=> parseUrlPiece" $ do + checkUrlPiece (Proxy :: Proxy ()) "()" + checkUrlPiece (Proxy :: Proxy Char) "Char" + checkUrlPieceI (Proxy :: Proxy Bool) "Bool" + checkUrlPieceI (Proxy :: Proxy Ordering) "Ordering" + checkUrlPiece (Proxy :: Proxy Int) "Int" + checkUrlPiece (Proxy :: Proxy Int8) "Int8" + checkUrlPiece (Proxy :: Proxy Int16) "Int16" + checkUrlPiece (Proxy :: Proxy Int32) "Int32" + checkUrlPiece (Proxy :: Proxy Int64) "Int64" + checkUrlPiece (Proxy :: Proxy Integer) "Integer" + checkUrlPiece (Proxy :: Proxy Word) "Word" + checkUrlPiece (Proxy :: Proxy Word8) "Word8" + checkUrlPiece (Proxy :: Proxy Word16) "Word16" + checkUrlPiece (Proxy :: Proxy Word32) "Word32" + checkUrlPiece (Proxy :: Proxy Word64) "Word64" + checkUrlPiece (Proxy :: Proxy String) "String" + 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 (Proxy :: Proxy Version) "Version" + + checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String" + checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer" + checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text" + checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day" + +#if MIN_VERSION_base(4,8,0) + checkUrlPiece (Proxy :: Proxy Natural) "Natural" +#endif + + it "bad integers are rejected" $ do + parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int) + + it "bounds checking works" $ do + parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8) + parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word) + + it "invalid utf8 is handled" $ do + parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text) diff --git a/test/Web/Internal/TestInstances.hs b/test/Web/Internal/TestInstances.hs new file mode 100644 --- /dev/null +++ b/test/Web/Internal/TestInstances.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Web.Internal.TestInstances + ( RandomCase(..) + , SimpleRec(..) + , NoEmptyKeyForm(..) + ) 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 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 + +data RandomCase a = RandomCase [Bool] a + +instance ToHttpApiData a => Show (RandomCase a) where + show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")" + +instance Eq a => Eq (RandomCase a) where + RandomCase _ x == RandomCase _ y = x == y + +instance Arbitrary a => Arbitrary (RandomCase a) where + arbitrary = liftA2 RandomCase nonempty arbitrary + where + nonempty = liftA2 (:) arbitrary arbitrary + +instance ToHttpApiData a => ToHttpApiData (RandomCase a) where + toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x))) + +instance FromHttpApiData a => FromHttpApiData (RandomCase a) where + parseUrlPiece s = RandomCase [] <$> parseUrlPiece s + +data SimpleRec = SimpleRec { rec1 :: T.Text, rec2 :: Int } + deriving (Eq, Show, Read, Generic) + +instance ToForm SimpleRec +instance FromForm SimpleRec + +instance Arbitrary SimpleRec where + arbitrary = SimpleRec <$> arbitrary <*> arbitrary + +newtype NoEmptyKeyForm = + NoEmptyKeyForm { unNoEmptyKeyForm :: Form } + deriving Show + +instance Arbitrary NoEmptyKeyForm where + arbitrary = NoEmptyKeyForm . removeEmptyKeys <$> arbitrary + where + removeEmptyKeys (Form m) = Form (HashMap.delete "" m)