@@ -11,20 +11,32 @@ open Microsoft.FSharp.Core.CompilerServices
1111
1212open FSharp.Data .GraphQL .Types .Introspection
1313open TypeCompiler
14+ open System.Collections .Generic
15+ open Newtonsoft.Json .Linq
16+ open Newtonsoft.Json
17+ open Microsoft.FSharp .Quotations
18+ open QuotationHelpers
1419
15- type internal ProviderSchemaConfig =
16- { Namespace : string
17- DefinedTypes : Map < string , ProvidedTypeDefinition option > }
20+ module Util =
21+ open System. Text . RegularExpressions
22+ open FSharp. Data . GraphQL
1823
19- //[<TypeProvider>]
20- type GraphQlProvider ( config : TypeProviderConfig ) as this =
21- inherit TypeProviderForNamespaces ()
22-
23- let asm = System.Reflection.Assembly.GetExecutingAssembly()
24+ let getOrFail ( err : string ) = function
25+ | Some v -> v
26+ | None -> failwith err
27+
28+ let tryOrFail ( err : string ) ( f : unit -> 'T ) =
29+ try f()
30+ with ex -> Exception( err, ex) |> raise
31+
32+ let firstToUpper ( str : string ) =
33+ if str <> null && str.Length > 0
34+ then str.[ 0 ]. ToString() .ToUpper() + str.Substring( 1 )
35+ else str
2436
2537 let requestSchema ( url : string ) =
2638 async {
27- let requestUrl = Uri( Uri( url), ( " /?query=" + FSharp.Data.GraphQL.Introspection.introspectionQuery), false )
39+ let requestUrl = Uri( Uri( url), ( " /?query=" + FSharp.Data.GraphQL.Introspection.introspectionQuery))
2840 let req = WebRequest.CreateHttp( requestUrl)
2941 req.Method <- " GET"
3042 use! resp = req.GetResponseAsync() |> Async.AwaitTask
@@ -40,37 +52,181 @@ type GraphQlProvider (config : TypeProviderConfig) as this =
4052 return Choice2Of2 errors
4153 }
4254
43- let compileTypesFromSchema ns ( schema : IntrospectionSchema ) =
55+ let compileTypesFromSchema asm ns ( schema : IntrospectionSchema ) =
56+ let underlyingType ( t : TypeReference ) =
57+ t.UnderlyingType
4458 let ctx = {
4559 Assembly = asm
4660 Namespace = ns
4761 KnownTypes = ProviderSessionContext.CoreTypes }
4862 let typeDefinitions =
49- schema.Types
50- |> Array.fold ( fun acc t -> Map.add t.Name ( ProvidedType ( initType ctx t, t)) acc) ctx.KnownTypes
63+ ( ctx.KnownTypes, schema.Types)
64+ ||> Array.fold ( fun acc t ->
65+ if acc.ContainsKey t.Name
66+ then acc
67+ else Map.add t.Name ( ProvidedType ( initType ctx t, t)) acc)
5168 let defctx = { ctx with KnownTypes = typeDefinitions }
5269 typeDefinitions
53- |> Map.iter ( fun k t ->
54- match t with
55- | NativeType _ -> ()
56- | ProvidedType ( t, itype) -> genType defctx itype t)
70+ |> Seq.iter ( fun kv ->
71+ match kv.Value with
72+ | NativeType t -> ()
73+ | ProvidedType ( t, itype) ->
74+ genType defctx itype t)
5775 typeDefinitions
58- |> Map.toSeq
59- |> Seq.map snd
60- |> Seq.choose (
61- function
62- | NativeType _ -> None
63- | ProvidedType ( t, _) -> Some t)
64- |> Seq.toList
6576
66- do
67- let choice = requestSchema( " http://localhost:8083" ) |> Async.RunSynchronously
68- match choice with
69- | Choice1Of2 schema ->
70- let types = compileTypesFromSchema " GraphQLNamespace"
71- this.AddNamespace( " GraphQLNamespace" , types)
72- | Choice2Of2 ex -> ()
77+ let rec jsonToObject ( token : JToken ) =
78+ match token.Type with
79+ | JTokenType.Object ->
80+ token.Children< JProperty>()
81+ |> Seq.map ( fun prop -> prop.Name, jsonToObject prop.Value)
82+ |> dict :> obj
83+ | JTokenType.Array ->
84+ token |> Seq.map jsonToObject |> Seq.toArray :> obj
85+ | _ ->
86+ ( token :?> JValue) .Value
87+
88+ let launchQuery ( serverUrl : string ) ( queryName : string ) ( cont : obj -> 'T ) ( query : string ) =
89+ async {
90+ use client = new WebClient()
91+ let queryJson = Map[ " query" , query] |> JsonConvert.SerializeObject
92+ let! json = client.UploadStringTaskAsync( Uri( serverUrl), queryJson) |> Async.AwaitTask
93+ let res = JToken.Parse json |> jsonToObject :?> IDictionary < string , obj >
94+ if res.ContainsKey( " errors" ) then
95+ res.[ " errors" ] :?> obj [] |> Seq .map string |> String .concat "\n " |> failwith
96+ let data =
97+ // Options are problematic within quotations so we just use null here
98+ if queryName <> null
99+ then ( res.[ " data" ] :?> IDictionary < string , obj >).[ queryName ]
100+ else res.[ " data" ]
101+ return cont( data)
102+ }
73103
104+ let buildQuery ( queryName : string ) ( queryFields : string )
105+ ( argNames : string []) ( argValues : obj []) =
106+ let queryFields , queryFragments =
107+ let mutable i = 0
108+ let mutable openBraces = 0
109+ let mutable closeBraces = 0
110+ while closeBraces = 0 || closeBraces < openBraces do
111+ match queryFields.Chars( i) with
112+ | '{' -> openBraces <- openBraces + 1
113+ | '}' -> closeBraces <- closeBraces + 1
114+ | _ -> ()
115+ i <- i + 1
116+ queryFields.Substring( 0 , i), queryFields.Substring( i)
117+ Seq.zip argNames argValues
118+ |> Seq.map ( fun ( k , v ) -> " %s %s " ( JsonConvert.SerializeObject v))
119+ |> String.concat " , "
120+ |> fun args -> sprintf " { %s %s %s %s "
121+
122+ let createMethod ( tdef : ProvidedTypeDefinition ) ( schemaTypes : Map < string , TypeReference >)
123+ ( serverUrl : string ) ( query : IntrospectionField ) =
124+ let findType ( t : IntrospectionTypeRef ) =
125+ TypeReference.findType t schemaTypes
126+ let makeExprArray ( exprs : Expr list ) =
127+ Expr.NewArray( typeof< obj>, exprs |> List.map ( fun e -> Expr.Coerce( e, typeof< obj>)))
128+ let resType = findType query.Type
129+ let asyncType = typedefof< Async< obj>>. MakeGenericType( resType)
130+ let args =
131+ query.Args
132+ |> Seq.map ( fun x -> ProvidedParameter( x.Name, findType x.Type))
133+ |> Seq.toList
134+ let m = ProvidedMethod( firstToUpper query.Name, args, asyncType, IsStaticMethod= true )
135+ let sargs = [ ProvidedStaticParameter( " query" , typeof< string>)]
136+ m.DefineStaticParameters( sargs, fun methName sargValues ->
137+ match sargValues with
138+ | [| :? string as queryFields |] ->
139+ // This will fail if the query is not well formed
140+ do Parser.parse queryFields |> ignore
141+ let queryName = query.Name
142+ let argNames = args |> Seq.map ( fun x -> x.Name) |> Seq.toArray
143+ let m2 = ProvidedMethod( methName, args, asyncType, IsStaticMethod = true )
144+ m2.InvokeCode <-
145+ if resType.Name = " FSharpOption`1" then
146+ fun argValues ->
147+ <@@
148+ (%% makeExprArray argValues: obj[])
149+ |> buildQuery queryName queryFields argNames
150+ |> launchQuery serverUrl queryName Option.ofObj
151+ @@>
152+ else
153+ fun argValues ->
154+ <@@
155+ (%% makeExprArray argValues: obj[])
156+ |> buildQuery queryName queryFields argNames
157+ |> launchQuery serverUrl queryName id
158+ @@>
159+ tdef.AddMember m2
160+ m2
161+ | _ -> failwith " unexpected parameter values" )
162+ m.InvokeCode <- fun _ -> <@@ null @@> // Dummy code
163+ m
164+
165+ let createMethods ( tdef : ProvidedTypeDefinition ) ( serverUrl : string )
166+ ( schema : IntrospectionSchema ) ( schemaTypes : Map < string , TypeReference >)
167+ ( opType : IntrospectionTypeRef option ) ( wrapperName : string ) =
168+ match opType with
169+ | Some op when op.Name.IsSome ->
170+ let opName = op.Name.Value
171+ let wrapper = ProvidedTypeDefinition( wrapperName, Some typeof< obj>)
172+ schema.Types
173+ |> Seq.collect ( fun t ->
174+ if t.Name = opName then defaultArg t.Fields [||] else [||])
175+ |> Seq.map ( createMethod wrapper schemaTypes serverUrl)
176+ |> Seq.toList
177+ |> function
178+ | [] -> ()
179+ | ops ->
180+ wrapper.AddMembers ops
181+ tdef.AddMember wrapper
182+ | _ -> ()
183+
184+ type internal ProviderSchemaConfig =
185+ { Namespace: string
186+ DefinedTypes: Map < string , ProvidedTypeDefinition option > }
187+
188+ [<TypeProvider>]
189+ type GraphQlProvider ( config : TypeProviderConfig ) as this =
190+ inherit TypeProviderForNamespaces ()
191+
192+ let asm = System.Reflection.Assembly.GetExecutingAssembly()
193+
194+ do
195+ let ns = " FSharp.Data.GraphQL"
196+ let generator = ProvidedTypeDefinition( asm, ns, " GraphQLProvider" , Some typeof< obj>)
197+ generator.DefineStaticParameters([ ProvidedStaticParameter( " url" , typeof< string>)], fun typeName parameterValues ->
198+ match parameterValues with
199+ | [| :? string as serverUrl|] ->
200+ let choice = Util.requestSchema( serverUrl) |> Async.RunSynchronously
201+ match choice with
202+ | Choice1Of2 schema ->
203+ let tdef = ProvidedTypeDefinition( asm, ns, typeName, Some typeof< obj>)
204+ let schemaTypes =
205+ Util.compileTypesFromSchema asm " GraphQLTypes"
206+ // Inner types
207+ let typesWrapper = ProvidedTypeDefinition( " Types" , Some typeof< obj>)
208+ schemaTypes
209+ |> Seq.choose ( fun kv ->
210+ match kv.Value with
211+ | ProvidedType( t,_) -> Some t
212+ | NativeType _ -> None)
213+ |> Seq.toList
214+ |> typesWrapper.AddMembers
215+ tdef.AddMember typesWrapper
216+ // Static methods
217+ Util.createMethods tdef serverUrl schema schemaTypes ( Some schema.QueryType) " Queries"
218+ Util.createMethods tdef serverUrl schema schemaTypes schema.MutationType " Mutations"
219+ Util.createMethods tdef serverUrl schema schemaTypes schema.SubscriptionType " Subscriptions"
220+ // Generic query method
221+ let m = ProvidedMethod( " Query" , [ ProvidedParameter( " query" , typeof< string>)], typeof< Async< obj>>)
222+ m.IsStaticMethod <- true
223+ m.InvokeCode <- fun argValues ->
224+ <@@ Util.launchQuery serverUrl null id (%% argValues.[ 0 ]: string) @@>
225+ tdef.AddMember m
226+ tdef
227+ | Choice2Of2 ex -> String.concat " \n " |> failwithf " %s "
228+ | _ -> failwith " unexpected parameter values" )
229+ this.AddNamespace( ns, [ generator])
74230
75231[<assembly: TypeProviderAssembly>]
76232do ()
0 commit comments