Created
October 1, 2014 08:06
-
-
Save thinkbeforecoding/7db1b995ed447a791ce5 to your computer and use it in GitHub Desktop.
Http Server in F#
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
// This module implements AwaitTask for non generic Task | |
// It should be useless in F# 4 since it should be implemented in FSharp.Core | |
[<AutoOpen>] | |
module AsyncExtensions = | |
open System | |
open System.Threading | |
open System.Threading.Tasks | |
type Microsoft.FSharp.Control.Async with | |
static member Raise(ex) = Async.FromContinuations(fun (_,econt,_) -> econt ex) | |
static member AwaitTask (t: Task) = | |
let tcs = new TaskCompletionSource<unit>(TaskContinuationOptions.None) | |
t.ContinueWith((fun _ -> | |
if t.IsFaulted then tcs.SetException t.Exception | |
elif t.IsCanceled then tcs.SetCanceled() | |
else tcs.SetResult(())), TaskContinuationOptions.ExecuteSynchronously) |> ignore | |
async { | |
try | |
do! Async.AwaitTask tcs.Task | |
with | |
| :? AggregateException as ex -> | |
do! Async.Raise (ex.Flatten().InnerExceptions |> Seq.head) } | |
open System.Net | |
open System.IO | |
open Microsoft.FSharp.Control | |
let server handler = | |
let listener = new HttpListener(IgnoreWriteExceptions = true ) | |
listener.Prefixes.Add("http://localhost:80/") | |
listener.Start() | |
let rec listen() = | |
async { | |
let! context = Async.AwaitTask <| listener.GetContextAsync() | |
match handler context with | |
| Some process -> Async.Start process | |
| None -> context.Response.StatusCode <- 404 | |
context.Response.Close() | |
return! listen() } | |
listen() | |
|> Async.Start | |
listener | |
let url path webPart (context: HttpListenerContext) = | |
if context.Request.Url.LocalPath = path then | |
webPart context | |
else | |
None | |
type WebPart = HttpListenerContext -> Async<unit> option | |
let methOd m (webPart: WebPart) (context: HttpListenerContext) = | |
if context.Request.HttpMethod = m then | |
webPart context | |
else | |
None | |
let GET = methOd "GET" | |
let POST = methOd "POST" | |
let text s (context: HttpListenerContext) = | |
async { | |
context.Response.ContentType <- "text/plain" | |
use writer = new StreamWriter(context.Response.OutputStream) | |
do! Async.AwaitTask(writer.WriteLineAsync (s: string)) | |
do! Async.AwaitTask(writer.FlushAsync()) | |
context.Response.Close() } | |
|> Some | |
let choose parts context = | |
parts | |
|> List.tryPick (fun part -> part context) | |
let s = server <| choose [GET (url "/hello" (text "Hello World")) | |
GET (url "/world" (text "World")) ] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment