Validation Workflow

Validation.fs

module RockSpot.Runtime.Validation

open Microsoft.FSharp.Quotations
open System
open System.Text

open FSharpx.Regex.Compiled
open FSharpx.Linq.QuotationEvaluation

type Test =
    | Success
    | Failure of string

type ValidationError =
    { Name : string;
      Message : string }

type 'a Validation =
    | Valid of 'a
    | Invalid of 'a * ValidationError list

type SkipMode =
    /// Won't skip any tests regardless of the state.
    | Disabled
    /// Will skip tests  on properties and fields that
    /// have failures.
    | PerProperty
    /// Will skip all remaining tests on encountering
    /// the first failure.
    | Enabled

module Operations =
    let private unknownFieldName = "_"

    let succeed x = Valid x

    let failMany x errors = Invalid (x, errors)

    let fail x error = failMany x (error :: [])

    let bind skipMode func expr =
        match expr with
        | Valid a -> func a
        | Invalid (a, errors) ->
            match skipMode with
            | Disabled ->
                match func a with
                | Valid _ -> expr
                | Invalid (x, er) -> failMany x (List.head er :: errors)
            | PerProperty ->
                match func a with
                | Valid _ -> expr
                | Invalid (x, ers) ->
                    // Might implement a lookup dictionary to avoid
                    // traversing the entire list of errors.
                    let er = List.head ers
                    if er.Name <> unknownFieldName && List.exists (fun e -> e.Name = er.Name) errors then
                        expr
                    else
                        failMany x (er :: errors)
            | Enabled -> expr


    let (|PropertyPath|_|) expr =
        let rec propertyPath expr lst =
            match expr with
            | Patterns.PropertyGet (Some inst, pi, args) ->
                propertyPath inst (pi.Name :: lst)
            | Patterns.FieldGet (Some inst, fi) ->
                propertyPath inst (fi.Name :: lst)
            | _ ->
                if List.isEmpty lst then None
                else Some lst

        let accumulate (sb : StringBuilder) (name : string) =
            if sb.Length = 0 then sb.Append(name)
            else sb.Append(".").Append(name)

        match propertyPath expr [] with
        | Some lst -> Some (lst |> List.fold accumulate (new StringBuilder()) |> toString)
        | None -> None

    let extractPath (propQ : 'a Expr) =
        match propQ with
        | PropertyPath path -> path
        | Patterns.Value (_, ty) ->
            if ty = typeof<'a> then unknownFieldName
            else failwith (sprintf "Type mismatch, expected %s but found %s." typeof<'a>.Name ty.Name)
        | _ -> failwith "Unsupported expression."

    let run func name value entity =
        match func value with
        | Success -> succeed entity
        | Failure msg -> fail entity { Name = name; Message = msg }

    let evalAndRun func propQ entity =
        let name = extractPath propQ
        let value = propQ.Eval()

        run func name value entity

    let bindifyQuotation func propQ = fun entity ->
        evalAndRun func propQ entity

    let bindifyTest func = fun entity ->
        run func unknownFieldName () entity

type ValidationBuilder<'a>(entity : 'a, skipMode) =

    member this.Bind(comp, func) =
        Operations.bind skipMode func comp

    [<CustomOperation("external", MaintainsVariableSpace = true)>]
    member this.BindQuotation(comp, func, propQ) =
        this.Bind(comp, (Operations.bindifyQuotation func propQ))

    [<CustomOperation("adhoc", MaintainsVariableSpace = true)>]
    member this.BindTest(comp, [<ProjectionParameter>] func) =
        this.Bind(comp, (Operations.bindifyTest func))

    member this.Yield(value) =
        Operations.succeed entity

let (|Valid|Invalid|) = function
    | Validation.Valid _ -> Valid
    | Validation.Invalid (_, errors) -> Invalid (List.rev errors)


let toException errors =
    errors
    |> List.map (fun e -> ArgumentException(e.Message, e.Name) :> Exception)
    |> List.toSeq
    |> (fun x -> AggregateException(x))

let validation (entity : 'a) skipMode = new ValidationBuilder<'a>(entity, skipMode)

module SkipDisabled =
    let validation (entity : 'a) = validation entity Disabled

module SkipEnabled =
    let validation (entity : 'a) = validation entity Enabled

module SkipPerProperty =
    let validation (entity : 'a) = validation entity PerProperty

[<RequireQualifiedAccess>]
module Objects =

    let required (value : obj) =
        let fail () = Failure "Field is required."
        
        if value |> isNull then fail()
        elif value |> getType = typeof<string> && 
            (value :?> string) |> isNullOrWhiteSpace then fail()
        else Success

[<AutoOpen>]
module ObjectsPervasives =     
    type ValidationBuilder<'a> with

        [<CustomOperation("required")>]
        member this.Required(comp, expr) =
            this.BindQuotation(comp, Objects.required, expr)

[<RequireQualifiedAccess>]
module Options =

    let optional func value =
        let func = Option.bind (fun x -> if x |> isNotNull then Some (func x) else Some Success)        
        match func value with
        | Some res -> res
        | None -> Success

[<AutoOpen>]
module OptionsPervasives =
    type ValidationBuilder<'a> with
    
        [<CustomOperation("option", MaintainsVariableSpace = true)>]
        member this.BindOption(comp, func, propQ) =
            this.Bind(comp, (Operations.bindifyQuotation (Options.optional func) propQ))

[<RequireQualifiedAccess>]
module Strings =
        
    let minLength length (value : string) =
        let value = trim value
        if value.Length <= length then Success
        else Failure (sprintf "The value must have at least %d characters." length)

    let maxLength length (value : string) =
        let value = trim value
        if  value.Length <= length then Success
        else Failure (sprintf "The value must have at least %d characters." length)

    let between min max (value : string) =
        let value = trim value
        if value.Length >= min && value.Length <= max then Success
        else Failure (sprintf "The value must have between %d and %d charcters." min max)

    [<Literal>]
    let private emailRegex =
        "^[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*\
        @(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?$"

    let email (value : string) =
        let value = safe value
        match value with
        | Match emailRegex _ -> Success
        | _ -> Failure "Invalid e-mail address."

[<AutoOpen>]
module StringsPervasives =
    type ValidationBuilder<'a> with

        [<CustomOperation("minLength")>]
        member this.MinLength(comp, expr, length) =
            this.BindQuotation(comp, (Strings.minLength length), expr)

        [<CustomOperation("maxLength")>]
        member this.MaxLength(comp, expr, length) =
            this.BindQuotation(comp, (Strings.maxLength length), expr)

        [<CustomOperation("between")>]
        member this.MaxLength(comp, expr, min, max) =
            this.BindQuotation(comp, (Strings.between min max), expr)
            
        [<CustomOperation("email")>]
        member this.Email(comp, expr) =
            this.BindQuotation(comp, Strings.email, expr)


module private Tests =
    open SkipPerProperty


    type User = { Name : string; Age : int; LastName : string option }
    
    let validate ux = validation ux {
        required  <@ ux.Name @>
        minLength <@ ux.Name @> 3
        adhoc (if ux.Name = "Diego" then Success else Failure "Oops.")
        external (Strings.between 10 20) <@ ux.Name @>
        option (Strings.minLength 3) <@ ux.LastName @>
    }

    let print = function
        | Valid -> printfn "Success\n\n"
        | Invalid errors -> printfn "Errors: %A\n\n" errors

    let validateAndPrint = validate >> print

    let test () =

        { Name = "Diego"; Age = 26; LastName = None } |> validateAndPrint
        { Name = ""; Age = 26; LastName = Some "Frata" } |> validateAndPrint
        { Name = "Diego"; Age = 22; LastName = None } |> validateAndPrint
        { Name = ""; Age = 22; LastName = None } |> validateAndPrint
        
//*)