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

HTTP clients (#21)

Browse Source
This commit is contained in:
Patrick Stevens
2023-12-28 19:46:52 +00:00
committed by GitHub
parent 146554df72
commit 67d870002e
13 changed files with 1091 additions and 103 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
ConsumePlugin/ConsumePlugin.fsproj
View File

@@ -22,10 +22,10 @@
<Compile Include="GeneratedPureGymDto.fs">
<MyriadFile>PureGymDto.fs</MyriadFile> <!--2-->
</Compile>
<None Include="RestApiExample.fs" />
<None Include="GeneratedRestClient.fs">
<Compile Include="RestApiExample.fs" />
<Compile Include="GeneratedRestClient.fs">
<MyriadFile>RestApiExample.fs</MyriadFile> <!--2-->
</None>
</Compile>
<None Include="..\runmyriad.sh">
<Link>runmyriad.sh</Link>
</None>

178
ConsumePlugin/GeneratedRestClient.fs
View File

@@ -2,3 +2,181 @@
// This code was generated by myriad.
// Changes to this file will be lost when the code is regenerated.
//------------------------------------------------------------------------------
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module PureGymApi =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IPureGymApi =
{ new IPureGymApi with
member _.GetGyms (ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri =
System.Uri (
client.BaseAddress.ToString () + "/v1/gyms/" |> System.Web.HttpUtility.UrlEncode
)
)
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 node.AsArray () |> Seq.map (fun elt -> Gym.jsonParse elt) |> List.ofSeq
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
member _.GetGymAttendance (gymId : int, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri =
System.Uri (
client.BaseAddress.ToString ()
+ "/v1/gyms/{gym_id}/attendance".Replace ("{gym_id}", gymId.ToString ())
|> System.Web.HttpUtility.UrlEncode
)
)
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 GymAttendance.jsonParse node
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
member _.GetMember (ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri =
System.Uri (
client.BaseAddress.ToString () + "/v1/member"
|> System.Web.HttpUtility.UrlEncode
)
)
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 Member.jsonParse node
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
member _.GetGym (gymId : int, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri =
System.Uri (
client.BaseAddress.ToString ()
+ "/v1/gyms/{gym_id}".Replace ("{gym_id}", gymId.ToString ())
|> System.Web.HttpUtility.UrlEncode
)
)
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 Gym.jsonParse node
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
member _.GetMemberActivity (ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri =
System.Uri (
client.BaseAddress.ToString () + "/v1/member/activity"
|> System.Web.HttpUtility.UrlEncode
)
)
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 MemberActivityDto.jsonParse node
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
member _.GetSessions (fromDate : DateTime, toDate : DateTime, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri =
System.Uri (
client.BaseAddress.ToString ()
+ ("/v2/gymSessions/member"
+ "?fromDate="
+ fromDate.ToString ()
+ "&toDate="
+ toDate.ToString ())
|> System.Web.HttpUtility.UrlEncode
)
)
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 Sessions.jsonParse node
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
}

53
ConsumePlugin/RestApiExample.fs
View File

@@ -5,6 +5,7 @@ open System.Threading
open System.Threading.Tasks
open RestEase
[<WoofWare.Myriad.Plugins.HttpClient>]
type IPureGymApi =
[<Get "v1/gyms/">]
abstract GetGyms : ?ct : CancellationToken -> Task<Gym list>
@@ -12,57 +13,15 @@ type IPureGymApi =
[<Get "v1/gyms/{gym_id}/attendance">]
abstract GetGymAttendance : [<Path "gym_id">] gymId : int * ?ct : CancellationToken -> Task<GymAttendance>
(*
[<Get "v1/member">]
abstract GetMember : unit -> Task<Member>
abstract GetMember : ?ct : CancellationToken -> Task<Member>
[<Get "v1/gyms/{gym_id}">]
abstract GetGym : [<Path "gym_id">] gymId : int -> Task<Gym>
abstract GetGym : [<Path "gym_id">] gymId : int * ?ct : CancellationToken -> Task<Gym>
[<Get "v1/member/activity">]
abstract GetMemberActivity : unit -> Task<MemberActivityDto>
abstract GetMemberActivity : ?ct : CancellationToken -> Task<MemberActivityDto>
[<Get "v2/gymSessions/member">]
abstract GetSessions : [<Query>] fromDate : DateTime -> [<Query>] toDate : DateTime -> Task<Sessions>
*)
module Foo =
let make (client : System.Net.Http.HttpClient) =
{ new IPureGymApi with
member _.GetGyms (ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let! response = client.GetAsync (client.BaseAddress.ToString () + "v1/gyms/") |> 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
node.AsArray ()
|> Seq.map (fun elt -> elt.AsValue () |> Gym.jsonParse)
|> List.ofSeq
}
|> fun a -> Async.StartAsTask (a, ?cancellationToken = ct)
member _.GetGymAttendance (gym_id : int, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let! response =
client.GetAsync (client.BaseAddress.ToString () + $"v1/gyms/{gym_id}/attendance")
|> 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 GymAttendance.jsonParse node
}
|> fun a -> Async.StartAsTask (a, ?cancellationToken = ct)
}
abstract GetSessions :
[<Query>] fromDate : DateTime * [<Query>] toDate : DateTime * ?ct : CancellationToken -> Task<Sessions>

80
README.md
View File

@@ -10,6 +10,7 @@ The `RemoveOptions` generator in particular is extremely half-baked.
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).
## `JsonParse`
@@ -41,7 +42,6 @@ type JsonRecordType =
and stamps out parsing methods like this:
```fsharp
/// Module containing JSON parsing methods for the InnerType type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
@@ -126,6 +126,84 @@ This generator is *far* from where I want it, because I haven't really spent any
* It needs some sort of attribute to mark a field as *not* receiving this treatment.
* What do we do about discriminated unions?
## `HttpClient`
Takes a type like this:
```fsharp
[<WoofWare.Myriad.Plugins.HttpClient>]
type IPureGymApi =
[<Get "v1/gyms/">]
abstract GetGyms : ?ct : CancellationToken -> Task<Gym list>
[<Get "v1/gyms/{gym_id}/attendance">]
abstract GetGymAttendance : [<Path "gym_id">] gymId : int * ?ct : CancellationToken -> Task<GymAttendance>
[<Get "v1/member">]
abstract GetMember : ?ct : CancellationToken -> Task<Member>
[<Get "v1/gyms/{gym_id}">]
abstract GetGym : [<Path "gym_id">] gymId : int * ?ct : CancellationToken -> Task<Gym>
[<Get "v1/member/activity">]
abstract GetMemberActivity : ?ct : CancellationToken -> Task<MemberActivityDto>
[<Get "v2/gymSessions/member">]
abstract GetSessions :
[<Query>] fromDate : DateTime * [<Query>] toDate : DateTime * ?ct : CancellationToken -> Task<Sessions>
```
and stamps out a type like this:
```fsharp
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module PureGymApi =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IPureGymApi =
{ new IPureGymApi with
member _.GetGyms (ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = System.Uri (client.BaseAddress.ToString () + "v1/gyms/")
)
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 node.AsArray () |> Seq.map (fun elt -> Gym.jsonParse elt) |> List.ofSeq
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
// (more methods here)
}
```
### What's the point?
The motivating example is again ahead-of-time compilation: we wish to avoid the reflection which RestEase does.
### Limitations
RestEase is complex, and handles a lot of different stuff.
* As of this writing, `[<Body>]` 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, and it generally assumes you're using types which `JsonParse` is applied to.
* Headers are not yet supported.
* 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.
* 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
See the tests.

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

@@ -115,24 +115,32 @@ module internal SynTypePatterns =
let (|DateOnly|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] ->
if i.idText = "System.DateOnly" || i.idText = "DateOnly" then
Some ()
else
None
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateOnly" ]
| [ "DateOnly" ] -> Some ()
| _ -> None
| _ -> None
let (|DateTime|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] ->
if i.idText = "System.DateTime" || i.idText = "DateTime" then
Some ()
else
None
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateTime" ]
| [ "DateTime" ] -> Some ()
| _ -> None
| _ -> None
let (|Task|_|) (fieldType : SynType) : SynType option =
match fieldType with
| SynType.App (SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)), _, args, _, _, _, _) ->
match ident |> List.map (fun i -> i.idText) with
| [ "Task" ]
| [ "Tasks" ; "Task" ]
| [ "Threading" ; "Tasks" ; "Task" ]
| [ "System" ; "Threading" ; "Tasks" ; "Task" ] ->
match args with
| [ arg ] -> Some arg
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
| _ -> None
| _ -> None

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

@@ -1,7 +1,7 @@
namespace WoofWare.Myriad.Plugins
open System
open System.Text
open System.Net.Http
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
@@ -17,7 +17,670 @@ module internal HttpClientGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
let createModule (ns : LongIdent) (interfaceType : SynTypeDefn) : SynModuleOrNamespace = failwith ""
type HttpAttribute =
// TODO: Format parameter to these attrs
| Query of string option
| Path of string
| Body
type Parameter =
{
Attributes : HttpAttribute list
IsOptional : bool
Id : Ident option
Type : SynType
}
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
Arity : SynArgInfo list
Args : Parameter list
Identifier : Ident
}
let httpMethodString (m : HttpMethod) : string =
if m = HttpMethod.Get then "Get"
elif m = HttpMethod.Post then "Post"
elif m = HttpMethod.Delete then "Delete"
elif m = HttpMethod.Patch then "Post"
elif m = HttpMethod.Options then "Options"
elif m = HttpMethod.Head then "Head"
elif m = HttpMethod.Put then "Put"
elif m = HttpMethod.Trace then "Trace"
else failwith $"Unrecognised method: %+A{m}"
/// E.g. converts `[<Get "blah">]` to (HttpMethod.Get, "blah")
let extractHttpInformation (attrs : SynAttribute list) : HttpMethod * string =
let matchingAttrs =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
| "Get"
| "GetAttribute"
| "RestEase.Get"
| "RestEase.GetAttribute" -> Some (HttpMethod.Get, attr.ArgExpr)
| "Post"
| "PostAttribute"
| "RestEase.Post"
| "RestEase.PostAttribute" -> Some (HttpMethod.Post, attr.ArgExpr)
| "Put"
| "PutAttribute"
| "RestEase.Put"
| "RestEase.PutAttribute" -> Some (HttpMethod.Put, attr.ArgExpr)
| "Delete"
| "DeleteAttribute"
| "RestEase.Delete"
| "RestEase.DeleteAttribute" -> Some (HttpMethod.Delete, attr.ArgExpr)
| "Head"
| "HeadAttribute"
| "RestEase.Head"
| "RestEase.HeadAttribute" -> Some (HttpMethod.Head, attr.ArgExpr)
| "Options"
| "OptionsAttribute"
| "RestEase.Options"
| "RestEase.OptionsAttribute" -> Some (HttpMethod.Options, attr.ArgExpr)
| "Patch"
| "PatchAttribute"
| "RestEase.Patch"
| "RestEase.PatchAttribute" -> Some (HttpMethod.Patch, attr.ArgExpr)
| "Trace"
| "TraceAttribute"
| "RestEase.Trace"
| "RestEase.TraceAttribute" -> Some (HttpMethod.Trace, attr.ArgExpr)
| _ -> None
)
match matchingAttrs with
| [ (meth, arg) ] ->
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 "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
let constructMember (info : MemberInfo) : SynMemberDefn =
let valInfo =
SynValInfo.SynValInfo (
[
[ SynArgInfo.Empty ]
[
for arg in info.Args do
match arg.Id with
| None -> yield SynArgInfo.CreateIdString (failwith "TODO: create an arg name")
| Some id -> yield SynArgInfo.CreateId id
]
],
SynArgInfo.Empty
)
let valData =
SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
valInfo,
None
)
let argPats =
let args =
info.Args
|> List.map (fun arg ->
let argName =
match arg.Id with
| None -> failwith "TODO: create an arg name"
| Some id -> id
let argType =
if arg.IsOptional then
SynType.CreateApp (
SynType.CreateLongIdent (SynLongIdent.CreateString "option"),
[ arg.Type ],
isPostfix = true
)
else
arg.Type
SynPat.CreateTyped (SynPat.CreateNamed argName, argType)
)
SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
|> SynPat.CreateParen
|> List.singleton
|> SynArgPats.Pats
let headPat =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "_" ; info.Identifier ],
None,
None,
argPats,
None,
range0
)
let requestUriTrailer =
// TODO: more principled treatment of the slash
(SynExpr.CreateConstString ("/" + info.UrlTemplate.TrimStart '/'), info.Args)
||> List.fold (fun template arg ->
(template, arg.Attributes)
||> List.fold (fun template attr ->
match attr with
| HttpAttribute.Path s ->
let varName =
match arg.Id with
| None -> failwith "TODO: anonymous args"
| Some id -> id
template
|> SynExpr.callMethodArg
"Replace"
(SynExpr.CreateParenedTuple
[
SynExpr.CreateConstString ("{" + s + "}")
SynExpr.callMethod "ToString" (SynExpr.CreateIdent varName)
])
| _ -> template
)
)
/// List of (query-param-key, parameter-which-provides-value)
let queryParams =
info.Args
|> List.collect (fun arg ->
arg.Attributes
|> List.choose (fun attr ->
match attr with
| Query None ->
let name =
match arg.Id with
| None ->
failwith
"Expected a name for the argument we're trying to use as an anonymous query parameter"
| Some name -> name.idText
Some (name, arg)
| Query (Some name) -> Some (name, arg)
| _ -> None
)
)
let requestUriTrailer =
match queryParams with
| [] -> requestUriTrailer
| (firstKey, firstValue) :: queryParams ->
let firstValueId =
match firstValue.Id with
| 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.CreateParen
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ])
)
|> SynExpr.CreateParen
|> SynExpr.plus (SynExpr.CreateConstString ("?" + firstKey + "="))
(prefix, queryParams)
||> List.fold (fun uri (paramKey, paramValue) ->
let paramValueId =
match paramValue.Id with
| None -> failwith "Unable to get parameter variable name from anonymous parameter"
| Some id -> id
toString (SynExpr.CreateIdent paramValueId) paramValue.Type
|> SynExpr.CreateParen
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
)
|> SynExpr.CreateParen
|> SynExpr.plus (SynExpr.plus uri (SynExpr.CreateConstString ("&" + paramKey + "=")))
)
|> SynExpr.plus requestUriTrailer
|> SynExpr.CreateParen
let requestUri =
SynExpr.App (
ExprAtomicFlag.Atomic,
false,
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ]),
SynExpr.CreateParen (
SynExpr.plus
(SynExpr.App (
ExprAtomicFlag.Atomic,
false,
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "client" ; Ident.Create "BaseAddress" ; Ident.Create "ToString" ],
[ range0 ; range0 ],
[ None ; None ; None ]
)
),
SynExpr.CreateConst SynConst.Unit,
range0
))
requestUriTrailer
),
range0
)
let bodyParams =
info.Args
|> List.collect (fun arg ->
arg.Attributes
|> List.choose (fun attr ->
match attr with
| Body -> Some arg
| _ -> None
)
)
if not bodyParams.IsEmpty then
failwith "[<Body>] is not yet supported"
let httpReqMessageConstructor =
[
SynExpr.equals
(SynExpr.CreateIdentString "Method")
(SynExpr.CreateLongIdent (
SynLongIdent.Create
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ]
))
SynExpr.equals (SynExpr.CreateIdentString "RequestUri") requestUri
]
|> SynExpr.CreateParenedTuple
let returnExpr =
JsonParseGenerator.parseNode
JsonParseGenerator.JsonParseOption.None
info.ReturnType
(SynExpr.CreateIdentString "node")
let implementation =
[
yield LetBang ("ct", SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "CancellationToken" ]))
yield
Use (
"httpMessage",
SynExpr.New (
false,
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpRequestMessage" ]
),
httpReqMessageConstructor,
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
LetBang (
"response",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "SendAsync" ]),
SynExpr.CreateParenedTuple
[ SynExpr.CreateIdentString "httpMessage" ; SynExpr.CreateIdentString "ct" ]
)
)
)
yield
Let (
"response",
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "response" ; "EnsureSuccessStatusCode" ]),
SynExpr.CreateConst SynConst.Unit
)
)
yield
LetBang (
"stream",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "response" ; "Content" ; "ReadAsStreamAsync" ]
),
SynExpr.CreateIdentString "ct"
)
)
)
yield
LetBang (
"node",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create
[ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ]
),
SynExpr.CreateParenedTuple
[
SynExpr.CreateIdentString "stream"
SynExpr.equals
(SynExpr.CreateIdentString "cancellationToken")
(SynExpr.CreateIdentString "ct")
]
)
)
)
]
|> SynExpr.createCompExpr "async" returnExpr
|> SynExpr.startAsTask
SynMemberDefn.Member (
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
None,
implementation,
range0,
DebugPointAtBinding.Yes range0,
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 createModule
(opens : SynOpenDeclTarget list)
(ns : LongIdent)
(interfaceType : SynTypeDefn)
: SynModuleOrNamespace
=
let (SynTypeDefn (SynComponentInfo (_, _, _, interfaceName, _, _, _, _), synTypeDefnRepr, _, _, _, _)) =
interfaceType
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 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<foo>` 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
{
HttpMethod = httpMethod
UrlTemplate = url
ReturnType = ret
Arity = arity
Args = args
Identifier = ident
}
| _ -> failwithf "Unrecognised member definition: %+A" defn
)
| _ -> failwithf "Unrecognised SynTypeDefnRepr: %+A" synTypeDefnRepr
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),
None,
Some range0,
[],
constructed,
[],
range0,
range0
)
let createFunc =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Create " Create a REST client.",
SynValData.SynValData (
None,
SynValInfo.SynValInfo (
[ [ SynArgInfo.SynArgInfo ([], false, Some (Ident.Create "client")) ] ],
SynArgInfo.Empty
),
None
),
SynPat.CreateLongIdent (
SynLongIdent.CreateString "make",
[
SynPat.CreateParen (
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "client"),
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpClient" ]
)
)
)
]
),
Some (SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceName))),
interfaceImpl,
range0,
DebugPointAtBinding.NoneAtLet,
synBindingTriviaZero false
)
|> List.singleton
|> SynModuleDecl.CreateLet
let moduleName : LongIdent =
List.last interfaceName
|> fun ident -> ident.idText
|> fun s ->
if s.StartsWith 'I' then
s.[1..]
else
failwithf "Expected interface type to start with 'I', but was: %s" s
|> Ident.Create
|> List.singleton
let attribs =
[
SynAttributeList.Create SynAttribute.compilationRepresentation
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
]
let modInfo =
SynComponentInfo.Create (moduleName, attributes = attribs, xmldoc = docString)
SynModuleOrNamespace.CreateNamespace (
ns,
decls =
[
for openStatement in opens do
yield SynModuleDecl.CreateOpen openStatement
yield SynModuleDecl.CreateNestedModule (modInfo, [ createFunc ])
]
)
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.
[<MyriadGenerator("http-client")>]
@@ -32,6 +695,15 @@ 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 namespaceAndTypes =
types
|> List.choose (fun (ns, types) ->
@@ -45,7 +717,7 @@ type HttpClientGenerator () =
|> List.collect (fun (ns, types) ->
types
|> List.map (fun interfaceType ->
let clientModule = HttpClientGenerator.createModule ns interfaceType
let clientModule = HttpClientGenerator.createModule opens ns interfaceType
clientModule
)
)

17
WoofWare.Myriad.Plugins/JsonParseGenerator.fs
View File

@@ -333,25 +333,10 @@ module internal JsonParseGenerator =
let decls = [ createMaker recordId recordFields ]
let compilationRepresentation : SynAttribute =
{
TypeName = SynLongIdent.CreateString "CompilationRepresentation"
ArgExpr =
SynExpr.CreateLongIdent (
false,
SynLongIdent.Create [ "CompilationRepresentationFlags" ; "ModuleSuffix" ],
None
)
|> SynExpr.CreateParen
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let attributes =
[
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
SynAttributeList.Create compilationRepresentation
SynAttributeList.Create SynAttribute.compilationRepresentation
]
let xmlDoc =

17
WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs
View File

@@ -162,25 +162,10 @@ module internal RemoveOptionsGenerator =
createMaker [ Ident.Create "Short" ] recordId recordFields
]
let compilationRepresentation : SynAttribute =
{
TypeName = SynLongIdent.CreateString "CompilationRepresentation"
ArgExpr =
SynExpr.CreateLongIdent (
false,
SynLongIdent.Create [ "CompilationRepresentationFlags" ; "ModuleSuffix" ],
None
)
|> SynExpr.CreateParen
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let attributes =
[
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
SynAttributeList.Create compilationRepresentation
SynAttributeList.Create SynAttribute.compilationRepresentation
]
let xmlDoc =

4
WoofWare.Myriad.Plugins/SurfaceBaseline.txt
View File

@@ -1,3 +1,7 @@
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.JsonParseAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.JsonParseGenerator inherit obj, implements Myriad.Core.IMyriadGenerator

22
WoofWare.Myriad.Plugins/SynAttribute.fs Normal file
View File

@@ -0,0 +1,22 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
open Myriad.Core
[<RequireQualifiedAccess>]
module internal SynAttribute =
let internal compilationRepresentation : SynAttribute =
{
TypeName = SynLongIdent.CreateString "CompilationRepresentation"
ArgExpr =
SynExpr.CreateLongIdent (
false,
SynLongIdent.Create [ "CompilationRepresentationFlags" ; "ModuleSuffix" ],
None
)
|> SynExpr.CreateParen
Target = None
AppliesToGetterAndSetter = false
Range = range0
}

96
WoofWare.Myriad.Plugins/SynExpr.fs
View File

@@ -6,6 +6,12 @@ open Myriad.Core
open Myriad.Core.Ast
open Fantomas.FCS.Text.Range
type internal CompExprBinding =
| LetBang of varName : string * rhs : SynExpr
| Let of varName : string * rhs : SynExpr
| Use of varName : string * rhs : SynExpr
| Do of body : SynExpr
[<RequireQualifiedAccess>]
module internal SynExpr =
@@ -80,6 +86,22 @@ module internal SynExpr =
b
)
/// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Addition",
[],
[ Some (IdentTrivia.OriginalNotation "+") ]
)
),
a
),
b
)
let stripOptionalParen (expr : SynExpr) : SynExpr =
match expr with
| SynExpr.Paren (expr, _, _, _) -> expr
@@ -156,3 +178,77 @@ module internal SynExpr =
let reraise : SynExpr =
SynExpr.CreateApp (SynExpr.CreateIdent (Ident.Create "reraise"), SynExpr.CreateConst SynConst.Unit)
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (body : SynExpr) =
let lambda =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "StartAsTask" ]),
SynExpr.CreateParenedTuple
[
SynExpr.CreateLongIdent (SynLongIdent.CreateString "a")
equals
(SynExpr.LongIdent (true, SynLongIdent.CreateString "cancellationToken", None, range0))
(SynExpr.CreateLongIdent (SynLongIdent.CreateString "ct"))
]
)
|> createLambda "a"
pipeThroughFunction lambda body
/// {compExpr} { {lets} ; return {ret} }
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
let contents : SynExpr =
(retStatement, List.rev lets)
||> List.fold (fun state binding ->
match binding with
| LetBang (lhs, rhs) ->
SynExpr.LetOrUseBang (
DebugPointAtBinding.Yes range0,
false,
true,
SynPat.CreateNamed (Ident.Create lhs),
rhs,
[],
state,
range0,
{
EqualsRange = Some range0
}
)
| Let (lhs, rhs) ->
SynExpr.LetOrUse (
false,
false,
[ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
| Use (lhs, rhs) ->
SynExpr.LetOrUse (
false,
true,
[ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
| Do body -> SynExpr.Do (body, range0)
)
SynExpr.CreateApp (
SynExpr.CreateIdent (Ident.Create compExpr),
SynExpr.ComputationExpr (false, contents, range0)
)
/// {expr} |> Async.AwaitTask
let awaitTask (expr : SynExpr) : SynExpr =
expr
|> pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "AwaitTask" ]))

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

@@ -26,9 +26,10 @@
<ItemGroup>
<Compile Include="AstHelper.fs" />
<Compile Include="SynExpr.fs" />
<Compile Include="SynAttribute.fs" />
<Compile Include="RemoveOptionsGenerator.fs" />
<Compile Include="JsonParseGenerator.fs" />
<None Include="HttpClientGenerator.fs" />
<Compile Include="HttpClientGenerator.fs" />
<None Include="version.json" />
<EmbeddedResource Include="SurfaceBaseline.txt" />
<None Include="..\README.md">

4
WoofWare.Myriad.Plugins/version.json
View File

@@ -1,7 +1,7 @@
{
"version": "1.0",
"version": "1.1",
"publicReleaseRefSpec": [
"^refs/heads/main$"
],
"pathFilters": null
}
}