patrick/WoofWare.Myriad
1
0
Fork 0
mirror of https://github.com/Smaug123/WoofWare.Myriad synced 2025-10-05 20:18:43 +00:00
Code Issues Packages Projects Releases Wiki Activity

Implement RestEase variable headers (#76)

Browse Source
This commit is contained in:
Patrick Stevens
2024-01-29 21:24:41 +00:00
committed by GitHub
parent 5c1841c3d2
commit f803b44311
9 changed files with 886 additions and 482 deletions
Download Patch File Download Diff File Expand all files Collapse all files

63
ConsumePlugin/GeneratedRestClient.fs
View File

@@ -1047,3 +1047,66 @@ module ApiWithBasePathAndAddress =
}
|> (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.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module ApiWithHeaders =
/// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties.
let make
(someHeader : unit -> string)
(someOtherHeader : unit -> int)
(client : System.Net.Http.HttpClient)
: IApiWithHeaders
=
{ new IApiWithHeaders with
member _.SomeHeader : string = someHeader ()
member _.SomeOtherHeader : int = someOtherHeader ()
member this.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
)
do httpMessage.Headers.Add ("X-Foo", this.SomeHeader.ToString ())
do httpMessage.Headers.Add ("Authorization", this.SomeOtherHeader.ToString ())
do httpMessage.Headers.Add ("Header-Name", "Header-Value")
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
}

12
ConsumePlugin/RestApiExample.fs
View File

@@ -125,3 +125,15 @@ type IApiWithBasePath =
type IApiWithBasePathAndAddress =
[<Get "endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<Header("Header-Name", "Header-Value")>]
type IApiWithHeaders =
[<Header "X-Foo">]
abstract SomeHeader : string
[<Header "Authorization">]
abstract SomeOtherHeader : int
[<Get "endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>

6
README.md
View File

@@ -258,6 +258,11 @@ module PureGymApi =
The motivating example is again ahead-of-time compilation: we wish to avoid the reflection which RestEase does.
### Features
* Variable and constant header values are supported:
see [the definition of `IApiWithHeaders`](./ConsumePlugin/RestApiExample.fs).
### Limitations
RestEase is complex, and handles a lot of different stuff.
@@ -270,7 +275,6 @@ RestEase is complex, and handles a lot of different stuff.
all body parameters must be types which have a suitable `toJsonNode : 'a -> JsonNode` method.
* 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.
* Anonymous parameters are currently forbidden.
There are also some design decisions:

108
WoofWare.Myriad.Plugins.Test/TestHttpClient/TestVariableHeader.fs Normal file
View File

@@ -0,0 +1,108 @@
namespace WoofWare.Myriad.Plugins.Test
open System
open System.Net
open System.Net.Http
open System.Threading
open NUnit.Framework
open FsUnitTyped
open PureGym
[<TestFixture>]
module TestVariableHeader =
[<Test>]
let ``Headers are set`` () : unit =
let proc (message : HttpRequestMessage) : HttpResponseMessage Async =
async {
message.Method |> shouldEqual HttpMethod.Get
message.RequestUri.ToString ()
|> shouldEqual "https://example.com/endpoint/param"
let headers =
[
for h in message.Headers do
yield $"%s{h.Key}: %s{Seq.exactlyOne h.Value}"
]
|> String.concat "\n"
let content = new StringContent (headers)
let resp = new HttpResponseMessage (HttpStatusCode.OK)
resp.Content <- content
return resp
}
use client = HttpClientMock.make (Uri "https://example.com") proc
let someHeaderCount = ref 10
let someHeader () =
(Interlocked.Increment someHeaderCount : int).ToString ()
let someOtherHeaderCount = ref -100
let someOtherHeader () =
Interlocked.Increment someOtherHeaderCount
let api = ApiWithHeaders.make someHeader someOtherHeader client
someHeaderCount.Value |> shouldEqual 10
someOtherHeaderCount.Value |> shouldEqual -100
api.GetPathParam("param").Result.Split "\n"
|> Array.sort
|> shouldEqual [| "Authorization: -99" ; "Header-Name: Header-Value" ; "X-Foo: 11" |]
someHeaderCount.Value |> shouldEqual 11
someOtherHeaderCount.Value |> shouldEqual -99
[<Test>]
let ``Headers get re-evaluated every time`` () : unit =
let proc (message : HttpRequestMessage) : HttpResponseMessage Async =
async {
message.Method |> shouldEqual HttpMethod.Get
message.RequestUri.ToString ()
|> shouldEqual "https://example.com/endpoint/param"
let headers =
[
for h in message.Headers do
yield $"%s{h.Key}: %s{Seq.exactlyOne h.Value}"
]
|> String.concat "\n"
let content = new StringContent (headers)
let resp = new HttpResponseMessage (HttpStatusCode.OK)
resp.Content <- content
return resp
}
use client = HttpClientMock.make (Uri "https://example.com") proc
let someHeaderCount = ref 10
let someHeader () =
(Interlocked.Increment someHeaderCount : int).ToString ()
let someOtherHeaderCount = ref -100
let someOtherHeader () =
Interlocked.Increment someOtherHeaderCount
let api = ApiWithHeaders.make someHeader someOtherHeader client
someHeaderCount.Value |> shouldEqual 10
someOtherHeaderCount.Value |> shouldEqual -100
api.GetPathParam("param").Result.Split "\n"
|> Array.sort
|> shouldEqual [| "Authorization: -99" ; "Header-Name: Header-Value" ; "X-Foo: 11" |]
api.GetPathParam("param").Result.Split "\n"
|> Array.sort
|> shouldEqual [| "Authorization: -98" ; "Header-Name: Header-Value" ; "X-Foo: 12" |]
someHeaderCount.Value |> shouldEqual 12
someOtherHeaderCount.Value |> shouldEqual -98

1
WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj
View File

@@ -19,6 +19,7 @@
<Compile Include="TestHttpClient\TestBasePath.fs" />
<Compile Include="TestHttpClient\TestBodyParam.fs" />
<Compile Include="TestHttpClient\TestVaultClient.fs" />
<Compile Include="TestHttpClient\TestVariableHeader.fs" />
<Compile Include="TestMockGenerator\TestMockGenerator.fs" />
<Compile Include="TestRemoveOptions.fs"/>
<Compile Include="TestSurface.fs"/>

211
WoofWare.Myriad.Plugins/AstHelper.fs
View File

@@ -33,11 +33,29 @@ type internal MemberInfo =
IsMutable : bool
}
[<RequireQualifiedAccess>]
type internal PropertyAccessors =
| Get
| Set
| GetSet
type internal PropertyInfo =
{
Type : SynType
Accessibility : SynAccess option
Attributes : SynAttribute list
XmlDoc : PreXmlDoc option
Accessors : PropertyAccessors
IsInline : bool
Identifier : Ident
}
type internal InterfaceType =
{
Attributes : SynAttribute list
Name : LongIdent
Members : MemberInfo list
Properties : PropertyInfo list
Generics : SynTyparDecls option
Accessibility : SynAccess option
}
@@ -230,6 +248,108 @@ module internal AstHelper =
((toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret
| _ -> [], ty
let private parseMember (slotSig : SynValSig) (flags : SynMemberFlags) : Choice<MemberInfo, PropertyInfo> =
if not flags.IsInstance then
failwith "member was not an instance member"
let propertyAccessors =
match flags.MemberKind with
| SynMemberKind.Member -> None
| SynMemberKind.PropertyGet -> Some PropertyAccessors.Get
| SynMemberKind.PropertySet -> Some PropertyAccessors.Set
| SynMemberKind.PropertyGetSet -> Some PropertyAccessors.GetSet
| kind -> failwithf "Unrecognised member kind: %+A" kind
match slotSig with
| SynValSig (attrs,
SynIdent.SynIdent (ident, _),
_typeParams,
synType,
_arity,
isInline,
isMutable,
xmlDoc,
accessibility,
synExpr,
_,
_) ->
match synExpr with
| Some _ -> failwith "literal members are not supported"
| None -> ()
let attrs = attrs |> List.collect _.Attributes
let args, ret = getType synType
let 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
}
)
match propertyAccessors with
| None ->
{
ReturnType = ret
Args = args
Identifier = ident
Attributes = attrs
XmlDoc = Some xmlDoc
Accessibility = accessibility
IsInline = isInline
IsMutable = isMutable
}
|> Choice1Of2
| Some accessors ->
{
Type = ret
Accessibility = accessibility
Attributes = attrs
XmlDoc = Some xmlDoc
Accessors = accessors
IsInline = isInline
Identifier = ident
}
|> Choice2Of2
/// 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, _),
@@ -242,104 +362,21 @@ module internal AstHelper =
let attrs = attrs |> List.collect (fun s -> s.Attributes)
let members =
let members, properties =
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,
_,
_) ->
match synExpr with
| Some _ -> failwith "literal members are not supported"
| None -> ()
let attrs = attrs |> List.collect (fun attr -> attr.Attributes)
let args, ret = getType synType
let 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
Args = args
Identifier = ident
Attributes = attrs
XmlDoc = Some xmlDoc
Accessibility = accessibility
IsInline = isInline
IsMutable = isMutable
}
| SynMemberDefn.AbstractSlot (slotSig, flags, _, _) -> parseMember slotSig flags
| _ -> failwith $"Unrecognised member definition: %+A{defn}"
)
| _ -> failwith $"Unrecognised SynTypeDefnRepr for an interface type: %+A{synTypeDefnRepr}"
|> List.partitionChoice
{
Members = members
Properties = properties
Name = interfaceName
Attributes = attrs
Generics = typars

204
WoofWare.Myriad.Plugins/HttpClientGenerator.fs
View File

@@ -2,7 +2,9 @@ namespace WoofWare.Myriad.Plugins
open System
open System.Net.Http
open System.Text
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
@@ -125,6 +127,20 @@ module internal HttpClientGenerator =
| matchingAttrs ->
failwith $"Required exactly one recognised RestEase attribute on member, but got %i{matchingAttrs.Length}"
/// Get the args associated with the Header attributes within the list.
let extractHeaderInformation (attrs : SynAttribute list) : SynExpr list list =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
| "Header"
| "RestEase.Header" ->
match attr.ArgExpr with
| SynExpr.Paren (SynExpr.Tuple (_, [ v1 ; v2 ], _, _), _, _, _) ->
Some [ SynExpr.stripOptionalParen v1 ; SynExpr.stripOptionalParen v2 ]
| e -> Some [ SynExpr.stripOptionalParen e ]
| _ -> None
)
let shouldAllowAnyStatusCode (attrs : SynAttribute list) : bool =
attrs
|> List.exists (fun attr ->
@@ -136,7 +152,14 @@ module internal HttpClientGenerator =
| _ -> false
)
let constructMember (info : MemberInfo) : SynMemberDefn =
/// constantHeaders are a list of (headerName, headerValue)
/// variableHeaders are a list of (headerName, selfPropertyToGetValueOf)
let constructMember
(constantHeaders : (SynExpr * SynExpr) list)
(variableHeaders : (SynExpr * Ident) list)
(info : MemberInfo)
: SynMemberDefn
=
let valInfo =
SynValInfo.SynValInfo (
[
@@ -194,8 +217,10 @@ module internal HttpClientGenerator =
|> SynArgPats.Pats
let headPat =
let thisIdent = if variableHeaders.IsEmpty then "_" else "this"
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "_" ; info.Identifier ],
SynLongIdent.CreateFromLongIdent [ Ident.Create thisIdent ; info.Identifier ],
None,
None,
argPats,
@@ -561,6 +586,38 @@ module internal HttpClientGenerator =
)
)
let setVariableHeaders =
variableHeaders
|> List.map (fun (headerName, callToGetValue) ->
Do (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "httpMessage" ; "Headers" ; "Add" ]),
SynExpr.CreateParenedTuple
[
headerName
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent
[ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ]
),
SynExpr.CreateConst SynConst.Unit
)
]
)
)
)
let setConstantHeaders =
constantHeaders
|> List.map (fun (headerName, headerValue) ->
Do (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "httpMessage" ; "Headers" ; "Add" ]),
SynExpr.CreateParenedTuple [ headerName ; headerValue ]
)
)
)
[
yield LetBang ("ct", SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "CancellationToken" ]))
yield Let ("uri", requestUri)
@@ -579,6 +636,9 @@ module internal HttpClientGenerator =
yield! handleBodyParams
yield! setVariableHeaders
yield! setConstantHeaders
yield
LetBang (
"response",
@@ -682,6 +742,12 @@ module internal HttpClientGenerator =
| _ -> None
)
let lowerFirstLetter (x : Ident) : Ident =
let result = StringBuilder x.idText.Length
result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
result.Append x.idText.[1..] |> ignore
Ident.Create ((result : StringBuilder).ToString ())
let createModule
(opens : SynOpenDeclTarget list)
(ns : LongIdent)
@@ -690,10 +756,48 @@ module internal HttpClientGenerator =
=
let interfaceType = AstHelper.parseInterface interfaceType
let constantHeaders =
interfaceType.Attributes
|> extractHeaderInformation
|> List.map (fun exprs ->
match exprs with
| [ key ; value ] -> key, value
| [] ->
failwith
"Expected constant header parameters to be of the form [<Header (key, value)>], but got no args"
| [ _ ] ->
failwith
"Expected constant header parameters to be of the form [<Header (key, value)>], but got only one arg"
| _ ->
failwith
"Expected constant header parameters to be of the form [<Header (key, value)>], but got more than two args"
)
let baseAddress = extractBaseAddress interfaceType.Attributes
let basePath = extractBasePath interfaceType.Attributes
let members =
let properties =
interfaceType.Properties
|> List.map (fun pi ->
let headerInfo =
match extractHeaderInformation pi.Attributes with
| [ [ x ] ] -> x
| [ xs ] ->
failwith
"Expected exactly one Header parameter on the member, with exactly one arg; got one Header parameter with non-1-many args"
| [] ->
failwith
"Expected exactly one Header parameter on the member, with exactly one arg; got no Header parameters"
| _ ->
failwith
"Expected exactly one Header parameter on the member, with exactly one arg; got multiple Header parameters"
headerInfo, pi
)
let nonPropertyMembers =
let properties = properties |> List.map (fun (header, pi) -> header, pi.Identifier)
interfaceType.Members
|> List.map (fun mem ->
let httpMethod, url = extractHttpInformation mem.Attributes
@@ -740,8 +844,57 @@ module internal HttpClientGenerator =
Accessibility = mem.Accessibility
}
)
|> List.map (constructMember constantHeaders properties)
let propertyMembers =
properties
|> List.map (fun (_, pi) ->
SynMemberDefn.Member (
SynBinding.SynBinding (
pi.Accessibility,
SynBindingKind.Normal,
pi.IsInline,
false,
[],
PreXmlDoc.Empty,
SynValData.SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
SynValInfo.SynValInfo ([ [ SynArgInfo.Empty ] ; [] ], SynArgInfo.Empty),
None
),
SynPat.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "_" ; pi.Identifier ],
[]
),
Some (SynBindingReturnInfo.Create pi.Type),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ lowerFirstLetter pi.Identifier ]
),
SynExpr.CreateConst SynConst.Unit
),
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = if pi.IsInline then Some range0 else None
EqualsRange = Some range0
}
),
range0
)
)
let members = propertyMembers @ nonPropertyMembers
let constructed = members |> List.map constructMember
let docString = PreXmlDoc.Create " Module for constructing a REST client."
let interfaceImpl =
@@ -750,12 +903,35 @@ module internal HttpClientGenerator =
None,
Some range0,
[],
constructed,
members,
[],
range0,
range0
)
let headerArgs =
properties
|> List.map (fun (_, pi) ->
SynPat.CreateTyped (
SynPat.CreateNamed (lowerFirstLetter pi.Identifier),
SynType.CreateFun (SynType.CreateLongIdent "unit", pi.Type)
)
|> SynPat.CreateParen
)
let clientCreationArg =
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "client"),
SynType.CreateLongIdent (SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpClient" ])
)
|> SynPat.CreateParen
let xmlDoc =
if properties.IsEmpty then
" Create a REST client."
else
" Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties."
let createFunc =
SynBinding.SynBinding (
None,
@@ -763,7 +939,7 @@ module internal HttpClientGenerator =
false,
false,
[],
PreXmlDoc.Create " Create a REST client.",
PreXmlDoc.Create xmlDoc,
SynValData.SynValData (
None,
SynValInfo.SynValInfo (
@@ -772,19 +948,7 @@ module internal HttpClientGenerator =
),
None
),
SynPat.CreateLongIdent (
SynLongIdent.CreateString "make",
[
SynPat.CreateParen (
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "client"),
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpClient" ]
)
)
)
]
),
SynPat.CreateLongIdent (SynLongIdent.CreateString "make", headerArgs @ [ clientCreationArg ]),
Some (
SynBindingReturnInfo.Create (
SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name)
@@ -800,7 +964,7 @@ module internal HttpClientGenerator =
let moduleName : LongIdent =
List.last interfaceType.Name
|> fun ident -> ident.idText
|> _.idText
|> fun s ->
if s.StartsWith 'I' then
s.[1..]

14
WoofWare.Myriad.Plugins/List.fs Normal file
View File

@@ -0,0 +1,14 @@
namespace WoofWare.Myriad.Plugins
[<RequireQualifiedAccess>]
module private List =
let partitionChoice<'a, 'b> (xs : Choice<'a, 'b> list) : 'a list * 'b list =
let xs, ys =
(([], []), xs)
||> List.fold (fun (xs, ys) v ->
match v with
| Choice1Of2 x -> x :: xs, ys
| Choice2Of2 y -> xs, y :: ys
)
List.rev xs, List.rev ys

1
WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
View File

@@ -24,6 +24,7 @@
</ItemGroup>
<ItemGroup>
<Compile Include="List.fs" />
<Compile Include="AstHelper.fs"/>
<Compile Include="SynExpr.fs"/>
<Compile Include="SynType.fs" />