[<AutoOpen>] | |
module Giraffe.Query | |
open Aether | |
open Microsoft.AspNetCore.Http | |
module Helpers = | |
let konst v _ = v | |
[<RequireQualifiedAccess>] | |
module Option = | |
let inline ofBool b = if b then Some [] else None | |
open Helpers | |
[<AutoOpen>] | |
module Values = | |
type QueryValue = string list option | |
[<RequireQualifiedAccess>] | |
module QueryValue = | |
let inline private (|Empty|NonEmpty|) xs = | |
match xs with | |
| [] -> Empty | |
| _ -> NonEmpty xs | |
(* Epimorphisms *) | |
let private Zero__ = | |
(function | None -> Some () | |
| _ -> None), konst None | |
let private Bool__ = | |
(function | None -> Some false | |
| Some Empty -> Some true | |
| _ -> None), Option.ofBool | |
let private String__ = | |
(function | Some [v] -> Some v | |
| _ -> None), List.singleton >> Some | |
let private List__ = | |
(function | None -> Some [] | |
| Some vs -> Some vs), Some | |
(* Prisms *) | |
let Zero_ = | |
Prism.ofEpimorphism Zero__ | |
let Bool_ = | |
Prism.ofEpimorphism Bool__ | |
let String_ = | |
Prism.ofEpimorphism String__ | |
let List_ = | |
Prism.ofEpimorphism List__ | |
(* Functional *) | |
[<AutoOpen>] | |
module Functional = | |
type QueryValueResult<'a> = Result<'a, string> | |
type QueryValue<'a> = QueryValue -> QueryValueResult<'a> * QueryValue | |
(* Functions *) | |
[<RequireQualifiedAccess>] | |
module QueryValue = | |
let inline unit (a: 'a) : QueryValue<_> = | |
fun value -> | |
Ok a, value | |
let zero = unit () | |
let inline error (e: string) : QueryValue<_> = | |
fun value -> | |
Error e, value | |
let inline internal ofResult result = | |
fun value -> | |
result, value | |
let inline bind (m: QueryValue<'a>) (f: 'a -> QueryValue<'b>) : QueryValue<'b> = | |
fun value -> | |
match m value with | |
| Ok a, value -> f a value | |
| Error e, value -> Error e, value | |
let inline apply (f: QueryValue<'a -> 'b>) (m: QueryValue<'a>) : QueryValue<'b> = | |
bind f (fun f' -> | |
bind m (f' >> unit)) | |
let inline map (f: 'a -> 'b) (m: QueryValue<'a>) : QueryValue<'b> = | |
bind m (f >> unit) | |
let inline map2 (f: 'a -> 'b -> 'c) (m1: QueryValue<'a>) (m2: QueryValue<'b>) : QueryValue<'c> = | |
apply (apply (unit f) m1) m2 | |
(* Operators *) | |
module Operators = | |
let inline (>>=) m f = | |
QueryValue.bind m f | |
let inline (=<<) f m = | |
QueryValue.bind m f | |
let inline (<*>) f m = | |
QueryValue.apply f m | |
let inline (<!>) f m = | |
QueryValue.map f m | |
let inline ( *>) m1 m2 = | |
QueryValue.map2 (konst id) m1 m2 | |
let inline (<* ) m1 m2 = | |
QueryValue.map2 konst m1 m2 | |
let inline (>=>) f g = | |
fun x -> f x >>= g | |
let inline (<=<) g f = | |
fun x -> f x >>= g | |
module Builder = | |
open Operators | |
type QueryValueBuilder () = | |
member inline __.Bind (m1, f) = m1 >>= f | |
member inline __.Combine (m1, m2) = m1 *> m2 | |
member inline __.Delay f = QueryValue.zero >>= f | |
member inline __.Return x = QueryValue.unit x | |
member inline __.Zero () = QueryValue.zero | |
let queryValue = Builder.QueryValueBuilder () | |
[<AutoOpen>] | |
module Optic = | |
[<RequireQualifiedAccess>] | |
module QueryValue = | |
[<RequireQualifiedAccess>] | |
module Optic = | |
type Get = | |
| Get with | |
static member (^.) (Get, l: Lens<QueryValue, 'b>) : QueryValue<_> = | |
fun value -> | |
Ok (Optic.get l value), value | |
static member (^.) (Get, p: Prism<QueryValue, 'b>) : QueryValue<_> = | |
fun value -> | |
match Optic.get p value with | |
| Some x -> Ok x, value | |
| None -> Error (sprintf "Couldn't use Prism %A on query string value: '%A'" p value), value | |
let inline get o : QueryValue<_> = | |
(Get ^. o) | |
type TryGet = | |
| TryGet with | |
static member (^.) (TryGet, l: Lens<QueryValue, 'b>) : QueryValue<_> = | |
fun value -> | |
Ok (Some (Optic.get l value)), value | |
static member (^.) (TryGet, p: Prism<QueryValue, 'b>) : QueryValue<_> = | |
fun value -> | |
Ok (Optic.get p value), value | |
let inline tryGet o : QueryValue<_> = | |
(TryGet ^. o) | |
let inline set o v : QueryValue<_> = | |
fun query -> | |
Ok (), Optic.set o v query | |
let inline map o f : QueryValue<_> = | |
fun query -> | |
Ok (), Optic.map o f query | |
[<AutoOpen>] | |
module Mapping = | |
open Operators | |
(* From *) | |
(* Defaults *) | |
type FromQueryValueDefaults = FromQueryValueDefaults with | |
(* Basic Types *) | |
static member inline FromQueryValue (_: unit) = | |
QueryValue.Optic.get QueryValue.Zero_ | |
static member inline FromQueryValue (_: bool) = | |
QueryValue.Optic.get QueryValue.Bool_ | |
static member inline FromQueryValue (_: string) = | |
QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: QueryValue) = | |
QueryValue.Optic.get id_ | |
(* Mapping Functions *) | |
let inline internal fromQueryValueDefaults (a: ^a, _: ^b) = | |
((^a or ^b) : (static member FromQueryValue: ^a -> ^a QueryValue) a) | |
let inline internal fromQueryValue x = | |
fst (fromQueryValueDefaults (Unchecked.defaultof<'a>, FromQueryValueDefaults) x) | |
let inline internal fromQueryValueFold xs = | |
List.fold (fun r x -> | |
match r with | |
| Error e -> Error e | |
| Ok xs -> | |
match fromQueryValue x with | |
| Ok x -> Ok (x :: xs) | |
| Error e -> Error e) (Ok []) (xs |> List.map (List.singleton >> Some) |> List.rev) | |
let inline private tryParse name f = | |
fun value -> | |
match f value with | |
| true, v -> fun value -> Ok v, value | |
| _ -> fun value -> Error (sprintf "Failed to parse '%A' as %s" value name), value | |
(* Defaults *) | |
open System | |
type FromQueryValueDefaults with | |
(* Numbers *) | |
static member inline FromQueryValue (_: float) = | |
tryParse "float" Double.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: decimal) = | |
tryParse "decimal" Decimal.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: int) = | |
tryParse "int" Int32.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: int16) = | |
tryParse "int16" Int16.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: int64) = | |
tryParse "int64" Int64.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: float32) = | |
tryParse "float32" Single.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: uint16) = | |
tryParse "uint16" UInt16.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: uint32) = | |
tryParse "uint32" UInt32.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
static member inline FromQueryValue (_: uint64) = | |
tryParse "uint64" UInt64.TryParse | |
=<< QueryValue.Optic.get QueryValue.String_ | |
(* Lists *) | |
static member inline FromQueryValue (_: 'a list) : QueryValue<'a list> = | |
fromQueryValueFold >> QueryValue.ofResult | |
=<< QueryValue.Optic.get QueryValue.List_ | |
static member inline FromQueryValue (_: 'a array) : QueryValue<'a array> = | |
fromQueryValueFold >> Result.map Array.ofList >> QueryValue.ofResult | |
=<< QueryValue.Optic.get QueryValue.List_ | |
(* Set *) | |
static member inline FromQueryValue (_: Set<'a>) : QueryValue<Set<'a>> = | |
fromQueryValueFold >> Result.map Set.ofList >> QueryValue.ofResult | |
=<< QueryValue.Optic.get QueryValue.List_ | |
(* Options *) | |
static member inline FromQueryValue (_: 'a option) : QueryValue<'a option> = | |
fun value -> | |
match fromQueryValue value with | |
| Ok v -> Ok (Some v), value | |
| _ -> Ok None, value | |
type Query = Map<string, string list> | |
module Convert = | |
open Microsoft.AspNetCore.WebUtilities | |
let toQuery (qs: QueryString) : Query = | |
QueryHelpers.ParseQuery qs.Value | |
|> Seq.map (fun kvp -> kvp.Key, kvp.Value |> List.ofSeq) | |
|> Map.ofSeq | |
(* Functional *) | |
[<AutoOpen>] | |
module Functional = | |
type QueryResult<'a> = Result<'a, string> | |
type Query<'a> = Query -> QueryResult<'a> * Query | |
(* Functions *) | |
[<RequireQualifiedAccess>] | |
module Query = | |
let inline unit x : Query<_> = | |
fun query -> | |
Ok x, query | |
let zero = unit () | |
let inline error e : Query<_> = | |
fun query -> | |
Error e, query | |
let inline internal ofResult result = | |
fun query -> | |
result, query | |
let inline bind (m: Query<'a>) (f: 'a -> Query<'b>) : Query<'b> = | |
fun query -> | |
match m query with | |
| Ok a, query -> f a query | |
| Error e, query -> Error e, query | |
let inline apply f m = | |
bind f (fun f' -> | |
bind m (f' >> unit)) | |
let inline map f m = | |
bind m (f >> unit) | |
let inline map2 f m1 m2 = | |
apply (apply (unit f) m1) m2 | |
(* Operators *) | |
module Operators = | |
let inline (>>=) m f = | |
Query.bind m f | |
let inline (=<<) f m = | |
Query.bind m f | |
let inline (<*>) f m = | |
Query.apply f m | |
let inline (<!>) f m = | |
Query.map f m | |
let inline ( *>) m1 m2 = | |
Query.map2 (konst id) m1 m2 | |
let inline (<* ) m1 m2 = | |
Query.map2 konst m1 m2 | |
let inline (>=>) f g = | |
fun x -> f x >>= g | |
let inline (<=<) g f = | |
fun x -> f x >>= g | |
(* Builder *) | |
module Builder = | |
open Operators | |
type QueryBuilder () = | |
member inline __.Bind (m1, f) = m1 >>= f | |
member inline __.Combine (m1, m2) = m1 *> m2 | |
member inline __.Delay f = Query.zero >>= f | |
member inline __.Return x = Query.unit x | |
member inline __.Zero () = Query.zero | |
let query = Builder.QueryBuilder () | |
[<AutoOpen>] | |
module Mapping = | |
open Operators | |
(* From *) | |
(* Defaults *) | |
type FromQueryDefaults = FromQueryDefaults with | |
static member inline FromQuery (_: Query) : Query<Query> = | |
fun query -> Ok query, query | |
static member inline FromQuery (_: Map<string, string>) : Query<Map<string, string>> = | |
fun query -> | |
let ret = | |
query | |
|> Map.filter (konst (function | [_] -> true | _ -> false)) | |
|> Map.map (konst List.head) | |
Ok ret, query | |
(* Mapping Functions *) | |
let inline internal fromQueryDefaults (a: ^a, _: ^b) = | |
((^a or ^b) : (static member FromQuery: ^a -> ^a Query) a) | |
let inline internal fromQuery x = | |
fst (fromQueryDefaults (Unchecked.defaultof<'a>, FromQueryDefaults) x) | |
(* Functions *) | |
[<RequireQualifiedAccess>] | |
module Query = | |
(* Read *) | |
let private readValue key = | |
fun query -> | |
Ok (Map.tryFind key query), query | |
let readMemberWith fromQueryValue key = | |
readValue key | |
>>= fun value -> | |
match fromQueryValue value with | |
| Ok v -> Query.unit v | |
| Error e -> Query.error (sprintf "%s: %s" key e) | |
let inline readWith fromQueryValue key = | |
readMemberWith fromQueryValue key | |
let inline read key = | |
readWith fromQueryValue key | |
let inline parse qs = | |
fromQuery (Convert.toQuery qs) | |
|> function | Ok a -> a | |
| Error e -> failwith e | |
let inline tryParse qs = | |
fromQuery (Convert.toQuery qs) | |
|> function | Ok a -> Some a | |
| Error _ -> None | |
[<AutoOpen>] | |
module HttpHandlers = | |
open Giraffe.HttpHandlers | |
open Giraffe.Tasks | |
open System.Threading.Tasks | |
module Query = | |
let inline bind (f: ^a -> HttpHandler) : HttpHandler = | |
fun (next : HttpFunc) (ctx : HttpContext) -> | |
task { | |
match Query.tryParse ctx.Request.QueryString with | |
| None -> return None | |
| Some a -> return! f a next ctx | |
} | |
let inline bindTask (f: ^a -> Task<HttpHandler>) : HttpHandler = | |
fun (next : HttpFunc) (ctx : HttpContext) -> | |
task { | |
match Query.tryParse ctx.Request.QueryString with | |
| None -> return None | |
| Some a -> | |
let! handler = f a | |
return! handler next ctx | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
This comment has been minimized.
Hi @Alxandr,
I have noticed some weird behavior when using
bool option
in my model:If param was empty i got
Some false
but if not empty I gotNone
. So I changed your code a little bit like that:and now it seems that it works but not sure if it doesn't break anything as I have no idea how this code works yet :).
I thought it may be useful for you.