module Serv.Internal.Cors where
import Control.Applicative
import Control.Monad
import Data.Maybe (catMaybes)
import Data.Monoid
import Data.Proxy
import Data.Set (Set)
import Data.Text (Text)
import Data.Time
import qualified Network.HTTP.Types as HTTP
import qualified Serv.Header.Proxies as Hp
import qualified Serv.Internal.Header.Serialization as Hs
import Serv.Internal.Server.Config
import Serv.Internal.Verb (Verb)
type Policy = Config -> Context -> AccessSet
class CorsPolicy m where
corsPolicy :: Proxy m -> Policy
data PermitAll
instance CorsPolicy PermitAll where
corsPolicy _ = permitAll
headerSet :: Bool -> Context -> AccessSet -> [HTTP.Header]
headerSet includeMethods ctx access
| not (originAllowed access) = []
| otherwise =
catMaybes
[ Hs.headerPair Hp.accessControlMaxAge (maxAge access)
, do guard includeMethods
Hs.headerPair Hp.accessControlAllowMethods (methodsAllowed access)
, Hs.headerPair Hp.accessControlAllowOrigin (origin ctx)
, Hs.headerPair Hp.accessControlExposeHeaders (headersExposed access)
, Hs.headerPair Hp.accessControlAllowHeaders (headersAllowed access)
, Hs.headerPair Hp.accessControlAllowCredentials (credentialsAllowed access)
]
data Context
= Context
{ origin :: Text
, headersExpected :: Set HTTP.HeaderName
, headersReturned :: Set HTTP.HeaderName
, methodsAvailable :: Set Verb
}
mergeContext :: Context -> Context -> Context
mergeContext a b =
Context
{ origin = origin a
, headersExpected = headersExpected a <> headersExpected b
, headersReturned = headersReturned a <> headersReturned b
, methodsAvailable = methodsAvailable a <> methodsAvailable b
}
data AccessSet =
AccessSet
{ originAllowed :: Bool
, headersExposed :: Set HTTP.HeaderName
, credentialsAllowed :: Bool
, methodsAllowed :: Set Verb
, headersAllowed :: Set HTTP.HeaderName
, maxAge :: Maybe NominalDiffTime
}
instance Monoid AccessSet where
mempty =
AccessSet
{ originAllowed = False
, headersExposed = mempty
, credentialsAllowed = False
, methodsAllowed = mempty
, headersAllowed = mempty
, maxAge = Nothing
}
mappend a b =
AccessSet
{ originAllowed = originAllowed a || originAllowed b
, headersExposed = headersExposed a <> headersExposed b
, credentialsAllowed = credentialsAllowed a || credentialsAllowed b
, methodsAllowed = methodsAllowed a <> methodsAllowed b
, headersAllowed = headersAllowed a <> headersAllowed b
, maxAge = liftA2 max (maxAge a) (maxAge b)
}
permitAll :: Policy
permitAll _config ctx =
AccessSet
{ originAllowed = True
, headersExposed = headersReturned ctx
, headersAllowed = headersExpected ctx
, credentialsAllowed = True
, methodsAllowed = methodsAvailable ctx
, maxAge = Nothing
}
wildcard :: Policy
wildcard config ctx =
(permitAll config ctx)
{ credentialsAllowed = False }
predicateWhitelist :: (Text -> Bool) -> Policy
predicateWhitelist originOk config ctx =
(permitAll config ctx)
{ originAllowed = originOk (origin ctx) }