F# little ADO wrapper

Db.fs

module Db

open System
open System.IO
open System.Data
open System.Collections.Generic
open System.Reflection
open Microsoft.FSharp.Reflection

type DbCon =
    | Nested of IDbConnection
    | Direct of IDbConnection

type DataReader(reader:IDataReader) =
  member private x.Reader = reader
  member x.Read() = reader.Read()
  member x.asNameValue() =
    let r = x.Reader
    [| for i in 0 .. r.FieldCount - 1 ->
            let readerName = r.GetName(i)
            // printfn "Field: %s" readerName
            let readerValue = r.[ i ]
            (readerName, readerValue) |] |> dict

  member x.GetValue(name:string): 'R =
    unbox (x.Reader.[name])

  static member (?) (dr:DataReader, name:string) : 'R = 
    unbox (dr.Reader.[name])
  interface IDisposable with
    member x.Dispose() = reader.Dispose()

let fromDBNull (o: obj): 'a option =
    try
        if o = null || DBNull.Value.Equals o
            then None
            else Some (unbox o)
    with :? InvalidCastException as e ->
        let msg = sprintf "Can't cast '%s' to '%s'" (o.GetType().Name) (typeof<'a>.Name)
        raise <| InvalidCastException(msg, e)

let toDBNull =
    function
    | None -> box DBNull.Value
    | Some x -> box x


let _IsOption (t: Type) =
    if t.IsGenericType
        then t.GetGenericTypeDefinition() = typedefof<option<_>>
        else false

let IsOption (opt: obj) =
    if opt = null
        then false
        else _IsOption (opt.GetType())

let IsNone (opt: obj): bool =
    if not (IsOption opt)
        then invalidArg "opt" "Object must be of option type"
        else unbox <| opt.GetType().GetMethod("get_IsNone").Invoke(null, [| opt |])


let (|SomeObj|_|) =
  let ty = typedefof<option<_>>
  fun (a:obj) ->
    let aty = a.GetType()
    let v = aty.GetProperty("Value")
    if aty.IsGenericType && aty.GetGenericTypeDefinition() = ty then
      if a = null then None
      else Some(v.GetValue(a, [| |]))
    else None

let GetOptionValue (opt: obj) =
    match opt with
    | SomeObj(x1) -> x1
    | _ -> invalidArg "opt" "Object must be of option type"


let (|OSome|ONone|) (x: obj) : Choice<obj, unit> =
    if IsNone x
        then ONone
        else OSome (GetOptionValue x)

let (|OptionType|NotOptionType|) x =
    if IsOption x
        then OptionType
        else NotOptionType

let optionToDBNull =
    function
    | OSome x -> x
    | _ -> box DBNull.Value

let MakeOptionType (t: Type) =
    typedefof<option<_>>.MakeGenericType [| t |]

let MakeOptionNone (t: Type) =
    let opt = MakeOptionType t
    opt.InvokeMember("None", BindingFlags.Public ||| BindingFlags.Static ||| BindingFlags.GetProperty, null, null, null)

let MakeOptionSome (t: Type) (value: obj) =
    let opt = MakeOptionType t
    opt.InvokeMember("Some", BindingFlags.Public ||| BindingFlags.Static ||| BindingFlags.InvokeMethod, null, null, [| value |])

let UnwrapOption (t: Type) (o: obj option) =
    let isOption = _IsOption t
    let underlyingType =
        if isOption
            then t.GetGenericArguments().[0]
            else null
    match o, isOption with
    | None, true -> MakeOptionNone underlyingType
    | None, false -> failwithf "Can't map null to non-option type %s" t.Name
    | Some x, true -> MakeOptionSome underlyingType x
    | Some x, false -> x


/// Represents a parameter to a command
type Parameter = {
    DbType: DbType option
    Direction: ParameterDirection
    ParameterName: string
    Value: obj
} with
    static member make(parameterName, value: obj) =
        { DbType = None
          Direction = ParameterDirection.Input
          ParameterName = parameterName
          Value = value }

/// Adds a parameter to a command
let addParameter (cmd: #IDbCommand) (p: Parameter) =
    //print p.ParameterName
    let par = cmd.CreateParameter()
    match p.DbType with
    | Some t -> par.DbType <- t
    | None -> ()
    par.Direction <- p.Direction
    par.ParameterName <- p.ParameterName
    par.Value <-
        match p.Value with
        | null -> box DBNull.Value
        | OptionType -> optionToDBNull p.Value
        | x -> x
    cmd.Parameters.Add par |> ignore

let splitStr(source:string) (split:string) =
    source.Split([|split|], StringSplitOptions.None)

let loadSqlCommands(fileName) =
    let sql = File.ReadLines(fileName)
    let sb = new System.Text.StringBuilder()
    let mutable name = ""

    seq {
        for line in sql do
            if line.StartsWith("--name: ") then
                sb.Clear() |> ignore
                name <- (splitStr line "--name: ").[1]
            else
                if line.StartsWith("GO") then
                    printfn "CMD:::%s" name
                    yield name, sb.ToString()
                else
                    sb.AppendLine(line) |> ignore
    } |> Map.ofSeq

let printParam parameters =
    [|
        for p in parameters do
            yield p.ParameterName, p.Value
    |]

let makeCmd (con:#IDbConnection) sql (parameters: #seq<Parameter>) =
    let cmd = con.CreateCommand()
    cmd.CommandText <- sql
    parameters |> Seq.iter (addParameter cmd)
    cmd

let select (con:#IDbConnection) sql parameters =
    printfn "SELECT: %s: %A" sql (parameters |> printParam)

    use cmd = makeCmd con sql parameters

    let rows = new DataReader(cmd.ExecuteReader())
    [|
        while rows.Read() do
            yield rows.asNameValue()
    |]

let exeSql (con:#IDbConnection) sql =
    printfn "Script: %s" sql
    use cmd = makeCmd con sql []

    cmd.ExecuteNonQuery()

let cmdSql (con:#IDbConnection) sql parameters =
    printfn "CMD: %s" sql
    use cmd = makeCmd con sql parameters

    cmd.ExecuteNonQuery()

let queryScalar (con:#IDbConnection) sql parameters =
    printfn "SCALAR: %s" sql
    use cmd = makeCmd con sql parameters

    let r = cmd.ExecuteScalar() |> fromDBNull 
    match r with
    | Some x -> x
    | None -> failwithf "Sql: %s with %A return Null" sql parameters


let onTran (con:#IDbConnection) (fn:unit -> 'a) =
    use tran = con.BeginTransaction()

    printfn "%s" "BEGIN TRAN"
    try
        let r = fn()

        tran.Commit()
        printfn "%s" "COMMIT TRAN"
        r
    with e -> 
        tran.Rollback()
        printfn "%s" "ROLLBACK TRAN"
        raise e

let internal strEq (a: string) (b: string) =
    StringComparer.InvariantCultureIgnoreCase.Equals(a, b)

/// Maps a row as a sequence of name,value
let asNameValue (r: IDataRecord) =
    let names = {0..r.FieldCount-1} |> Seq.map r.GetName
    let values = {0..r.FieldCount-1} |> Seq.map r.GetValue
    Seq.zip names values

let unpack(row:IDictionary<string, obj>, name) =
    unbox row.[name]

let toRecord<'a> (row:IDictionary<string, obj>)=
    let createRecord = FSharpValue.PreComputeRecordConstructor(typeof<'a>)
    let make values = (createRecord values) :?> 'a
    let fields = FSharpType.GetRecordFields typeof<'a>
    let setOptionTypes (y: obj, p: PropertyInfo) =
        UnwrapOption p.PropertyType (fromDBNull y)

    let values =
        try
            [|
                for f in fields do
                    //printfn "Field: %s" f.Name
                    let value = row.[f.Name]
                    yield setOptionTypes(value, f)
            |]   
        with
        | :? KeyNotFoundException as ex -> 
            let names = [|for f in fields do yield f.Name|] |> Set.ofArray
            let keys = row.Keys |> Set.ofSeq
            let notFound = Set.difference names keys
            failwithf "%s: %A" ex.Message notFound

    make values