{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Network.Wai.Handler.Hal
( run,
runWithOptions,
runWithContext,
Options (..),
defaultOptions,
toWaiRequest,
fromWaiResponse,
)
where
import AWS.Lambda.Context (LambdaContext)
import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest as HalRequest
( RequestContext (identity),
)
import qualified AWS.Lambda.Events.ApiGateway.ProxyRequest as HalRequest hiding
( RequestContext (..),
)
import qualified AWS.Lambda.Events.ApiGateway.ProxyResponse as HalResponse
import Control.Exception (IOException, tryJust)
import Control.Monad.IO.Class (MonadIO (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Builder.Extra as Builder
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
import qualified Data.IORef as IORef
import Data.List (foldl', sort)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Vault.Lazy (Key, Vault)
import qualified Data.Vault.Lazy as Vault
import Network.HTTP.Media (MediaType, matches, parseAccept, renderHeader)
import Network.HTTP.Types.Header
( HeaderName,
ResponseHeaders,
hContentType,
hHost,
hRange,
hReferer,
hUserAgent,
)
import Network.HTTP.Types.URI
( Query,
QueryItem,
encodePath,
queryTextToQuery,
renderQuery,
)
import Network.HTTP.Types.Version (HttpVersion (..))
import Network.Socket (PortNumber)
import qualified Network.Socket as NS
import qualified Network.Wai as Wai
import qualified Network.Wai.Internal as Wai
import System.IO
( IOMode (..),
SeekMode (..),
hPutStrLn,
hSeek,
stderr,
withFile,
)
run ::
(MonadIO m) =>
Wai.Application ->
HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
m HalResponse.ProxyResponse
run :: forall (m :: * -> *).
MonadIO m =>
Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
run = Options
-> Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
forall (m :: * -> *).
MonadIO m =>
Options
-> Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
runWithOptions Options
defaultOptions
data Options = Options
{
Options -> Vault
vault :: Vault,
Options -> PortNumber
portNumber :: PortNumber,
Options -> [MediaType]
binaryMediaTypes :: [MediaType]
}
defaultOptions :: Options
defaultOptions :: Options
defaultOptions =
Options
{ vault :: Vault
vault = Vault
Vault.empty,
portNumber :: PortNumber
portNumber = PortNumber
443,
binaryMediaTypes :: [MediaType]
binaryMediaTypes = []
}
runWithOptions ::
(MonadIO m) =>
Options ->
Wai.Application ->
HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
m HalResponse.ProxyResponse
runWithOptions :: forall (m :: * -> *).
MonadIO m =>
Options
-> Application -> ProxyRequest NoAuthorizer -> m ProxyResponse
runWithOptions Options
opts Application
app ProxyRequest NoAuthorizer
req = IO ProxyResponse -> m ProxyResponse
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProxyResponse -> m ProxyResponse)
-> IO ProxyResponse -> m ProxyResponse
forall a b. (a -> b) -> a -> b
$ do
Request
waiReq <- Options -> ProxyRequest NoAuthorizer -> IO Request
forall a. Options -> ProxyRequest a -> IO Request
toWaiRequest Options
opts ProxyRequest NoAuthorizer
req
IORef (Maybe Response)
responseRef <- Maybe Response -> IO (IORef (Maybe Response))
forall a. a -> IO (IORef a)
IORef.newIORef Maybe Response
forall a. Maybe a
Nothing
ResponseReceived
Wai.ResponseReceived <- Application
app Request
waiReq ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
waiResp ->
ResponseReceived
Wai.ResponseReceived ResponseReceived -> IO () -> IO ResponseReceived
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IORef (Maybe Response) -> Maybe Response -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Maybe Response)
responseRef (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
waiResp)
Just Response
waiResp <- IORef (Maybe Response) -> IO (Maybe Response)
forall a. IORef a -> IO a
IORef.readIORef IORef (Maybe Response)
responseRef
Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts Response
waiResp
runWithContext ::
(MonadIO m) =>
Options ->
( Key LambdaContext ->
Key (HalRequest.ProxyRequest HalRequest.NoAuthorizer) ->
Wai.Application
) ->
LambdaContext ->
HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
m HalResponse.ProxyResponse
runWithContext :: forall (m :: * -> *).
MonadIO m =>
Options
-> (Key LambdaContext
-> Key (ProxyRequest NoAuthorizer) -> Application)
-> LambdaContext
-> ProxyRequest NoAuthorizer
-> m ProxyResponse
runWithContext Options
opts Key LambdaContext -> Key (ProxyRequest NoAuthorizer) -> Application
app LambdaContext
ctx ProxyRequest NoAuthorizer
req = IO ProxyResponse -> m ProxyResponse
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProxyResponse -> m ProxyResponse)
-> IO ProxyResponse -> m ProxyResponse
forall a b. (a -> b) -> a -> b
$ do
Key LambdaContext
contextKey <- IO (Key LambdaContext)
forall a. IO (Key a)
Vault.newKey
Key (ProxyRequest NoAuthorizer)
requestKey <- IO (Key (ProxyRequest NoAuthorizer))
forall a. IO (Key a)
Vault.newKey
let vault' :: Vault
vault' =
Options -> Vault
vault Options
opts
Vault -> (Vault -> Vault) -> Vault
forall a b. a -> (a -> b) -> b
& Key LambdaContext -> LambdaContext -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key LambdaContext
contextKey LambdaContext
ctx
Vault -> (Vault -> Vault) -> Vault
forall a b. a -> (a -> b) -> b
& Key (ProxyRequest NoAuthorizer)
-> ProxyRequest NoAuthorizer -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key (ProxyRequest NoAuthorizer)
requestKey ProxyRequest NoAuthorizer
req
opts' :: Options
opts' = Options
opts {vault = vault'}
Request
waiReq <- Options -> ProxyRequest NoAuthorizer -> IO Request
forall a. Options -> ProxyRequest a -> IO Request
toWaiRequest Options
opts' ProxyRequest NoAuthorizer
req
IORef (Maybe Response)
responseRef <- Maybe Response -> IO (IORef (Maybe Response))
forall a. a -> IO (IORef a)
IORef.newIORef Maybe Response
forall a. Maybe a
Nothing
ResponseReceived
Wai.ResponseReceived <- Key LambdaContext -> Key (ProxyRequest NoAuthorizer) -> Application
app Key LambdaContext
contextKey Key (ProxyRequest NoAuthorizer)
requestKey Request
waiReq ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
waiResp ->
ResponseReceived
Wai.ResponseReceived ResponseReceived -> IO () -> IO ResponseReceived
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IORef (Maybe Response) -> Maybe Response -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (Maybe Response)
responseRef (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
waiResp)
Just Response
waiResp <- IORef (Maybe Response) -> IO (Maybe Response)
forall a. IORef a -> IO a
IORef.readIORef IORef (Maybe Response)
responseRef
Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts' Response
waiResp
toWaiRequest ::
Options ->
HalRequest.ProxyRequest a ->
IO Wai.Request
toWaiRequest :: forall a. Options -> ProxyRequest a -> IO Request
toWaiRequest Options
opts ProxyRequest a
req = do
let port :: PortNumber
port = Options -> PortNumber
portNumber Options
opts
pathSegments :: [Text]
pathSegments = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> Text
forall a. ProxyRequest a -> Text
HalRequest.path ProxyRequest a
req
query :: Query
query = Query -> Query
forall a. Ord a => [a] -> [a]
sort (Query -> Query)
-> (HashMap Text [Text] -> Query) -> HashMap Text [Text] -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text [Text] -> Query
constructQuery (HashMap Text [Text] -> Query) -> HashMap Text [Text] -> Query
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> HashMap Text [Text]
forall a. ProxyRequest a -> HashMap Text [Text]
HalRequest.multiValueQueryStringParameters ProxyRequest a
req
hints :: AddrInfo
hints =
AddrInfo
NS.defaultHints
{ NS.addrFlags = [NS.AI_NUMERICHOST],
NS.addrFamily = NS.AF_INET,
NS.addrSocketType = NS.Stream
}
sourceIp :: String
sourceIp =
Text -> String
T.unpack
(Text -> String)
-> (RequestContext a -> Text) -> RequestContext a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity -> Text
HalRequest.sourceIp
(Identity -> Text)
-> (RequestContext a -> Identity) -> RequestContext a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestContext a -> Identity
forall a. RequestContext a -> Identity
HalRequest.identity
(RequestContext a -> String) -> RequestContext a -> String
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> RequestContext a
forall a. ProxyRequest a -> RequestContext a
HalRequest.requestContext ProxyRequest a
req
SockAddr
sourceHost <-
(IOException -> Maybe IOException)
-> IO [AddrInfo] -> IO (Either IOException [AddrInfo])
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust
(forall a. a -> Maybe a
Just @IOException)
(Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
NS.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
sourceIp) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port))
IO (Either IOException [AddrInfo])
-> (Either IOException [AddrInfo] -> IO SockAddr) -> IO SockAddr
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right (AddrInfo
s : [AddrInfo]
_) -> SockAddr -> IO SockAddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> IO SockAddr) -> SockAddr -> IO SockAddr
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
NS.addrAddress AddrInfo
s
Either IOException [AddrInfo]
_ -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Cannot convert sourceIp ",
String -> String
forall a. Show a => a -> String
show String
sourceIp,
String
" to address; assuming 127.0.0.1"
]
SockAddr -> IO SockAddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> IO SockAddr)
-> (HostAddress -> SockAddr) -> HostAddress -> IO SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> HostAddress -> SockAddr
NS.SockAddrInet PortNumber
port (HostAddress -> IO SockAddr) -> HostAddress -> IO SockAddr
forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8, Word8) -> HostAddress
NS.tupleToHostAddress (Word8
127, Word8
0, Word8
0, Word8
1)
IO ByteString
body <- ByteString -> IO (IO ByteString)
returnChunks (ByteString -> IO (IO ByteString))
-> ByteString -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> ByteString
forall a. ProxyRequest a -> ByteString
HalRequest.body ProxyRequest a
req
let waiReq :: Request
waiReq =
Wai.Request
{ requestMethod :: ByteString
Wai.requestMethod = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> Text
forall a. ProxyRequest a -> Text
HalRequest.httpMethod ProxyRequest a
req,
httpVersion :: HttpVersion
Wai.httpVersion = Int -> Int -> HttpVersion
HttpVersion Int
1 Int
1,
rawPathInfo :: ByteString
Wai.rawPathInfo =
ByteString -> ByteString
BL.toStrict
(ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString
(Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Query -> Builder
encodePath [Text]
pathSegments [],
rawQueryString :: ByteString
Wai.rawQueryString = case Query
query of
[] -> ByteString
""
Query
_ -> Bool -> Query -> ByteString
renderQuery Bool
True Query
query,
requestHeaders :: [Header]
Wai.requestHeaders =
[Header] -> [Header]
forall a. Ord a => [a] -> [a]
sort
([Header] -> [Header])
-> (HashMap (CI Text) [Text] -> [Header])
-> HashMap (CI Text) [Text]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CI Text, [Text]) -> [Header]) -> [(CI Text, [Text])] -> [Header]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \(CI Text
hName, [Text]
hValues) ->
((Text -> ByteString) -> CI Text -> HeaderName
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map Text -> ByteString
T.encodeUtf8 CI Text
hName,) (ByteString -> Header) -> (Text -> ByteString) -> Text -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> Header) -> [Text] -> [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
hValues
)
([(CI Text, [Text])] -> [Header])
-> (HashMap (CI Text) [Text] -> [(CI Text, [Text])])
-> HashMap (CI Text) [Text]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap (CI Text) [Text] -> [(CI Text, [Text])]
forall k v. HashMap k v -> [(k, v)]
H.toList
(HashMap (CI Text) [Text] -> [Header])
-> HashMap (CI Text) [Text] -> [Header]
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> HashMap (CI Text) [Text]
forall a. ProxyRequest a -> HashMap (CI Text) [Text]
HalRequest.multiValueHeaders ProxyRequest a
req,
isSecure :: Bool
Wai.isSecure = Bool
True,
remoteHost :: SockAddr
Wai.remoteHost = SockAddr
sourceHost,
pathInfo :: [Text]
Wai.pathInfo = [Text]
pathSegments,
queryString :: Query
Wai.queryString = Query
query,
requestBody :: IO ByteString
Wai.requestBody = IO ByteString
body,
vault :: Vault
Wai.vault = Options -> Vault
vault Options
opts,
requestBodyLength :: RequestBodyLength
Wai.requestBodyLength =
Word64 -> RequestBodyLength
Wai.KnownLength (Word64 -> RequestBodyLength)
-> (ByteString -> Word64) -> ByteString -> RequestBodyLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length (ByteString -> RequestBodyLength)
-> ByteString -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ ProxyRequest a -> ByteString
forall a. ProxyRequest a -> ByteString
HalRequest.body ProxyRequest a
req,
requestHeaderHost :: Maybe ByteString
Wai.requestHeaderHost = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hHost ProxyRequest a
req,
requestHeaderRange :: Maybe ByteString
Wai.requestHeaderRange = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hRange ProxyRequest a
req,
requestHeaderReferer :: Maybe ByteString
Wai.requestHeaderReferer = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hReferer ProxyRequest a
req,
requestHeaderUserAgent :: Maybe ByteString
Wai.requestHeaderUserAgent = HeaderName -> ProxyRequest a -> Maybe ByteString
forall a. HeaderName -> ProxyRequest a -> Maybe ByteString
getHeader HeaderName
hUserAgent ProxyRequest a
req
}
Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
waiReq
returnChunks :: BL.ByteString -> IO (IO B.ByteString)
returnChunks :: ByteString -> IO (IO ByteString)
returnChunks ByteString
bs = do
IORef [ByteString]
chunkRef <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
IORef.newIORef ([ByteString] -> IO (IORef [ByteString]))
-> [ByteString] -> IO (IORef [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
bs
IO ByteString -> IO (IO ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ByteString -> IO (IO ByteString))
-> (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString))
-> IO (IO ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef [ByteString]
chunkRef (([ByteString] -> ([ByteString], ByteString))
-> IO (IO ByteString))
-> ([ByteString] -> ([ByteString], ByteString))
-> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$
\case
[] -> ([ByteString], ByteString)
forall a. Monoid a => a
mempty
(ByteString
ch : [ByteString]
chs) -> ([ByteString]
chs, ByteString
ch)
constructQuery :: HashMap Text [Text] -> Query
constructQuery :: HashMap Text [Text] -> Query
constructQuery = ((Text, [Text]) -> Query) -> [(Text, [Text])] -> Query
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text, [Text]) -> Query
expandParamList ([(Text, [Text])] -> Query)
-> (HashMap Text [Text] -> [(Text, [Text])])
-> HashMap Text [Text]
-> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text [Text] -> [(Text, [Text])]
forall k v. HashMap k v -> [(k, v)]
H.toList
where
expandParamList :: (Text, [Text]) -> [QueryItem]
expandParamList :: (Text, [Text]) -> Query
expandParamList (Text
param, [Text]
values) =
QueryText -> Query
queryTextToQuery (QueryText -> Query) -> QueryText -> Query
forall a b. (a -> b) -> a -> b
$ case [Text]
values of
[] -> [(Text
param, Maybe Text
forall a. Maybe a
Nothing)]
[Text]
_ -> (Text
param,) (Maybe Text -> (Text, Maybe Text))
-> (Text -> Maybe Text) -> Text -> (Text, Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> (Text, Maybe Text)) -> [Text] -> QueryText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
values
getHeader :: HeaderName -> HalRequest.ProxyRequest a -> Maybe ByteString
HeaderName
h =
(Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
T.encodeUtf8 (Maybe Text -> Maybe ByteString)
-> (ProxyRequest a -> Maybe Text)
-> ProxyRequest a
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> HashMap (CI Text) Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup ((ByteString -> Text) -> HeaderName -> CI Text
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map ByteString -> Text
T.decodeUtf8 HeaderName
h) (HashMap (CI Text) Text -> Maybe Text)
-> (ProxyRequest a -> HashMap (CI Text) Text)
-> ProxyRequest a
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxyRequest a -> HashMap (CI Text) Text
forall a. ProxyRequest a -> HashMap (CI Text) Text
HalRequest.headers
fromWaiResponse :: Options -> Wai.Response -> IO HalResponse.ProxyResponse
fromWaiResponse :: Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts (Wai.ResponseFile Status
status [Header]
headers String
path Maybe FilePart
mFilePart) = do
ByteString
fileData <- String -> Maybe FilePart -> IO ByteString
readFilePart String
path Maybe FilePart
mFilePart
ProxyResponse -> IO ProxyResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(ProxyResponse -> IO ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> IO ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> ProxyResponse -> ProxyResponse
addHeaders [Header]
headers
(ProxyResponse -> ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ProxyBody -> ProxyResponse
HalResponse.response Status
status
(ProxyBody -> ProxyResponse)
-> (ByteString -> ProxyBody) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MediaType -> ByteString -> ProxyBody
createProxyBody Options
opts ([Header] -> MediaType
getContentType [Header]
headers)
(ByteString -> IO ProxyResponse) -> ByteString -> IO ProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString
fileData
fromWaiResponse Options
opts (Wai.ResponseBuilder Status
status [Header]
headers Builder
builder) =
ProxyResponse -> IO ProxyResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(ProxyResponse -> IO ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> IO ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> ProxyResponse -> ProxyResponse
addHeaders [Header]
headers
(ProxyResponse -> ProxyResponse)
-> (ByteString -> ProxyResponse) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ProxyBody -> ProxyResponse
HalResponse.response Status
status
(ProxyBody -> ProxyResponse)
-> (ByteString -> ProxyBody) -> ByteString -> ProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> MediaType -> ByteString -> ProxyBody
createProxyBody Options
opts ([Header] -> MediaType
getContentType [Header]
headers)
(ByteString -> ProxyBody)
-> (ByteString -> ByteString) -> ByteString -> ProxyBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
(ByteString -> IO ProxyResponse) -> ByteString -> IO ProxyResponse
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
builder
fromWaiResponse Options
opts (Wai.ResponseStream Status
status [Header]
headers StreamingBody
stream) = do
IORef Builder
builderRef <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
IORef.newIORef Builder
forall a. Monoid a => a
mempty
let addChunk :: Builder -> IO ()
addChunk Builder
chunk = IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef Builder
builderRef (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunk)
flush :: IO ()
flush = IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef Builder
builderRef (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
Builder.flush)
StreamingBody
stream Builder -> IO ()
addChunk IO ()
flush
Builder
builder <- IORef Builder -> IO Builder
forall a. IORef a -> IO a
IORef.readIORef IORef Builder
builderRef
Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts (Status -> [Header] -> Builder -> Response
Wai.ResponseBuilder Status
status [Header]
headers Builder
builder)
fromWaiResponse Options
opts (Wai.ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
_ Response
resp) = Options -> Response -> IO ProxyResponse
fromWaiResponse Options
opts Response
resp
readFilePart :: FilePath -> Maybe Wai.FilePart -> IO ByteString
readFilePart :: String -> Maybe FilePart -> IO ByteString
readFilePart String
path Maybe FilePart
mPart = String -> IOMode -> (Handle -> IO ByteString) -> IO ByteString
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode ((Handle -> IO ByteString) -> IO ByteString)
-> (Handle -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
case Maybe FilePart
mPart of
Maybe FilePart
Nothing -> Handle -> IO ByteString
B.hGetContents Handle
h
Just (Wai.FilePart Integer
offset Integer
count Integer
_) -> do
Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
Handle -> Int -> IO ByteString
B.hGet Handle
h (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
count
createProxyBody :: Options -> MediaType -> ByteString -> HalResponse.ProxyBody
createProxyBody :: Options -> MediaType -> ByteString -> ProxyBody
createProxyBody Options
opts MediaType
contentType ByteString
body =
HalResponse.ProxyBody
{ $sel:contentType:ProxyBody :: Text
HalResponse.contentType = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
contentType,
$sel:serialized:ProxyBody :: Text
HalResponse.serialized =
if Bool
isBase64Encoded
then ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
body
else ByteString -> Text
T.decodeUtf8 ByteString
body,
Bool
isBase64Encoded :: Bool
$sel:isBase64Encoded:ProxyBody :: Bool
HalResponse.isBase64Encoded
}
where
isBase64Encoded :: Bool
isBase64Encoded = (MediaType -> Bool) -> [MediaType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MediaType
contentType MediaType -> MediaType -> Bool
forall a. Accept a => a -> a -> Bool
`matches`) ([MediaType] -> Bool) -> [MediaType] -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> [MediaType]
binaryMediaTypes Options
opts
addHeaders ::
ResponseHeaders -> HalResponse.ProxyResponse -> HalResponse.ProxyResponse
[Header]
headers ProxyResponse
response = (ProxyResponse -> Header -> ProxyResponse)
-> ProxyResponse -> [Header] -> ProxyResponse
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ProxyResponse -> Header -> ProxyResponse
addHeader ProxyResponse
response [Header]
headers
where
addHeader :: ProxyResponse -> Header -> ProxyResponse
addHeader ProxyResponse
r (HeaderName
hName, ByteString
hValue) =
Text -> Text -> ProxyResponse -> ProxyResponse
HalResponse.addHeader
(ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
hName)
(ByteString -> Text
T.decodeUtf8 ByteString
hValue)
ProxyResponse
r
getContentType :: ResponseHeaders -> MediaType
getContentType :: [Header] -> MediaType
getContentType [Header]
headers =
MediaType -> Maybe MediaType -> MediaType
forall a. a -> Maybe a -> a
fromMaybe MediaType
"application/octet-stream" (Maybe MediaType -> MediaType) -> Maybe MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$
HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType [Header]
headers Maybe ByteString
-> (ByteString -> Maybe MediaType) -> Maybe MediaType
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe MediaType
forall a. Accept a => ByteString -> Maybe a
parseAccept