module Web.Internal.HttpApiData where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
import Data.Foldable (Foldable)
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
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
import qualified Data.Attoparsec.Text as Atto
import qualified Data.Attoparsec.Time as Atto
class ToHttpApiData a where
toUrlPiece :: a -> Text
toUrlPiece = toQueryParam
toEncodedUrlPiece :: a -> BS.Builder
toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
toHeader :: a -> ByteString
toHeader = encodeUtf8 . toUrlPiece
toQueryParam :: a -> Text
toQueryParam = toUrlPiece
class FromHttpApiData a where
parseUrlPiece :: Text -> Either Text a
parseUrlPiece = parseQueryParam
parseHeader :: ByteString -> Either Text a
parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')
parseQueryParam :: Text -> Either Text a
parseQueryParam = parseUrlPiece
toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text
toUrlPieces = fmap toUrlPiece
parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
parseUrlPieces = traverse parseUrlPiece
toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text
toQueryParams = fmap toQueryParam
parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
parseQueryParams = traverse parseQueryParam
parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a
parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece
parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a
parseHeaderMaybe = either (const Nothing) Just . parseHeader
parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a
parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam
defaultParseError :: Text -> Either Text a
defaultParseError input = Left ("could not parse: `" <> input <> "'")
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
showTextData :: TextShow a => a -> Text
showTextData = T.toLower . showt
#else
showTextData :: Show a => a -> Text
showTextData = T.toLower . showt
showt :: Show a => a -> Text
showt = T.pack . show
#endif
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
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)
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
parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a
#else
parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a
#endif
parseBoundedTextData = parseBoundedEnumOfI showTextData
lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a
lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower
parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece
parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam
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
readTextData :: Read a => Text -> Either Text a
readTextData = parseMaybeTextData (readMaybe . T.unpack)
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
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)
unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder
unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece
instance ToHttpApiData () where
toUrlPiece () = "_"
toEncodedUrlPiece = unsafeToEncodedUrlPiece
instance ToHttpApiData Char where
toUrlPiece = T.singleton
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; toEncodedUrlPiece = unsafeToEncodedUrlPiece
#endif
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
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))
instance ToHttpApiData TimeOfDay where
toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q"
toEncodedUrlPiece = unsafeToEncodedUrlPiece
instance ToHttpApiData LocalTime where
toUrlPiece = timeToUrlPiece "%H:%M:%S%Q"
toEncodedUrlPiece = unsafeToEncodedUrlPiece
instance ToHttpApiData ZonedTime where
toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z"
toEncodedUrlPiece = unsafeToEncodedUrlPiece
instance ToHttpApiData UTCTime where
toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
toEncodedUrlPiece = unsafeToEncodedUrlPiece
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; 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 (Last a) where
toUrlPiece = toUrlPiece . getLast
toEncodedUrlPiece = toEncodedUrlPiece . getLast
instance ToHttpApiData a => ToHttpApiData (Maybe a) where
toUrlPiece (Just x) = "just " <> toUrlPiece x
toUrlPiece Nothing = "nothing"
instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
toUrlPiece (Left x) = "left " <> toUrlPiece x
toUrlPiece (Right x) = "right " <> toUrlPiece x
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
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)
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 ("underflow: " <> 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
instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day
instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay
instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime
instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
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
instance FromHttpApiData a => FromHttpApiData (Maybe a) where
parseUrlPiece s
| T.toLower (T.take 7 s) == "nothing" = pure Nothing
| otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
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
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
parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes
newtype LenientData a = LenientData { getLenientData :: Either Text a }
deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable)
instance FromHttpApiData a => FromHttpApiData (LenientData a) where
parseUrlPiece = Right . LenientData . parseUrlPiece
parseHeader = Right . LenientData . parseHeader
parseQueryParam = Right . LenientData . parseQueryParam
runAtto :: Atto.Parser a -> Text -> Either Text a
runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
Left err -> Left (T.pack err)
Right x -> Right x