Serialization.hs

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE ExplicitForAll        #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

-- | 'HeaderName's define semantics for 'Text' values seen in HTTP headers
-- over the wire. This module provides classes to map both to and from
-- these reprsentations.
module Network.HTTP.Kinder.Header.Serialization (


  -- * Classes for encoding and decoding

    HeaderEncode (..)
  , HeaderDecode (..)

  -- ** Listing constraints to type-level lists

  , AllHeaderEncodes
  , AllHeaderDecodes

  -- * Extra serialization utilities

  , headerEncodePair
  , headerEncodeBS
  , headerDecodeBS

  -- * Utilities for writing serialization instances

  , 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

-- | Determines a 'Text' representation for some value to be encoded as
-- a value of a given 'HeaderName'. Any proxy can be passed as the first
-- argument, although 'Sing' is a nice one to choose. Encodings may choose
-- to not be represented on the wire at all as desired by returning
-- 'Nothing'. This implies default behavior.
class HeaderEncode (n :: HeaderName) a where
  headerEncode :: sing n -> a -> Maybe Text

-- | For a given concrete type @a@, a list of pairs @ts@ satisfies
-- @'AllHeaderEncode' a ts@ if each @(n, a)@ in @ts@ has @'HeaderEncode'
-- n a@.
type family AllHeaderEncodes hs :: Constraint where
  AllHeaderEncodes '[] = ()
  AllHeaderEncodes ( '(n, a) ': hs ) = (HeaderEncode n a, AllHeaderEncodes hs)

-- | Encode a 'HeaderName' singleton and a 'HeaderEncode'-represented value
-- as a pair of name and representation, ready to be sent over the wire.
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)

-- | While the semantics of HTTP headers are built off of 'Text'-like
-- values, usually we require a 'S.ByteString' for emission. This helper
-- function converts a header value directly to a 'S.ByteString'.
headerEncodeBS :: HeaderEncode n a => sing n -> a -> Maybe S.ByteString
headerEncodeBS s = fmap Text.encodeUtf8 . headerEncode s

-- | Interprets a (possibly missing) 'Text' representation for some value
-- taking semantics at a given 'HeaderName'. Any proxy can be passed as the
-- first argument, although 'Sing' is a nice one to choose. If a value is
-- expected and no representation is provided then 'Nothing' can be passed
-- seeking a default value (should one exist).
class HeaderDecode (n :: HeaderName) a where
  headerDecode :: sing n -> Maybe Text -> Either String a

-- | For a given concrete type @a@, a list of pairs @ts@ satisfies
-- @'AllHeaderDecode' a ts@ if each @(n, a)@ in @ts@ has @'HeaderDecode'
-- n a@.
type family AllHeaderDecodes hs :: Constraint where
  AllHeaderDecodes '[] = ()
  AllHeaderDecodes ( '(n, a) ': hs ) = (HeaderDecode n a, AllHeaderDecodes hs)

-- | While HTTP header semantics are built off of 'Text'-like values, we
-- usually read a raw 'S.ByteString' from the wire. This helper function
-- combines a 'HeaderDecode' with a UTF-8 decode so as to attempt to
-- deserialize header values directly from a 'S.ByteString'.
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)

-- Instances/Encoding
-- ----------------------------------------------------------------------------

-- | Output a set of text items as a comma-delimited list OR return nothing
-- if the set is empty
displaySetOpt :: Set Text -> Maybe Text
displaySetOpt s
  | Set.null s = Nothing
  | otherwise = Just (Text.intercalate "," (Set.toList s))

-- | Extend a 'HeaderEncode' instance on @'Set' v@ to @[v]@.
uniqueSet :: (Ord v, HeaderEncode n (Set v)) => sing n -> [v] -> Maybe Text
uniqueSet s = headerEncode s . Set.fromList

-- | Reports a "raw" value without interpretation
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

-- | Any value can be forced as optional if desired
instance HeaderEncode h t => HeaderEncode h (Maybe t) where
  headerEncode p v = v >>= headerEncode p

-- Instances/Decoding
-- ----------------------------------------------------------------------------

-- | Fail to decode if there is no header. For headers which lack default
-- values. If a header lacks a natural default then avoiding failure should
-- be /explicitly/ requested in the types by wrapping it with a 'Maybe'.
required :: (Text -> Either String a) -> Maybe Text -> Either String a
required _ Nothing = Left "missing header value"
required f (Just t) = f t

-- | For headers with natural notions of default values.
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

-- | Returns the raw header value
instance HeaderDecode n (Raw Text) where
  headerDecode _ = required $ \text -> Right (Raw text)

-- | Any value may be only optionally captured as desired
instance HeaderDecode h t => HeaderDecode h (Maybe t) where
  headerDecode _ Nothing = Right Nothing
  headerDecode p (Just t) = fmap Just (headerDecode p (Just t))