module Network.HTTP.Kinder.Header.Serialization (
HeaderEncode (..)
, HeaderDecode (..)
, AllHeaderEncodes
, AllHeaderDecodes
, headerEncodePair
, headerEncodeBS
, headerDecodeBS
, displaySetOpt
, uniqueSet
, required
, withDefault
) where
import qualified Data.ByteString as S
import Data.CaseInsensitive (CI)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Singletons
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time
import GHC.Exts
import Network.HTTP.Kinder.Common
import Network.HTTP.Kinder.Header.Definitions
import Network.HTTP.Kinder.Verb
import Network.HTTP.Media (MediaType, Quality)
import qualified Network.HTTP.Media as Media
class HeaderEncode (n :: HeaderName) a where
headerEncode :: sing n -> a -> Maybe Text
type family AllHeaderEncodes hs :: Constraint where
AllHeaderEncodes '[] = ()
AllHeaderEncodes ( '(n, a) ': hs ) = (HeaderEncode n a, AllHeaderEncodes hs)
headerEncodePair
:: forall a (n :: HeaderName)
. HeaderEncode n a => Sing n -> a -> Maybe (CI S.ByteString, S.ByteString)
headerEncodePair s a = do
bs <- headerEncodeBS s a
return (headerName s, bs)
headerEncodeBS :: HeaderEncode n a => sing n -> a -> Maybe S.ByteString
headerEncodeBS s = fmap Text.encodeUtf8 . headerEncode s
class HeaderDecode (n :: HeaderName) a where
headerDecode :: sing n -> Maybe Text -> Either String a
type family AllHeaderDecodes hs :: Constraint where
AllHeaderDecodes '[] = ()
AllHeaderDecodes ( '(n, a) ': hs ) = (HeaderDecode n a, AllHeaderDecodes hs)
headerDecodeBS :: HeaderDecode n a => sing n -> Maybe S.ByteString -> Either String a
headerDecodeBS proxy mays =
case mays of
Nothing -> headerDecode proxy Nothing
Just s ->
case Text.decodeUtf8' s of
Left err -> Left (show err)
Right t -> headerDecode proxy (Just t)
displaySetOpt :: Set Text -> Maybe Text
displaySetOpt s
| Set.null s = Nothing
| otherwise = Just (Text.intercalate "," (Set.toList s))
uniqueSet :: (Ord v, HeaderEncode n (Set v)) => sing n -> [v] -> Maybe Text
uniqueSet s = headerEncode s . Set.fromList
instance HeaderEncode n (Raw Text) where
headerEncode _ (Raw t) = Just t
instance HeaderEncode 'Allow (Set Verb) where
headerEncode _ = displaySetOpt . Set.map verbName
instance HeaderEncode 'Allow [Verb] where
headerEncode = uniqueSet
instance HeaderEncode 'AccessControlExposeHeaders (Set SomeHeaderName) where
headerEncode _ = displaySetOpt . Set.map headerName' where
headerName' (SomeHeaderName h) = headerName h
instance HeaderEncode 'AccessControlExposeHeaders [SomeHeaderName] where
headerEncode = uniqueSet
instance HeaderEncode 'AccessControlAllowHeaders (Set SomeHeaderName) where
headerEncode _ = displaySetOpt . Set.map headerName' where
headerName' (SomeHeaderName h) = headerName h
instance HeaderEncode 'AccessControlAllowHeaders [SomeHeaderName] where
headerEncode = uniqueSet
instance HeaderEncode 'AccessControlMaxAge NominalDiffTime where
headerEncode _ ndt = Just $ Text.pack (show (round ndt :: Int))
instance HeaderEncode 'AccessControlAllowOrigin Text where
headerEncode _ org = Just org
instance HeaderEncode 'AccessControlAllowMethods (Set Verb) where
headerEncode _ = displaySetOpt . Set.map verbName
instance HeaderEncode 'AccessControlAllowMethods [Verb] where
headerEncode = uniqueSet
instance HeaderEncode 'AccessControlAllowCredentials Bool where
headerEncode _ ok = Just (if ok then "true" else "false")
instance HeaderEncode 'ContentType MediaType where
headerEncode _ mt =
case Text.decodeUtf8' (Media.renderHeader mt) of
Left _err -> Nothing
Right txt -> Just txt
instance HeaderEncode h t => HeaderEncode h (Maybe t) where
headerEncode p v = v >>= headerEncode p
required :: (Text -> Either String a) -> Maybe Text -> Either String a
required _ Nothing = Left "missing header value"
required f (Just t) = f t
withDefault :: a -> (Text -> Either String a) -> (Maybe Text -> Either String a)
withDefault def _ Nothing = Right def
withDefault _ f (Just a) = f a
instance HeaderDecode Accept [Quality MediaType] where
headerDecode _ = withDefault [] parser where
parser txt =
case Media.parseQuality (Text.encodeUtf8 txt) of
Nothing -> Left "malformed accept header"
Just mts -> Right mts
instance HeaderDecode ContentType MediaType where
headerDecode _ = required $ \txt ->
case Media.parseAccept (Text.encodeUtf8 txt) of
Nothing -> Left "malformed content type"
Just ct -> Right ct
instance HeaderDecode n (Raw Text) where
headerDecode _ = required $ \text -> Right (Raw text)
instance HeaderDecode h t => HeaderDecode h (Maybe t) where
headerDecode _ Nothing = Right Nothing
headerDecode p (Just t) = fmap Just (headerDecode p (Just t))