F# Database Abstractions using Donald

Database.fsx

open System
open System.Data
open System.Data.Common
open Donald

//
// Logging
type LogError =
    { Error   : exn
      Message : string }

type LogMessage =
    | LogError of LogError
    | LogVerbose of string

type IAppLogger =
    abstract member Write : LogMessage -> unit

type IAppLoggerFactory =
    abstract member CreateLogger : unit -> IAppLogger

//
// Abstractions
type IDbAction =
    abstract member Execute : unit -> Result<unit, ProviderError>
    abstract member Query : (IDataReader -> 'a) -> Result<'a list, ProviderError>
    abstract member QuerySingle : (IDataReader -> 'a) -> Result<'a option, ProviderError>

type IDbBatch =
    inherit IDisposable
    abstract member Save : unit -> unit
    abstract member Undo : unit -> unit
    abstract member CreateAction : sql: string -> param: (string * SqlType) list -> IDbAction

type IDbEffect =
    inherit IDisposable
    abstract member CreateAction : sql: string -> param: (string * SqlType) list -> IDbAction
    abstract member CreateBatch : unit -> IDbBatch

type IDbConnectionFactory =
    abstract member CreateConnection : unit -> IDbConnection

type IDbFixture =
    abstract member CreateUid : unit -> Guid
    abstract member CreateEffect : unit -> IDbEffect

//
// Implementation
module internal DbUnit =
    let toDetailString (dbUnit : DbUnit) =
        let cmd = dbUnit.Command
        let param =
            [ for i in 0 .. cmd.Parameters.Count - 1 ->
                let p = cmd.Parameters.[i] :?> DbParameter
                p.ParameterName, p.Value |> string ]

        sprintf "\nExecuting command:\n%A\n%A\n" param cmd.CommandText

    let toLogMessage (dbUnit : DbUnit) =
        LogVerbose (toDetailString dbUnit)

module internal DbError =
    let toLogMessage (result : Result<'a, DbError>) =
        let createLogMessge heading content =
            sprintf "\n%s:\n%s\n" heading content

        match result with
        | Error (DbConnectionError e) ->
            createLogMessge "Failed to connect" e.ConnectionString
            |> fun message -> LogError { Error = e.Error; Message = message }

        | Error (DbTransactionError e) ->
            createLogMessge "Failed to commit or rollback transaction" (string e.Step)
            |> fun message -> LogError { Error = e.Error; Message = message }

        | Error (DbExecutionError e) ->
            createLogMessge "Failed to execute" e.Statement
            |> fun message -> LogError { Error = e.Error; Message = message }

        | Error (DataReaderCastError e) ->
            createLogMessge "Failed to read and cast the following field" e.FieldName
            |> fun message -> LogError { Error = e.Error; Message = message }

        | Error (DataReaderOutOfRangeError e) ->
            createLogMessge "Failed to read the following field" e.FieldName
            |> fun message -> LogError { Error = e.Error; Message = message }

        | Ok record ->
            createLogMessge "Read data" (sprintf "\n%A\n" record)
            |> LogVerbose

    let toProviderError (result : Result<'a, DbError>) =
        match result with
        | Error (DbConnectionError _) ->
            Error (ProviderError [ "Could not connect to the database." ])

        | Error (DbTransactionError _) ->
            Error (ProviderError [ "Unable to save changes." ])

        | Error (DbExecutionError _) ->
            Error (ProviderError [ "Unable to execute operation." ])

        | Error (DataReaderCastError _)
        | Error (DataReaderOutOfRangeError _) ->
            Error (ProviderError [ "Unable to read data." ])

        | Ok record ->
            Ok record

module DbResult =
    let saveOrUndo (dbBatch : IDbBatch) (result : Result<'a, ProviderError>) =
        match result with
        | Ok x ->
            dbBatch.Save ()
            Ok x

        | Error e ->
            dbBatch.Undo ()
            Error e

type DbAction (cmd : IDbCommand, logger : IAppLogger) =
    let logCmd (logger : IAppLogger) (dbUnit : DbUnit) =
        logger.Write(DbUnit.toLogMessage dbUnit)
        dbUnit

    let logError (logger : IAppLogger) (result : Result<'a, DbError>) : Result<'a, DbError> =
        logger.Write(DbError.toLogMessage result)
        result

    interface IDbAction with
        member _.Execute () =
            new DbUnit(cmd)
            |> logCmd logger
            |> Db.exec
            |> logError logger
            |> DbError.toProviderError

        member _.Query map =
            new DbUnit(cmd)
            |> logCmd logger
            |> Db.query map
            |> logError logger
            |> DbError.toProviderError

        member _.QuerySingle map =
            new DbUnit(cmd)
            |> logCmd logger
            |> Db.querySingle map
            |> logError logger
            |> DbError.toProviderError

type DbBatch (transaction : IDbTransaction, logger : IAppLogger) =
    interface IDbBatch with
        member _.CreateAction sql param =
            let dbUnit =
                transaction.Connection
                |> Db.newCommand sql
                |> Db.setParams param
                |> Db.setTransaction transaction

            new DbAction(dbUnit.Command, logger)

        member _.Save () =
            transaction.TryCommit()

        member _.Undo () =
            transaction.TryRollback()

    interface IDisposable with
        member _.Dispose () =
            transaction.Dispose ()

type DbEffect (connection : IDbConnection, logger : IAppLogger) =
    interface IDbEffect with
        member _.CreateAction sql param =
            let dbUnit =
                connection
                |> Db.newCommand sql
                |> Db.setParams param

            new DbAction(dbUnit.Command, logger)

        member _.CreateBatch () =
            let transaction = connection.TryBeginTransaction ()
            new DbBatch(transaction, logger)

    interface IDisposable with
        member _.Dispose () =
            connection.Dispose ()

type DbFixture (connectionFactory : IDbConnectionFactory, logFactory : IAppLoggerFactory) =
    interface IDbFixture with
        member _.CreateUid () = Guid.NewGuid()

        member _.CreateEffect () =
            let connection = connectionFactory.CreateConnection()
            let logger = logFactory.CreateLogger()
            new DbEffect(connection, logger)