From 0d231c5200a1f7451e9f16121f75619092ec3e73 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 30 Dec 2023 10:24:42 +0000 Subject: [PATCH 01/13] Respect BasePath attribute (#44) --- ConsumePlugin/GeneratedRestClient.fs | 152 ++++++++++++++++-- ConsumePlugin/RestApiExample.fs | 6 + MyriadPlugin.Test/HttpClient.fs | 6 +- MyriadPlugin.Test/MyriadPlugin.Test.fsproj | 15 +- .../TestAllowAnyStatusCode.fs | 0 .../TestHttpClient/TestBasePath.fs | 80 +++++++++ .../{ => TestHttpClient}/TestPathParam.fs | 0 .../TestPureGymRestApi.fs | 0 .../{ => TestHttpClient}/TestReturnTypes.fs | 0 .../{ => TestJsonParse}/TestJsonParse.fs | 0 .../{ => TestJsonParse}/TestPureGymJson.fs | 0 .../HttpClientGenerator.fs | 64 +++++++- 12 files changed, 297 insertions(+), 26 deletions(-) rename MyriadPlugin.Test/{ => TestHttpClient}/TestAllowAnyStatusCode.fs (100%) create mode 100644 MyriadPlugin.Test/TestHttpClient/TestBasePath.fs rename MyriadPlugin.Test/{ => TestHttpClient}/TestPathParam.fs (100%) rename MyriadPlugin.Test/{ => TestHttpClient}/TestPureGymRestApi.fs (100%) rename MyriadPlugin.Test/{ => TestHttpClient}/TestReturnTypes.fs (100%) rename MyriadPlugin.Test/{ => TestJsonParse}/TestJsonParse.fs (100%) rename MyriadPlugin.Test/{ => TestJsonParse}/TestPureGymJson.fs (100%) diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index 341824b..a457290 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -26,7 +26,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("v1/gyms/", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("v1/gyms/", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -52,7 +57,9 @@ module PureGymApi = let uri = System.Uri ( - client.BaseAddress, + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), System.Uri ( "v1/gyms/{gym_id}/attendance" .Replace ("{gym_id}", gymId.ToString () |> System.Web.HttpUtility.UrlEncode), @@ -83,7 +90,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("v1/member", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("v1/member", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -109,7 +121,9 @@ module PureGymApi = let uri = System.Uri ( - client.BaseAddress, + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), System.Uri ( "v1/gyms/{gym_id}" .Replace ("{gym_id}", gymId.ToString () |> System.Web.HttpUtility.UrlEncode), @@ -140,7 +154,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("v1/member/activity", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("v1/member/activity", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -166,7 +185,9 @@ module PureGymApi = let uri = System.Uri ( - client.BaseAddress, + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), System.Uri ( ("/v2/gymSessions/member" + "?fromDate=" @@ -201,7 +222,9 @@ module PureGymApi = let uri = System.Uri ( - client.BaseAddress, + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), System.Uri ( "endpoint/{param}" .Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode), @@ -227,7 +250,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -247,7 +275,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -267,7 +300,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -287,7 +325,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -307,7 +350,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -327,7 +375,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -347,7 +400,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -367,7 +425,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -386,7 +449,12 @@ module PureGymApi = let! ct = Async.CancellationToken let uri = - System.Uri (client.BaseAddress, System.Uri ("endpoint", System.UriKind.Relative)) + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("endpoint", System.UriKind.Relative) + ) let httpMessage = new System.Net.Http.HttpRequestMessage ( @@ -401,3 +469,55 @@ module PureGymApi = } |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) } +namespace PureGym + +open System +open System.Threading +open System.Threading.Tasks +open System.IO +open System.Net +open System.Net.Http +open RestEase + +/// Module for constructing a REST client. +[] +[] +module ApiWithoutBasePath = + /// Create a REST client. + let make (client : System.Net.Http.HttpClient) : IApiWithoutBasePath = + { new IApiWithoutBasePath with + member _.GetPathParam (parameter : string, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> + raise ( + System.ArgumentNullException ( + nameof (client.BaseAddress), + "No base path was supplied on the type, and no BaseAddress was on the HttpClient." + ) + ) + | v -> v), + System.Uri ( + "endpoint/{param}" + .Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode), + System.UriKind.Relative + ) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Get, + RequestUri = uri + ) + + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStringAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + } diff --git a/ConsumePlugin/RestApiExample.fs b/ConsumePlugin/RestApiExample.fs index 7fdc677..dce03cd 100644 --- a/ConsumePlugin/RestApiExample.fs +++ b/ConsumePlugin/RestApiExample.fs @@ -9,6 +9,7 @@ open System.Net.Http open RestEase [] +[] type IPureGymApi = [] abstract GetGyms : ?ct : CancellationToken -> Task @@ -60,3 +61,8 @@ type IPureGymApi = [] abstract GetWithoutAnyReturnCode : ?ct : CancellationToken -> Task + +[] +type IApiWithoutBasePath = + [] + abstract GetPathParam : [] parameter : string * ?ct : CancellationToken -> Task diff --git a/MyriadPlugin.Test/HttpClient.fs b/MyriadPlugin.Test/HttpClient.fs index a978424..7951424 100644 --- a/MyriadPlugin.Test/HttpClient.fs +++ b/MyriadPlugin.Test/HttpClient.fs @@ -11,7 +11,11 @@ type HttpClientMock (result : HttpRequestMessage -> Async) [] module HttpClientMock = - let make (baseUrl : System.Uri) (handler : HttpRequestMessage -> Async) = + let makeNoUri (handler : HttpRequestMessage -> Async) = let result = new HttpClientMock (handler) + result + + let make (baseUrl : System.Uri) (handler : HttpRequestMessage -> Async) = + let result = makeNoUri handler result.BaseAddress <- baseUrl result diff --git a/MyriadPlugin.Test/MyriadPlugin.Test.fsproj b/MyriadPlugin.Test/MyriadPlugin.Test.fsproj index ac451fc..6b898d0 100644 --- a/MyriadPlugin.Test/MyriadPlugin.Test.fsproj +++ b/MyriadPlugin.Test/MyriadPlugin.Test.fsproj @@ -8,15 +8,16 @@ - - - + + + + + + + + - - - - diff --git a/MyriadPlugin.Test/TestAllowAnyStatusCode.fs b/MyriadPlugin.Test/TestHttpClient/TestAllowAnyStatusCode.fs similarity index 100% rename from MyriadPlugin.Test/TestAllowAnyStatusCode.fs rename to MyriadPlugin.Test/TestHttpClient/TestAllowAnyStatusCode.fs diff --git a/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs b/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs new file mode 100644 index 0000000..3104507 --- /dev/null +++ b/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs @@ -0,0 +1,80 @@ +namespace MyriadPlugin.Test + +open System +open System.Net +open System.Net.Http +open NUnit.Framework +open PureGym +open FsUnitTyped + +[] +module TestBasePath = + [] + let ``Base path is respected`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Get + let content = new StringContent (message.RequestUri.ToString ()) + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + use client = HttpClientMock.makeNoUri proc + let api = PureGymApi.make client + + let observedUri = api.GetPathParam("param").Result + observedUri |> shouldEqual "https://whatnot.com/endpoint/param" + + [] + let ``Without a base path but with BaseAddress, request goes through`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Get + let content = new StringContent (message.RequestUri.ToString ()) + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + use client = HttpClientMock.make (System.Uri "https://baseaddress.com") proc + let api = ApiWithoutBasePath.make client + + let observedUri = api.GetPathParam("param").Result + observedUri |> shouldEqual "https://baseaddress.com/endpoint/param" + + [] + let ``Without a base path, request throws`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Get + let content = new StringContent (message.RequestUri.ToString ()) + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + use client = HttpClientMock.makeNoUri proc + let api = ApiWithoutBasePath.make client + + let observedExc = + async { + let! result = api.GetPathParam ("param") |> Async.AwaitTask |> Async.Catch + + match result with + | Choice1Of2 _ -> return failwith "test failure" + | Choice2Of2 exc -> return exc + } + |> Async.RunSynchronously + + let observedExc = + match observedExc with + | :? AggregateException as exc -> + match exc.InnerException with + | :? ArgumentNullException as exc -> exc + | _ -> failwith "test failure" + | _ -> failwith "test failure" + + observedExc.Message + |> shouldEqual + "No base path was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')" diff --git a/MyriadPlugin.Test/TestPathParam.fs b/MyriadPlugin.Test/TestHttpClient/TestPathParam.fs similarity index 100% rename from MyriadPlugin.Test/TestPathParam.fs rename to MyriadPlugin.Test/TestHttpClient/TestPathParam.fs diff --git a/MyriadPlugin.Test/TestPureGymRestApi.fs b/MyriadPlugin.Test/TestHttpClient/TestPureGymRestApi.fs similarity index 100% rename from MyriadPlugin.Test/TestPureGymRestApi.fs rename to MyriadPlugin.Test/TestHttpClient/TestPureGymRestApi.fs diff --git a/MyriadPlugin.Test/TestReturnTypes.fs b/MyriadPlugin.Test/TestHttpClient/TestReturnTypes.fs similarity index 100% rename from MyriadPlugin.Test/TestReturnTypes.fs rename to MyriadPlugin.Test/TestHttpClient/TestReturnTypes.fs diff --git a/MyriadPlugin.Test/TestJsonParse.fs b/MyriadPlugin.Test/TestJsonParse/TestJsonParse.fs similarity index 100% rename from MyriadPlugin.Test/TestJsonParse.fs rename to MyriadPlugin.Test/TestJsonParse/TestJsonParse.fs diff --git a/MyriadPlugin.Test/TestPureGymJson.fs b/MyriadPlugin.Test/TestJsonParse/TestPureGymJson.fs similarity index 100% rename from MyriadPlugin.Test/TestPureGymJson.fs rename to MyriadPlugin.Test/TestJsonParse/TestPureGymJson.fs diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index 9116539..29e7fab 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -53,6 +53,7 @@ module internal HttpClientGenerator = Args : Parameter list Identifier : Ident EnsureSuccessHttpCode : bool + BasePath : SynExpr option } let httpMethodString (m : HttpMethod) : string = @@ -296,13 +297,55 @@ module internal HttpClientGenerator = let requestUri = let uriIdent = SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ]) + let baseAddress = + SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "BaseAddress" ]) + + let baseAddress = + SynExpr.CreateMatch ( + baseAddress, + [ + SynMatchClause.Create ( + SynPat.CreateNull, + None, + match info.BasePath with + | None -> + SynExpr.CreateApp ( + SynExpr.CreateIdentString "raise", + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.Create [ "System" ; "ArgumentNullException" ] + ), + SynExpr.CreateParenedTuple + [ + SynExpr.CreateApp ( + SynExpr.CreateIdentString "nameof", + SynExpr.CreateParen baseAddress + ) + SynExpr.CreateConstString + "No base path was supplied on the type, and no BaseAddress was on the HttpClient." + ] + ) + ) + ) + | Some expr -> SynExpr.CreateApp (uriIdent, expr) + ) + SynMatchClause.Create ( + SynPat.CreateNamed (Ident.Create "v"), + None, + SynExpr.CreateIdentString "v" + ) + ] + ) + |> SynExpr.CreateParen + SynExpr.App ( ExprAtomicFlag.Atomic, false, uriIdent, SynExpr.CreateParenedTuple [ - SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "BaseAddress" ]) + baseAddress SynExpr.CreateApp ( uriIdent, SynExpr.CreateParenedTuple @@ -551,15 +594,31 @@ module internal HttpClientGenerator = convertSigParam param :: extractTypes rest | _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType + let extractBasePath (attrs : SynAttributes) : SynExpr option = + attrs + |> List.tryPick (fun attr -> + attr.Attributes + |> List.tryPick (fun attr -> + match attr.TypeName.AsString with + | "BasePath" + | "RestEase.BasePath" + | "BasePathAttribute" + | "RestEase.BasePathAttribute" -> Some attr.ArgExpr + | _ -> None + ) + ) + let createModule (opens : SynOpenDeclTarget list) (ns : LongIdent) (interfaceType : SynTypeDefn) : SynModuleOrNamespace = - let (SynTypeDefn (SynComponentInfo (_, _, _, interfaceName, _, _, _, _), synTypeDefnRepr, _, _, _, _)) = + let (SynTypeDefn (SynComponentInfo (attrs, _, _, interfaceName, _, _, _, _), synTypeDefnRepr, _, _, _, _)) = interfaceType + let basePath = extractBasePath attrs + let members = match synTypeDefnRepr with | SynTypeDefnRepr.ObjectModel (_kind, members, _) -> @@ -640,6 +699,7 @@ module internal HttpClientGenerator = Args = args Identifier = ident EnsureSuccessHttpCode = shouldEnsureSuccess + BasePath = basePath } | _ -> failwithf "Unrecognised member definition: %+A" defn ) From 4c55bbed22376f0f17a79f4f149af3da0334ee8c Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 30 Dec 2023 10:37:30 +0000 Subject: [PATCH 02/13] Fix BaseAddress semantics (#45) --- ConsumePlugin/GeneratedRestClient.fs | 106 +++++++++++++++++- ConsumePlugin/RestApiExample.fs | 19 +++- .../TestHttpClient/TestBasePath.fs | 12 +- README.md | 8 +- .../HttpClientGenerator.fs | 21 +++- 5 files changed, 147 insertions(+), 19 deletions(-) diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index a457290..2ac321a 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -482,10 +482,10 @@ open RestEase /// Module for constructing a REST client. [] [] -module ApiWithoutBasePath = +module ApiWithoutBaseAddress = /// Create a REST client. - let make (client : System.Net.Http.HttpClient) : IApiWithoutBasePath = - { new IApiWithoutBasePath with + let make (client : System.Net.Http.HttpClient) : IApiWithoutBaseAddress = + { new IApiWithoutBaseAddress with member _.GetPathParam (parameter : string, ct : CancellationToken option) = async { let! ct = Async.CancellationToken @@ -497,7 +497,7 @@ module ApiWithoutBasePath = raise ( System.ArgumentNullException ( nameof (client.BaseAddress), - "No base path was supplied on the type, and no BaseAddress was on the HttpClient." + "No base address was supplied on the type, and no BaseAddress was on the HttpClient." ) ) | v -> v), @@ -521,3 +521,101 @@ module ApiWithoutBasePath = } |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) } +namespace PureGym + +open System +open System.Threading +open System.Threading.Tasks +open System.IO +open System.Net +open System.Net.Http +open RestEase + +/// Module for constructing a REST client. +[] +[] +module ApiWithBasePath = + /// Create a REST client. + let make (client : System.Net.Http.HttpClient) : IApiWithBasePath = + { new IApiWithBasePath with + member _.GetPathParam (parameter : string, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> + raise ( + System.ArgumentNullException ( + nameof (client.BaseAddress), + "No base address was supplied on the type, and no BaseAddress was on the HttpClient." + ) + ) + | v -> v), + System.Uri ( + "endpoint/{param}" + .Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode), + System.UriKind.Relative + ) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Get, + RequestUri = uri + ) + + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStringAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + } +namespace PureGym + +open System +open System.Threading +open System.Threading.Tasks +open System.IO +open System.Net +open System.Net.Http +open RestEase + +/// Module for constructing a REST client. +[] +[] +module ApiWithBasePathAndAddress = + /// Create a REST client. + let make (client : System.Net.Http.HttpClient) : IApiWithBasePathAndAddress = + { new IApiWithBasePathAndAddress with + member _.GetPathParam (parameter : string, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ( + "endpoint/{param}" + .Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode), + System.UriKind.Relative + ) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Get, + RequestUri = uri + ) + + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStringAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + } diff --git a/ConsumePlugin/RestApiExample.fs b/ConsumePlugin/RestApiExample.fs index dce03cd..ad75d4e 100644 --- a/ConsumePlugin/RestApiExample.fs +++ b/ConsumePlugin/RestApiExample.fs @@ -9,7 +9,7 @@ open System.Net.Http open RestEase [] -[] +[] type IPureGymApi = [] abstract GetGyms : ?ct : CancellationToken -> Task @@ -63,6 +63,21 @@ type IPureGymApi = abstract GetWithoutAnyReturnCode : ?ct : CancellationToken -> Task [] -type IApiWithoutBasePath = +type IApiWithoutBaseAddress = + [] + abstract GetPathParam : [] parameter : string * ?ct : CancellationToken -> Task + +// TODO: implement BasePath support + +[] +[] +type IApiWithBasePath = + [] + abstract GetPathParam : [] parameter : string * ?ct : CancellationToken -> Task + +[] +[] +[] +type IApiWithBasePathAndAddress = [] abstract GetPathParam : [] parameter : string * ?ct : CancellationToken -> Task diff --git a/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs b/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs index 3104507..a17c06f 100644 --- a/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs +++ b/MyriadPlugin.Test/TestHttpClient/TestBasePath.fs @@ -10,7 +10,7 @@ open FsUnitTyped [] module TestBasePath = [] - let ``Base path is respected`` () = + let ``Base address is respected`` () = let proc (message : HttpRequestMessage) : HttpResponseMessage Async = async { message.Method |> shouldEqual HttpMethod.Get @@ -27,7 +27,7 @@ module TestBasePath = observedUri |> shouldEqual "https://whatnot.com/endpoint/param" [] - let ``Without a base path but with BaseAddress, request goes through`` () = + let ``Without a base address attr but with BaseAddress on client, request goes through`` () = let proc (message : HttpRequestMessage) : HttpResponseMessage Async = async { message.Method |> shouldEqual HttpMethod.Get @@ -38,13 +38,13 @@ module TestBasePath = } use client = HttpClientMock.make (System.Uri "https://baseaddress.com") proc - let api = ApiWithoutBasePath.make client + let api = ApiWithoutBaseAddress.make client let observedUri = api.GetPathParam("param").Result observedUri |> shouldEqual "https://baseaddress.com/endpoint/param" [] - let ``Without a base path, request throws`` () = + let ``Without a base address attr or BaseAddress on client, request throws`` () = let proc (message : HttpRequestMessage) : HttpResponseMessage Async = async { message.Method |> shouldEqual HttpMethod.Get @@ -55,7 +55,7 @@ module TestBasePath = } use client = HttpClientMock.makeNoUri proc - let api = ApiWithoutBasePath.make client + let api = ApiWithoutBaseAddress.make client let observedExc = async { @@ -77,4 +77,4 @@ module TestBasePath = observedExc.Message |> shouldEqual - "No base path was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')" + "No base address was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')" diff --git a/README.md b/README.md index 95945e4..a52b6a1 100644 --- a/README.md +++ b/README.md @@ -210,14 +210,12 @@ RestEase is complex, and handles a lot of different stuff. * Deserialisation follows the same logic as the `JsonParse` generator, and it generally assumes you're using types which `JsonParse` is applied to. * Headers are not yet supported. -* You have to specify the `BaseAddress` on the input client yourself, and you can't have the same client talking to a - different `BaseAddress` this way unless you manually set it before making any different request. -* I haven't yet worked out how to integrate this with a mocked HTTP client; you can always mock up an `HttpClient`, - but I prefer to use a mock which defines a single member `SendAsync`. * Anonymous parameters are currently forbidden. + +There are also some design decisions: + * Every function must take an optional `CancellationToken` (which is good practice anyway); so arguments are forced to be tupled. - This is a won't-fix for as long as F# requires tupled arguments if any of the args are optional. # Detailed examples diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index 29e7fab..495d80f 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -53,6 +53,7 @@ module internal HttpClientGenerator = Args : Parameter list Identifier : Ident EnsureSuccessHttpCode : bool + BaseAddress : SynExpr option BasePath : SynExpr option } @@ -307,7 +308,7 @@ module internal HttpClientGenerator = SynMatchClause.Create ( SynPat.CreateNull, None, - match info.BasePath with + match info.BaseAddress with | None -> SynExpr.CreateApp ( SynExpr.CreateIdentString "raise", @@ -323,7 +324,7 @@ module internal HttpClientGenerator = SynExpr.CreateParen baseAddress ) SynExpr.CreateConstString - "No base path was supplied on the type, and no BaseAddress was on the HttpClient." + "No base address was supplied on the type, and no BaseAddress was on the HttpClient." ] ) ) @@ -608,6 +609,20 @@ module internal HttpClientGenerator = ) ) + let extractBaseAddress (attrs : SynAttributes) : SynExpr option = + attrs + |> List.tryPick (fun attr -> + attr.Attributes + |> List.tryPick (fun attr -> + match attr.TypeName.AsString with + | "BaseAddress" + | "RestEase.BaseAddress" + | "BaseAddressAttribute" + | "RestEase.BaseAddressAttribute" -> Some attr.ArgExpr + | _ -> None + ) + ) + let createModule (opens : SynOpenDeclTarget list) (ns : LongIdent) @@ -617,6 +632,7 @@ module internal HttpClientGenerator = let (SynTypeDefn (SynComponentInfo (attrs, _, _, interfaceName, _, _, _, _), synTypeDefnRepr, _, _, _, _)) = interfaceType + let baseAddress = extractBaseAddress attrs let basePath = extractBasePath attrs let members = @@ -699,6 +715,7 @@ module internal HttpClientGenerator = Args = args Identifier = ident EnsureSuccessHttpCode = shouldEnsureSuccess + BaseAddress = baseAddress BasePath = basePath } | _ -> failwithf "Unrecognised member definition: %+A" defn From dd7e004e363faf25ef805dd25697457223f44074 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 30 Dec 2023 11:35:22 +0000 Subject: [PATCH 03/13] Add initial support for `[]` (#46) --- ConsumePlugin/GeneratedRestClient.fs | 161 ++++++++++++++++++ ConsumePlugin/RestApiExample.fs | 20 +++ MyriadPlugin.Test/MyriadPlugin.Test.fsproj | 1 + .../TestHttpClient/TestBodyParam.fs | 105 ++++++++++++ .../TestHttpClient/TestReturnTypes.fs | 4 +- README.md | 1 - WoofWare.Myriad.Plugins/AstHelper.fs | 19 +++ .../HttpClientGenerator.fs | 140 +++++++++++---- WoofWare.Myriad.Plugins/SynExpr.fs | 12 +- 9 files changed, 422 insertions(+), 41 deletions(-) create mode 100644 MyriadPlugin.Test/TestHttpClient/TestBodyParam.fs diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index 2ac321a..6071063 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -216,6 +216,167 @@ module PureGymApi = } |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + member _.CreateUserString (user : string, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("users/new", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Post, + RequestUri = uri + ) + + let queryParams = new System.Net.Http.StringContent (user) + do httpMessage.Content <- queryParams + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStringAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + + member _.CreateUserStream (user : System.IO.Stream, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("users/new", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Post, + RequestUri = uri + ) + + let queryParams = new System.Net.Http.StreamContent (user) + do httpMessage.Content <- queryParams + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + + member _.CreateUserByteArr (user : byte[], ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("users/new", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Post, + RequestUri = uri + ) + + let queryParams = new System.Net.Http.ByteArrayContent (user) + do httpMessage.Content <- queryParams + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + + member _.CreateUserByteArr' (user : array, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("users/new", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Post, + RequestUri = uri + ) + + let queryParams = new System.Net.Http.ByteArrayContent (user) + do httpMessage.Content <- queryParams + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + + member _.CreateUserByteArr'' (user : byte array, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("users/new", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Post, + RequestUri = uri + ) + + let queryParams = new System.Net.Http.ByteArrayContent (user) + do httpMessage.Content <- queryParams + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + + member _.CreateUserHttpContent (user : System.Net.Http.HttpContent, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("users/new", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Post, + RequestUri = uri + ) + + do httpMessage.Content <- user + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! node = response.Content.ReadAsStringAsync ct |> Async.AwaitTask + return node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + member _.GetPathParam (parameter : string, ct : CancellationToken option) = async { let! ct = Async.CancellationToken diff --git a/ConsumePlugin/RestApiExample.fs b/ConsumePlugin/RestApiExample.fs index ad75d4e..381b271 100644 --- a/ConsumePlugin/RestApiExample.fs +++ b/ConsumePlugin/RestApiExample.fs @@ -31,6 +31,26 @@ type IPureGymApi = abstract GetSessions : [] fromDate : DateOnly * [] toDate : DateOnly * ?ct : CancellationToken -> Task + // An example from RestEase's own docs + [] + abstract CreateUserString : [] user : string * ?ct : CancellationToken -> Task + + [] + abstract CreateUserStream : [] user : System.IO.Stream * ?ct : CancellationToken -> Task + + [] + abstract CreateUserByteArr : [] user : byte[] * ?ct : CancellationToken -> Task + + [] + abstract CreateUserByteArr' : [] user : array * ?ct : CancellationToken -> Task + + [] + abstract CreateUserByteArr'' : [] user : byte array * ?ct : CancellationToken -> Task + + [] + abstract CreateUserHttpContent : + [] user : System.Net.Http.HttpContent * ?ct : CancellationToken -> Task + [] abstract GetPathParam : [] parameter : string * ?ct : CancellationToken -> Task diff --git a/MyriadPlugin.Test/MyriadPlugin.Test.fsproj b/MyriadPlugin.Test/MyriadPlugin.Test.fsproj index 6b898d0..f6c91a1 100644 --- a/MyriadPlugin.Test/MyriadPlugin.Test.fsproj +++ b/MyriadPlugin.Test/MyriadPlugin.Test.fsproj @@ -16,6 +16,7 @@ + diff --git a/MyriadPlugin.Test/TestHttpClient/TestBodyParam.fs b/MyriadPlugin.Test/TestHttpClient/TestBodyParam.fs new file mode 100644 index 0000000..fcbd45d --- /dev/null +++ b/MyriadPlugin.Test/TestHttpClient/TestBodyParam.fs @@ -0,0 +1,105 @@ +namespace MyriadPlugin.Test + +open System +open System.IO +open System.Net +open System.Net.Http +open System.Text.Json.Nodes +open NUnit.Framework +open PureGym +open FsUnitTyped + +[] +module TestBodyParam = + + [] + let ``Body param of string`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Post + let! content = message.Content.ReadAsStringAsync () |> Async.AwaitTask + let content = new StringContent (content) + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + use client = HttpClientMock.make (Uri "https://example.com") proc + let api = PureGymApi.make client + + let observedUri = api.CreateUserString("username?not!url%encoded").Result + observedUri |> shouldEqual "username?not!url%encoded" + + [] + let ``Body param of stream`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Post + let! content = message.Content.ReadAsStreamAsync () |> Async.AwaitTask + let content = new StreamContent (content) + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + let contents = [| 1uy ; 2uy ; 3uy ; 4uy |] + + use client = HttpClientMock.make (Uri "https://example.com") proc + let api = PureGymApi.make client + + use stream = new MemoryStream (contents) + let observedContent = api.CreateUserStream(stream).Result + let buf = Array.zeroCreate 10 + let written = observedContent.ReadAtLeast (buf.AsSpan (), 5, false) + buf |> Array.take written |> shouldEqual contents + + [] + let ``Body param of HttpContent`` () = + let mutable observedContent = None + + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Post + let resp = new HttpResponseMessage (HttpStatusCode.OK) + observedContent <- Some message.Content + resp.Content <- new StringContent ("oh hi") + return resp + } + + use client = HttpClientMock.make (Uri "https://example.com") proc + let api = PureGymApi.make client + + use content = new StringContent ("hello!") + + api.CreateUserHttpContent(content).Result |> shouldEqual "oh hi" + Object.ReferenceEquals (Option.get observedContent, content) |> shouldEqual true + + [] + [] + [] + let ``Body param of byte arr`` (case : string) = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Post + let! content = message.Content.ReadAsStreamAsync () |> Async.AwaitTask + let content = new StreamContent (content) + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + use client = HttpClientMock.make (Uri "https://example.com") proc + let api = PureGymApi.make client + + let contents = [| 1uy ; 2uy ; 3uy ; 4uy |] + + let observedContent = + match case with + | "ByteArr" -> api.CreateUserByteArr(contents).Result + | "ByteArr'" -> api.CreateUserByteArr'(contents).Result + | "ByteArr''" -> api.CreateUserByteArr''(contents).Result + | _ -> failwith $"Unrecognised case: %s{case}" + + let buf = Array.zeroCreate 10 + let written = observedContent.ReadAtLeast (buf.AsSpan (), 5, false) + buf |> Array.take written |> shouldEqual contents diff --git a/MyriadPlugin.Test/TestHttpClient/TestReturnTypes.fs b/MyriadPlugin.Test/TestHttpClient/TestReturnTypes.fs index 91e7792..a0affd8 100644 --- a/MyriadPlugin.Test/TestHttpClient/TestReturnTypes.fs +++ b/MyriadPlugin.Test/TestHttpClient/TestReturnTypes.fs @@ -54,8 +54,8 @@ module TestReturnTypes = | _ -> failwith $"unrecognised case: %s{case}" let buf = Array.zeroCreate 10 - stream.Read (buf, 0, 10) |> shouldEqual 4 - Array.take 4 buf |> shouldEqual result + let written = stream.ReadAtLeast (buf.AsSpan (), 10, false) + Array.take written buf |> shouldEqual result [] [] diff --git a/README.md b/README.md index a52b6a1..574d194 100644 --- a/README.md +++ b/README.md @@ -204,7 +204,6 @@ The motivating example is again ahead-of-time compilation: we wish to avoid the RestEase is complex, and handles a lot of different stuff. -* As of this writing, `[]` is explicitly unsupported (it throws with a TODO). * Parameters are serialised solely with `ToString`, and there's no control over this; nor is there control over encoding in any sense. * Deserialisation follows the same logic as the `JsonParse` generator, diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index a31f431..1418deb 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -116,6 +116,14 @@ module internal SynTypePatterns = | _ -> None | _ -> None + let (|Byte|_|) (fieldType : SynType) : unit option = + match fieldType with + | SynType.LongIdent ident -> + match ident.LongIdent with + | [ i ] -> [ "byte" ] |> List.tryFind (fun s -> s = i.idText) |> Option.map ignore + | _ -> None + | _ -> None + let (|HttpResponseMessage|_|) (fieldType : SynType) : unit option = match fieldType with | SynType.LongIdent ident -> @@ -127,6 +135,17 @@ module internal SynTypePatterns = | _ -> None | _ -> None + let (|HttpContent|_|) (fieldType : SynType) : unit option = + match fieldType with + | SynType.LongIdent ident -> + match ident.LongIdent |> List.map (fun i -> i.idText) with + | [ "System" ; "Net" ; "Http" ; "HttpContent" ] + | [ "Net" ; "Http" ; "HttpContent" ] + | [ "Http" ; "HttpContent" ] + | [ "HttpContent" ] -> Some () + | _ -> None + | _ -> None + let (|Stream|_|) (fieldType : SynType) : unit option = match fieldType with | SynType.LongIdent ident -> diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index 495d80f..eefa2eb 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -31,6 +31,22 @@ module internal HttpClientGenerator = Type : SynType } + [] + type BodyParamMethods = + | StringContent + | StreamContent + | ByteArrayContent + | HttpContent + | Serialise of SynType + + override this.ToString () = + match this with + | BodyParamMethods.Serialise _ -> "ToString" + | BodyParamMethods.ByteArrayContent -> "ByteArrayContent" + | BodyParamMethods.StringContent -> "StringContent" + | BodyParamMethods.StreamContent -> "StreamContent" + | BodyParamMethods.HttpContent -> "HttpContent" + let synBindingTriviaZero (isMember : bool) = { SynBindingTrivia.EqualsRange = Some range0 @@ -256,18 +272,9 @@ module internal HttpClientGenerator = | None -> failwith "Unable to get parameter variable name from anonymous parameter" | Some id -> id - let toString (ident : SynExpr) (ty : SynType) = - match ty with - | DateOnly -> - ident - |> SynExpr.callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-dd") - | DateTime -> - ident - |> SynExpr.callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-ddTHH:mm:ss") - | _ -> SynExpr.callMethod "ToString" ident - let prefix = - toString (SynExpr.CreateIdent firstValueId) firstValue.Type + SynExpr.CreateIdent firstValueId + |> SynExpr.toString firstValue.Type |> SynExpr.CreateParen |> SynExpr.pipeThroughFunction ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]) @@ -282,7 +289,7 @@ module internal HttpClientGenerator = | None -> failwith "Unable to get parameter variable name from anonymous parameter" | Some id -> id - toString (SynExpr.CreateIdent paramValueId) paramValue.Type + SynExpr.toString paramValue.Type (SynExpr.CreateIdent paramValueId) |> SynExpr.CreateParen |> SynExpr.pipeThroughFunction ( SynExpr.CreateLongIdent ( @@ -370,8 +377,23 @@ module internal HttpClientGenerator = ) ) - if not bodyParams.IsEmpty then - failwith "[] is not yet supported" + let bodyParam = + match bodyParams with + | [] -> None + | [ x ] -> + // TODO: body serialisation method + let paramName = + match x.Id with + | None -> failwith "Anonymous [] parameter is unsupported" + | Some id -> id + + match x.Type with + | Stream -> Some (BodyParamMethods.StreamContent, paramName) + | String -> Some (BodyParamMethods.StringContent, paramName) + | ArrayType Byte -> Some (BodyParamMethods.ByteArrayContent, paramName) + | HttpContent -> Some (BodyParamMethods.HttpContent, paramName) + | ty -> Some (BodyParamMethods.Serialise ty, paramName) + | _ -> failwith "You can only have at most one [] parameter on a method." let httpReqMessageConstructor = [ @@ -397,6 +419,71 @@ module internal HttpClientGenerator = info.ReturnType (SynExpr.CreateIdentString "node") + let handleBodyParams = + match bodyParam with + | None -> [] + | Some (bodyParamType, bodyParamName) -> + match bodyParamType with + | BodyParamMethods.StreamContent + | BodyParamMethods.ByteArrayContent + | BodyParamMethods.StringContent -> + [ + Let ( + "queryParams", + SynExpr.New ( + false, + SynType.CreateLongIdent ( + SynLongIdent.Create + [ "System" ; "Net" ; "Http" ; (bodyParamType : BodyParamMethods).ToString () ] + ), + SynExpr.CreateParen (SynExpr.CreateIdent bodyParamName), + range0 + ) + ) + Do ( + SynExpr.LongIdentSet ( + SynLongIdent.Create [ "httpMessage" ; "Content" ], + SynExpr.CreateIdentString "queryParams", + range0 + ) + ) + ] + | BodyParamMethods.HttpContent -> + [ + Do ( + SynExpr.LongIdentSet ( + SynLongIdent.Create [ "httpMessage" ; "Content" ], + SynExpr.CreateIdent bodyParamName, + range0 + ) + ) + ] + | BodyParamMethods.Serialise _ -> + failwith "We don't yet support serialising Body parameters; use string or Stream instead" + (* + // TODO: this should use JSON instead of ToString + [ + Let ( + "queryParams", + SynExpr.New ( + false, + SynType.CreateLongIdent ( + SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "StringContent" ] + ), + SynExpr.CreateParen (SynExpr.CreateIdent bodyParamName |> SynExpr.toString ty), + range0 + ) + ) + Do ( + SynExpr.LongIdentSet ( + SynLongIdent.Create [ "httpMessage" ; "Content" ], + SynExpr.CreateIdentString "queryParams", + range0 + ) + ) + ] + *) + let implementation = [ yield LetBang ("ct", SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "CancellationToken" ])) @@ -413,30 +500,9 @@ module internal HttpClientGenerator = range0 ) ) - (* - if not bodyParams.IsEmpty then - yield - Use ( - "queryParams", - SynExpr.New ( - false, - SynType.CreateLongIdent ( - SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "StringContent" ] - ), - SynExpr.CreateParen (failwith "TODO"), - range0 - ) - ) - yield - Do ( - SynExpr.LongIdentSet ( - SynLongIdent.Create [ "httpMessage" ; "Content" ], - SynExpr.CreateIdentString "queryParams", - range0 - ) - ) - *) + yield! handleBodyParams + yield LetBang ( "response", diff --git a/WoofWare.Myriad.Plugins/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr.fs index dafc6c7..6f0cf28 100644 --- a/WoofWare.Myriad.Plugins/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr.fs @@ -240,7 +240,7 @@ module internal SynExpr = SynExprLetOrUseTrivia.InKeyword = None } ) - | Do body -> SynExpr.Do (body, range0) + | Do body -> SynExpr.CreateSequential [ SynExpr.Do (body, range0) ; state ] ) SynExpr.CreateApp ( @@ -252,3 +252,13 @@ module internal SynExpr = let awaitTask (expr : SynExpr) : SynExpr = expr |> pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "AwaitTask" ])) + + /// {ident}.ToString () + /// with special casing for some types like DateTime + let toString (ty : SynType) (ident : SynExpr) = + match ty with + | DateOnly -> ident |> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-dd") + | DateTime -> + ident + |> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-ddTHH:mm:ss") + | _ -> callMethod "ToString" ident From 79d7502f3ff2e0ca980e143a6baa8df46b493cbd Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 30 Dec 2023 12:29:16 +0000 Subject: [PATCH 04/13] Fix copy-paste Dependabot error (#48) --- .github/dependabot.yml | 2 +- README.md | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/dependabot.yml b/.github/dependabot.yml index 72c2bfe..2e62656 100644 --- a/.github/dependabot.yml +++ b/.github/dependabot.yml @@ -7,7 +7,7 @@ updates: interval: "weekly" - package-ecosystem: "nuget" - directory: "/ApiSurface" + directory: "/" schedule: interval: "weekly" ignore: diff --git a/README.md b/README.md index 574d194..60d62a6 100644 --- a/README.md +++ b/README.md @@ -204,6 +204,9 @@ The motivating example is again ahead-of-time compilation: we wish to avoid the RestEase is complex, and handles a lot of different stuff. +* If you set the `BaseAddress` on your input `HttpClient`, make sure to end with a trailing slash + on any trailing directories (so `"blah/foo/"` rather than `"blah/foo"`). + We combine URIs using `UriKind.Relative`, so without a trailing slash, the last component may be chopped off. * Parameters are serialised solely with `ToString`, and there's no control over this; nor is there control over encoding in any sense. * Deserialisation follows the same logic as the `JsonParse` generator, From ed0e4da0a382d68c53f5cf559caac696b38846a6 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sat, 30 Dec 2023 12:50:53 +0000 Subject: [PATCH 05/13] Bump deps (#54) --- Directory.Build.props | 4 +- .../HttpClient.fs | 2 +- .../PureGymDtos.fs | 2 +- .../TestHttpClient/TestAllowAnyStatusCode.fs | 2 +- .../TestHttpClient/TestBasePath.fs | 2 +- .../TestHttpClient/TestBodyParam.fs | 2 +- .../TestHttpClient/TestPathParam.fs | 2 +- .../TestHttpClient/TestPureGymRestApi.fs | 2 +- .../TestHttpClient/TestReturnTypes.fs | 2 +- .../TestJsonParse/TestJsonParse.fs | 2 +- .../TestJsonParse/TestPureGymJson.fs | 2 +- .../TestRemoveOptions.fs | 2 +- .../TestSurface.fs | 2 +- .../WoofWare.Myriad.Plugins.Test.fsproj | 80 +++++++++---------- WoofWare.Myriad.sln | 10 +-- nix/deps.nix | 71 ++++++++-------- 16 files changed, 92 insertions(+), 97 deletions(-) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/HttpClient.fs (94%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/PureGymDtos.fs (99%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestHttpClient/TestAllowAnyStatusCode.fs (98%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestHttpClient/TestBasePath.fs (98%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestHttpClient/TestBodyParam.fs (99%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestHttpClient/TestPathParam.fs (96%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestHttpClient/TestPureGymRestApi.fs (99%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestHttpClient/TestReturnTypes.fs (98%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestJsonParse/TestJsonParse.fs (95%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestJsonParse/TestPureGymJson.fs (98%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestRemoveOptions.fs (92%) rename {MyriadPlugin.Test => WoofWare.Myriad.Plugins.Test}/TestSurface.fs (94%) rename MyriadPlugin.Test/MyriadPlugin.Test.fsproj => WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj (78%) diff --git a/Directory.Build.props b/Directory.Build.props index 8a619c2..e9f58d0 100644 --- a/Directory.Build.props +++ b/Directory.Build.props @@ -10,8 +10,8 @@ embedded - - + + - RecordFile.fs + + RecordFile.fs - - JsonRecord.fs + + JsonRecord.fs - PureGymDto.fs + PureGymDto.fs - RestApiExample.fs + RestApiExample.fs + + + + MockExample.fs runmyriad.sh diff --git a/ConsumePlugin/GeneratedJson.fs b/ConsumePlugin/GeneratedJson.fs index c51e2f5..16f4e36 100644 --- a/ConsumePlugin/GeneratedJson.fs +++ b/ConsumePlugin/GeneratedJson.fs @@ -3,6 +3,7 @@ // Changes to this file will be lost when the code is regenerated. //------------------------------------------------------------------------------ + namespace ConsumePlugin /// Module containing JSON parsing methods for the InnerType type diff --git a/ConsumePlugin/GeneratedMock.fs b/ConsumePlugin/GeneratedMock.fs new file mode 100644 index 0000000..918d11b --- /dev/null +++ b/ConsumePlugin/GeneratedMock.fs @@ -0,0 +1,74 @@ +//------------------------------------------------------------------------------ +// This code was generated by myriad. +// Changes to this file will be lost when the code is regenerated. +//------------------------------------------------------------------------------ + +namespace SomeNamespace + +/// Mock record type for an interface +type internal PublicTypeMock = + { + Mem1 : string * int -> string list + Mem2 : string -> int + } + + static member Empty : PublicTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface IPublicType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +namespace SomeNamespace + +/// Mock record type for an interface +type internal InternalTypeMock = + { + Mem1 : string * int -> unit + Mem2 : string -> int + } + + static member Empty : InternalTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface InternalType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +namespace SomeNamespace + +/// Mock record type for an interface +type private PrivateTypeMock = + { + Mem1 : string * int -> unit + Mem2 : string -> int + } + + static member Empty : PrivateTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface PrivateType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +namespace SomeNamespace + +/// Mock record type for an interface +type internal VeryPublicTypeMock<'a, 'b> = + { + Mem1 : 'a -> 'b + } + + static member Empty<'a, 'b> () : VeryPublicTypeMock<'a, 'b> = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface VeryPublicType<'a, 'b> with + member this.Mem1 (arg0) = this.Mem1 (arg0) diff --git a/ConsumePlugin/GeneratedPureGymDto.fs b/ConsumePlugin/GeneratedPureGymDto.fs index d97aa14..7fc1049 100644 --- a/ConsumePlugin/GeneratedPureGymDto.fs +++ b/ConsumePlugin/GeneratedPureGymDto.fs @@ -3,6 +3,7 @@ // Changes to this file will be lost when the code is regenerated. //------------------------------------------------------------------------------ + namespace PureGym /// Module containing JSON parsing methods for the GymOpeningHours type diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index 6071063..1c3262f 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -4,6 +4,7 @@ //------------------------------------------------------------------------------ + namespace PureGym open System diff --git a/ConsumePlugin/MockExample.fs b/ConsumePlugin/MockExample.fs new file mode 100644 index 0000000..569fe9f --- /dev/null +++ b/ConsumePlugin/MockExample.fs @@ -0,0 +1,22 @@ +namespace SomeNamespace + +open WoofWare.Myriad.Plugins + +[] +type IPublicType = + abstract Mem1 : string * int -> string list + abstract Mem2 : string -> int + +[] +type internal InternalType = + abstract Mem1 : string * int -> unit + abstract Mem2 : string -> int + +[] +type private PrivateType = + abstract Mem1 : string * int -> unit + abstract Mem2 : string -> int + +[] +type VeryPublicType<'a, 'b> = + abstract Mem1 : 'a -> 'b diff --git a/README.md b/README.md index 60d62a6..020c95b 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,7 @@ Currently implemented: * `JsonParse` (to stamp out `jsonParse : JsonNode -> 'T` methods); * `RemoveOptions` (to strip `option` modifiers from a type). * `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client). +* `GenerateMock` (to stamp out a record type corresponding to an interface). ## `JsonParse` @@ -219,6 +220,51 @@ There are also some design decisions: * Every function must take an optional `CancellationToken` (which is good practice anyway); so arguments are forced to be tupled. +## `GenerateMock` + +Takes a type like this: + +```fsharp +[] +type IPublicType = + abstract Mem1 : string * int -> string list + abstract Mem2 : string -> int +``` + +and stamps out a type like this: + +```fsharp +/// Mock record type for an interface +type internal PublicTypeMock = + { + Mem1 : string * int -> string list + Mem2 : string -> int + } + + static member Empty : PublicTypeMock = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface IPublicType with + member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) + member this.Mem2 (arg0) = this.Mem2 (arg0) +``` + +### What's the point? + +Reflective mocking libraries like [Foq](https://github.com/fsprojects/Foq) in my experience are a rich source of flaky tests. +The [Grug-brained developer](https://grugbrain.dev/) would prefer to do this without reflection, and this reduces the rate of strange one-in-ten-thousand "failed to generate IL" errors. +But since F# does not let you partially update an interface definition, we instead stamp out a record, +thereby allowing the programmer to use F#'s record-update syntax. + +### Limitations + +* We currently only support interfaces with tupled arguments. +* We make the resulting record type at most internal (never public), since this is intended only to be used in tests. + You will therefore need an `AssemblyInfo.fs` file [like the one in WoofWare.Myriad's own tests](./ConsumePlugin/AssemblyInfo.fs). + # Detailed examples See the tests. diff --git a/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs new file mode 100644 index 0000000..9511801 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs @@ -0,0 +1,21 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System +open SomeNamespace +open NUnit.Framework +open FsUnitTyped + +[] +module TestMockGenerator = + + [] + let ``Example of use: IPublicType`` () = + let mock = + { PublicTypeMock.Empty with + Mem1 = fun (s, count) -> List.replicate count s + } + + let _ = + Assert.Throws (fun () -> mock.Mem2 "hi" |> ignore) + + mock.Mem1 ("hi", 3) |> shouldEqual [ "hi" ; "hi" ; "hi" ] diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index 98be32c..a4c81e6 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -17,8 +17,9 @@ - + + diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 1418deb..dd6f196 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -6,26 +6,64 @@ open Fantomas.FCS.Text.Range open Fantomas.FCS.Xml open Myriad.Core.AstExtensions +type internal ParameterInfo = + { + Attributes : SynAttribute list + IsOptional : bool + Id : Ident option + Type : SynType + } + +type internal MemberInfo = + { + ReturnType : SynType + Arity : SynArgInfo list + Args : ParameterInfo list + Identifier : Ident + Attributes : SynAttribute list + XmlDoc : PreXmlDoc option + } + +type internal InterfaceType = + { + Attributes : SynAttribute list + Name : LongIdent + Members : MemberInfo list + Generics : SynTyparDecls option + Accessibility : SynAccess option + } + +type internal RecordType = + { + Name : Ident + Fields : SynField seq + Members : SynMemberDefns option + XmlDoc : PreXmlDoc option + Generics : SynTyparDecls option + Accessibility : SynAccess option + } + [] module internal AstHelper = - let constructRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr = + let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr = let fields = fields |> List.map (fun (rfn, synExpr) -> SynExprRecordField (rfn, Some range0, synExpr, None)) SynExpr.Record (None, None, fields, range0) - let private createRecordType - ( - name : Ident, - repr : SynTypeDefnRepr, - members : SynMemberDefns, - xmldoc : PreXmlDoc - ) - : SynTypeDefn - = - let name = SynComponentInfo.Create ([ name ], xmldoc = xmldoc) + let defineRecordType (record : RecordType) : SynTypeDefn = + let repr = + SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, Seq.toList record.Fields, range0), range0) + + let name = + SynComponentInfo.Create ( + [ record.Name ], + ?xmldoc = record.XmlDoc, + ?parameters = record.Generics, + access = record.Accessibility + ) let trivia : SynTypeDefnTrivia = { @@ -34,21 +72,7 @@ module internal AstHelper = WithKeyword = Some range0 } - SynTypeDefn (name, repr, members, None, range0, trivia) - - let defineRecordType - ( - name : Ident, - fields : SynField seq, - members : SynMemberDefns option, - xmldoc : PreXmlDoc option - ) - : SynTypeDefn - = - let repr = - SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, Seq.toList fields, range0), range0) - - createRecordType (name, repr, defaultArg members SynMemberDefns.Empty, defaultArg xmldoc PreXmlDoc.Empty) + SynTypeDefn (name, repr, defaultArg record.Members SynMemberDefns.Empty, None, range0, trivia) let isOptionIdent (ident : SynLongIdent) : bool = match ident.LongIdent with @@ -75,6 +99,167 @@ module internal AstHelper = false | _ -> false + let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list = + moduleDecls + |> List.choose (fun moduleDecl -> + match moduleDecl with + | SynModuleDecl.Open (target, _) -> Some target + | _ -> None + ) + + let extractOpens (ast : ParsedInput) : SynOpenDeclTarget list = + match ast with + | ParsedInput.ImplFile (ParsedImplFileInput (_, _, _, _, _, modules, _, _, _)) -> + modules + |> List.collect (fun (SynModuleOrNamespace (_, _, _, decls, _, _, _, _, _)) -> extractOpensFromDecl decls) + | _ -> [] + + let rec convertSigParam (ty : SynType) : ParameterInfo = + match ty with + | SynType.Paren (inner, _) -> convertSigParam inner + | SynType.LongIdent ident -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.CreateLongIdent ident + } + | SynType.SignatureParameter (attrs, opt, id, usedType, _) -> + let attrs = attrs |> List.collect (fun attrs -> attrs.Attributes) + + { + Attributes = attrs + IsOptional = opt + Id = id + Type = usedType + } + | _ -> failwithf "expected SignatureParameter, got: %+A" ty + + let rec extractTupledTypes (tupleType : SynTupleTypeSegment list) : ParameterInfo list = + match tupleType with + | [] -> [] + | [ SynTupleTypeSegment.Type param ] -> [ convertSigParam param ] + | SynTupleTypeSegment.Type param :: SynTupleTypeSegment.Star _ :: rest -> + convertSigParam param :: extractTupledTypes rest + | _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType + + /// Assumes that the input type is an ObjectModel, i.e. a `type Foo = member ...` + let parseInterface (interfaceType : SynTypeDefn) : InterfaceType = + let (SynTypeDefn (SynComponentInfo (attrs, typars, _, interfaceName, _, _, accessibility, _), + synTypeDefnRepr, + _, + _, + _, + _)) = + interfaceType + + let attrs = attrs |> List.collect (fun s -> s.Attributes) + + let members = + match synTypeDefnRepr with + | SynTypeDefnRepr.ObjectModel (_kind, members, _) -> + members + |> List.map (fun defn -> + match defn with + | SynMemberDefn.AbstractSlot (slotSig, flags, _, _) -> + match flags.MemberKind with + | SynMemberKind.Member -> () + | kind -> failwithf "Unrecognised member kind: %+A" kind + + if not flags.IsInstance then + failwith "member was not an instance member" + + match slotSig with + | SynValSig (attrs, + SynIdent.SynIdent (ident, _), + _typeParams, + synType, + arity, + isInline, + isMutable, + xmlDoc, + accessibility, + synExpr, + _, + _) -> + if isInline then + failwith "inline members not supported" + + if isMutable then + failwith "mutable members not supported" + + match accessibility with + | Some (SynAccess.Internal _) + | Some (SynAccess.Private _) -> failwith "only public members are supported" + | _ -> () + + match synExpr with + | Some _ -> failwith "literal members are not supported" + | None -> () + + let arity = + match arity with + | SynValInfo ([ curriedArgs ], SynArgInfo ([], false, _)) -> curriedArgs + | SynValInfo (curriedArgs, SynArgInfo ([], false, _)) -> + failwithf "only tupled arguments are currently supported, but got: %+A" curriedArgs + | SynValInfo (_, info) -> + failwithf + "only bare return values like `Task` are supported, but got: %+A" + info + + let attrs = attrs |> List.collect (fun attr -> attr.Attributes) + + let args, ret = + match synType with + | SynType.Fun (argType, returnType, _, _) -> argType, returnType + | _ -> + failwithf + "Expected a return type of a generic Task; bad signature was: %+A" + synType + + let args = + match args with + | SynType.SignatureParameter _ -> [ convertSigParam args ] + | SynType.Tuple (false, path, _) -> extractTupledTypes path + | SynType.LongIdent (SynLongIdent (ident, _, _)) -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident) + } + |> List.singleton + | SynType.Var (typar, _) -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.Var (typar, range0) + } + |> List.singleton + | _ -> failwithf "Unrecognised args in interface method declaration: %+A" args + + { + ReturnType = ret + Arity = arity + Args = args + Identifier = ident + Attributes = attrs + XmlDoc = Some xmlDoc + } + | _ -> failwithf "Unrecognised member definition: %+A" defn + ) + | _ -> failwithf "Unrecognised SynTypeDefnRepr for an interface type: %+A" synTypeDefnRepr + + { + Members = members + Name = interfaceName + Attributes = attrs + Generics = typars + Accessibility = accessibility + } + + [] module internal SynTypePatterns = let (|OptionType|_|) (fieldType : SynType) = diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index eefa2eb..3adcc7b 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -9,6 +9,8 @@ open Myriad.Core /// Attribute indicating a record type to which the "create HTTP client" Myriad /// generator should apply during build. +/// This generator is intended to replicate much of the functionality of RestEase, +/// i.e. to stamp out HTTP REST clients from interfaces defining the API. type HttpClientAttribute () = inherit Attribute () @@ -47,24 +49,13 @@ module internal HttpClientGenerator = | BodyParamMethods.StreamContent -> "StreamContent" | BodyParamMethods.HttpContent -> "HttpContent" - let synBindingTriviaZero (isMember : bool) = - { - SynBindingTrivia.EqualsRange = Some range0 - InlineKeyword = None - LeadingKeyword = - if isMember then - SynLeadingKeyword.Member range0 - else - SynLeadingKeyword.Let range0 - } - type MemberInfo = { /// E.g. HttpMethod.Get HttpMethod : HttpMethod /// E.g. "v1/gyms/{gym_id}/attendance" UrlTemplate : string - ReturnType : SynType + TaskReturnType : SynType Arity : SynArgInfo list Args : Parameter list Identifier : Ident @@ -408,15 +399,15 @@ module internal HttpClientGenerator = |> SynExpr.CreateParenedTuple let returnExpr = - match info.ReturnType with + match info.TaskReturnType with | HttpResponseMessage | String | Stream -> SynExpr.CreateIdentString "node" - | _ -> + | retType -> JsonParseGenerator.parseNode None JsonParseGenerator.JsonParseOption.None - info.ReturnType + retType (SynExpr.CreateIdentString "node") let handleBodyParams = @@ -523,7 +514,7 @@ module internal HttpClientGenerator = SynExpr.CreateConst SynConst.Unit ) ) - match info.ReturnType with + match info.TaskReturnType with | HttpResponseMessage -> yield Let ("node", SynExpr.CreateIdentString "response") | String -> yield @@ -602,91 +593,58 @@ module internal HttpClientGenerator = implementation, range0, DebugPointAtBinding.Yes range0, - synBindingTriviaZero true + SynExpr.synBindingTriviaZero true ), range0 ) - let rec convertSigParam (ty : SynType) : Parameter = - match ty with - | SynType.Paren (inner, _) -> convertSigParam inner - | SynType.SignatureParameter (attrs, opt, id, usedType, _) -> - let attrs = - attrs - |> List.collect (fun attrs -> - attrs.Attributes - |> List.choose (fun attr -> - match attr.TypeName.AsString with - | "Query" - | "QueryAttribute" -> - match attr.ArgExpr with - | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Query None) - | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> - Some (HttpAttribute.Query (Some s)) - | SynExpr.Const (a, _) -> - failwithf "unrecognised constant arg to the Query attribute: %+A" a - | _ -> None - | "Path" - | "PathAttribute" -> - match attr.ArgExpr with - | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> - Some (HttpAttribute.Path s) - | SynExpr.Const (a, _) -> - failwithf "unrecognised constant arg to the Path attribute: %+A" a - | _ -> None - | "Body" - | "BodyAttribute" -> - match attr.ArgExpr with - | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Body) - | SynExpr.Const (a, _) -> - failwithf "unrecognised constant arg to the Body attribute: %+A" a - | _ -> None - | _ -> None - ) - ) - - { - Attributes = attrs - IsOptional = opt - Id = id - Type = usedType - } - | _ -> failwithf "expected SignatureParameter, got: %+A" ty - - let rec extractTypes (tupleType : SynTupleTypeSegment list) : Parameter list = - match tupleType with - | [] -> [] - | [ SynTupleTypeSegment.Type param ] -> [ convertSigParam param ] - | SynTupleTypeSegment.Type param :: SynTupleTypeSegment.Star _ :: rest -> - convertSigParam param :: extractTypes rest - | _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType - - let extractBasePath (attrs : SynAttributes) : SynExpr option = + let getHttpAttributes (attrs : SynAttribute list) : HttpAttribute list = attrs - |> List.tryPick (fun attr -> - attr.Attributes - |> List.tryPick (fun attr -> - match attr.TypeName.AsString with - | "BasePath" - | "RestEase.BasePath" - | "BasePathAttribute" - | "RestEase.BasePathAttribute" -> Some attr.ArgExpr + |> List.choose (fun attr -> + match attr.TypeName.AsString with + | "Query" + | "QueryAttribute" -> + match attr.ArgExpr with + | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Query None) + | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> + Some (HttpAttribute.Query (Some s)) + | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Query attribute: %+A" a | _ -> None - ) + | "Path" + | "PathAttribute" -> + match attr.ArgExpr with + | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> Some (HttpAttribute.Path s) + | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Path attribute: %+A" a + | _ -> None + | "Body" + | "BodyAttribute" -> + match attr.ArgExpr with + | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Body) + | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Body attribute: %+A" a + | _ -> None + | _ -> None ) - let extractBaseAddress (attrs : SynAttributes) : SynExpr option = + let extractBasePath (attrs : SynAttribute list) : SynExpr option = attrs |> List.tryPick (fun attr -> - attr.Attributes - |> List.tryPick (fun attr -> - match attr.TypeName.AsString with - | "BaseAddress" - | "RestEase.BaseAddress" - | "BaseAddressAttribute" - | "RestEase.BaseAddressAttribute" -> Some attr.ArgExpr - | _ -> None - ) + match attr.TypeName.AsString with + | "BasePath" + | "RestEase.BasePath" + | "BasePathAttribute" + | "RestEase.BasePathAttribute" -> Some attr.ArgExpr + | _ -> None + ) + + let extractBaseAddress (attrs : SynAttribute list) : SynExpr option = + attrs + |> List.tryPick (fun attr -> + match attr.TypeName.AsString with + | "BaseAddress" + | "RestEase.BaseAddress" + | "BaseAddressAttribute" + | "RestEase.BaseAddressAttribute" -> Some attr.ArgExpr + | _ -> None ) let createModule @@ -695,105 +653,51 @@ module internal HttpClientGenerator = (interfaceType : SynTypeDefn) : SynModuleOrNamespace = - let (SynTypeDefn (SynComponentInfo (attrs, _, _, interfaceName, _, _, _, _), synTypeDefnRepr, _, _, _, _)) = - interfaceType + let interfaceType = AstHelper.parseInterface interfaceType - let baseAddress = extractBaseAddress attrs - let basePath = extractBasePath attrs + let baseAddress = extractBaseAddress interfaceType.Attributes + let basePath = extractBasePath interfaceType.Attributes let members = - match synTypeDefnRepr with - | SynTypeDefnRepr.ObjectModel (_kind, members, _) -> - members - |> List.map (fun defn -> - match defn with - | SynMemberDefn.AbstractSlot (slotSig, flags, _, _) -> - match flags.MemberKind with - | SynMemberKind.Member -> () - | kind -> failwithf "Unrecognised member kind: %+A" kind + interfaceType.Members + |> List.map (fun mem -> + let httpMethod, url = extractHttpInformation mem.Attributes - if not flags.IsInstance then - failwith "member was not an instance member" + let shouldEnsureSuccess = not (shouldAllowAnyStatusCode mem.Attributes) - match slotSig with - | SynValSig (attrs, - SynIdent.SynIdent (ident, _), - _typeParams, - synType, - arity, - isInline, - isMutable, - _xmlDoc, - accessibility, - synExpr, - _, - _) -> - if isInline then - failwith "inline members not supported" - - if isMutable then - failwith "mutable members not supported" - - match accessibility with - | Some (SynAccess.Internal _) - | Some (SynAccess.Private _) -> failwith "only public members are supported" - | _ -> () - - match synExpr with - | Some _ -> failwith "literal members are not supported" - | None -> () - - let attrs = attrs |> List.collect (fun a -> a.Attributes) - - let arity = - match arity with - | SynValInfo ([ curriedArgs ], SynArgInfo ([], false, _)) -> curriedArgs - | SynValInfo (curriedArgs, SynArgInfo ([], false, _)) -> - failwithf "only tupled arguments are supported, but got: %+A" curriedArgs - | SynValInfo (_, info) -> - failwithf - "only bare return values like `Task` are supported, but got: %+A" - info - - let args, ret = - match synType with - | SynType.Fun (argType, Task returnType, _, _) -> argType, returnType - | _ -> - failwithf - "Expected a return type of a generic Task; bad signature was: %+A" - synType - - let args = - match args with - | SynType.SignatureParameter _ -> [ convertSigParam args ] - | SynType.Tuple (false, path, _) -> extractTypes path - | _ -> failwithf "Unrecognised args in interface method declaration: %+A" args - - let httpMethod, url = extractHttpInformation attrs - - let shouldEnsureSuccess = not (shouldAllowAnyStatusCode attrs) + let returnType = + match mem.ReturnType with + | Task ty -> ty + | a -> failwith $"Method must return a generic Task; returned %+A{a}" + { + HttpMethod = httpMethod + UrlTemplate = url + TaskReturnType = returnType + Arity = mem.Arity + Args = + mem.Args + |> List.map (fun arg -> { - HttpMethod = httpMethod - UrlTemplate = url - ReturnType = ret - Arity = arity - Args = args - Identifier = ident - EnsureSuccessHttpCode = shouldEnsureSuccess - BaseAddress = baseAddress - BasePath = basePath + Attributes = arg.Attributes |> getHttpAttributes + IsOptional = arg.IsOptional + Id = arg.Id + Type = arg.Type } - | _ -> failwithf "Unrecognised member definition: %+A" defn - ) - | _ -> failwithf "Unrecognised SynTypeDefnRepr: %+A" synTypeDefnRepr + ) + Identifier = mem.Identifier + EnsureSuccessHttpCode = shouldEnsureSuccess + BaseAddress = baseAddress + BasePath = basePath + } + ) let constructed = members |> List.map constructMember let docString = PreXmlDoc.Create " Module for constructing a REST client." let interfaceImpl = SynExpr.ObjExpr ( - SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceName), + SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name), None, Some range0, [], @@ -832,17 +736,21 @@ module internal HttpClientGenerator = ) ] ), - Some (SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceName))), + Some ( + SynBindingReturnInfo.Create ( + SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name) + ) + ), interfaceImpl, range0, DebugPointAtBinding.NoneAtLet, - synBindingTriviaZero false + SynExpr.synBindingTriviaZero false ) |> List.singleton |> SynModuleDecl.CreateLet let moduleName : LongIdent = - List.last interfaceName + List.last interfaceType.Name |> fun ident -> ident.idText |> fun s -> if s.StartsWith 'I' then @@ -871,14 +779,6 @@ module internal HttpClientGenerator = ] ) - let rec extractOpens (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list = - moduleDecls - |> List.choose (fun moduleDecl -> - match moduleDecl with - | SynModuleDecl.Open (target, _) -> Some target - | other -> None - ) - /// Myriad generator that provides an HTTP client for an interface type using RestEase annotations. [] type HttpClientGenerator () = @@ -892,14 +792,7 @@ type HttpClientGenerator () = let types = Ast.extractTypeDefn ast - let opens = - match ast with - | ParsedInput.ImplFile (ParsedImplFileInput (_, _, _, _, _, modules, _, _, _)) -> - modules - |> List.collect (fun (SynModuleOrNamespace (nsId, _, _, decls, _, _, _, _, _)) -> - HttpClientGenerator.extractOpens decls - ) - | _ -> [] + let opens = AstHelper.extractOpens ast let namespaceAndTypes = types @@ -911,12 +804,6 @@ type HttpClientGenerator () = let modules = namespaceAndTypes - |> List.collect (fun (ns, types) -> - types - |> List.map (fun interfaceType -> - let clientModule = HttpClientGenerator.createModule opens ns interfaceType - clientModule - ) - ) + |> List.collect (fun (ns, types) -> types |> List.map (HttpClientGenerator.createModule opens ns)) Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs new file mode 100644 index 0000000..b48bfd0 --- /dev/null +++ b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs @@ -0,0 +1,326 @@ +namespace WoofWare.Myriad.Plugins + +open System +open Fantomas.FCS.Syntax +open Fantomas.FCS.SyntaxTrivia +open Fantomas.FCS.Xml +open Myriad.Core + +/// Attribute indicating an interface type for which the "Generate Mock" Myriad +/// generator should apply during build. +/// This generator creates a record which implements the interface, +/// but where each method is represented as a record field, so you can use +/// record update syntax to easily specify partially-implemented mock objects. +type GenerateMockAttribute () = + inherit Attribute () + +[] +module internal InterfaceMockGenerator = + open Fantomas.FCS.Text.Range + open Myriad.Core.Ast + + let private getName (SynField (_, _, id, _, _, _, _, _, _)) = + match id with + | None -> failwith "Expected record field to have a name, but it was somehow anonymous" + | Some id -> id + + let createType + (name : string) + (interfaceType : InterfaceType) + (xmlDoc : PreXmlDoc) + (fields : SynField list) + : SynModuleDecl + = + let synValData = + { + SynMemberFlags.IsInstance = false + SynMemberFlags.IsDispatchSlot = false + SynMemberFlags.IsOverrideOrExplicitImpl = false + SynMemberFlags.IsFinal = false + SynMemberFlags.GetterOrSetterIsCompilerGenerated = false + SynMemberFlags.MemberKind = SynMemberKind.Member + } + + let failwithFun = + SynExpr.createLambda + "x" + (SynExpr.CreateApp ( + SynExpr.CreateIdentString "raise", + SynExpr.CreateParen ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "NotImplementedException" ]), + SynExpr.CreateConstString "Unimplemented mock function" + ) + ) + )) + + let constructorIdent = + let generics = + interfaceType.Generics + |> Option.map (fun generics -> SynValTyparDecls (Some generics, false)) + + SynPat.LongIdent ( + SynLongIdent.CreateString "Empty", + None, + generics, + SynArgPats.Pats ( + if generics.IsNone then + [] + else + [ SynPat.CreateParen (SynPat.CreateConst SynConst.Unit) ] + ), + None, + range0 + ) + + let constructorReturnType = + match interfaceType.Generics with + | None -> SynType.CreateLongIdent name + | Some generics -> + let generics = + generics.TyparDecls + |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) + + SynType.App ( + SynType.CreateLongIdent name, + Some range0, + generics, + List.replicate (generics.Length - 1) range0, + Some range0, + false, + range0 + ) + |> SynBindingReturnInfo.Create + + let constructor = + SynMemberDefn.Member ( + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + SynValData.SynValData (Some synValData, SynValInfo.Empty, None), + constructorIdent, + Some constructorReturnType, + AstHelper.instantiateRecord ( + fields + |> List.map (fun field -> + ((SynLongIdent.CreateFromLongIdent [ getName field ], true), Some failwithFun) + ) + ), + range0, + DebugPointAtBinding.Yes range0, + { SynExpr.synBindingTriviaZero true with + LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0) + } + ), + range0 + ) + + let interfaceMembers = + let members = + interfaceType.Members + |> List.map (fun memberInfo -> + + let synValData = + SynValData.SynValData ( + Some ( + { + IsInstance = true + IsDispatchSlot = false + IsOverrideOrExplicitImpl = true + IsFinal = false + GetterOrSetterIsCompilerGenerated = false + MemberKind = SynMemberKind.Member + } + ), + valInfo = + SynValInfo.SynValInfo ( + curriedArgInfos = + [ + [ SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) ] + [] + ], + returnInfo = + SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) + ), + thisIdOpt = None + ) + + let headArgs = + SynPat.Tuple ( + false, + memberInfo.Args + |> List.mapi (fun i _arg -> SynPat.CreateNamed (Ident.Create $"arg%i{i}")), + List.replicate (memberInfo.Args.Length - 1) range0, + range0 + ) + |> SynPat.CreateParen + + let headPat = + SynPat.LongIdent ( + SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ], + None, + None, + SynArgPats.Pats [ headArgs ], + None, + range0 + ) + + SynMemberDefn.Member ( + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + PreXmlDoc.Empty, + synValData, + headPat, + None, + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ] + ), + SynExpr.CreateParen ( + memberInfo.Args + |> List.mapi (fun i _arg -> SynExpr.CreateIdentString $"arg%i{i}") + |> SynExpr.CreateTuple + ) + ), + range0, + DebugPointAtBinding.Yes range0, + { + LeadingKeyword = SynLeadingKeyword.Member range0 + InlineKeyword = None + EqualsRange = Some range0 + } + ), + range0 + ) + ) + + let interfaceName = + let baseName = + SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name) + + match interfaceType.Generics with + | None -> baseName + | Some generics -> + let generics = + match generics with + | SynTyparDecls.PostfixList (decls, _, _) -> decls + | SynTyparDecls.PrefixList (decls, _) -> decls + | SynTyparDecls.SinglePrefix (decl, _) -> [ decl ] + |> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0)) + + SynType.App ( + baseName, + Some range0, + generics, + List.replicate (generics.Length - 1) range0, + Some range0, + false, + range0 + ) + + SynMemberDefn.Interface (interfaceName, Some range0, Some members, range0) + + // TODO: allow an arg to the attribute, specifying a custom visibility + let access = + match interfaceType.Accessibility with + | Some (SynAccess.Public _) + | Some (SynAccess.Internal _) + | None -> SynAccess.Internal range0 + | Some (SynAccess.Private _) -> SynAccess.Private range0 + + let record = + { + Name = Ident.Create name + Fields = fields + Members = Some [ constructor ; interfaceMembers ] + XmlDoc = Some xmlDoc + Generics = interfaceType.Generics + Accessibility = Some access + } + + let typeDecl = AstHelper.defineRecordType record + + SynModuleDecl.Types ([ typeDecl ], range0) + + let constructMember (mem : MemberInfo) : SynField = + let inputType = + match mem.Args |> List.map (fun pi -> pi.Type) |> List.rev with + | [] -> failwith "no-arg functions not supported yet" + | [ x ] -> x + | last :: rest -> + ([ SynTupleTypeSegment.Type last ], rest) + ||> List.fold (fun ty nextArg -> + SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty + ) + |> fun segs -> SynType.Tuple (false, segs, range0) + + let funcType = SynType.CreateFun (inputType, mem.ReturnType) + + SynField.SynField ( + [], + true, + Some mem.Identifier, + funcType, + false, + mem.XmlDoc |> Option.defaultValue PreXmlDoc.Empty, + None, + range0, + SynFieldTrivia.Zero + ) + + let createRecord (namespaceId : LongIdent) (interfaceType : SynTypeDefn) : SynModuleOrNamespace = + let interfaceType = AstHelper.parseInterface interfaceType + let fields = interfaceType.Members |> List.map constructMember + let docString = PreXmlDoc.Create " Mock record type for an interface" + + let name = + List.last interfaceType.Name + |> fun s -> s.idText + |> fun s -> + if s.StartsWith 'I' && s.Length > 1 && Char.IsUpper s.[1] then + s.[1..] + else + s + |> fun s -> s + "Mock" + + let typeDecl = createType name interfaceType docString fields + + SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ typeDecl ]) + +/// Myriad generator that creates a record which implements the given interface, +/// but with every field mocked out. +[] +type InterfaceMockGenerator () = + + interface IMyriadGenerator with + member _.ValidInputExtensions = [ ".fs" ] + + member _.Generate (context : GeneratorContext) = + let ast, _ = + Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head + + let types = Ast.extractTypeDefn ast + + let namespaceAndInterfaces = + types + |> List.choose (fun (ns, types) -> + match types |> List.filter Ast.hasAttribute with + | [] -> None + | types -> Some (ns, types) + ) + + let opens = AstHelper.extractOpens ast + + let modules = + namespaceAndInterfaces + |> List.collect (fun (ns, records) -> records |> List.map (InterfaceMockGenerator.createRecord ns)) + + Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index d861d72..c55d4b8 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -9,6 +9,8 @@ open Myriad.Core /// Attribute indicating a record type to which the "Add JSON parse" Myriad /// generator should apply during build. +/// The purpose of this generator is to create methods of the form +/// `{TypeName}.jsonParse : System.Text.Json.Nodes.JsonNode -> {TypeName}`. type JsonParseAttribute () = inherit Attribute () @@ -325,7 +327,7 @@ module internal JsonParseGenerator = (SynLongIdent.CreateFromLongIdent [ id ], true), Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ])) ) - |> AstHelper.constructRecord + |> AstHelper.instantiateRecord let assignments = (finalConstruction, assignments) diff --git a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs index 699718b..6d04e91 100644 --- a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs +++ b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs @@ -8,6 +8,7 @@ open Myriad.Core /// Attribute indicating a record type to which the "Remove Options" Myriad /// generator should apply during build. +/// The purpose of this generator is to strip the `option` modifier from types. type RemoveOptionsAttribute () = inherit Attribute () @@ -46,14 +47,26 @@ module internal RemoveOptionsGenerator = ) // TODO: this option seems a bit odd - let createType (xmlDoc : PreXmlDoc option) (fields : SynField list) = + let createType + (xmlDoc : PreXmlDoc option) + (accessibility : SynAccess option) + (generics : SynTyparDecls option) + (fields : SynField list) + = let fields : SynField list = fields |> List.map removeOption let name = Ident.Create "Short" - let typeDecl : SynTypeDefn = - match xmlDoc with - | None -> AstHelper.defineRecordType (name, fields, None, None) - | Some xmlDoc -> AstHelper.defineRecordType (name, fields, None, Some xmlDoc) + let record = + { + Name = name + Fields = fields + Members = None + XmlDoc = xmlDoc + Generics = generics + Accessibility = accessibility + } + + let typeDecl = AstHelper.defineRecordType record SynModuleDecl.Types ([ typeDecl ], range0) @@ -114,7 +127,7 @@ module internal RemoveOptionsGenerator = (SynLongIdent.CreateFromLongIdent [ id ], true), Some body ) - |> AstHelper.constructRecord + |> AstHelper.instantiateRecord let pattern = SynPat.LongIdent ( @@ -150,15 +163,15 @@ module internal RemoveOptionsGenerator = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn - let (SynComponentInfo (_attributes, _typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) = + let (SynComponentInfo (_attributes, typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) = synComponentInfo match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, recordFields, _recordRange), _) -> let decls = [ - createType (Some doc) recordFields + createType (Some doc) accessibility typeParams recordFields createMaker [ Ident.Create "Short" ] recordId recordFields ] diff --git a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt index 4c171fc..a035237 100644 --- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt @@ -1,7 +1,11 @@ +WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.GenerateMockAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientAttribute inherit System.Attribute WoofWare.Myriad.Plugins.HttpClientAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientGenerator inherit obj, implements Myriad.Core.IMyriadGenerator WoofWare.Myriad.Plugins.HttpClientGenerator..ctor [constructor]: unit +WoofWare.Myriad.Plugins.InterfaceMockGenerator inherit obj, implements Myriad.Core.IMyriadGenerator +WoofWare.Myriad.Plugins.InterfaceMockGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseAttribute inherit System.Attribute WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseGenerator inherit obj, implements Myriad.Core.IMyriadGenerator diff --git a/WoofWare.Myriad.Plugins/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr.fs index 6f0cf28..968f397 100644 --- a/WoofWare.Myriad.Plugins/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr.fs @@ -262,3 +262,14 @@ module internal SynExpr = ident |> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-ddTHH:mm:ss") | _ -> callMethod "ToString" ident + + let synBindingTriviaZero (isMember : bool) = + { + SynBindingTrivia.EqualsRange = Some range0 + InlineKeyword = None + LeadingKeyword = + if isMember then + SynLeadingKeyword.Member range0 + else + SynLeadingKeyword.Let range0 + } diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 8c71f92..5f0fa5b 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -28,6 +28,7 @@ + diff --git a/WoofWare.Myriad.Plugins/version.json b/WoofWare.Myriad.Plugins/version.json index 6b85091..63f3e25 100644 --- a/WoofWare.Myriad.Plugins/version.json +++ b/WoofWare.Myriad.Plugins/version.json @@ -1,5 +1,5 @@ { - "version": "1.1", + "version": "1.2", "publicReleaseRefSpec": [ "^refs/heads/main$" ], From 7b3bd3232361dea74292285eae2628159416d280 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sun, 31 Dec 2023 12:28:51 +0000 Subject: [PATCH 07/13] Add ability to mock out curried functions (#58) --- ConsumePlugin/GeneratedMock.fs | 55 +++++- ConsumePlugin/GeneratedRestClient.fs | 2 +- ConsumePlugin/MockExample.fs | 10 + ConsumePlugin/RestApiExample.fs | 2 +- .../TestMockGenerator/TestMockGenerator.fs | 15 +- WoofWare.Myriad.Plugins/AstHelper.fs | 176 ++++++++++++------ .../HttpClientGenerator.fs | 54 ++++-- .../InterfaceMockGenerator.fs | 110 +++++++---- 8 files changed, 298 insertions(+), 126 deletions(-) diff --git a/ConsumePlugin/GeneratedMock.fs b/ConsumePlugin/GeneratedMock.fs index 918d11b..41292af 100644 --- a/ConsumePlugin/GeneratedMock.fs +++ b/ConsumePlugin/GeneratedMock.fs @@ -10,17 +10,20 @@ type internal PublicTypeMock = { Mem1 : string * int -> string list Mem2 : string -> int + Mem3 : int * option -> string } static member Empty : PublicTypeMock = { Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem3 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) } interface IPublicType with - member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) - member this.Mem2 (arg0) = this.Mem2 (arg0) + member this.Mem1 (arg_0_0, arg_0_1) = this.Mem1 (arg_0_0, arg_0_1) + member this.Mem2 (arg_0_0) = this.Mem2 (arg_0_0) + member this.Mem3 (arg_0_0, arg_0_1) = this.Mem3 (arg_0_0, arg_0_1) namespace SomeNamespace /// Mock record type for an interface @@ -37,8 +40,8 @@ type internal InternalTypeMock = } interface InternalType with - member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) - member this.Mem2 (arg0) = this.Mem2 (arg0) + member this.Mem1 (arg_0_0, arg_0_1) = this.Mem1 (arg_0_0, arg_0_1) + member this.Mem2 (arg_0_0) = this.Mem2 (arg_0_0) namespace SomeNamespace /// Mock record type for an interface @@ -55,8 +58,8 @@ type private PrivateTypeMock = } interface PrivateType with - member this.Mem1 (arg0, arg1) = this.Mem1 (arg0, arg1) - member this.Mem2 (arg0) = this.Mem2 (arg0) + member this.Mem1 (arg_0_0, arg_0_1) = this.Mem1 (arg_0_0, arg_0_1) + member this.Mem2 (arg_0_0) = this.Mem2 (arg_0_0) namespace SomeNamespace /// Mock record type for an interface @@ -65,10 +68,46 @@ type internal VeryPublicTypeMock<'a, 'b> = Mem1 : 'a -> 'b } - static member Empty<'a, 'b> () : VeryPublicTypeMock<'a, 'b> = + static member Empty () : VeryPublicTypeMock<'a, 'b> = { Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) } interface VeryPublicType<'a, 'b> with - member this.Mem1 (arg0) = this.Mem1 (arg0) + member this.Mem1 (arg_0_0) = this.Mem1 (arg_0_0) +namespace SomeNamespace + +/// Mock record type for an interface +type internal CurriedMock<'a> = + { + Mem1 : int -> 'a -> string + Mem2 : int * string -> 'a -> string + Mem3 : (int * string) -> 'a -> string + Mem4 : (int * string) -> ('a * int) -> string + Mem5 : int * string -> ('a * int) -> string + Mem6 : int * string -> 'a * int -> string + } + + static member Empty () : CurriedMock<'a> = + { + Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem3 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem4 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem5 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + Mem6 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function")) + } + + interface Curried<'a> with + member this.Mem1 (arg_0_0) (arg_1_0) = this.Mem1 (arg_0_0) (arg_1_0) + member this.Mem2 (arg_0_0, arg_0_1) (arg_1_0) = this.Mem2 (arg_0_0, arg_0_1) (arg_1_0) + member this.Mem3 ((arg_0_0, arg_0_1)) (arg_1_0) = this.Mem3 (arg_0_0, arg_0_1) (arg_1_0) + + member this.Mem4 ((arg_0_0, arg_0_1)) ((arg_1_0, arg_1_1)) = + this.Mem4 (arg_0_0, arg_0_1) (arg_1_0, arg_1_1) + + member this.Mem5 (arg_0_0, arg_0_1) ((arg_1_0, arg_1_1)) = + this.Mem5 (arg_0_0, arg_0_1) (arg_1_0, arg_1_1) + + member this.Mem6 (arg_0_0, arg_0_1) (arg_1_0, arg_1_1) = + this.Mem6 (arg_0_0, arg_0_1) (arg_1_0, arg_1_1) diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index 1c3262f..9b0da01 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -644,7 +644,7 @@ open RestEase /// Module for constructing a REST client. [] [] -module ApiWithoutBaseAddress = +module internal ApiWithoutBaseAddress = /// Create a REST client. let make (client : System.Net.Http.HttpClient) : IApiWithoutBaseAddress = { new IApiWithoutBaseAddress with diff --git a/ConsumePlugin/MockExample.fs b/ConsumePlugin/MockExample.fs index 569fe9f..35930c5 100644 --- a/ConsumePlugin/MockExample.fs +++ b/ConsumePlugin/MockExample.fs @@ -6,6 +6,7 @@ open WoofWare.Myriad.Plugins type IPublicType = abstract Mem1 : string * int -> string list abstract Mem2 : string -> int + abstract Mem3 : x : int * ?ct : System.Threading.CancellationToken -> string [] type internal InternalType = @@ -20,3 +21,12 @@ type private PrivateType = [] type VeryPublicType<'a, 'b> = abstract Mem1 : 'a -> 'b + +[] +type Curried<'a> = + abstract Mem1 : int -> 'a -> string + abstract Mem2 : int * string -> 'a -> string + abstract Mem3 : (int * string) -> 'a -> string + abstract Mem4 : (int * string) -> ('a * int) -> string + abstract Mem5 : x : int * string -> ('a * int) -> string + abstract Mem6 : int * string -> y : 'a * int -> string diff --git a/ConsumePlugin/RestApiExample.fs b/ConsumePlugin/RestApiExample.fs index 381b271..7e97703 100644 --- a/ConsumePlugin/RestApiExample.fs +++ b/ConsumePlugin/RestApiExample.fs @@ -83,7 +83,7 @@ type IPureGymApi = abstract GetWithoutAnyReturnCode : ?ct : CancellationToken -> Task [] -type IApiWithoutBaseAddress = +type internal IApiWithoutBaseAddress = [] abstract GetPathParam : [] parameter : string * ?ct : CancellationToken -> Task diff --git a/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs index 9511801..7da125d 100644 --- a/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs +++ b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs @@ -10,7 +10,7 @@ module TestMockGenerator = [] let ``Example of use: IPublicType`` () = - let mock = + let mock : IPublicType = { PublicTypeMock.Empty with Mem1 = fun (s, count) -> List.replicate count s } @@ -19,3 +19,16 @@ module TestMockGenerator = Assert.Throws (fun () -> mock.Mem2 "hi" |> ignore) mock.Mem1 ("hi", 3) |> shouldEqual [ "hi" ; "hi" ; "hi" ] + + [] + let ``Example of use: curried args`` () = + let mock : Curried<_> = + { CurriedMock.Empty () with + Mem1 = fun i c -> Array.replicate i c |> String + Mem2 = fun (i, s) c -> String.concat $"%c{c}" (List.replicate i s) + Mem3 = fun (i, s) c -> String.concat $"%c{c}" (List.replicate i s) + } + + mock.Mem1 3 'a' |> shouldEqual "aaa" + mock.Mem2 (3, "hi") 'a' |> shouldEqual "hiahiahi" + mock.Mem3 (3, "hi") 'a' |> shouldEqual "hiahiahi" diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index dd6f196..4d04b46 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -14,14 +14,23 @@ type internal ParameterInfo = Type : SynType } +type internal TupledArg = + { + HasParen : bool + Args : ParameterInfo list + } + type internal MemberInfo = { ReturnType : SynType - Arity : SynArgInfo list - Args : ParameterInfo list + Accessibility : SynAccess option + /// Each element of this list is a list of args in a tuple, or just one arg if not a tuple. + Args : TupledArg list Identifier : Ident Attributes : SynAttribute list XmlDoc : PreXmlDoc option + IsInline : bool + IsMutable : bool } type internal InterfaceType = @@ -114,16 +123,19 @@ module internal AstHelper = |> List.collect (fun (SynModuleOrNamespace (_, _, _, decls, _, _, _, _, _)) -> extractOpensFromDecl decls) | _ -> [] - let rec convertSigParam (ty : SynType) : ParameterInfo = + let rec convertSigParam (ty : SynType) : ParameterInfo * bool = match ty with - | SynType.Paren (inner, _) -> convertSigParam inner + | SynType.Paren (inner, _) -> + let result, _ = convertSigParam inner + result, true | SynType.LongIdent ident -> { Attributes = [] IsOptional = false Id = None Type = SynType.CreateLongIdent ident - } + }, + false | SynType.SignatureParameter (attrs, opt, id, usedType, _) -> let attrs = attrs |> List.collect (fun attrs -> attrs.Attributes) @@ -132,17 +144,61 @@ module internal AstHelper = IsOptional = opt Id = id Type = usedType - } + }, + false + | SynType.Var (typar, _) -> + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.Var (typar, range0) + }, + false | _ -> failwithf "expected SignatureParameter, got: %+A" ty - let rec extractTupledTypes (tupleType : SynTupleTypeSegment list) : ParameterInfo list = + let rec extractTupledTypes (tupleType : SynTupleTypeSegment list) : TupledArg = match tupleType with - | [] -> [] - | [ SynTupleTypeSegment.Type param ] -> [ convertSigParam param ] + | [] -> + { + HasParen = false + Args = [] + } + | [ SynTupleTypeSegment.Type param ] -> + let converted, hasParen = convertSigParam param + + { + HasParen = hasParen + Args = [ converted ] + } | SynTupleTypeSegment.Type param :: SynTupleTypeSegment.Star _ :: rest -> - convertSigParam param :: extractTupledTypes rest + let rest = extractTupledTypes rest + let converted, _ = convertSigParam param + + { + HasParen = false + Args = converted :: rest.Args + } | _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType + let toFun (inputs : SynType list) (ret : SynType) : SynType = + (ret, List.rev inputs) + ||> List.fold (fun ty input -> SynType.CreateFun (input, ty)) + + /// Returns the args (where these are tuple types if curried) in order, and the return type. + let rec getType (ty : SynType) : (SynType * bool) list * SynType = + match ty with + | SynType.Paren (ty, _) -> getType ty + | SynType.Fun (argType, returnType, _, _) -> + let args, ret = getType returnType + // TODO this code is clearly wrong + let (inputArgs, inputRet), hasParen = + match argType with + | SynType.Paren (argType, _) -> getType argType, true + | _ -> getType argType, false + + ((toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret + | _ -> [], ty + /// Assumes that the input type is an ObjectModel, i.e. a `type Foo = member ...` let parseInterface (interfaceType : SynTypeDefn) : InterfaceType = let (SynTypeDefn (SynComponentInfo (attrs, typars, _, interfaceName, _, _, accessibility, _), @@ -182,74 +238,74 @@ module internal AstHelper = synExpr, _, _) -> - if isInline then - failwith "inline members not supported" - - if isMutable then - failwith "mutable members not supported" - - match accessibility with - | Some (SynAccess.Internal _) - | Some (SynAccess.Private _) -> failwith "only public members are supported" - | _ -> () match synExpr with | Some _ -> failwith "literal members are not supported" | None -> () - let arity = - match arity with - | SynValInfo ([ curriedArgs ], SynArgInfo ([], false, _)) -> curriedArgs - | SynValInfo (curriedArgs, SynArgInfo ([], false, _)) -> - failwithf "only tupled arguments are currently supported, but got: %+A" curriedArgs - | SynValInfo (_, info) -> - failwithf - "only bare return values like `Task` are supported, but got: %+A" - info - let attrs = attrs |> List.collect (fun attr -> attr.Attributes) - let args, ret = - match synType with - | SynType.Fun (argType, returnType, _, _) -> argType, returnType - | _ -> - failwithf - "Expected a return type of a generic Task; bad signature was: %+A" - synType + let args, ret = getType synType let args = - match args with - | SynType.SignatureParameter _ -> [ convertSigParam args ] - | SynType.Tuple (false, path, _) -> extractTupledTypes path - | SynType.LongIdent (SynLongIdent (ident, _, _)) -> - { - Attributes = [] - IsOptional = false - Id = None - Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident) - } - |> List.singleton - | SynType.Var (typar, _) -> - { - Attributes = [] - IsOptional = false - Id = None - Type = SynType.Var (typar, range0) - } - |> List.singleton - | _ -> failwithf "Unrecognised args in interface method declaration: %+A" args + args + |> List.map (fun (args, hasParen) -> + match args with + | SynType.Tuple (false, path, _) -> extractTupledTypes path + | SynType.SignatureParameter _ -> + let arg, hasParen = convertSigParam args + + { + HasParen = hasParen + Args = [ arg ] + } + | SynType.LongIdent (SynLongIdent (ident, _, _)) -> + { + HasParen = false + Args = + { + Attributes = [] + IsOptional = false + Id = None + Type = + SynType.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent ident + ) + } + |> List.singleton + } + | SynType.Var (typar, _) -> + { + HasParen = false + Args = + { + Attributes = [] + IsOptional = false + Id = None + Type = SynType.Var (typar, range0) + } + |> List.singleton + } + | _ -> failwith $"Unrecognised args in interface method declaration: %+A{args}" + |> fun ty -> + { ty with + HasParen = ty.HasParen || hasParen + } + ) { ReturnType = ret - Arity = arity Args = args Identifier = ident Attributes = attrs XmlDoc = Some xmlDoc + Accessibility = accessibility + IsInline = isInline + IsMutable = isMutable } - | _ -> failwithf "Unrecognised member definition: %+A" defn + | _ -> failwith $"Unrecognised member definition: %+A{defn}" ) - | _ -> failwithf "Unrecognised SynTypeDefnRepr for an interface type: %+A" synTypeDefnRepr + | _ -> failwith $"Unrecognised SynTypeDefnRepr for an interface type: %+A{synTypeDefnRepr}" { Members = members diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index 3adcc7b..3e2b8f5 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -3,7 +3,6 @@ namespace WoofWare.Myriad.Plugins open System open System.Net.Http open Fantomas.FCS.Syntax -open Fantomas.FCS.SyntaxTrivia open Fantomas.FCS.Xml open Myriad.Core @@ -56,12 +55,12 @@ module internal HttpClientGenerator = /// E.g. "v1/gyms/{gym_id}/attendance" UrlTemplate : string TaskReturnType : SynType - Arity : SynArgInfo list Args : Parameter list Identifier : Ident EnsureSuccessHttpCode : bool BaseAddress : SynExpr option BasePath : SynExpr option + Accessibility : SynAccess option } let httpMethodString (m : HttpMethod) : string = @@ -121,10 +120,10 @@ module internal HttpClientGenerator = match arg with | SynExpr.Const (SynConst.String (text, SynStringKind.Regular, _), _) -> meth, text | arg -> - failwithf "Unrecognised AST member in attribute argument. Only regular strings are supported: %+A" arg + failwith $"Unrecognised AST member in attribute argument. Only regular strings are supported: %+A{arg}" | [] -> failwith "Required exactly one recognised RestEase attribute on member, but got none" | matchingAttrs -> - failwithf "Required exactly one recognised RestEase attribute on member, but got %i" matchingAttrs.Length + failwith $"Required exactly one recognised RestEase attribute on member, but got %i{matchingAttrs.Length}" let shouldAllowAnyStatusCode (attrs : SynAttribute list) : bool = attrs @@ -581,7 +580,7 @@ module internal HttpClientGenerator = SynMemberDefn.Member ( SynBinding.SynBinding ( - None, + info.Accessibility, SynBindingKind.Normal, false, false, @@ -608,19 +607,19 @@ module internal HttpClientGenerator = | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Query None) | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> Some (HttpAttribute.Query (Some s)) - | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Query attribute: %+A" a + | SynExpr.Const (a, _) -> failwith $"unrecognised constant arg to the Query attribute: %+A{a}" | _ -> None | "Path" | "PathAttribute" -> match attr.ArgExpr with | SynExpr.Const (SynConst.String (s, SynStringKind.Regular, _), _) -> Some (HttpAttribute.Path s) - | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Path attribute: %+A" a + | SynExpr.Const (a, _) -> failwith $"unrecognised constant arg to the Path attribute: %+A{a}" | _ -> None | "Body" | "BodyAttribute" -> match attr.ArgExpr with - | SynExpr.Const (SynConst.Unit, _) -> Some (HttpAttribute.Body) - | SynExpr.Const (a, _) -> failwithf "unrecognised constant arg to the Body attribute: %+A" a + | SynExpr.Const (SynConst.Unit, _) -> Some HttpAttribute.Body + | SynExpr.Const (a, _) -> failwith $"unrecognised constant arg to the Body attribute: %+A{a}" | _ -> None | _ -> None ) @@ -670,13 +669,16 @@ module internal HttpClientGenerator = | Task ty -> ty | a -> failwith $"Method must return a generic Task; returned %+A{a}" - { - HttpMethod = httpMethod - UrlTemplate = url - TaskReturnType = returnType - Arity = mem.Arity - Args = - mem.Args + if mem.IsMutable then + failwith $"mutable methods not supported (identifier: %+A{mem.Identifier})" + + if mem.IsInline then + failwith $"inline methods not supported (identifier: %+A{mem.Identifier})" + + let args = + match mem.Args with + | [ args ] -> + args.Args |> List.map (fun arg -> { Attributes = arg.Attributes |> getHttpAttributes @@ -685,10 +687,21 @@ module internal HttpClientGenerator = Type = arg.Type } ) + | [] -> failwith $"Expected %+A{mem.Identifier} to have tupled args, but it had no args." + | _ -> + failwith + $"Expected %+A{mem.Identifier} to have tupled args, but it was curried: %+A{mem.Args}." + + { + HttpMethod = httpMethod + UrlTemplate = url + TaskReturnType = returnType + Args = args Identifier = mem.Identifier EnsureSuccessHttpCode = shouldEnsureSuccess BaseAddress = baseAddress BasePath = basePath + Accessibility = mem.Accessibility } ) @@ -756,7 +769,7 @@ module internal HttpClientGenerator = if s.StartsWith 'I' then s.[1..] else - failwithf "Expected interface type to start with 'I', but was: %s" s + failwith $"Expected interface type to start with 'I', but was: %s{s}" |> Ident.Create |> List.singleton @@ -767,7 +780,12 @@ module internal HttpClientGenerator = ] let modInfo = - SynComponentInfo.Create (moduleName, attributes = attribs, xmldoc = docString) + SynComponentInfo.Create ( + moduleName, + attributes = attribs, + xmldoc = docString, + access = interfaceType.Accessibility + ) SynModuleOrNamespace.CreateNamespace ( ns, diff --git a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs index b48bfd0..307c2dc 100644 --- a/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs +++ b/WoofWare.Myriad.Plugins/InterfaceMockGenerator.fs @@ -62,7 +62,7 @@ module internal InterfaceMockGenerator = SynPat.LongIdent ( SynLongIdent.CreateString "Empty", None, - generics, + None, // no generics on the "Empty", only on the return type SynArgPats.Pats ( if generics.IsNone then [] @@ -126,7 +126,7 @@ module internal InterfaceMockGenerator = let synValData = SynValData.SynValData ( - Some ( + Some { IsInstance = true IsDispatchSlot = false @@ -134,14 +134,27 @@ module internal InterfaceMockGenerator = IsFinal = false GetterOrSetterIsCompilerGenerated = false MemberKind = SynMemberKind.Member - } - ), + }, valInfo = SynValInfo.SynValInfo ( curriedArgInfos = [ - [ SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) ] - [] + yield + [ + SynArgInfo.SynArgInfo ( + attributes = [], + optional = false, + ident = None + ) + ] + yield! + memberInfo.Args + |> List.mapi (fun i arg -> + arg.Args + |> List.mapi (fun j arg -> + SynArgInfo.CreateIdString $"arg_%i{i}_%i{j}" + ) + ) ], returnInfo = SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None) @@ -150,25 +163,50 @@ module internal InterfaceMockGenerator = ) let headArgs = - SynPat.Tuple ( - false, - memberInfo.Args - |> List.mapi (fun i _arg -> SynPat.CreateNamed (Ident.Create $"arg%i{i}")), - List.replicate (memberInfo.Args.Length - 1) range0, - range0 + memberInfo.Args + |> List.mapi (fun i tupledArgs -> + let args = + tupledArgs.Args + |> List.mapi (fun j _ -> SynPat.CreateNamed (Ident.Create $"arg_%i{i}_%i{j}")) + + SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0) + |> SynPat.CreateParen + |> fun i -> if tupledArgs.HasParen then SynPat.Paren (i, range0) else i ) - |> SynPat.CreateParen let headPat = SynPat.LongIdent ( SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ], None, None, - SynArgPats.Pats [ headArgs ], + SynArgPats.Pats headArgs, None, range0 ) + let body = + let tuples = + memberInfo.Args + |> List.mapi (fun i args -> + args.Args + |> List.mapi (fun j args -> SynExpr.CreateIdentString $"arg_%i{i}_%i{j}") + |> SynExpr.CreateParenedTuple + ) + + match tuples |> List.rev with + | [] -> failwith "expected args but got none" + | last :: rest -> + + (last, rest) + ||> List.fold (fun trail next -> SynExpr.CreateApp (next, trail)) + |> fun args -> + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ] + ), + args + ) + SynMemberDefn.Member ( SynBinding.SynBinding ( None, @@ -180,16 +218,7 @@ module internal InterfaceMockGenerator = synValData, headPat, None, - SynExpr.CreateApp ( - SynExpr.CreateLongIdent ( - SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ] - ), - SynExpr.CreateParen ( - memberInfo.Args - |> List.mapi (fun i _arg -> SynExpr.CreateIdentString $"arg%i{i}") - |> SynExpr.CreateTuple - ) - ), + body, range0, DebugPointAtBinding.Yes range0, { @@ -250,23 +279,30 @@ module internal InterfaceMockGenerator = SynModuleDecl.Types ([ typeDecl ], range0) - let constructMember (mem : MemberInfo) : SynField = - let inputType = - match mem.Args |> List.map (fun pi -> pi.Type) |> List.rev with - | [] -> failwith "no-arg functions not supported yet" - | [ x ] -> x - | last :: rest -> - ([ SynTupleTypeSegment.Type last ], rest) - ||> List.fold (fun ty nextArg -> - SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty - ) - |> fun segs -> SynType.Tuple (false, segs, range0) + let private buildType (x : ParameterInfo) : SynType = + if x.IsOptional then + SynType.App (SynType.CreateLongIdent "option", Some range0, [ x.Type ], [], Some range0, false, range0) + else + x.Type - let funcType = SynType.CreateFun (inputType, mem.ReturnType) + let private constructMemberSinglePlace (tuple : TupledArg) : SynType = + match tuple.Args |> List.rev |> List.map buildType with + | [] -> failwith "no-arg functions not supported yet" + | [ x ] -> x + | last :: rest -> + ([ SynTupleTypeSegment.Type last ], rest) + ||> List.fold (fun ty nextArg -> SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty) + |> fun segs -> SynType.Tuple (false, segs, range0) + |> fun ty -> if tuple.HasParen then SynType.Paren (ty, range0) else ty + + let constructMember (mem : MemberInfo) : SynField = + let inputType = mem.Args |> List.map constructMemberSinglePlace + + let funcType = AstHelper.toFun inputType mem.ReturnType SynField.SynField ( [], - true, + false, Some mem.Identifier, funcType, false, From ad2eeaaa4f07db9ee2bf4cc12edd96c16bcc3367 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Wed, 3 Jan 2024 19:47:59 +0000 Subject: [PATCH 08/13] URI support (#59) --- ConsumePlugin/GeneratedPureGymDto.fs | 24 +++++++++++++++ ConsumePlugin/GeneratedRestClient.fs | 30 +++++++++++++++++++ ConsumePlugin/PureGymDto.fs | 6 ++++ ConsumePlugin/RestApiExample.fs | 3 ++ .../TestHttpClient/TestPureGymRestApi.fs | 24 +++++++++++++++ WoofWare.Myriad.Plugins/AstHelper.fs | 9 ++++++ WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 4 +++ 7 files changed, 100 insertions(+) diff --git a/ConsumePlugin/GeneratedPureGymDto.fs b/ConsumePlugin/GeneratedPureGymDto.fs index 7fc1049..d0ce354 100644 --- a/ConsumePlugin/GeneratedPureGymDto.fs +++ b/ConsumePlugin/GeneratedPureGymDto.fs @@ -944,3 +944,27 @@ module Sessions = Summary = Summary Visits = Visits } +namespace PureGym + +/// Module containing JSON parsing methods for the UriThing type +[] +[] +module UriThing = + /// Parse from a JSON node. + let jsonParse (node : System.Text.Json.Nodes.JsonNode) : UriThing = + let SomeUri = + (match node.["someUri"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("someUri") + ) + ) + | v -> v) + .AsValue() + .GetValue () + |> System.Uri + + { + SomeUri = SomeUri + } diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs index 9b0da01..39efb85 100644 --- a/ConsumePlugin/GeneratedRestClient.fs +++ b/ConsumePlugin/GeneratedRestClient.fs @@ -180,6 +180,36 @@ module PureGymApi = } |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + member _.GetUrl (ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> System.Uri "https://whatnot.com" + | v -> v), + System.Uri ("some/url", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Get, + RequestUri = uri + ) + + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! stream = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + + let! node = + System.Text.Json.Nodes.JsonNode.ParseAsync (stream, cancellationToken = ct) + |> Async.AwaitTask + + return UriThing.jsonParse node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + member _.GetSessions (fromDate : DateOnly, toDate : DateOnly, ct : CancellationToken option) = async { let! ct = Async.CancellationToken diff --git a/ConsumePlugin/PureGymDto.fs b/ConsumePlugin/PureGymDto.fs index 455ed88..1010dd8 100644 --- a/ConsumePlugin/PureGymDto.fs +++ b/ConsumePlugin/PureGymDto.fs @@ -177,3 +177,9 @@ type Sessions = [] Visits : Visit list } + +[] +type UriThing = + { + SomeUri : Uri + } diff --git a/ConsumePlugin/RestApiExample.fs b/ConsumePlugin/RestApiExample.fs index 7e97703..b1bafb6 100644 --- a/ConsumePlugin/RestApiExample.fs +++ b/ConsumePlugin/RestApiExample.fs @@ -26,6 +26,9 @@ type IPureGymApi = [] abstract GetMemberActivity : ?ct : CancellationToken -> Task + [] + abstract GetUrl : ?ct : CancellationToken -> Task + // We'll use this one to check handling of absolute URIs too [] abstract GetSessions : diff --git a/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestPureGymRestApi.fs b/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestPureGymRestApi.fs index 446f4ba..acc4960 100644 --- a/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestPureGymRestApi.fs +++ b/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestPureGymRestApi.fs @@ -236,3 +236,27 @@ module TestPureGymRestApi = let api = PureGymApi.make client api.GetSessions(startDate, endDate).Result |> shouldEqual expected + + [] + let ``URI example`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Get + + message.RequestUri.ToString () |> shouldEqual "https://whatnot.com/some/url" + + let content = + new StringContent ("""{"someUri": "https://patrick@en.wikipedia.org/wiki/foo"}""") + + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + } + + use client = HttpClientMock.makeNoUri proc + let api = PureGymApi.make client + + let uri = api.GetUrl().Result.SomeUri + uri.ToString () |> shouldEqual "https://patrick@en.wikipedia.org/wiki/foo" + uri.UserInfo |> shouldEqual "patrick" + uri.Host |> shouldEqual "en.wikipedia.org" diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 4d04b46..c005985 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -423,6 +423,15 @@ module internal SynTypePatterns = | _ -> None | _ -> None + let (|Uri|_|) (fieldType : SynType) = + match fieldType with + | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) -> + match ident |> List.map (fun i -> i.idText) with + | [ "System" ; "Uri" ] + | [ "Uri" ] -> Some () + | _ -> None + | _ -> None + let (|Task|_|) (fieldType : SynType) : SynType option = match fieldType with | SynType.App (SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)), _, args, _, _, _, _) -> diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index c55d4b8..5121add 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -136,6 +136,10 @@ module internal JsonParseGenerator = |> SynExpr.pipeThroughFunction ( SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "DateOnly" ; "Parse" ]) ) + | Uri -> + node + |> asValueGetValue propertyName "string" + |> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ])) | DateTime -> node |> asValueGetValue propertyName "string" From 948fbfbc84884feb9ff544eb9d07982f039eb293 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Mon, 8 Jan 2024 00:50:33 +0000 Subject: [PATCH 09/13] Allow JSON parsing to happen in an extension method (#63) --- ConsumePlugin/GeneratedJson.fs | 65 +++++++ ConsumePlugin/JsonRecord.fs | 13 ++ Directory.Build.props | 2 +- .../TestJsonParse/TestExtensionMethod.fs | 26 +++ .../TestJsonParse/TestJsonParse.fs | 15 ++ .../TestMockGenerator/TestMockGenerator.fs | 2 + .../WoofWare.Myriad.Plugins.Test.fsproj | 1 + WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 181 ++++++++++++++---- WoofWare.Myriad.Plugins/SurfaceBaseline.txt | 1 + WoofWare.Myriad.Plugins/SynAttribute.fs | 9 + WoofWare.Myriad.Plugins/SynExpr.fs | 4 +- WoofWare.Myriad.Plugins/version.json | 2 +- 12 files changed, 284 insertions(+), 37 deletions(-) create mode 100644 WoofWare.Myriad.Plugins.Test/TestJsonParse/TestExtensionMethod.fs diff --git a/ConsumePlugin/GeneratedJson.fs b/ConsumePlugin/GeneratedJson.fs index 16f4e36..8c1486a 100644 --- a/ConsumePlugin/GeneratedJson.fs +++ b/ConsumePlugin/GeneratedJson.fs @@ -108,3 +108,68 @@ module JsonRecordType = E = E F = F } +namespace ConsumePlugin + +/// Module containing JSON parsing extension members for the ToGetExtensionMethod type +[] +module ToGetExtensionMethodJsonParseExtension = + ///Extension methods for JSON parsing + type ToGetExtensionMethod with + + /// Parse from a JSON node. + static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : ToGetExtensionMethod = + let Sailor = + (match node.["sailor"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("sailor") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let Soldier = + (match node.["soldier"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("soldier") + ) + ) + | v -> v) + .AsValue() + .GetValue () + |> System.Uri + + let Tailor = + (match node.["tailor"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("tailor") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let Tinker = + (match node.["tinker"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("tinker") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + { + Tinker = Tinker + Tailor = Tailor + Soldier = Soldier + Sailor = Sailor + } diff --git a/ConsumePlugin/JsonRecord.fs b/ConsumePlugin/JsonRecord.fs index 371e2df..b78502c 100644 --- a/ConsumePlugin/JsonRecord.fs +++ b/ConsumePlugin/JsonRecord.fs @@ -28,3 +28,16 @@ type JsonRecordType = E : string array F : int[] } + +[] +type ToGetExtensionMethod = + { + Tinker : string + Tailor : int + Soldier : System.Uri + Sailor : float + } + +[] +module ToGetExtensionMethod = + let thisModuleWouldClash = 3 diff --git a/Directory.Build.props b/Directory.Build.props index e9f58d0..2bc68d8 100644 --- a/Directory.Build.props +++ b/Directory.Build.props @@ -6,8 +6,8 @@ true true true - FS3559 embedded + FS3388,FS3559 diff --git a/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestExtensionMethod.fs b/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestExtensionMethod.fs new file mode 100644 index 0000000..610d003 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestExtensionMethod.fs @@ -0,0 +1,26 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System +open System.Text.Json.Nodes +open ConsumePlugin +open NUnit.Framework +open FsUnitTyped + +[] +module TestExtensionMethod = + + [] + let ``Parse via extension method`` () = + let json = + """{"tinker": "job", "tailor": 3, "soldier": "https://example.com", "sailor": 3.1}""" + |> JsonNode.Parse + + let expected = + { + Tinker = "job" + Tailor = 3 + Soldier = Uri "https://example.com" + Sailor = 3.1 + } + + ToGetExtensionMethod.jsonParse json |> shouldEqual expected diff --git a/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs b/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs index f8b4009..2cae6ef 100644 --- a/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs +++ b/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs @@ -32,3 +32,18 @@ module TestJsonParse = let actual = s |> JsonNode.Parse |> JsonRecordType.jsonParse actual |> shouldEqual expected + + [] + let ``Inner example`` () = + let s = + """{ + "something": "oh hi" +}""" + + let expected = + { + Thing = "oh hi" + } + + let actual = s |> JsonNode.Parse |> InnerType.jsonParse + actual |> shouldEqual expected diff --git a/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs index 7da125d..612d48e 100644 --- a/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs +++ b/WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs @@ -14,6 +14,7 @@ module TestMockGenerator = { PublicTypeMock.Empty with Mem1 = fun (s, count) -> List.replicate count s } + :> _ let _ = Assert.Throws (fun () -> mock.Mem2 "hi" |> ignore) @@ -28,6 +29,7 @@ module TestMockGenerator = Mem2 = fun (i, s) c -> String.concat $"%c{c}" (List.replicate i s) Mem3 = fun (i, s) c -> String.concat $"%c{c}" (List.replicate i s) } + :> _ mock.Mem1 3 'a' |> shouldEqual "aaa" mock.Mem2 (3, "hi") 'a' |> shouldEqual "hiahiahi" diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index a4c81e6..b6b5910 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -11,6 +11,7 @@ + diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 5121add..8756c0a 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -9,11 +9,26 @@ open Myriad.Core /// Attribute indicating a record type to which the "Add JSON parse" Myriad /// generator should apply during build. -/// The purpose of this generator is to create methods of the form +/// The purpose of this generator is to create methods (possibly extension methods) of the form /// `{TypeName}.jsonParse : System.Text.Json.Nodes.JsonNode -> {TypeName}`. -type JsonParseAttribute () = +/// +/// If you supply isExtensionMethod = true, you will get extension methods. +/// These can only be consumed from F#, but the benefit is that they don't use up the module name +/// (since by default we create a module called "{TypeName}"). +type JsonParseAttribute (isExtensionMethod : bool) = inherit Attribute () + /// If changing this, *adjust the documentation strings* + static member internal DefaultIsExtensionMethod = false + + /// Shorthand for the "isExtensionMethod = false" constructor; see documentation there for details. + new () = JsonParseAttribute JsonParseAttribute.DefaultIsExtensionMethod + +type internal JsonParseOutputSpec = + { + ExtensionMethods : bool + } + [] module internal JsonParseGenerator = open Fantomas.FCS.Text.Range @@ -227,7 +242,7 @@ module internal JsonParseGenerator = | [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true | _ -> false - let createMaker (typeName : LongIdent) (fields : SynField list) = + let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynField list) = let xmlDoc = PreXmlDoc.Create " Parse from a JSON node." let returnInfo = @@ -237,10 +252,26 @@ module internal JsonParseGenerator = let functionName = Ident.Create "jsonParse" let inputVal = + let memberFlags = + if spec.ExtensionMethods then + { + SynMemberFlags.IsInstance = false + SynMemberFlags.IsDispatchSlot = false + SynMemberFlags.IsOverrideOrExplicitImpl = false + SynMemberFlags.IsFinal = false + SynMemberFlags.GetterOrSetterIsCompilerGenerated = false + SynMemberFlags.MemberKind = SynMemberKind.Member + } + |> Some + else + None + + let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg + SynValData.SynValData ( - None, + memberFlags, SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty), - Some inputArg + thisIdOpt ) let assignments = @@ -367,20 +398,60 @@ module internal JsonParseGenerator = range0 ) - let binding = - SynBinding.Let ( - isInline = false, - isMutable = false, - xmldoc = xmlDoc, - returnInfo = returnInfo, - expr = assignments, - valData = inputVal, - pattern = pattern - ) + if spec.ExtensionMethods then + let binding = + SynBinding.SynBinding ( + None, + SynBindingKind.Normal, + false, + false, + [], + xmlDoc, + inputVal, + pattern, + Some returnInfo, + assignments, + range0, + DebugPointAtBinding.NoneAtInvisible, + { + LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0) + InlineKeyword = None + EqualsRange = Some range0 + } + ) - SynModuleDecl.CreateLet [ binding ] + let mem = SynMemberDefn.Member (binding, range0) - let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) = + let containingType = + SynTypeDefn.SynTypeDefn ( + SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create "Extension methods for JSON parsing"), + SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0), + [ mem ], + None, + range0, + { + LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0 + EqualsRange = None + WithKeyword = None + } + ) + + SynModuleDecl.Types ([ containingType ], range0) + else + let binding = + SynBinding.Let ( + isInline = false, + isMutable = false, + xmldoc = xmlDoc, + returnInfo = returnInfo, + expr = assignments, + valData = inputVal, + pattern = pattern + ) + + SynModuleDecl.CreateLet [ binding ] + + let createRecordModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn @@ -390,30 +461,54 @@ module internal JsonParseGenerator = match synTypeDefnRepr with | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> - let decls = [ createMaker recordId recordFields ] + let decls = [ createMaker spec recordId recordFields ] let attributes = - [ - SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) - SynAttributeList.Create SynAttribute.compilationRepresentation - ] + if spec.ExtensionMethods then + [ SynAttributeList.Create SynAttribute.autoOpen ] + else + [ + SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) + SynAttributeList.Create SynAttribute.compilationRepresentation + ] let xmlDoc = - recordId - |> Seq.map (fun i -> i.idText) - |> String.concat "." - |> sprintf " Module containing JSON parsing methods for the %s type" + let fullyQualified = recordId |> Seq.map (fun i -> i.idText) |> String.concat "." + + let description = + if spec.ExtensionMethods then + "extension members" + else + "methods" + + $" Module containing JSON parsing %s{description} for the %s{fullyQualified} type" |> PreXmlDoc.Create + let moduleName = + if spec.ExtensionMethods then + match recordId with + | [] -> failwith "unexpectedly got an empty identifier for record name" + | recordId -> + let expanded = + List.last recordId + |> fun i -> i.idText + |> fun s -> s + "JsonParseExtension" + |> Ident.Create + + List.take (List.length recordId - 1) recordId @ [ expanded ] + else + recordId + let info = - SynComponentInfo.Create (recordId, attributes = attributes, xmldoc = xmlDoc) + SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) let mdl = SynModuleDecl.CreateNestedModule (info, decls) SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ]) | _ -> failwithf "Not a record type" -/// Myriad generator that provides a JSON parse function for a record type. +/// Myriad generator that provides a method (possibly an extension method) for a record type, +/// containing a JSON parse function. [] type JsonParseGenerator () = @@ -429,17 +524,37 @@ type JsonParseGenerator () = let namespaceAndRecords = records |> List.choose (fun (ns, types) -> - match types |> List.filter Ast.hasAttribute with - | [] -> None - | types -> Some (ns, types) + types + |> List.choose (fun typeDef -> + match Ast.getAttribute typeDef with + | None -> None + | Some attr -> + let arg = + match SynExpr.stripOptionalParen attr.ArgExpr with + | SynExpr.Const (SynConst.Bool value, _) -> value + | SynExpr.Const (SynConst.Unit, _) -> JsonParseAttribute.DefaultIsExtensionMethod + | arg -> + failwith + $"Unrecognised argument %+A{arg} to []. Literals are not supported. Use `true` or `false` (or unit) only." + + let spec = + { + ExtensionMethods = arg + } + + Some (typeDef, spec) + ) + |> function + | [] -> None + | ty -> Some (ns, ty) ) let modules = namespaceAndRecords |> List.collect (fun (ns, records) -> records - |> List.map (fun record -> - let recordModule = JsonParseGenerator.createRecordModule ns record + |> List.map (fun (record, spec) -> + let recordModule = JsonParseGenerator.createRecordModule ns spec record recordModule ) ) diff --git a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt index a035237..7491d1d 100644 --- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt @@ -7,6 +7,7 @@ WoofWare.Myriad.Plugins.HttpClientGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.InterfaceMockGenerator inherit obj, implements Myriad.Core.IMyriadGenerator WoofWare.Myriad.Plugins.InterfaceMockGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: bool WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseGenerator inherit obj, implements Myriad.Core.IMyriadGenerator WoofWare.Myriad.Plugins.JsonParseGenerator..ctor [constructor]: unit diff --git a/WoofWare.Myriad.Plugins/SynAttribute.fs b/WoofWare.Myriad.Plugins/SynAttribute.fs index 8d9f2fd..b0958b9 100644 --- a/WoofWare.Myriad.Plugins/SynAttribute.fs +++ b/WoofWare.Myriad.Plugins/SynAttribute.fs @@ -20,3 +20,12 @@ module internal SynAttribute = AppliesToGetterAndSetter = false Range = range0 } + + let internal autoOpen : SynAttribute = + { + TypeName = SynLongIdent.CreateString "AutoOpen" + ArgExpr = SynExpr.CreateConst SynConst.Unit + Target = None + AppliesToGetterAndSetter = false + Range = range0 + } diff --git a/WoofWare.Myriad.Plugins/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr.fs index 968f397..cde2731 100644 --- a/WoofWare.Myriad.Plugins/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr.fs @@ -102,9 +102,9 @@ module internal SynExpr = b ) - let stripOptionalParen (expr : SynExpr) : SynExpr = + let rec stripOptionalParen (expr : SynExpr) : SynExpr = match expr with - | SynExpr.Paren (expr, _, _, _) -> expr + | SynExpr.Paren (expr, _, _, _) -> stripOptionalParen expr | expr -> expr /// Given e.g. "byte", returns "System.Byte". diff --git a/WoofWare.Myriad.Plugins/version.json b/WoofWare.Myriad.Plugins/version.json index 63f3e25..dd79bd9 100644 --- a/WoofWare.Myriad.Plugins/version.json +++ b/WoofWare.Myriad.Plugins/version.json @@ -1,5 +1,5 @@ { - "version": "1.2", + "version": "1.3", "publicReleaseRefSpec": [ "^refs/heads/main$" ], From 41e9e4f82c33dbc9208e3833a2291d6496d303fc Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 8 Jan 2024 19:27:33 +0000 Subject: [PATCH 10/13] Bump fsharp-analyzers from 0.22.0 to 0.23.0 (#64) --- .config/dotnet-tools.json | 4 ++-- flake.nix | 2 +- nix/deps.nix | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.config/dotnet-tools.json b/.config/dotnet-tools.json index 51b4c9e..be4ccec 100644 --- a/.config/dotnet-tools.json +++ b/.config/dotnet-tools.json @@ -9,10 +9,10 @@ ] }, "fsharp-analyzers": { - "version": "0.22.0", + "version": "0.23.0", "commands": [ "fsharp-analyzers" ] } } -} +} \ No newline at end of file diff --git a/flake.nix b/flake.nix index d328d00..91cb8e9 100644 --- a/flake.nix +++ b/flake.nix @@ -45,7 +45,7 @@ in { packages = { fantomas = dotnetTool null "fantomas" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fantomas.version "sha256-Jmo7s8JMdQ8SxvNvPnryfE7n24mIgKi5cbgNwcQw3yU="; - fsharp-analyzers = dotnetTool "FSharp.Analyzers.Cli" "fsharp-analyzers" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fsharp-analyzers.version "sha256-wDS7aE4VI718iwU8xUm0aCOYIcFpMuqWu9+H5d+8XAA="; + fsharp-analyzers = dotnetTool "FSharp.Analyzers.Cli" "fsharp-analyzers" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fsharp-analyzers.version "sha256-CWMW06ncSs8QkQvxNPNrgn3TAzMU6qCT1k2A3pnGrYQ="; fetchDeps = let flags = []; runtimeIds = ["win-x64"] ++ map (system: pkgs.dotnetCorePackages.systemToDotnetRid system) dotnet-sdk.meta.platforms; diff --git a/nix/deps.nix b/nix/deps.nix index 4d3bf8f..25aaad7 100644 --- a/nix/deps.nix +++ b/nix/deps.nix @@ -3,8 +3,8 @@ {fetchNuGet}: [ (fetchNuGet { pname = "fsharp-analyzers"; - version = "0.22.0"; - sha256 = "sha256-wDS7aE4VI718iwU8xUm0aCOYIcFpMuqWu9+H5d+8XAA="; + version = "0.23.0"; + sha256 = "sha256-CWMW06ncSs8QkQvxNPNrgn3TAzMU6qCT1k2A3pnGrYQ="; }) (fetchNuGet { pname = "fantomas"; From 0b25100f007a112729b2b8e3c98bb2dcc3a46453 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 15 Jan 2024 11:33:02 +0000 Subject: [PATCH 11/13] Bump cachix/install-nix-action from 24 to 25 (#67) --- .github/workflows/dotnet.yaml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/.github/workflows/dotnet.yaml b/.github/workflows/dotnet.yaml index 0d7ab05..2543e6a 100644 --- a/.github/workflows/dotnet.yaml +++ b/.github/workflows/dotnet.yaml @@ -28,7 +28,7 @@ jobs: with: fetch-depth: 0 # so that NerdBank.GitVersioning has access to history - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -49,7 +49,7 @@ jobs: with: fetch-depth: 0 # so that NerdBank.GitVersioning has access to history - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -66,7 +66,7 @@ jobs: - name: Checkout uses: actions/checkout@v4 - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -79,7 +79,7 @@ jobs: - name: Checkout uses: actions/checkout@v4 - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -92,7 +92,7 @@ jobs: - name: Checkout uses: actions/checkout@v4 - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -105,7 +105,7 @@ jobs: steps: - uses: actions/checkout@master - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -118,7 +118,7 @@ jobs: steps: - uses: actions/checkout@master - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -132,7 +132,7 @@ jobs: with: fetch-depth: 0 # so that NerdBank.GitVersioning has access to history - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} @@ -174,7 +174,7 @@ jobs: steps: - uses: actions/checkout@v4 - name: Install Nix - uses: cachix/install-nix-action@v24 + uses: cachix/install-nix-action@v25 with: extra_nix_config: | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} From 268a2f6f523d8d128193b465d4047732a2dbbb5d Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Mon, 15 Jan 2024 15:27:36 +0000 Subject: [PATCH 12/13] Bump FsUnit from 6.0.0-alpha3 to 6.0.0 (#66) --- .../WoofWare.Myriad.Plugins.Test.fsproj | 2 +- nix/deps.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index b6b5910..5500c78 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -26,7 +26,7 @@ - + diff --git a/nix/deps.nix b/nix/deps.nix index 25aaad7..ee2964d 100644 --- a/nix/deps.nix +++ b/nix/deps.nix @@ -48,8 +48,8 @@ }) (fetchNuGet { pname = "FsUnit"; - version = "6.0.0-alpha3"; - sha256 = "00ip3w8zj77vrnw8g41pgksa1ffmqmkkpj465l6g3bcypz4gy25y"; + version = "6.0.0"; + sha256 = "18q3p0z155znwj1l0qq3vq9nh9wl2i4mlfx4pmrnia4czr0xdkmb"; }) (fetchNuGet { pname = "Microsoft.AspNetCore.App.Ref"; From 515ea306a297434e4e1a04d2e30929f762b43f7e Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Thu, 25 Jan 2024 19:56:44 +0000 Subject: [PATCH 13/13] Map/dictionary support, and check for null when passing to ofJson (#68) --- ConsumePlugin/ConsumePlugin.fsproj | 7 +- ConsumePlugin/GeneratedJson.fs | 12 +- ConsumePlugin/GeneratedPureGymDto.fs | 99 +++- ConsumePlugin/GeneratedVault.fs | 549 ++++++++++++++++++ ConsumePlugin/Vault.fs | 78 +++ .../TestHttpClient/TestVaultClient.fs | 170 ++++++ .../WoofWare.Myriad.Plugins.Test.fsproj | 1 + WoofWare.Myriad.Plugins/AstHelper.fs | 59 +- WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 111 +++- 9 files changed, 1069 insertions(+), 17 deletions(-) create mode 100644 ConsumePlugin/GeneratedVault.fs create mode 100644 ConsumePlugin/Vault.fs create mode 100644 WoofWare.Myriad.Plugins.Test/TestHttpClient/TestVaultClient.fs diff --git a/ConsumePlugin/ConsumePlugin.fsproj b/ConsumePlugin/ConsumePlugin.fsproj index 518896a..7278c06 100644 --- a/ConsumePlugin/ConsumePlugin.fsproj +++ b/ConsumePlugin/ConsumePlugin.fsproj @@ -31,9 +31,10 @@ MockExample.fs - - runmyriad.sh - + + + Vault.fs + diff --git a/ConsumePlugin/GeneratedJson.fs b/ConsumePlugin/GeneratedJson.fs index 8c1486a..ca0132d 100644 --- a/ConsumePlugin/GeneratedJson.fs +++ b/ConsumePlugin/GeneratedJson.fs @@ -61,7 +61,17 @@ module JsonRecordType = |> Seq.map (fun elt -> elt.AsValue().GetValue ()) |> Array.ofSeq - let D = InnerType.jsonParse node.["d"] + let D = + InnerType.jsonParse ( + match node.["d"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("d") + ) + ) + | v -> v + ) let C = (match node.["hi"] with diff --git a/ConsumePlugin/GeneratedPureGymDto.fs b/ConsumePlugin/GeneratedPureGymDto.fs index d0ce354..8436efe 100644 --- a/ConsumePlugin/GeneratedPureGymDto.fs +++ b/ConsumePlugin/GeneratedPureGymDto.fs @@ -254,9 +254,41 @@ module Gym = .AsValue() .GetValue () - let Location = GymLocation.jsonParse node.["location"] - let AccessOptions = GymAccessOptions.jsonParse node.["accessOptions"] - let GymOpeningHours = GymOpeningHours.jsonParse node.["gymOpeningHours"] + let Location = + GymLocation.jsonParse ( + match node.["location"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("location") + ) + ) + | v -> v + ) + + let AccessOptions = + GymAccessOptions.jsonParse ( + match node.["accessOptions"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("accessOptions") + ) + ) + | v -> v + ) + + let GymOpeningHours = + GymOpeningHours.jsonParse ( + match node.["gymOpeningHours"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("gymOpeningHours") + ) + ) + | v -> v + ) let EmailAddress = (match node.["emailAddress"] with @@ -282,7 +314,17 @@ module Gym = .AsValue() .GetValue () - let Address = GymAddress.jsonParse node.["address"] + let Address = + GymAddress.jsonParse ( + match node.["address"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("address") + ) + ) + | v -> v + ) let Status = (match node.["status"] with @@ -857,7 +899,17 @@ namespace PureGym module Visit = /// Parse from a JSON node. let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Visit = - let Gym = VisitGym.jsonParse node.["Gym"] + let Gym = + VisitGym.jsonParse ( + match node.["Gym"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("Gym") + ) + ) + | v -> v + ) let Duration = (match node.["Duration"] with @@ -910,8 +962,29 @@ namespace PureGym module SessionsSummary = /// Parse from a JSON node. let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsSummary = - let ThisWeek = SessionsAggregate.jsonParse node.["ThisWeek"] - let Total = SessionsAggregate.jsonParse node.["Total"] + let ThisWeek = + SessionsAggregate.jsonParse ( + match node.["ThisWeek"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("ThisWeek") + ) + ) + | v -> v + ) + + let Total = + SessionsAggregate.jsonParse ( + match node.["Total"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("Total") + ) + ) + | v -> v + ) { Total = Total @@ -938,7 +1011,17 @@ module Sessions = |> Seq.map (fun elt -> Visit.jsonParse elt) |> List.ofSeq - let Summary = SessionsSummary.jsonParse node.["Summary"] + let Summary = + SessionsSummary.jsonParse ( + match node.["Summary"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("Summary") + ) + ) + | v -> v + ) { Summary = Summary diff --git a/ConsumePlugin/GeneratedVault.fs b/ConsumePlugin/GeneratedVault.fs new file mode 100644 index 0000000..cace90a --- /dev/null +++ b/ConsumePlugin/GeneratedVault.fs @@ -0,0 +1,549 @@ +//------------------------------------------------------------------------------ +// This code was generated by myriad. +// Changes to this file will be lost when the code is regenerated. +//------------------------------------------------------------------------------ + + +namespace ConsumePlugin + +/// Module containing JSON parsing methods for the JwtVaultAuthResponse type +[] +[] +module JwtVaultAuthResponse = + /// Parse from a JSON node. + let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultAuthResponse = + let NumUses = + (match node.["num_uses"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("num_uses") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let Orphan = + (match node.["orphan"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("orphan") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let EntityId = + (match node.["entity_id"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("entity_id") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let TokenType = + (match node.["token_type"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("token_type") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let Renewable = + (match node.["renewable"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("renewable") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let LeaseDuration = + (match node.["lease_duration"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("lease_duration") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let IdentityPolicies = + (match node.["identity_policies"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("identity_policies") + ) + ) + | v -> v) + .AsArray () + |> Seq.map (fun elt -> elt.AsValue().GetValue ()) + |> List.ofSeq + + let TokenPolicies = + (match node.["token_policies"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("token_policies") + ) + ) + | v -> v) + .AsArray () + |> Seq.map (fun elt -> elt.AsValue().GetValue ()) + |> List.ofSeq + + let Policies = + (match node.["policies"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("policies") + ) + ) + | v -> v) + .AsArray () + |> Seq.map (fun elt -> elt.AsValue().GetValue ()) + |> List.ofSeq + + let Accessor = + (match node.["accessor"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("accessor") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let ClientToken = + (match node.["client_token"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("client_token") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + { + ClientToken = ClientToken + Accessor = Accessor + Policies = Policies + TokenPolicies = TokenPolicies + IdentityPolicies = IdentityPolicies + LeaseDuration = LeaseDuration + Renewable = Renewable + TokenType = TokenType + EntityId = EntityId + Orphan = Orphan + NumUses = NumUses + } +namespace ConsumePlugin + +/// Module containing JSON parsing methods for the JwtVaultResponse type +[] +[] +module JwtVaultResponse = + /// Parse from a JSON node. + let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultResponse = + let Auth = + JwtVaultAuthResponse.jsonParse ( + match node.["auth"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("auth") + ) + ) + | v -> v + ) + + let LeaseDuration = + (match node.["lease_duration"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("lease_duration") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let Renewable = + (match node.["renewable"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("renewable") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let LeaseId = + (match node.["lease_id"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("lease_id") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let RequestId = + (match node.["request_id"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("request_id") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + { + RequestId = RequestId + LeaseId = LeaseId + Renewable = Renewable + LeaseDuration = LeaseDuration + Auth = Auth + } +namespace ConsumePlugin + +/// Module containing JSON parsing methods for the JwtSecretResponse type +[] +[] +module JwtSecretResponse = + /// Parse from a JSON node. + let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtSecretResponse = + let Data8 = + (match node.["data8"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data8") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) + let value = (kvp.Value).AsValue().GetValue () |> System.Uri + key, value + ) + |> Seq.map System.Collections.Generic.KeyValuePair + |> System.Collections.Generic.Dictionary + + let Data7 = + (match node.["data7"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data7") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> Map.ofSeq + + let Data6 = + (match node.["data6"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data6") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) |> System.Uri + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> dict + + let Data5 = + (match node.["data5"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data5") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) |> System.Uri + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> readOnlyDict + + let Data4 = + (match node.["data4"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data4") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> Map.ofSeq + + let Data3 = + (match node.["data3"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data3") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> Seq.map System.Collections.Generic.KeyValuePair + |> System.Collections.Generic.Dictionary + + let Data2 = + (match node.["data2"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data2") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> dict + + let Data = + (match node.["data"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("data") + ) + ) + | v -> v) + .AsObject () + |> Seq.map (fun kvp -> + let key = (kvp.Key) + let value = (kvp.Value).AsValue().GetValue () + key, value + ) + |> readOnlyDict + + let LeaseDuration = + (match node.["lease_duration"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("lease_duration") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let Renewable = + (match node.["renewable"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("renewable") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let LeaseId = + (match node.["lease_id"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("lease_id") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + let RequestId = + (match node.["request_id"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("request_id") + ) + ) + | v -> v) + .AsValue() + .GetValue () + + { + RequestId = RequestId + LeaseId = LeaseId + Renewable = Renewable + LeaseDuration = LeaseDuration + Data = Data + Data2 = Data2 + Data3 = Data3 + Data4 = Data4 + Data5 = Data5 + Data6 = Data6 + Data7 = Data7 + Data8 = Data8 + } + +namespace ConsumePlugin + +open System +open System.Collections.Generic +open System.Text.Json.Serialization +open System.Threading +open System.Threading.Tasks +open RestEase + +/// Module for constructing a REST client. +[] +[] +module VaultClient = + /// Create a REST client. + let make (client : System.Net.Http.HttpClient) : IVaultClient = + { new IVaultClient with + member _.GetSecret + ( + jwt : JwtVaultResponse, + path : string, + mountPoint : string, + ct : CancellationToken option + ) + = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> + raise ( + System.ArgumentNullException ( + nameof (client.BaseAddress), + "No base address was supplied on the type, and no BaseAddress was on the HttpClient." + ) + ) + | v -> v), + System.Uri ( + "v1/{mountPoint}/{path}" + .Replace("{path}", path.ToString () |> System.Web.HttpUtility.UrlEncode) + .Replace ( + "{mountPoint}", + mountPoint.ToString () |> System.Web.HttpUtility.UrlEncode + ), + System.UriKind.Relative + ) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Get, + RequestUri = uri + ) + + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! stream = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + + let! node = + System.Text.Json.Nodes.JsonNode.ParseAsync (stream, cancellationToken = ct) + |> Async.AwaitTask + + return JwtSecretResponse.jsonParse node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + + member _.GetJwt (role : string, jwt : string, ct : CancellationToken option) = + async { + let! ct = Async.CancellationToken + + let uri = + System.Uri ( + (match client.BaseAddress with + | null -> + raise ( + System.ArgumentNullException ( + nameof (client.BaseAddress), + "No base address was supplied on the type, and no BaseAddress was on the HttpClient." + ) + ) + | v -> v), + System.Uri ("v1/auth/jwt/login", System.UriKind.Relative) + ) + + let httpMessage = + new System.Net.Http.HttpRequestMessage ( + Method = System.Net.Http.HttpMethod.Get, + RequestUri = uri + ) + + let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask + let response = response.EnsureSuccessStatusCode () + let! stream = response.Content.ReadAsStreamAsync ct |> Async.AwaitTask + + let! node = + System.Text.Json.Nodes.JsonNode.ParseAsync (stream, cancellationToken = ct) + |> Async.AwaitTask + + return JwtVaultResponse.jsonParse node + } + |> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct)) + } diff --git a/ConsumePlugin/Vault.fs b/ConsumePlugin/Vault.fs new file mode 100644 index 0000000..73dcaf9 --- /dev/null +++ b/ConsumePlugin/Vault.fs @@ -0,0 +1,78 @@ +namespace ConsumePlugin + +open System +open System.Collections.Generic +open System.Text.Json.Serialization +open System.Threading +open System.Threading.Tasks +open RestEase + +[] +type JwtVaultAuthResponse = + { + [] + ClientToken : string + Accessor : string + Policies : string list + [] + TokenPolicies : string list + [] + IdentityPolicies : string list + [] + LeaseDuration : int + Renewable : bool + [] + TokenType : string + [] + EntityId : string + Orphan : bool + [] + NumUses : int + } + +[] +type JwtVaultResponse = + { + [] + RequestId : string + [] + LeaseId : string + Renewable : bool + [] + LeaseDuration : int + Auth : JwtVaultAuthResponse + } + +[] +type JwtSecretResponse = + { + [] + RequestId : string + [] + LeaseId : string + Renewable : bool + [] + LeaseDuration : int + Data : IReadOnlyDictionary + // These ones aren't actually part of the Vault response, but are here for tests + Data2 : IDictionary + Data3 : Dictionary + Data4 : Map + Data5 : IReadOnlyDictionary + Data6 : IDictionary + Data7 : Map + Data8 : Dictionary + } + +[] +type IVaultClient = + [] + abstract GetSecret : + jwt : JwtVaultResponse * + [] path : string * + [] mountPoint : string * + ?ct : CancellationToken -> + Task + + [] + abstract GetJwt : role : string * jwt : string * ?ct : CancellationToken -> Task diff --git a/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestVaultClient.fs b/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestVaultClient.fs new file mode 100644 index 0000000..bfacfab --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestHttpClient/TestVaultClient.fs @@ -0,0 +1,170 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System +open System.Net +open System.Net.Http +open NUnit.Framework +open FsUnitTyped +open ConsumePlugin + +[] +module TestVaultClient = + + let exampleVaultKeyResponseString = + """{ + "request_id": "e2470000-0000-0000-0000-000000001f47", + "lease_id": "", + "renewable": false, + "lease_duration": 0, + "data": { + "key1_1": "value1_1", + "key1_2": "value1_2" + }, + "data2": { + "key2_1": "value2_1", + "key2_2": "value2_2" + }, + "data3": { + "key3_1": "value3_1", + "key3_2": "value3_2" + }, + "data4": { + "key4_1": "value4_1", + "key4_2": "value4_2" + }, + "data5": { + "https://example.com/data5/1": "value5_1", + "https://example.com/data5/2": "value5_2" + }, + "data6": { + "https://example.com/data6/1": "value6_1", + "https://example.com/data6/2": "value6_2" + }, + "data7": { + "key7_1": 71, + "key7_2": 72 + }, + "data8": { + "key8_1": "https://example.com/data8/1", + "key8_2": "https://example.com/data8/2" + } +}""" + + let exampleVaultJwtResponseString = + """{ + "request_id": "80000000-0000-0000-0000-00000000000d", + "lease_id": "", + "renewable": false, + "lease_duration": 0, + "data": null, + "wrap_info": null, + "warnings": null, + "auth": { + "client_token": "redacted_client_token", + "accessor": "redacted_accessor", + "policies": [ + "policy1", + "default" + ], + "identity_policies": [ + "identity-policy", + "default-2" + ], + "token_policies": [ + "token-policy", + "default-3" + ], + "metadata": { + "role": "some-role" + }, + "lease_duration": 43200, + "renewable": true, + "entity_id": "20000000-0000-0000-0000-000000000007", + "token_type": "service", + "orphan": true, + "mfa_requirement": null, + "num_uses": 0 + } +}""" + + [] + let ``URI example`` () = + let proc (message : HttpRequestMessage) : HttpResponseMessage Async = + async { + message.Method |> shouldEqual HttpMethod.Get + + let requestUri = message.RequestUri.ToString () + + match requestUri with + | "https://my-vault.com/v1/auth/jwt/login" -> + let content = new StringContent (exampleVaultJwtResponseString) + + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + | "https://my-vault.com/v1/mount/path" -> + let content = new StringContent (exampleVaultKeyResponseString) + + let resp = new HttpResponseMessage (HttpStatusCode.OK) + resp.Content <- content + return resp + | _ -> return failwith $"bad URI: %s{requestUri}" + } + + use client = HttpClientMock.make (Uri "https://my-vault.com") proc + let api = VaultClient.make client + + let vaultResponse = api.GetJwt("role", "jwt").Result + let value = api.GetSecret(vaultResponse, "path", "mount").Result + + value.Data + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> k, v) + |> shouldEqual [ "key1_1", "value1_1" ; "key1_2", "value1_2" ] + + value.Data2 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> k, v) + |> shouldEqual [ "key2_1", "value2_1" ; "key2_2", "value2_2" ] + + value.Data3 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> k, v) + |> shouldEqual [ "key3_1", "value3_1" ; "key3_2", "value3_2" ] + + value.Data4 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> k, v) + |> shouldEqual [ "key4_1", "value4_1" ; "key4_2", "value4_2" ] + + value.Data5 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> (k : Uri).ToString (), v) + |> shouldEqual + [ + "https://example.com/data5/1", "value5_1" + "https://example.com/data5/2", "value5_2" + ] + + value.Data6 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> (k : Uri).ToString (), v) + |> shouldEqual + [ + "https://example.com/data6/1", "value6_1" + "https://example.com/data6/2", "value6_2" + ] + + value.Data7 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> k, v) + |> shouldEqual [ "key7_1", 71 ; "key7_2", 72 ] + + value.Data8 + |> Seq.toList + |> List.map (fun (KeyValue (k, v)) -> k, (v : Uri).ToString ()) + |> shouldEqual + [ + "key8_1", "https://example.com/data8/1" + "key8_2", "https://example.com/data8/2" + ] diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index 5500c78..0990990 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -18,6 +18,7 @@ + diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index c005985..dedeb4b 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -102,10 +102,35 @@ module internal AstHelper = || System.String.Equals (i.idText, "[]", System.StringComparison.Ordinal) -> true - // TODO: consider FSharpList or whatever it is - | [ i ] -> - printfn $"Not array: %s{i.idText}" - false + | _ -> false + + let isMapIdent (ident : SynLongIdent) : bool = + match ident.LongIdent |> List.map _.idText with + | [ "Map" ] -> true + | _ -> false + + let isReadOnlyDictionaryIdent (ident : SynLongIdent) : bool = + match ident.LongIdent |> List.map _.idText with + | [ "IReadOnlyDictionary" ] + | [ "Generic" ; "IReadOnlyDictionary" ] + | [ "Collections" ; "Generic" ; "IReadOnlyDictionary" ] + | [ "System" ; "Collections" ; "Generic" ; "IReadOnlyDictionary" ] -> true + | _ -> false + + let isDictionaryIdent (ident : SynLongIdent) : bool = + match ident.LongIdent |> List.map _.idText with + | [ "Dictionary" ] + | [ "Generic" ; "Dictionary" ] + | [ "Collections" ; "Generic" ; "Dictionary" ] + | [ "System" ; "Collections" ; "Generic" ; "Dictionary" ] -> true + | _ -> false + + let isIDictionaryIdent (ident : SynLongIdent) : bool = + match ident.LongIdent |> List.map _.idText with + | [ "IDictionary" ] + | [ "Generic" ; "IDictionary" ] + | [ "Collections" ; "Generic" ; "IDictionary" ] + | [ "System" ; "Collections" ; "Generic" ; "IDictionary" ] -> true | _ -> false let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list = @@ -337,6 +362,32 @@ module internal SynTypePatterns = | SynType.Array (1, innerType, _) -> Some innerType | _ -> None + let (|DictionaryType|_|) (fieldType : SynType) = + match fieldType with + | SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isDictionaryIdent ident -> + Some (key, value) + | _ -> None + + let (|IDictionaryType|_|) (fieldType : SynType) = + match fieldType with + | SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isIDictionaryIdent ident -> + Some (key, value) + | _ -> None + + let (|IReadOnlyDictionaryType|_|) (fieldType : SynType) = + match fieldType with + | SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when + AstHelper.isReadOnlyDictionaryIdent ident + -> + Some (key, value) + | _ -> None + + let (|MapType|_|) (fieldType : SynType) = + match fieldType with + | SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isMapIdent ident -> + Some (key, value) + | _ -> None + /// Returns the string name of the type. let (|PrimitiveType|_|) (fieldType : SynType) = match fieldType with diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 8756c0a..186cbe5 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -85,6 +85,14 @@ module internal JsonParseGenerator = |> SynExpr.callMethod "AsValue" |> SynExpr.callGenericMethod "GetValue" typeName + /// {node}.AsObject() + /// If `propertyName` is Some, uses `assertNotNull {node}` instead of `{node}`. + let asObject (propertyName : SynExpr option) (node : SynExpr) : SynExpr = + match propertyName with + | None -> node + | Some propertyName -> assertNotNull propertyName node + |> SynExpr.callMethod "AsObject" + /// {type}.jsonParse {node} let typeJsonParse (typeName : LongIdent) (node : SynExpr) : SynExpr = SynExpr.CreateApp ( @@ -133,6 +141,54 @@ module internal JsonParseGenerator = let parseFunction (typeName : string) : LongIdent = List.append (SynExpr.qualifyPrimitiveType typeName) [ Ident.Create "Parse" ] + /// fun kvp -> let key = {key(kvp)} in let value = {value(kvp)} in (key, value)) + /// The inputs will be fed with appropriate SynExprs to apply them to the `kvp.Key` and `kvp.Value` args. + let dictionaryMapper (key : SynExpr -> SynExpr) (value : SynExpr -> SynExpr) : SynExpr = + let keyArg = + SynExpr.CreateLongIdent (SynLongIdent.Create [ "kvp" ; "Key" ]) + |> SynExpr.CreateParen + + let valueArg = + SynExpr.CreateLongIdent (SynLongIdent.Create [ "kvp" ; "Value" ]) + |> SynExpr.CreateParen + + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "key"), expr = key keyArg) + ], + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "value"), expr = value valueArg) + ], + SynExpr.CreateTuple [ SynExpr.CreateIdentString "key" ; SynExpr.CreateIdentString "value" ], + range0, + { + InKeyword = None + } + ), + range0, + { + InKeyword = None + } + ) + |> SynExpr.createLambda "kvp" + + /// A conforming JSON object has only strings as keys. But it would be reasonable to allow the user + /// to parse these as URIs, for example. + let parseKeyString (desiredType : SynType) (key : SynExpr) : SynExpr = + match desiredType with + | String -> key + | Uri -> + key + |> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ])) + | _ -> + failwithf + $"Unable to parse the key type %+A{desiredType} of a JSON object. Keys are strings, and this plugin does not know how to convert to that from a string." + /// Given `node.["town"]`, for example, choose how to obtain a JSON value from it. /// The property name is used in error messages at runtime to show where a JSON /// parse error occurred; supply `None` to indicate "don't validate". @@ -217,6 +273,56 @@ module internal JsonParseGenerator = | ArrayType ty -> parseNode None options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt")) |> asArrayMapped propertyName "Array" node + | IDictionaryType (keyType, valueType) -> + node + |> asObject propertyName + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), + dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) + ) + ) + |> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "dict" ])) + | DictionaryType (keyType, valueType) -> + node + |> asObject propertyName + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), + dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) + ) + ) + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), + SynExpr.CreateLongIdent ( + SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyValuePair" ] + ) + ) + ) + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "Dictionary" ]) + ) + | IReadOnlyDictionaryType (keyType, valueType) -> + node + |> asObject propertyName + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), + dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) + ) + ) + |> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "readOnlyDict" ])) + | MapType (keyType, valueType) -> + node + |> asObject propertyName + |> SynExpr.pipeThroughFunction ( + SynExpr.CreateApp ( + SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]), + dictionaryMapper (parseKeyString keyType) (parseNode None options valueType) + ) + ) + |> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Map" ; "ofSeq" ])) | _ -> // Let's just hope that we've also got our own type annotation! let typeName = @@ -224,7 +330,10 @@ module internal JsonParseGenerator = | SynType.LongIdent ident -> ident.LongIdent | _ -> failwith $"Unrecognised type: %+A{fieldType}" - typeJsonParse typeName node + match propertyName with + | None -> node + | Some propertyName -> assertNotNull propertyName node + |> typeJsonParse typeName /// propertyName is probably a string literal, but it could be a [] variable /// The result of this function is the body of a let-binding (not including the LHS of that let-binding).