F# Computation Expression for ADO.NET TRANsactional Queries

Program.fs

open System.Data.SqlClient
open Tranq
open Tranq.Directive

let insert = required {
  let! _ = Database.execute "insert person (id, name) values (1, 'hoge1')"
  let! _ = Database.execute "insert person (id, name) values (2, 'hoge2')"
  let! _ = Database.execute "insert person (id, name) values (3, 'hoge3')"
  return () }

let delete = required {
  let! _ = Database.execute "delete from person"
  return () }

let query = required {
  return! Database.query "select * from person" }

let manipulate = requiresNew {
  do! insert
  let! result = query
  do! delete
  return result }

[<EntryPoint>]
let main _ = 
  let provider() =
    let config = "Data Source=.\SQLEXPRESS;Initial Catalog=SampleDB;Integrated Security=True"
    new SqlConnection(config) :> System.Data.Common.DbConnection

  match runTx manipulate provider with
  | Some result -> 
    result |> Seq.iter (printfn "%A")
  | _ -> 
    printfn "failed"
  0

Tranq.fs

namespace Tranq

open System.Data
open System.Data.Common

[<AutoOpen>]
module internal Helper =

  let confirmOpen (con: DbConnection) =
    if con.State <> ConnectionState.Open then
      con.Open()
    con

type TxContext = { 
  provider: unit -> DbConnection
  con: DbConnection
  tx: DbTransaction option }

type TxBlock<'R> = TxBlock of (TxContext -> 'R option)

type TxAttr = Required | RequiresNew | Suppress

type TxBlockBuilder(txAttr: TxAttr, level: IsolationLevel) =
  let run (TxBlock block) ctx = block ctx
  member this.Return(result) = TxBlock(fun _ -> Some result)
  member this.ReturnFrom(m) = m
  member this.Bind(m, f) = TxBlock(fun ctx -> 
    match run m ctx with
    | Some out -> run (f out) ctx
    | _ -> None)
  member this.Delay(f) = TxBlock(fun ctx -> 
    let runDelay ctx = run (f()) ctx
    let completeTx result (tx: DbTransaction) =
      match result with
      | Some _ -> tx.Commit()
      | _ -> tx.Rollback()
      result
    match txAttr, ctx.tx with
    | Required, Some _ -> 
      runDelay ctx
    | Required, None
    | RequiresNew, None ->
      let con = confirmOpen ctx.con
      use tx = con.BeginTransaction(level)
      let result = runDelay {ctx with con = con; tx = Some tx }
      completeTx result tx
    | RequiresNew, Some _ ->
      use con = confirmOpen (ctx.provider())
      use tx = con.BeginTransaction(level)
      let result = runDelay {ctx with con = con; tx = Some tx }
      completeTx result tx
    | Suppress, _ -> 
      use con = confirmOpen (ctx.provider())
      runDelay {ctx with con = con; tx = None })

module Database =

  let private createCommand sql (con: DbConnection) tx =
    let con = confirmOpen con
    let cmd = con.CreateCommand()
    tx |> Option.iter (fun tx -> cmd.Transaction <- tx)
    cmd.CommandText <- sql
    cmd

  let query sql = TxBlock(fun { con = con; tx = tx } ->
    use cmd = createCommand sql con tx
    let ary = ResizeArray()
    use reader = cmd.ExecuteReader()
    while reader.Read() do
      [ 0 .. reader.FieldCount - 1 ]
      |> Seq.map (fun i -> reader.GetName(i), reader.GetValue(i))
      |> Map.ofSeq
      |> ary.Add
    Some ary)

  let execute sql = TxBlock(fun { con = con; tx = tx } ->
    use cmd = createCommand sql con tx
    let ret = cmd.ExecuteNonQuery()
    Some ret )

module Directive =

  let txBlock txAttr level = TxBlockBuilder(txAttr, level)
  let required = txBlock Required IsolationLevel.ReadCommitted
  let requiresNew = txBlock RequiresNew IsolationLevel.ReadCommitted
  let suppress = txBlock Suppress IsolationLevel.ReadCommitted

  let abort = TxBlock(fun _ -> None)

  let runTx (TxBlock block) provider = 
    use con = provider()
    block { provider = provider; con = con; tx = None }