FSharp.Data.Npgsql retry functionality and related enhancements.

src/DesignTime/DesignTime.fsproj

@@ -10,8 +10,7 @@
     <AutoGenerateBindingRedirects>true</AutoGenerateBindingRedirects>
     <DisableImplicitFSharpCoreReference>true</DisableImplicitFSharpCoreReference>
     <DisableImplicitSystemValueTupleReference>true</DisableImplicitSystemValueTupleReference>
-    <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
-    <WarningsAsErrors>1182</WarningsAsErrors>
+    <TreatWarningsAsErrors>false</TreatWarningsAsErrors>
     <LangVersion>preview</LangVersion>
   </PropertyGroup>
   <ItemGroup>

src/DesignTime/NpgsqlConnectionProvider.fs

@@ -11,14 +11,15 @@ open System.Collections.Concurrent
 open System.Reflection
 
 let mutable cacheInstanceCount = 0
-let methodsCache = ConcurrentDictionary<string, ProvidedMethod> ()
+let methodsCache = ConcurrentDictionary<string * bool, ProvidedMethod> ()
 let typeCache = ConcurrentDictionary<string, ProvidedTypeDefinition> ()
 let schemaCache = ConcurrentDictionary<string, DbSchemaLookups> ()
 
 let addCreateCommandMethod(connectionString, rootType: ProvidedTypeDefinition,
                            commands: ProvidedTypeDefinition, customTypes: Map<string, ProvidedTypeDefinition>,
                            dbSchemaLookups: DbSchemaLookups, globalXCtor, globalPrepare: bool,
-                           providedTypeReuse, methodTypes, globalCollectionType: CollectionType, globalCommandTimeout : int) = 
+                           providedTypeReuse, methodTypes, globalCollectionType: CollectionType, globalCommandTimeout: int,
+                           globalTries: int, globalRetryWaitTime: int, globalAsyncChoice: bool) = 
 
     let staticParams = 
         [
@@ -31,21 +32,23 @@ let addCreateCommandMethod(connectionString, rootType: ProvidedTypeDefinition,
             if not globalXCtor then yield ProvidedStaticParameter("XCtor", typeof<bool>, false)
             yield ProvidedStaticParameter("Prepare", typeof<bool>, globalPrepare)
             yield ProvidedStaticParameter("CommandTimeout", typeof<int>, globalCommandTimeout)
+            yield ProvidedStaticParameter("Tries", typeof<int>, globalTries)
+            yield ProvidedStaticParameter("RetryWaitTime", typeof<int>, globalRetryWaitTime)
         ]
 
     let m = ProvidedMethod("CreateCommand", [], typeof<obj>, isStatic = true)
     m.DefineStaticParameters(staticParams, (fun methodName args ->
-        let sqlStatement, resultType, collectionType, singleRow, allParametersOptional, typename, xctor, (prepare: bool), (commandTimeout : int) = 
+        let sqlStatement, resultType, collectionType, singleRow, allParametersOptional, typename, xctor, (prepare: bool), (commandTimeout: int), (tries: int), (retryWaitTime: int) = 
             if not globalXCtor then
-                args.[0] :?> _ , args.[1] :?> _, args.[2] :?> _, args.[3] :?> _, args.[4] :?> _, args.[5] :?> _, args.[6] :?> _, args.[7] :?> _, args.[8] :?> _
+                args.[0] :?> _ , args.[1] :?> _, args.[2] :?> _, args.[3] :?> _, args.[4] :?> _, args.[5] :?> _, args.[6] :?> _, args.[7] :?> _, args.[8] :?> _, args.[9] :?> _, args.[10] :?> _
             else
-                args.[0] :?> _ , args.[1] :?> _, args.[2] :?> _, args.[3] :?> _, args.[4] :?> _, args.[5] :?> _, true, args.[6] :?> _, args.[7] :?> _
+                args.[0] :?> _ , args.[1] :?> _, args.[2] :?> _, args.[3] :?> _, args.[4] :?> _, args.[5] :?> _, true, args.[6] :?> _, args.[7] :?> _, args.[8] :?> _, args.[9] :?> _
 
         //let methodName = Regex.Replace(methodName, @"\s+", " ", RegexOptions.Multiline).Replace("\"", "").Replace("@", ":").Replace("CreateCommand,CommandText=", "").Trim()
         let commandTypeName = if typename <> "" then typename else methodName
 
         methodsCache.GetOrAdd(
-            commandTypeName,
+            (commandTypeName, globalAsyncChoice),
             fun _ ->    
                 if singleRow && not (resultType = ResultType.Records || resultType = ResultType.Tuples) then
                     invalidArg "SingleRow" "SingleRow can be set only for ResultType.Records or ResultType.Tuples."
@@ -66,13 +69,15 @@ let addCreateCommandMethod(connectionString, rootType: ProvidedTypeDefinition,
                             collectionType,
                             singleRow,
                             (if statements.Length > 1 then (i + 1).ToString () else ""),
-                            providedTypeReuse))
+                            providedTypeReuse,
+                            globalAsyncChoice))
 
                 let cmdProvidedType = ProvidedTypeDefinition (commandTypeName, Some typeof<ISqlCommandImplementation>, hideObjectMethods = true)
                 commands.AddMember cmdProvidedType
 
                 QuotationsFactory.AddTopLevelTypes cmdProvidedType parameters resultType methodTypes customTypes statements
                     (if resultType <> ResultType.Records || providedTypeReuse = NoReuse then cmdProvidedType else rootType)
+                    globalAsyncChoice
 
                 let designTimeConfig = 
                     Expr.Lambda (Var ("x", typeof<unit>),
@@ -85,6 +90,8 @@ let addCreateCommandMethod(connectionString, rootType: ProvidedTypeDefinition,
                             QuotationsFactory.BuildDataColumnsExpr (statements, resultType <> ResultType.DataTable)
                             Expr.Value prepare
                             Expr.Value commandTimeout
+                            Expr.Value tries
+                            Expr.Value retryWaitTime
                         ]))
 
                 let method = QuotationsFactory.GetCommandFactoryMethod (cmdProvidedType, designTimeConfig, xctor, commandTypeName)
@@ -160,7 +167,7 @@ let createTableTypes(customTypes : Map<string, ProvidedTypeDefinition>, item: Db
 
     tables
 
-let createRootType (assembly, nameSpace: string, typeName, connectionString, xctor, prepare, reuseProvidedTypes, methodTypes, collectionType, commandTimeout) =
+let createRootType (assembly, nameSpace: string, typeName, connectionString, xctor, prepare, reuseProvidedTypes, methodTypes, collectionType, commandTimeout, tries, retryWaitTime, asyncChoice) =
     if String.IsNullOrWhiteSpace connectionString then invalidArg "Connection" "Value is empty!" 
 
     let databaseRootType = ProvidedTypeDefinition (assembly, nameSpace, typeName, baseType = Some typeof<obj>, hideObjectMethods = true)
@@ -191,7 +198,7 @@ let createRootType (assembly, nameSpace: string, typeName, connectionString, xct
     let commands = ProvidedTypeDefinition("Commands", None)
     databaseRootType.AddMember commands
     let providedTypeReuse = if reuseProvidedTypes then WithCache typeCache else NoReuse
-    addCreateCommandMethod (connectionString, databaseRootType, commands, customTypes, schemaLookups, xctor, prepare, providedTypeReuse, methodTypes, collectionType, commandTimeout)
+    addCreateCommandMethod (connectionString, databaseRootType, commands, customTypes, schemaLookups, xctor, prepare, providedTypeReuse, methodTypes, collectionType, commandTimeout, tries, retryWaitTime, asyncChoice)
 
     databaseRootType
 
@@ -208,8 +215,11 @@ let internal getProviderType (assembly, nameSpace) =
             ProvidedStaticParameter("MethodTypes", typeof<MethodTypes>, MethodTypes.Sync ||| MethodTypes.Async)
             ProvidedStaticParameter("CollectionType", typeof<CollectionType>, CollectionType.List)
             ProvidedStaticParameter("CommandTimeout", typeof<int>, 0)
+            ProvidedStaticParameter("Tries", typeof<int>, 1)
+            ProvidedStaticParameter("RetryWaitTime", typeof<int>, 1000)
+            ProvidedStaticParameter("AsyncChoice", typeof<bool>, false)
         ],
-        fun typeName args -> typeCache.GetOrAdd (typeName, fun typeName -> createRootType (assembly, nameSpace, typeName, unbox args.[0], unbox args.[1], unbox args.[2], unbox args.[3], unbox args.[4], unbox args.[5], unbox args.[6])))
+        fun typeName args -> typeCache.GetOrAdd (typeName, fun typeName -> createRootType (assembly, nameSpace, typeName, unbox args.[0], unbox args.[1], unbox args.[2], unbox args.[3], unbox args.[4], unbox args.[5], unbox args.[6], unbox args.[7], unbox args.[8], unbox args.[9])))
 
     providerType.AddXmlDoc """
 <summary>Typed access to PostgreSQL programmable objects, tables and functions.</summary> 
@@ -220,6 +230,9 @@ let internal getProviderType (assembly, nameSpace) =
 <param name='MethodTypes'>Indicates whether to generate Execute, AsyncExecute or both methods for commands.</param>
 <param name='CollectionType'>Indicates whether rows should be returned in a list, array or ResizeArray.</param>
 <param name='CommandTimeout'>The time to wait (in seconds) while trying to execute a command before terminating the attempt and generating an error. Set to zero for infinity.</param>
+<param name='Tries'>The number of attempts alotted for a database operation. Set to 0 for infinity.</param>
+<param name='RetryWaitTime'>The time to wait (in milliseconds) while waiting to retry a databased operation before terminating the attempt and generating an error. Set to zero for infinity.</param>
+<param name='AsyncChoice'>Whether Async functions perform Async.Catch implcity and return Choice<'a, Exception> rather than 'a.</param>
 """
     providerType
 

src/DesignTime/QuotationsFactory.fs

@@ -5,7 +5,9 @@ open System.Data
 open System.Reflection
 open FSharp.Quotations
 open ProviderImplementation.ProvidedTypes
+open ProviderImplementation.ProvidedTypes.UncheckedQuotations
 open Npgsql
+open FSharp
 open FSharp.Data.Npgsql
 open InformationSchema
 open System.Collections.Concurrent
@@ -14,6 +16,7 @@ open System.Threading.Tasks
 type internal ReturnType = {
     Single: Type
     RowProvidedType: Type option
+    AsyncChoice: bool
 }
 
 type internal Statement = {
@@ -82,7 +85,8 @@ type internal QuotationsFactory () =
     static member GetMapperFromOptionToObj (t: Type, value: Expr) =
         Expr.Call (typeof<Utils>.GetMethod(nameof Utils.OptionToObj).MakeGenericMethod t, [ Expr.Coerce (value, typeof<obj>) ])
 
-    static member AddGeneratedMethod (sqlParameters: Parameter list, executeArgs: ProvidedParameter list, erasedType, providedOutputType, name) =
+    static member AddGeneratedMethod (sqlParameters: Parameter list, executeArgs: ProvidedParameter list, erasedType, providedOutputType: Type, asyncChoice, name) =
+
         let mappedInputParamValues (exprArgs: Expr list) = 
             (exprArgs.Tail, sqlParameters)
             ||> List.map2 (fun expr param ->
@@ -105,9 +109,21 @@ type internal QuotationsFactory () =
         let invokeCode exprArgs =
             let vals = mappedInputParamValues exprArgs
             let paramValues = if vals.IsEmpty then QuotationsFactory.ParamArrayEmptyExpr else Expr.NewArray (typeof<string * obj>, vals)
-            Expr.Call (Expr.Coerce (exprArgs.[0], erasedType), typeof<ISqlCommand>.GetMethod name, [ paramValues ])    
-
-        ProvidedMethod(name, executeArgs, providedOutputType, invokeCode)
+            let callWithoutChoice = Expr.Call (Expr.Coerce (exprArgs.[0], erasedType), typeof<ISqlCommand>.GetMethod name, [ paramValues ])
+            if  asyncChoice &&
+                providedOutputType.Name = (async { return () }).GetType().Name then
+                Expr.CallUnchecked (ProvidedTypeBuilder.MakeGenericMethod (typeof<Async>.GetMethod "Catch", [providedOutputType.GenericTypeArguments.[0]]), [callWithoutChoice])
+            else callWithoutChoice
+
+        let outputType =
+            if  asyncChoice &&
+                providedOutputType.Name = (async { return () }).GetType().Name then
+                let choiceType = ProvidedTypeBuilder.MakeGenericType (typedefof<Choice<_, _>>, [providedOutputType.GenericTypeArguments.[0]; typeof<Exception>])
+                let asyncType = ProvidedTypeBuilder.MakeGenericType ((async { return () }).GetType().GetGenericTypeDefinition(), [choiceType])
+                asyncType
+            else providedOutputType
+
+        ProvidedMethod(name, executeArgs, outputType, invokeCode)
 
     static member GetRecordType (rootTypeName, columns: Column list, customTypes: Map<string, ProvidedTypeDefinition>, typeNameSuffix, providedTypeReuse) =
         columns 
@@ -321,14 +337,14 @@ type internal QuotationsFactory () =
 
         tableType
 
-    static member GetOutputTypes (rootTypeName, sql, statementType, customTypes: Map<string, ProvidedTypeDefinition>, resultType, collectionType, singleRow, typeNameSuffix, providedTypeReuse) =    
+    static member GetOutputTypes (rootTypeName, sql, statementType, customTypes: Map<string, ProvidedTypeDefinition>, resultType, collectionType, singleRow, typeNameSuffix, providedTypeReuse, asyncChoice) =    
         let returnType =
             match resultType, statementType with
             | ResultType.DataReader, _
             | _, Control ->
                 None
             | _, NonQuery ->
-                Some { Single = typeof<int>; RowProvidedType = None }
+                Some { Single = typeof<int>; RowProvidedType = None; AsyncChoice = asyncChoice }
             | ResultType.DataTable, Query columns ->
                 let dataRowType = QuotationsFactory.GetDataRowType (customTypes, columns)
                 let dataTableType =
@@ -340,7 +356,7 @@ type internal QuotationsFactory () =
 
                 dataTableType.AddMember dataRowType
 
-                Some { Single = dataTableType; RowProvidedType = None }
+                Some { Single = dataTableType; RowProvidedType = None; AsyncChoice = asyncChoice }
             | _, Query columns ->
                 let providedRowType =
                     if List.length columns = 1 then
@@ -364,7 +380,8 @@ type internal QuotationsFactory () =
                             ProvidedTypeBuilder.MakeGenericType (typedefof<LazySeq<_>>, [ providedRowType ])
                         else
                             ProvidedTypeBuilder.MakeGenericType (typedefof<_ list>, [ providedRowType ])
-                    RowProvidedType = Some providedRowType }
+                    RowProvidedType = Some providedRowType
+                    AsyncChoice = asyncChoice }
 
         { Type = statementType; Sql = sql; ReturnType = returnType }
 
@@ -440,12 +457,12 @@ type internal QuotationsFactory () =
                 | _ ->
                     QuotationsFactory.DataColumnArrayEmptyExpr))
 
-    static member AddTopLevelTypes (cmdProvidedType: ProvidedTypeDefinition) parameters resultType (methodTypes: MethodTypes) customTypes statements typeToAttachTo =
+    static member AddTopLevelTypes (cmdProvidedType: ProvidedTypeDefinition) parameters resultType (methodTypes: MethodTypes) customTypes statements typeToAttachTo asyncChoice =
         let executeArgs = QuotationsFactory.GetExecuteArgs (parameters, customTypes)
 
         let addRedirectToISqlCommandMethods outputType xmlDoc =
             let add outputType name xmlDoc =
-                let m = QuotationsFactory.AddGeneratedMethod (parameters, executeArgs, cmdProvidedType.BaseType, outputType, name) 
+                let m = QuotationsFactory.AddGeneratedMethod (parameters, executeArgs, cmdProvidedType.BaseType, outputType, asyncChoice, name) 
                 Option.iter m.AddXmlDoc xmlDoc
                 cmdProvidedType.AddMember m
 
@@ -455,6 +472,18 @@ type internal QuotationsFactory () =
                 add (typedefof<Async<_>>.MakeGenericType outputType) "AsyncExecute" xmlDoc
             if methodTypes.HasFlag MethodTypes.Task then
                 add (typedefof<Task<_>>.MakeGenericType outputType) "TaskAsyncExecute" xmlDoc
+
+        let evt =
+            let evtName = "RetryEvent"
+            let evtType = typeof<Handler<Exception>>
+            let erasedType = cmdProvidedType.BaseType
+            ProvidedEvent (
+                evtName,
+                evtType,
+                (fun args -> Expr.Call (Expr.Coerce (args.[0], erasedType), typeof<ISqlCommand>.GetMethod ("add_" + evtName), [Expr.Coerce (args.[1], evtType)])),
+                (fun args -> Expr.Call (Expr.Coerce (args.[0], erasedType), typeof<ISqlCommand>.GetMethod ("remove_" + evtName), [Expr.Coerce (args.[1], evtType)])),
+                false)
+        cmdProvidedType.AddMember evt
 
         match statements with
         | _ when resultType = ResultType.DataReader ->