7 people like it.

A reversible stateful execution workflow

This is an attempt to define a workflow that contains reversible stateful computations. In the event of an exception being raised, all insofar successful operations will fold back to their original state. The implementation uses the notion of reversible computation primitives, which are composed using a free monad that is interpreted with a trampoline.

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
#r "System.Runtime.Serialization.dll"

type Reversible<'T> = private { Untyped : ReversibleExpr }

// the syntactic monad over reversible primitives
and private ReversibleExpr =
    | Primitive of ReversiblePrimitive
    | Bind of ReversibleExpr * (obj -> ReversibleExpr)
    | Sequential of ReversibleExpr seq
    // execution-specific branches
    | Continuation of (obj -> ReversibleExpr)
    | Value of obj * System.Type

// untyped reversible computation primitive
and private ReversiblePrimitive =
    {
        Execute : unit -> obj // untyped unit -> 'T
        Recover : obj -> unit // untyped 'T -> unit
        Finally : unit -> unit // execute regardless of outcome
        Type : System.Type
    }

and ReversibleBuilder() =
    member r.Return (x : 'T) : Reversible<'T> =
        let primitive = { Execute = (fun () -> x :> obj) ; Recover = ignore ; Finally = id ; Type = typeof<'T> }
        { Untyped = Primitive primitive }
    member r.Bind(f : Reversible<'T>, g : 'T -> Reversible<'S>) : Reversible<'S> =
        let g0 (o : obj) = (g (o :?> 'T)).Untyped
        { Untyped = Bind(f.Untyped, g0) }

    member r.Zero() = r.Return ()
    member r.Delay(f : unit -> Reversible<'T>) = r.Bind(r.Zero(), f)
    member r.Combine(f : Reversible<unit>, g : Reversible<'T>) = r.Bind(f, fun () -> g)
    member r.For(xs : 'T seq, f : 'T -> Reversible<unit>) : Reversible<unit> = 
        { Untyped = Sequential(seq { for t in xs -> (f t).Untyped } |> Seq.cache) }
    member r.While(b : unit -> bool, f : Reversible<unit>) : Reversible<unit> =
        { Untyped = Sequential(seq { while b () do yield f.Untyped } |> Seq.cache) }

let reversible = new ReversibleBuilder()

module Reversible =

    open System.Runtime.Serialization
    open System.IO

    /// executes a reversible workflow
    let run (f : Reversible<'T>) =
        let iter fs = List.iter (fun f -> f ()) fs

        // deep clone an object
        let clone (o : obj) =
            try
                let ndc = new NetDataContractSerializer()
                use stream = new MemoryStream()
                do ndc.Serialize(stream, o); stream.Position <- 0L
                ndc.Deserialize(stream)
            with _ -> o

        // lazy seq deconstructor AP
        let (|Cons|Nil|) (t : _ seq) =
            if Seq.isEmpty t then Nil
            else Cons(Seq.head t, Seq.skip 1 t)

        let rec eval ((recovs, finals) as state) =
            function
            | (Bind (f, g)) :: rest -> eval state (f :: Continuation g :: rest)
            | Sequential(Cons(f, fs)) :: rest -> eval state (f :: Sequential fs :: rest)
            | Sequential Nil :: rest -> eval state (Value (null,typeof<unit>) :: rest)
            | Primitive { Execute = exec ; Recover = recov ; Finally = final ; Type = t } :: rest ->
                let result, state' = 
                    try 
                        let result = exec ()
                        let closure = let r = clone result in fun () -> recov r
                        result, (closure :: recovs, final :: finals)
                    with e ->
                        iter recovs;
                        iter (List.rev finals);
                        raise e
                eval state' (Value (result, t) :: rest)
            | Value (o,_) :: Continuation f :: rest -> eval state (f o :: rest)
            | Value (o,_) :: [] -> iter (List.rev finals) ; o
            | Value (_,t) :: rest when t = typeof<unit> -> eval state rest
            | stack -> failwithf "stack error: %A" stack

        eval ([],[]) [f.Untyped] :?> 'T

    let ofPrimitive (execute : unit -> 'T) (recover : 'T -> unit) (final : unit -> unit) =
        let primitive = 
            { 
                Execute = fun () -> execute () :> obj
                Recover = fun o -> recover (o :?> 'T)
                Finally = final
                Type = typeof<'T>
            }
        { Untyped = Primitive primitive } : Reversible<'T>

    let failwith msg = ofPrimitive (fun () -> failwith msg) id id


// example 1

let test n = 
    Reversible.ofPrimitive (fun () -> printfn "Executing %d..." n)
                            (fun () -> printfn "Recovering %d..." n)
                            (fun () -> printfn "Finalizing %d..." n)

reversible {
    for i in 1 .. 10 do
        if i <> 7 then do! test i
        else do! Reversible.failwith "boom!"
} |> Reversible.run

// example 2

open System.IO

let delete (file : string) =
    let tmp = Path.GetTempFileName()
    Reversible.ofPrimitive (fun () -> printfn "Deleting %s..." file; File.Copy(file, tmp, true) ; File.Delete file)
                            (fun () -> printfn "Recovering %s..." file; File.Copy(tmp, file))
                            (fun () -> printfn "Cleaning up for %s..." file; File.Delete tmp)

let testFiles = 
    [0..9] 
    |> List.map (fun _ -> Path.GetTempFileName())
    |> List.mapi (fun i f -> File.WriteAllText(f, sprintf "file %d" i); f)

reversible {
    for f in testFiles @ ["/nonexistent.txt"] do
        do! delete f
} |> Reversible.run

testFiles |> List.map File.ReadAllText
type Reversible<'T> =
  private {Untyped: ReversibleExpr;}

Full name: Script.Reversible<_>
Reversible.Untyped: ReversibleExpr
type private ReversibleExpr =
  | Primitive of ReversiblePrimitive
  | Bind of ReversibleExpr * (obj -> ReversibleExpr)
  | Sequential of seq<ReversibleExpr>
  | Continuation of (obj -> ReversibleExpr)
  | Value of obj * Type

Full name: Script.ReversibleExpr
union case ReversibleExpr.Primitive: ReversiblePrimitive -> ReversibleExpr
type private ReversiblePrimitive =
  {Execute: unit -> obj;
   Recover: obj -> unit;
   Finally: unit -> unit;
   Type: Type;}

Full name: Script.ReversiblePrimitive
union case ReversibleExpr.Bind: ReversibleExpr * (obj -> ReversibleExpr) -> ReversibleExpr
type obj = System.Object

Full name: Microsoft.FSharp.Core.obj
union case ReversibleExpr.Sequential: seq<ReversibleExpr> -> ReversibleExpr
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
union case ReversibleExpr.Continuation: (obj -> ReversibleExpr) -> ReversibleExpr
union case ReversibleExpr.Value: obj * System.Type -> ReversibleExpr
namespace System
type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type
ReversiblePrimitive.Execute: unit -> obj
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
ReversiblePrimitive.Recover: obj -> unit
ReversiblePrimitive.Finally: unit -> unit
ReversiblePrimitive.Type: System.Type
Multiple items
type ReversibleBuilder =
  new : unit -> ReversibleBuilder
  member Bind : f:Reversible<'T> * g:('T -> Reversible<'S>) -> Reversible<'S>
  member Combine : f:Reversible<unit> * g:Reversible<'T> -> Reversible<'T>
  member Delay : f:(unit -> Reversible<'T>) -> Reversible<'T>
  member For : xs:seq<'T> * f:('T -> Reversible<unit>) -> Reversible<unit>
  member Return : x:'T -> Reversible<'T>
  member While : b:(unit -> bool) * f:Reversible<unit> -> Reversible<unit>
  member Zero : unit -> Reversible<unit>

Full name: Script.ReversibleBuilder

--------------------
new : unit -> ReversibleBuilder
val r : ReversibleBuilder
member ReversibleBuilder.Return : x:'T -> Reversible<'T>

Full name: Script.ReversibleBuilder.Return
val x : 'T
val primitive : ReversiblePrimitive
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val typeof<'T> : System.Type

Full name: Microsoft.FSharp.Core.Operators.typeof
member ReversibleBuilder.Bind : f:Reversible<'T> * g:('T -> Reversible<'S>) -> Reversible<'S>

Full name: Script.ReversibleBuilder.Bind
val f : Reversible<'T>
val g : ('T -> Reversible<'S>)
val g0 : (obj -> ReversibleExpr)
val o : obj
member ReversibleBuilder.Zero : unit -> Reversible<unit>

Full name: Script.ReversibleBuilder.Zero
member ReversibleBuilder.Return : x:'T -> Reversible<'T>
member ReversibleBuilder.Delay : f:(unit -> Reversible<'T>) -> Reversible<'T>

Full name: Script.ReversibleBuilder.Delay
val f : (unit -> Reversible<'T>)
member ReversibleBuilder.Bind : f:Reversible<'T> * g:('T -> Reversible<'S>) -> Reversible<'S>
member ReversibleBuilder.Zero : unit -> Reversible<unit>
member ReversibleBuilder.Combine : f:Reversible<unit> * g:Reversible<'T> -> Reversible<'T>

Full name: Script.ReversibleBuilder.Combine
val f : Reversible<unit>
val g : Reversible<'T>
member ReversibleBuilder.For : xs:seq<'T> * f:('T -> Reversible<unit>) -> Reversible<unit>

Full name: Script.ReversibleBuilder.For
val xs : seq<'T>
val f : ('T -> Reversible<unit>)
val t : 'T
module Seq

from Microsoft.FSharp.Collections
val cache : source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.cache
member ReversibleBuilder.While : b:(unit -> bool) * f:Reversible<unit> -> Reversible<unit>

Full name: Script.ReversibleBuilder.While
val b : (unit -> bool)
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
val reversible : ReversibleBuilder

Full name: Script.reversible
namespace System.Runtime
namespace System.Runtime.Serialization
namespace System.IO
val run : f:Reversible<'T> -> 'T

Full name: Script.Reversible.run


 executes a reversible workflow
val iter : ((unit -> unit) list -> unit)
val fs : (unit -> unit) list
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val iter : action:('T -> unit) -> list:'T list -> unit

Full name: Microsoft.FSharp.Collections.List.iter
val f : (unit -> unit)
val clone : (obj -> obj)
val ndc : NetDataContractSerializer
Multiple items
type NetDataContractSerializer =
  inherit XmlObjectSerializer
  new : unit -> NetDataContractSerializer + 6 overloads
  member AssemblyFormat : FormatterAssemblyStyle with get, set
  member Binder : SerializationBinder with get, set
  member Context : StreamingContext with get, set
  member Deserialize : stream:Stream -> obj
  member IgnoreExtensionDataObject : bool
  member IsStartObject : reader:XmlReader -> bool + 1 overload
  member MaxItemsInObjectGraph : int
  member ReadObject : reader:XmlReader -> obj + 2 overloads
  member Serialize : stream:Stream * graph:obj -> unit
  ...

Full name: System.Runtime.Serialization.NetDataContractSerializer

--------------------
NetDataContractSerializer() : unit
NetDataContractSerializer(context: StreamingContext) : unit
NetDataContractSerializer(rootName: string, rootNamespace: string) : unit
NetDataContractSerializer(rootName: System.Xml.XmlDictionaryString, rootNamespace: System.Xml.XmlDictionaryString) : unit
NetDataContractSerializer(context: StreamingContext, maxItemsInObjectGraph: int, ignoreExtensionDataObject: bool, assemblyFormat: Formatters.FormatterAssemblyStyle, surrogateSelector: ISurrogateSelector) : unit
NetDataContractSerializer(rootName: string, rootNamespace: string, context: StreamingContext, maxItemsInObjectGraph: int, ignoreExtensionDataObject: bool, assemblyFormat: Formatters.FormatterAssemblyStyle, surrogateSelector: ISurrogateSelector) : unit
NetDataContractSerializer(rootName: System.Xml.XmlDictionaryString, rootNamespace: System.Xml.XmlDictionaryString, context: StreamingContext, maxItemsInObjectGraph: int, ignoreExtensionDataObject: bool, assemblyFormat: Formatters.FormatterAssemblyStyle, surrogateSelector: ISurrogateSelector) : unit
val stream : MemoryStream
Multiple items
type MemoryStream =
  inherit Stream
  new : unit -> MemoryStream + 6 overloads
  member CanRead : bool
  member CanSeek : bool
  member CanWrite : bool
  member Capacity : int with get, set
  member Flush : unit -> unit
  member GetBuffer : unit -> byte[]
  member Length : int64
  member Position : int64 with get, set
  member Read : buffer:byte[] * offset:int * count:int -> int
  ...

Full name: System.IO.MemoryStream

--------------------
MemoryStream() : unit
MemoryStream(capacity: int) : unit
MemoryStream(buffer: byte []) : unit
MemoryStream(buffer: byte [], writable: bool) : unit
MemoryStream(buffer: byte [], index: int, count: int) : unit
MemoryStream(buffer: byte [], index: int, count: int, writable: bool) : unit
MemoryStream(buffer: byte [], index: int, count: int, writable: bool, publiclyVisible: bool) : unit
NetDataContractSerializer.Serialize(stream: Stream, graph: obj) : unit
property MemoryStream.Position: int64
NetDataContractSerializer.Deserialize(stream: Stream) : obj
val t : seq<'a>
val isEmpty : source:seq<'T> -> bool

Full name: Microsoft.FSharp.Collections.Seq.isEmpty
val head : source:seq<'T> -> 'T

Full name: Microsoft.FSharp.Collections.Seq.head
val skip : count:int -> source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.skip
val eval : ((unit -> unit) list * (unit -> unit) list -> ReversibleExpr list -> obj)
val recovs : (unit -> unit) list
val finals : (unit -> unit) list
val state : (unit -> unit) list * (unit -> unit) list
val f : ReversibleExpr
val g : (obj -> ReversibleExpr)
val rest : ReversibleExpr list
active recognizer Cons: seq<'a> -> Choice<('a * seq<'a>),unit>
val fs : seq<ReversibleExpr>
active recognizer Nil: seq<'a> -> Choice<('a * seq<'a>),unit>
val exec : (unit -> obj)
val recov : (obj -> unit)
val final : (unit -> unit)
val t : System.Type
val result : obj
val state' : (unit -> unit) list * (unit -> unit) list
val closure : (unit -> unit)
val r : obj
val e : exn
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
val raise : exn:System.Exception -> 'T

Full name: Microsoft.FSharp.Core.Operators.raise
val f : (obj -> ReversibleExpr)
val stack : ReversibleExpr list
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val ofPrimitive : execute:(unit -> 'T) -> recover:('T -> unit) -> final:(unit -> unit) -> Reversible<'T>

Full name: Script.Reversible.ofPrimitive
val execute : (unit -> 'T)
val recover : ('T -> unit)
val failwith : msg:string -> Reversible<unit>

Full name: Script.Reversible.failwith
val msg : string
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val test : n:int -> Reversible<unit>

Full name: Script.test
val n : int
Multiple items
module Reversible

from Script

--------------------
type Reversible<'T> =
  private {Untyped: ReversibleExpr;}

Full name: Script.Reversible<_>
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val i : int
val delete : file:string -> Reversible<unit>

Full name: Script.delete
val file : string
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
val tmp : string
type Path =
  static val DirectorySeparatorChar : char
  static val AltDirectorySeparatorChar : char
  static val VolumeSeparatorChar : char
  static val InvalidPathChars : char[]
  static val PathSeparator : char
  static member ChangeExtension : path:string * extension:string -> string
  static member Combine : [<ParamArray>] paths:string[] -> string + 3 overloads
  static member GetDirectoryName : path:string -> string
  static member GetExtension : path:string -> string
  static member GetFileName : path:string -> string
  ...

Full name: System.IO.Path
Path.GetTempFileName() : string
type File =
  static member AppendAllLines : path:string * contents:IEnumerable<string> -> unit + 1 overload
  static member AppendAllText : path:string * contents:string -> unit + 1 overload
  static member AppendText : path:string -> StreamWriter
  static member Copy : sourceFileName:string * destFileName:string -> unit + 1 overload
  static member Create : path:string -> FileStream + 3 overloads
  static member CreateText : path:string -> StreamWriter
  static member Decrypt : path:string -> unit
  static member Delete : path:string -> unit
  static member Encrypt : path:string -> unit
  static member Exists : path:string -> bool
  ...

Full name: System.IO.File
File.Copy(sourceFileName: string, destFileName: string) : unit
File.Copy(sourceFileName: string, destFileName: string, overwrite: bool) : unit
File.Delete(path: string) : unit
val testFiles : string list

Full name: Script.testFiles
val map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map
val mapi : mapping:(int -> 'T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.mapi
val f : string
File.WriteAllText(path: string, contents: string) : unit
File.WriteAllText(path: string, contents: string, encoding: System.Text.Encoding) : unit
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
File.ReadAllText(path: string) : string
File.ReadAllText(path: string, encoding: System.Text.Encoding) : string
Raw view Test code New version

More information

Link:http://fssnip.net/fZ
Posted:11 years ago
Author:Eirik Tsarpalis
Tags: reversible computation , workflow , stateful execution