Skip to content

Instantly share code, notes, and snippets.

@Alxandr
Created October 30, 2017 08:34
Show Gist options
  • Save Alxandr/50aef7fbe4806ceb4c2889f1cbde1438 to your computer and use it in GitHub Desktop.
Save Alxandr/50aef7fbe4806ceb4c2889f1cbde1438 to your computer and use it in GitHub Desktop.
[<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
}
@whitebear-gh
Copy link

whitebear-gh commented Jan 5, 2018

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 got None. So I changed your code a little bit like that:

    let private Bool__ =
      (function | None       -> None
                | Some Empty -> Some true
                | Some (NonEmpty (h::t)) -> Some (bool.Parse h)
                | _          -> None), Option.ofBool

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment