Created
January 8, 2015 21:50
-
-
Save ane/7ac1b9d886b72f890d3d to your computer and use it in GitHub Desktop.
A more developed DTO handling that fails because .NET serialization can cast any null object to something.
This file contains 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
// Learn more about F# at http://fsharp.org | |
// See the 'F# Tutorial' project for more help. | |
open Suave | |
open Suave.Json | |
open Suave.Types | |
open Suave.Types.Methods | |
open Suave.Utils | |
open Suave.Http | |
open Suave.Http.Authentication | |
open Suave.Http.Writers | |
open Suave.Http.Applicatives | |
open Suave.Http.Successful | |
open Suave.Http.RequestErrors | |
open Suave.Web | |
open System | |
open System.Net.Http | |
open System.Text | |
open System.Runtime.Serialization | |
[<DataContract>] | |
type HelloResponse = | |
{ [<field:DataMember(Name = "Greeting")>] | |
Greeting : string } | |
[<DataContract>] | |
type PlusRequest = | |
{ [<field:DataMember(Name = "A")>] | |
A : int | |
[<field:DataMember(Name = "B")>] | |
B : int } | |
[<DataContract>] | |
type BeepRequest = | |
{ [<field:DataMember(Name = "Boing")>] | |
Boing : string } | |
/// Checks whether header is present in the context c. | |
let hasHeader (hdr : string) (hdrValue : string) (c : HttpContext) = | |
async.Return <| match c.request.headers %% hdr.ToLower() with | |
| Some v when v = hdrValue.ToLower() -> Some c | |
| _ -> None | |
/// Converts an object to JSON and passes it to a HTTP response such as OK, anything | |
/// that accepts a string. | |
let asJson (status : string -> WebPart) dto : WebPart = | |
set_header "Content-Type" "application/json" >>= status (ASCII.to_string' <| to_json dto) | |
/// Combinator for checking whether the request body JSON is of the type 'a. | |
let is<'a> = | |
hasHeader "Content-Type" "application/json" >>= fun c -> | |
async.Return <| try | |
// try to cast, if it fails, catch the exception and return None | |
from_json<'a> c.request.raw_form |> ignore | |
Some c | |
with :? InvalidCastException -> None | |
/// Tries to deserialize the DTO from JSON, returns None if it fails. | |
let parseDTO<'a> ctx = | |
try | |
let obj = from_json<'a> ctx.request.raw_form | |
Some obj | |
with :? InvalidCastException -> None | |
/// Reads a JSON blob that is expected to be of type 'a, a function that operates on 'a; | |
/// deserializes the JSON to an instance of 'a, and passes that instance to the function. | |
let withDTO<'a> (builder : 'a -> WebPart) : WebPart = | |
hasHeader "Content-Type" "application/json" >>= fun ctx -> | |
let dto = parseDTO<'a> ctx | |
match dto with | |
| Some d -> builder d ctx | |
| _ -> fail | |
let greeter p = asJson OK { Greeting = sprintf "Hello %d!" (p.A + p.B) } | |
let bip b = asJson OK { Greeting = sprintf "You boinged: %s" b.Boing } | |
let isPlusRequest = is<PlusRequest> | |
let app = | |
choose [ POST >>= url "/blah" >>= withDTO<PlusRequest> greeter <|> withDTO<BeepRequest> bip | |
authenticate_basic (fun (u, p) -> u = "perkele" && p = "helvetti") | |
POST >>= url "/ding" >>= asJson OK { Greeting = "Hello protected user!" } | |
NOT_FOUND "Not found" ] | |
[<EntryPoint>] | |
let main argv = | |
web_server default_config app | |
0 // return an integer exit code |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment