Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
/// A module for proxying requests to another computer/ip/port
module Suave.Proxy
open System
open System.IO
open System.Net
open System.Collections.Generic
open Suave.Utils
open Suave.Sockets
open Suave.Sockets.Control
open Suave.Web
open Suave.Tcp
open Suave.Response
open Suave.Http
open Suave.Http
open System.Text
open Suave.Sockets
open Suave
/// Copies the headers from 'headers1' to 'headers2'
let private toHeaderList (headers : WebHeaderCollection) =
headers.AllKeys
|> Seq.map (fun key -> key, headers.[key])
|> List.ofSeq
let readFully (s : Stream) : byte[] =
let arr = Array.zeroCreate 1000000
let read = s.Read(arr,0,arr.Length)
Array.sub arr 0 read
let parseHttp (code : int) =
match HttpCode.tryParse code with
| Choice1Of2 a -> a
| _ -> failwith ""
/// Send the web response from HttpWebResponse to the HttpRequest 'p'
let private sendWebResponse (data : HttpWebResponse) ({ request = { trace = t }; response = resp } as ctx : HttpContext) =
let headers = toHeaderList data.Headers
// TODO: if downstream sends a Content-Length header copy from one stream
// to the other asynchronously
//"-> readFully" |> Log.verbose ctx.runtime.logger "Suave.Proxy.sendWebResponse:GetResponseStream" ctx.request.trace
let bytes = data.GetResponseStream() |> readFully
//"<- readFully" |> Log.verbose ctx.runtime.logger "Suave.Proxy.sendWebResponse:GetResponseStream" ctx.request.trace
response (parseHttp(int data.StatusCode)) bytes { ctx with response = { resp with headers = resp.headers @ headers } }
let response_f (context: HttpContext) c =
Suave.HttpOutput.writeContent true context c
let transferStreamBounded (c : Connection) (s : Stream) (len : int) =
c
/// Forward the HttpRequest 'p' to the 'ip':'port'
let forward (ip : IPAddress) (port : uint16) (ctx : HttpContext) =
let p = ctx.request
let buildWebHeadersCollection (h : NameValueList) =
let r = new WebHeaderCollection()
for e in h do
let key = fst e
if not (WebHeaderCollection.IsRestricted key) then
r.Add(key, snd e)
r
let url = new UriBuilder("http", ip.ToString(), int port, p.url.AbsolutePath, p.rawQuery)
let q = WebRequest.Create(url.Uri) :?> HttpWebRequest
q.AllowAutoRedirect <- false
q.AllowReadStreamBuffering <- false
q.AllowWriteStreamBuffering <- false
q.Method <- string p.``method``
q.Headers <- buildWebHeadersCollection p.headers
q.Proxy <- null
//copy restricted headers
let header s = getFirst p.headers s
header "accept" |> Choice.iter (fun v -> q.Accept <- v)
header "date" |> Choice.iter (fun v -> q.Date <- DateTime.Parse v)
header "expect" |> Choice.iter (fun v -> q.Expect <- v)
header "host" |> Choice.iter (fun v -> q.Host <- v)
header "range" |> Choice.iter (fun v -> q.AddRange(Int64.Parse v))
header "referer" |> Choice.iter (fun v -> q.Referer <- v)
header "content-type" |> Choice.iter (fun v -> q.ContentType <- v)
header "content-length" |> Choice.iter (fun v -> q.ContentLength <- Int64.Parse(v))
header "if-modified-since" |> Choice.iter (fun v -> q.IfModifiedSince <- DateTime.Parse v)
header "transfer-encoding" |> Choice.iter (fun v -> q.TransferEncoding <- v)
header "user-agent" |> Choice.iter (fun v -> q.UserAgent <- v)
fun (ctx : HttpContext) -> async {
//q.Headers.Add("X-Forwarded-For", p.ipaddr.ToString())
q.Headers.Add("X-Forwarded-For", ctx.clientIpTrustProxy |> string)
if p.``method`` = HttpMethod.POST || p.``method`` = HttpMethod.PUT then
match p.headers %% "content-length" with
| Choice1Of2 contentLength ->
let s = q.GetRequestStream()
let buff = Array.zeroCreate (int32 contentLength)
s.Read(buff,0,int32 contentLength) |> ignore
let! _ = Connection.send ctx.connection (ByteSegment(buff))
//Suave.HttpOutput.writeContentLengthHeader (s.re)
//do! transferStreamBounded ctx.connection (q.GetRequestStream()) (int32 contentLength)
return Some ctx
| _ -> return Some ctx
else
try
let! data = q.AsyncGetResponse()
let! res =sendWebResponse ((data : WebResponse) :?> HttpWebResponse) ctx
match res with
| Some newCtx ->
//{ ctx with response = newCtx.response }
//do! newCtx.response
// do! response newCtx.respon
let! a = response_f ctx newCtx.response.content
return Some newCtx
| None -> return None
with
| :? WebException as ex when ex.Response <> null ->
let! res = sendWebResponse (ex.Response :?> HttpWebResponse) ctx
match res with
| Some newCtx ->
//do! response_f newCtx
return Some newCtx
| _ -> return None
| :? WebException as ex when ex.Response = null ->
let! res = response HTTP_502 (System.Text.Encoding.UTF8.GetBytes "suave proxy: Could not connect to upstream") ctx
match res with
| Some newCtx ->
//do! response_f newCtx
return Some newCtx
| _ -> return None
}
/// Proxy the HttpRequest 'r' with the proxy found with 'proxy_resolver'
let private proxy proxyResolver (r : HttpContext) =
match proxyResolver r.request with
| Some (ip, port) -> forward ip port r
| None -> failwith "invalid request."
///// Run a proxy server with the given configuration and given upstream/target
/////// resolver.
//let createReverseProxyServerAsync (config : SuaveConfig) resolver =
// let all =
// [ for binding in config.bindings do
// let reqLoop = ParsingAndControl.requestLoop (SuaveConfig.toRuntime config homeFolder compressionFolder false binding ) (SocketPart (proxy resolver))
// let server = startTcpIpServerAsync (config.bufferSize, config.maxOps) config.logger reqLoop binding.socketBinding
// yield server ]
// let listening = all |> List.map fst |> Async.Parallel |> Async.Ignore
// let server = all |> List.map snd |> Async.Parallel |> Async.Ignore
// listening, server
//let startReverseProxyServer config resolver =
// Async.RunSynchronously(createReverseProxyServerAsync config resolver |> snd,
// cancellationToken = config.cancellationToken)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment