proxy

/// 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)