-- | Integration of "Freckle.App" tooling with "Network.Wai"
module Freckle.App.Wai
  ( makeLoggingMiddleware
  , makeRequestMetricsMiddleware
  , noCacheMiddleware
  , corsMiddleware
  , denyFrameEmbeddingMiddleware
  ) where

import Freckle.App.Prelude hiding (decodeUtf8)

import Control.Monad.Logger (LogLevel(..))
import Control.Monad.Reader (runReaderT)
import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.CaseInsensitive as CI
import Data.Default (def)
import Data.IP (fromHostAddress, fromHostAddress6)
import Data.String (fromString)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags)
import qualified Freckle.App.Datadog as Datadog
import Freckle.App.Logging
import Network.HTTP.Types (QueryItem, ResponseHeaders)
import Network.HTTP.Types.Status (Status, status200, statusCode)
import Network.Socket
import Network.Wai
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.RequestLogger
  ( Destination(Logger)
  , OutputFormat(..)
  , OutputFormatterWithDetails
  , destination
  , mkRequestLogger
  , outputFormat
  )
import System.Log.FastLogger (LoggerSet, toLogStr)

makeLoggingMiddleware
  :: HasLogging app
  => app
  -> (Request -> [(Text, Text)])
  -> LoggerSet
  -> IO Middleware
makeLoggingMiddleware :: app -> (Request -> [(Text, Text)]) -> LoggerSet -> IO Middleware
makeLoggingMiddleware app
app Request -> [(Text, Text)]
getTags LoggerSet
ls = case app -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat app
app of
  LogFormat
FormatJSON ->
    OutputFormat -> IO Middleware
makeWith
      (OutputFormat -> IO Middleware) -> OutputFormat -> IO Middleware
forall a b. (a -> b) -> a -> b
$ OutputFormatterWithDetails -> OutputFormat
CustomOutputFormatWithDetails
      (OutputFormatterWithDetails -> OutputFormat)
-> OutputFormatterWithDetails -> OutputFormat
forall a b. (a -> b) -> a -> b
$ LogLevel
-> OutputFormatterWithDetails -> OutputFormatterWithDetails
suppressByStatus (app -> LogLevel
forall a. HasLogging a => a -> LogLevel
getLogLevel app
app)
      (OutputFormatterWithDetails -> OutputFormatterWithDetails)
-> OutputFormatterWithDetails -> OutputFormatterWithDetails
forall a b. (a -> b) -> a -> b
$ (Request -> [(Text, Text)]) -> OutputFormatterWithDetails
jsonOutputFormatter Request -> [(Text, Text)]
getTags
  LogFormat
FormatTerminal -> OutputFormat -> IO Middleware
makeWith (OutputFormat -> IO Middleware) -> OutputFormat -> IO Middleware
forall a b. (a -> b) -> a -> b
$ Bool -> OutputFormat
Detailed (Bool -> OutputFormat) -> Bool -> OutputFormat
forall a b. (a -> b) -> a -> b
$ app -> Bool
forall a. HasLogging a => a -> Bool
getLogDefaultANSI app
app
 where
  makeWith :: OutputFormat -> IO Middleware
makeWith OutputFormat
format =
    RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings
forall a. Default a => a
def { outputFormat :: OutputFormat
outputFormat = OutputFormat
format, destination :: Destination
destination = LoggerSet -> Destination
Logger LoggerSet
ls }

suppressByStatus
  :: LogLevel -> OutputFormatterWithDetails -> OutputFormatterWithDetails
suppressByStatus :: LogLevel
-> OutputFormatterWithDetails -> OutputFormatterWithDetails
suppressByStatus LogLevel
minLevel OutputFormatterWithDetails
f ZonedDate
date Request
req Status
status Maybe Integer
responseSize NominalDiffTime
duration [ZonedDate]
reqBody Builder
response
  | Status -> LogLevel
statusLevel Status
status LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
minLevel
  = OutputFormatterWithDetails
f ZonedDate
date Request
req Status
status Maybe Integer
responseSize NominalDiffTime
duration [ZonedDate]
reqBody Builder
response
  | Bool
otherwise
  = LogStr
""

jsonOutputFormatter
  :: (Request -> [(Text, Text)]) -> OutputFormatterWithDetails
jsonOutputFormatter :: (Request -> [(Text, Text)]) -> OutputFormatterWithDetails
jsonOutputFormatter Request -> [(Text, Text)]
getTags ZonedDate
date Request
req Status
status Maybe Integer
responseSize NominalDiffTime
duration [ZonedDate]
_reqBody Builder
response
  = ZonedDate -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr
    (ZonedDate -> LogStr) -> ZonedDate -> LogStr
forall a b. (a -> b) -> a -> b
$ LogLevel -> Value -> ZonedDate
forall a. ToJSON a => LogLevel -> a -> ZonedDate
formatJsonNoLoc (Status -> LogLevel
statusLevel Status
status)
    (Value -> ZonedDate) -> Value -> ZonedDate
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
    ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [ Key
"time" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ZonedDate -> Text
decodeUtf8 ZonedDate
date
      , Key
"method" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ZonedDate -> Text
decodeUtf8 (Request -> ZonedDate
requestMethod Request
req)
      , Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ZonedDate -> Text
decodeUtf8 (Request -> ZonedDate
rawPathInfo Request
req)
      , Key
"query_string" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (QueryItem -> Value) -> [QueryItem] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map QueryItem -> Value
queryItemToJSON (Request -> [QueryItem]
queryString Request
req)
      , Key
"status" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
      , Key
"duration_ms" Key -> NominalDiffTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (NominalDiffTime
duration NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000)
      , Key
"request_size" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RequestBodyLength -> Value
requestBodyLengthToJSON (Request -> RequestBodyLength
requestBodyLength Request
req)
      , Key
"response_size" Key -> Maybe Integer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
responseSize
      , Key
"response_body" Key -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode Status
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
400
        Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Value
maybeDecodeToValue (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
response
      , Key
"client_ip" Key -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (ZonedDate -> Text
decodeUtf8 (ZonedDate -> Text) -> Maybe ZonedDate -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ZonedDate
clientIp)
      ]
    [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> ((Text, Text) -> Pair) -> [(Text, Text)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Text -> Pair) -> (Key, Text) -> Pair
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
(.=) ((Key, Text) -> Pair)
-> ((Text, Text) -> (Key, Text)) -> (Text, Text) -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Key) -> (Text, Text) -> (Key, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Key
forall a. IsString a => String -> a
fromString (String -> Key) -> (Text -> String) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)) (Request -> [(Text, Text)]
getTags Request
req)
  where clientIp :: Maybe ZonedDate
clientIp = Request -> Maybe ZonedDate
requestRealIp Request
req Maybe ZonedDate -> Maybe ZonedDate -> Maybe ZonedDate
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ZonedDate -> Maybe ZonedDate
forall a. a -> Maybe a
Just (SockAddr -> ZonedDate
sockAddrToIp (SockAddr -> ZonedDate) -> SockAddr -> ZonedDate
forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
remoteHost Request
req)

statusLevel :: Status -> LogLevel
statusLevel :: Status -> LogLevel
statusLevel Status
status = case Status -> Int
statusCode Status
status of
  Int
404 -> LogLevel
LevelInfo -- Special case
  Int
code | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 -> LogLevel
LevelError
  Int
code | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
400 -> LogLevel
LevelWarn
  Int
code | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300 -> LogLevel
LevelInfo
  Int
_ -> LogLevel
LevelDebug

decodeUtf8 :: ByteString -> Text
decodeUtf8 :: ZonedDate -> Text
decodeUtf8 = OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode

requestBodyLengthToJSON :: RequestBodyLength -> Value
requestBodyLengthToJSON :: RequestBodyLength -> Value
requestBodyLengthToJSON RequestBodyLength
ChunkedBody = Text -> Value
String Text
"Unknown"
requestBodyLengthToJSON (KnownLength Word64
l) = Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON Word64
l

queryItemToJSON :: QueryItem -> Value
queryItemToJSON :: QueryItem -> Value
queryItemToJSON (ZonedDate
name, Maybe ZonedDate
mValue) =
  (Text, Maybe Text) -> Value
forall a. ToJSON a => a -> Value
toJSON (ZonedDate -> Text
decodeUtf8 ZonedDate
name, ZonedDate -> Text
decodeUtf8 (ZonedDate -> Text) -> Maybe ZonedDate -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ZonedDate
mValue)

-- Try to decode as a 'Value'. Otherwise make a JSON string.
maybeDecodeToValue :: BSL.ByteString -> Value
maybeDecodeToValue :: ByteString -> Value
maybeDecodeToValue ByteString
str =
  Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode (ZonedDate -> Text)
-> (ByteString -> ZonedDate) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ZonedDate
BSL.toStrict (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString
str)
    (Maybe Value -> Value)
-> (ByteString -> Maybe Value) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromJSON Value => ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode @Value
    (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString
str

-- Copied from bugnag-haskell

requestRealIp :: Request -> Maybe ByteString
requestRealIp :: Request -> Maybe ZonedDate
requestRealIp Request
request =
  Request -> Maybe ZonedDate
requestForwardedFor Request
request Maybe ZonedDate -> Maybe ZonedDate -> Maybe ZonedDate
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HeaderName -> [(HeaderName, ZonedDate)] -> Maybe ZonedDate
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Real-IP" (Request -> [(HeaderName, ZonedDate)]
requestHeaders Request
request)

requestForwardedFor :: Request -> Maybe ByteString
requestForwardedFor :: Request -> Maybe ZonedDate
requestForwardedFor Request
request =
  ZonedDate -> Maybe ZonedDate
readForwardedFor (ZonedDate -> Maybe ZonedDate)
-> Maybe ZonedDate -> Maybe ZonedDate
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> [(HeaderName, ZonedDate)] -> Maybe ZonedDate
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-For" (Request -> [(HeaderName, ZonedDate)]
requestHeaders Request
request)

-- |
--
-- >>> readForwardedFor ""
-- Nothing
--
-- >>> readForwardedFor "123.123.123"
-- Just "123.123.123"
--
-- >>> readForwardedFor "123.123.123, 45.45.45"
-- Just "123.123.123"
--
readForwardedFor :: ByteString -> Maybe ByteString
readForwardedFor :: ZonedDate -> Maybe ZonedDate
readForwardedFor ZonedDate
bs
  | ZonedDate -> Bool
BS8.null ZonedDate
bs = Maybe ZonedDate
forall a. Maybe a
Nothing
  | Bool
otherwise = ZonedDate -> Maybe ZonedDate
forall a. a -> Maybe a
Just (ZonedDate -> Maybe ZonedDate) -> ZonedDate -> Maybe ZonedDate
forall a b. (a -> b) -> a -> b
$ (ZonedDate, ZonedDate) -> ZonedDate
forall a b. (a, b) -> a
fst ((ZonedDate, ZonedDate) -> ZonedDate)
-> (ZonedDate, ZonedDate) -> ZonedDate
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ZonedDate -> (ZonedDate, ZonedDate)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ZonedDate
bs

sockAddrToIp :: SockAddr -> ByteString
sockAddrToIp :: SockAddr -> ZonedDate
sockAddrToIp (SockAddrInet PortNumber
_ HostAddress
h) = String -> ZonedDate
BS8.pack (String -> ZonedDate) -> String -> ZonedDate
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show (IPv4 -> String) -> IPv4 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress -> IPv4
fromHostAddress HostAddress
h
sockAddrToIp (SockAddrInet6 PortNumber
_ HostAddress
_ HostAddress6
h HostAddress
_) = String -> ZonedDate
BS8.pack (String -> ZonedDate) -> String -> ZonedDate
forall a b. (a -> b) -> a -> b
$ IPv6 -> String
forall a. Show a => a -> String
show (IPv6 -> String) -> IPv6 -> String
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> IPv6
fromHostAddress6 HostAddress6
h
sockAddrToIp SockAddr
_ = ZonedDate
"<socket>"

makeRequestMetricsMiddleware
  :: (HasDogStatsClient env, HasDogStatsTags env)
  => env
  -> (Request -> [(Text, Text)])
  -> Middleware
makeRequestMetricsMiddleware :: env -> (Request -> [(Text, Text)]) -> Middleware
makeRequestMetricsMiddleware env
env Request -> [(Text, Text)]
getTags Application
app Request
req Response -> IO ResponseReceived
sendResponse' = do
  UTCTime
start <- IO UTCTime
getCurrentTime
  Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    (ReaderT env IO () -> env -> IO ())
-> env -> ReaderT env IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT env IO () -> env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
env (ReaderT env IO () -> IO ()) -> ReaderT env IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> [(Text, Text)] -> ReaderT env IO ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
 HasDogStatsTags env) =>
Text -> [(Text, Text)] -> m ()
Datadog.increment Text
"requests" ([(Text, Text)] -> ReaderT env IO ())
-> [(Text, Text)] -> ReaderT env IO ()
forall a b. (a -> b) -> a -> b
$ Response -> [(Text, Text)]
tags Response
res
      Text -> [(Text, Text)] -> UTCTime -> ReaderT env IO ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
 HasDogStatsTags env) =>
Text -> [(Text, Text)] -> UTCTime -> m ()
Datadog.histogramSinceMs Text
"response_time_ms" (Response -> [(Text, Text)]
tags Response
res) UTCTime
start
    Response -> IO ResponseReceived
sendResponse' Response
res
 where
  tags :: Response -> [(Text, Text)]
tags Response
res =
    Request -> [(Text, Text)]
getTags Request
req
      [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"method", ZonedDate -> Text
decodeUtf8 (ZonedDate -> Text) -> ZonedDate -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ZonedDate
requestMethod Request
req)
         , (Text
"status", String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response -> Status
responseStatus Response
res)
         ]

noCacheMiddleware :: Middleware
noCacheMiddleware :: Middleware
noCacheMiddleware = [(ZonedDate, ZonedDate)] -> Middleware
addHeaders [(ZonedDate, ZonedDate)
forall a b. (IsString a, IsString b) => (a, b)
cacheControlHeader]
 where
  cacheControlHeader :: (a, b)
cacheControlHeader =
    (a
"Cache-Control", b
"no-cache, no-store, max-age=0, private")

corsMiddleware
  :: (ByteString -> Bool)
  -- ^ Predicate that returns 'True' for valid @Origin@ values
  -> [ByteString]
  -- ^ Extra headers to add to @Expose-Headers@
  -> Middleware
corsMiddleware :: (ZonedDate -> Bool) -> [ZonedDate] -> Middleware
corsMiddleware ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders =
  (ZonedDate -> Bool) -> [ZonedDate] -> Middleware
handleOptions ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders
    Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonedDate -> Bool) -> [ZonedDate] -> Middleware
addCORSHeaders ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders

-- | Middleware that adds header to deny all frame embedding
denyFrameEmbeddingMiddleware :: Middleware
denyFrameEmbeddingMiddleware :: Middleware
denyFrameEmbeddingMiddleware = [(ZonedDate, ZonedDate)] -> Middleware
addHeaders [(ZonedDate
"X-Frame-Options", ZonedDate
"DENY")]

handleOptions :: (ByteString -> Bool) -> [ByteString] -> Middleware
handleOptions :: (ZonedDate -> Bool) -> [ZonedDate] -> Middleware
handleOptions ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders Application
app Request
req Response -> IO ResponseReceived
sendResponse =
  case (Request -> ZonedDate
requestMethod Request
req, HeaderName -> [(HeaderName, ZonedDate)] -> Maybe ZonedDate
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Origin" (Request -> [(HeaderName, ZonedDate)]
requestHeaders Request
req)) of
    (ZonedDate
"OPTIONS", Just ZonedDate
origin) -> Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ZonedDate)] -> ByteString -> Response
responseLBS
      Status
status200
      ([(ZonedDate, ZonedDate)] -> [(HeaderName, ZonedDate)]
toHeaders ([(ZonedDate, ZonedDate)] -> [(HeaderName, ZonedDate)])
-> [(ZonedDate, ZonedDate)] -> [(HeaderName, ZonedDate)]
forall a b. (a -> b) -> a -> b
$ (ZonedDate -> Bool)
-> [ZonedDate] -> ZonedDate -> [(ZonedDate, ZonedDate)]
corsResponseHeaders ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders ZonedDate
origin
      )
      ByteString
forall a. Monoid a => a
mempty
    QueryItem
_ -> Application
app Request
req Response -> IO ResponseReceived
sendResponse
 where
  toHeaders :: [(ByteString, ByteString)] -> ResponseHeaders
  toHeaders :: [(ZonedDate, ZonedDate)] -> [(HeaderName, ZonedDate)]
toHeaders = ((ZonedDate, ZonedDate) -> (HeaderName, ZonedDate))
-> [(ZonedDate, ZonedDate)] -> [(HeaderName, ZonedDate)]
forall a b. (a -> b) -> [a] -> [b]
map ((ZonedDate -> HeaderName)
-> (ZonedDate, ZonedDate) -> (HeaderName, ZonedDate)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ZonedDate -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk)

addCORSHeaders :: (ByteString -> Bool) -> [ByteString] -> Middleware
addCORSHeaders :: (ZonedDate -> Bool) -> [ZonedDate] -> Middleware
addCORSHeaders ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders Application
app Request
req Response -> IO ResponseReceived
sendResponse =
  case HeaderName -> [(HeaderName, ZonedDate)] -> Maybe ZonedDate
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Origin" (Request -> [(HeaderName, ZonedDate)]
requestHeaders Request
req) of
    Maybe ZonedDate
Nothing -> Application
app Request
req Response -> IO ResponseReceived
sendResponse
    Just ZonedDate
origin -> [(ZonedDate, ZonedDate)] -> Middleware
addHeaders
      ((ZonedDate -> Bool)
-> [ZonedDate] -> ZonedDate -> [(ZonedDate, ZonedDate)]
corsResponseHeaders ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders ZonedDate
origin)
      Application
app
      Request
req
      Response -> IO ResponseReceived
sendResponse

corsResponseHeaders
  :: (ByteString -> Bool)
  -> [ByteString]
  -> ByteString
  -> [(ByteString, ByteString)]
corsResponseHeaders :: (ZonedDate -> Bool)
-> [ZonedDate] -> ZonedDate -> [(ZonedDate, ZonedDate)]
corsResponseHeaders ZonedDate -> Bool
validateOrigin [ZonedDate]
extraExposedHeaders ZonedDate
origin =
  [ (ZonedDate
"Access-Control-Allow-Origin", ZonedDate
validatedOrigin)
  , (ZonedDate
"Access-Control-Allow-Methods", ZonedDate
"POST, GET, OPTIONS, PUT, DELETE, PATCH")
  , (ZonedDate
"Access-Control-Allow-Credentials", ZonedDate
"true")
  , (ZonedDate
"Access-Control-Allow-Headers", ZonedDate
"Content-Type, *")
  , (ZonedDate
"Access-Control-Expose-Headers", ZonedDate -> [ZonedDate] -> ZonedDate
BS.intercalate ZonedDate
", " [ZonedDate]
exposedHeaders)
  ]
 where
  validatedOrigin :: ZonedDate
validatedOrigin = if ZonedDate -> Bool
validateOrigin ZonedDate
origin then ZonedDate
origin else ZonedDate
"BADORIGIN"

  exposedHeaders :: [ZonedDate]
exposedHeaders =
    [ZonedDate
"Set-Cookie", ZonedDate
"Content-Disposition", ZonedDate
"Link"] [ZonedDate] -> [ZonedDate] -> [ZonedDate]
forall a. Semigroup a => a -> a -> a
<> [ZonedDate]
extraExposedHeaders