Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
open System
let dispose x = (x :> IDisposable).Dispose()
module Workflow =
/// Represents what we will tell the Twilio phone system to do
type PhoneCommand =
/// Connect the caller to a given phone queue
| ConnectToQueue of queueName:string
/// Say the message, and then hangup
| Hangup of msg:string
/// Say the message, then record the caller's message
| TakeMessage of msg:string
/// Say the message, then wait for a user to input a given number of key presses
| WaitForKeypresses of msg:string * numberDigits:int
/// What our workflow returns
type CallHandlingProgram =
| Complete of result:PhoneCommand
| InProgress of result:PhoneCommand * nextStep: (string -> CallHandlingProgram)
/// Use internally for any step where we need to wait for a string
type Internal = NeedKey of PhoneCommand
type CallBuilder() =
// No zero - we must return something
member this.Return(a:PhoneCommand) = Complete a
member this.ReturnFrom(a) = a
member this.Bind(NeedKey(x),f) = InProgress(x, fun x -> f(x) )
let call = new CallBuilder()
let waitForKeypress msg num = WaitForKeypresses(msg,num) |> NeedKey
module Example =
open Workflow
let listQueuesAndWaitForResponse() =
// We make this recursive so we can try a number of times before bugging out
let rec handleQueues retries = call {
let! keyPress = waitForKeypress "Please press 1 to discuss naughty lists, press 2 to discuss a reindeer malfunction, press 3 for any other enquires" 1
match keyPress with
| "1" -> return ConnectToQueue "Naughty children"
| "2" -> return ConnectToQueue "Naughty raindeer"
| "3" -> return ConnectToQueue "Account enquires"
| _ -> match retries with
| i when i >= 3 -> return Hangup "Sorry, key not recognised"
| _ -> return! handleQueues (retries+1)
}
handleQueues 0
let takeCall fromNumber toNumber (now:System.DateTime) =
call {
// 1. If the call is on Christmas Eve or later, leave a message saying we are busy
if now.DayOfYear >= 358 then // 358 is the 24th of December
return Hangup "I'm sorry, we are now shut for the rest of year, happy holidays !"
else
// 2. If the call is out of hours, request a message is left and email it to ourselves
// Elves are 9 to 5 workers
if now.Hour <= 8 || now.Hour >= 17 then
return TakeMessage "I'm sorry, we are closed for the day, please leave a message and we'll get back to you asap"
else
// 3. Offer to talk to elves, or take a mesasge
let! keyPress = waitForKeypress "Please press 1 to talk to one of our elves, or 2 to leave us a message" 1
match keyPress with
| "1" -> return! listQueuesAndWaitForResponse()
| "2" -> return TakeMessage "Please leave your message after the beep"
| _ -> return Hangup "Happy christmas!"
}
module CallHandling =
type CallDetails = { NumberFrom:string; NumberTo:String; CallAt: DateTime }
with static member Example = { NumberFrom = "0800 123456"; NumberTo = "01-DIAL-SANTA"; CallAt = DateTime(2000,01,01) }
type CallResponse =
| CompletedResponse of Workflow.PhoneCommand
| IntermediateResponse of Workflow.PhoneCommand
type internal CallHandlerMessages =
| CallStarted of AsyncReplyChannel<CallResponse>
| DigitsProvided of string * AsyncReplyChannel<CallResponse>
| PersistToStorage
type internal CallHandlerState = {
CurrentProgram: (string -> Workflow.CallHandlingProgram) option
Digits: string list
} with static member NotStarted = { CurrentProgram = None; Digits = [] }
type CallHandler(callDetails: CallDetails, persistAfter: TimeSpan) =
let getProgram() = Example.takeCall callDetails.NumberFrom callDetails.NumberTo callDetails.CallAt
let stepProgram reply state program =
match program with
| Workflow.Complete(resp) ->
CompletedResponse(resp) |> reply
state
| Workflow.InProgress(resp,next) ->
IntermediateResponse(resp) |> reply
{ state with CurrentProgram = Some next }
let resurrectViaReplay digitHistory =
let replayError _ = Workflow.Complete (Workflow.Hangup "Failed to replay history")
let state = CallHandlerState.NotStarted
let rec stepDigits keyPresses program =
match keyPresses with
| [] -> program
| key::other -> match (stepProgram ignore state (program key)).CurrentProgram with
| None -> replayError
| Some s -> stepDigits other s
let nextStep = match (stepProgram ignore state <| getProgram()).CurrentProgram with
| None -> replayError
| Some p -> p
nextStep |> stepDigits (List.rev digitHistory)
let agent = MailboxProcessor<_>.Start( fun inbox ->
let rec messageLoop (state: CallHandlerState) = async {
let! message = inbox.TryReceive(int persistAfter.TotalMilliseconds)
let newState =
match message with
| Some (CallStarted(caller)) ->
stepProgram caller.Reply state <| getProgram()
| Some (DigitsProvided(digits,caller)) ->
let program = match state.CurrentProgram with
| Some program -> program
| None -> resurrectViaReplay state.Digits
let state' = stepProgram caller.Reply state <| program(digits)
{ state' with Digits = digits :: state'.Digits } // store for later replay if needed
| Some PersistToStorage | None ->
// production version: persist state.Digits to secure storage
{ state with CurrentProgram = None }
return! messageLoop newState }
messageLoop CallHandlerState.NotStarted )
member x.StartSync() = agent.PostAndReply( CallStarted )
member x.StepSync(digits) = agent.PostAndReply( fun caller -> DigitsProvided(digits,caller) )
member internal x.DirectPost(msg) = agent.Post(msg) // For use by the switchboard to post directly to the agent
interface IDisposable with member __.Dispose() = dispose agent
module SwitchBoard =
/// The protocol definiton for interacting with the switch board agent
type private SwitchBoardProtocol<'Id,'Handler when 'Id: comparison and 'Handler :> IDisposable> =
| StoreHandler of id:'Id * handler:'Handler
| FindHandler of id:'Id * reply: AsyncReplyChannel<'Handler option>
| RemoveHandler of id:'Id // This is also responsible for disposing the object
| RequestOfHandler of id:'Id * toRun:( Result<'Handler,string> -> unit )
/// Object responsible for finding and routing calls to handler by id
/// This is essentially a thread safe Map of handlers which handles disposal
type Switchboard<'Id,'Handler when 'Id: comparison and 'Handler :> IDisposable>() =
let agent = MailboxProcessor<_>.Start( fun inbox ->
let rec messageLoop (state: Map<'Id,'Handler>) = async {
let! message = inbox.Receive()
let newState = match message with
| StoreHandler(id, handler) ->
state.Add(id,handler)
| RemoveHandler(id) -> match state.TryFind(id) with
| None -> state
| Some handler ->
dispose handler
state.Remove(id)
| FindHandler(id, channel) ->
state.TryFind(id) |> channel.Reply
state
| RequestOfHandler(id,f) -> match state.TryFind(id) with
| None ->
Error("Cannot find callId") |> f
state
| Some h ->
Ok(h) |> f
state
return! messageLoop newState
}
messageLoop Map.empty // Kick off the message loop with no open calls
)
interface IDisposable with member x.Dispose() = dispose agent
member x.StoreHandler(id,handler) = StoreHandler(id,handler) |> agent.Post
member x.FindHandler(id) = agent.PostAndReply( fun channel -> FindHandler(id,channel) ) // TODO: move to Async
member x.RemoveHandler(id) = RemoveHandler(id) |> agent.Post
member x.RequestOfHandler(id, getF) = agent.PostAndReply(fun channel -> RequestOfHandler(id, getF channel ))
module HttpEndpoint =
open CallHandling
open SwitchBoard
type HttpHandler(autoStoreTimeout) =
let switchBoard = new Switchboard<_,_>()
interface IDisposable with member x.Dispose() = dispose switchBoard
member x.StartCall(callId:string, numberFrom, numberTo,callAt) =
// create new object, get first response.
let handler = new CallHandler( { NumberFrom = numberFrom; NumberTo = numberTo; CallAt = callAt }, autoStoreTimeout)
match handler.StartSync() with
| CompletedResponse details as resp ->
resp // If complete we are done, note: we return the the resp to aid testing, in real life we would return details
| IntermediateResponse details as resp ->
do switchBoard.StoreHandler(callId,handler) // We are not done, so store the handler for next time
resp
member x.StepCall(callId,digits) =
let handler = switchBoard.FindHandler(callId)
match handler with
| None -> Workflow.Hangup "Unknown call" |> CompletedResponse
| Some handler ->
match handler.StepSync(digits) with
| IntermediateResponse details as resp -> resp
| CompletedResponse details as resp ->
// We are done so remove handler
do switchBoard.RemoveHandler(callId)
do (handler :> IDisposable).Dispose()
resp
member x.StepCallForwarded(callId,digits) =
// Rather than lookup the handler then call it, just ask the switchboard to pass the message straight through
let stepResult = switchBoard.RequestOfHandler(callId, fun channel ->
function
| Ok (handler:CallHandler) -> handler.DirectPost( CallHandlerMessages.DigitsProvided(digits,channel) )
| Error err -> channel.Reply(CallResponse.CompletedResponse (Workflow.Hangup err)))
match stepResult with
| IntermediateResponse details as resp -> resp
| CompletedResponse details as resp ->
// We are done so remove handler
do switchBoard.RemoveHandler(callId)
resp
module Testing =
open CallHandling
open Workflow
let private runTestScenarios simulateCall name =
let (=?) a b =
if a <> b then failwithf "%A does not equal %A" a b;
simulateCall (DateTime(2017,12,24)) [] =?
[ Hangup "I'm sorry, we are now shut for the rest of year, happy holidays !"]
simulateCall (DateTime(2017,12,22,17,0,0)) [ ] =?
[ TakeMessage "I'm sorry, we are closed for the day, please leave a message and we'll get back to you asap"]
simulateCall (DateTime(2017,12,22,12,0,0)) [ "2" ] =?
[ WaitForKeypresses("Please press 1 to talk to one of our elves, or 2 to leave us a message", 1)
TakeMessage "Please leave your message after the beep"]
simulateCall (DateTime(2017,12,22,12,0,0)) [ "1"; "4"; "4"; "2" ] =?
[ WaitForKeypresses("Please press 1 to talk to one of our elves, or 2 to leave us a message", 1)
WaitForKeypresses("Please press 1 to discuss naughty lists, press 2 to discuss a reindeer malfunction, press 3 for any other enquires",1)
WaitForKeypresses("Please press 1 to discuss naughty lists, press 2 to discuss a reindeer malfunction, press 3 for any other enquires",1)
WaitForKeypresses("Please press 1 to discuss naughty lists, press 2 to discuss a reindeer malfunction, press 3 for any other enquires",1)
ConnectToQueue "Naughty raindeer"]
printfn "%s - all passed" name
let private defaultAutoStoreTime = TimeSpan.FromSeconds(30.)
let testCallAgent() =
let runCallViaAgent dt listOfKeyPresses =
use call = new CallHandler({ CallDetails.Example with CallAt = dt }, defaultAutoStoreTime)
let rec runIt listOfKeyPresses = function
| CompletedResponse r -> [r]
| IntermediateResponse r -> match listOfKeyPresses with
| [] -> failwith "Run out of input keys"
| keysPressed::futureKeys -> r :: runIt futureKeys (call.StepSync keysPressed)
call.StartSync() |> runIt listOfKeyPresses
do runTestScenarios runCallViaAgent "CallHandler direct"
let testHttp() =
let runCallViaHTTP dt listOfKeyPresses =
use http = new HttpEndpoint.HttpHandler(defaultAutoStoreTime)
let details = { CallDetails.Example with CallAt = dt }
let callId = Guid.NewGuid().ToString()
let rec runIt listOfKeyPresses = function
| CompletedResponse r -> [r]
| IntermediateResponse r -> match listOfKeyPresses with
| [] -> failwith "Run out of input keys"
| keysPressed::futureKeys -> r :: runIt futureKeys (http.StepCall(callId,keysPressed))
http.StartCall(callId,details.NumberFrom,details.NumberTo,details.CallAt) |> runIt listOfKeyPresses
do runTestScenarios runCallViaHTTP "Via switchboard"
let testHttpForwarded() =
let runCallViaHTTP dt listOfKeyPresses =
use http = new HttpEndpoint.HttpHandler(defaultAutoStoreTime)
let details = { CallDetails.Example with CallAt = dt }
let callId = Guid.NewGuid().ToString()
let rec runIt listOfKeyPresses = function
| CompletedResponse r -> [r]
| IntermediateResponse r -> match listOfKeyPresses with
| [] -> failwith "Run out of input keys"
| keysPressed::futureKeys -> r :: runIt futureKeys (http.StepCallForwarded(callId,keysPressed))
http.StartCall(callId,details.NumberFrom,details.NumberTo,details.CallAt) |> runIt listOfKeyPresses
do runTestScenarios runCallViaHTTP "Switchboard with forwarding"
let testRewind() =
let runCallViaAgent dt listOfKeyPresses =
use call = new CallHandler({ CallDetails.Example with CallAt = dt }, defaultAutoStoreTime)
let rec runIt listOfKeyPresses = function
| CompletedResponse r -> [r]
| IntermediateResponse r -> match listOfKeyPresses with
| [] -> failwith "Run out of input keys"
| keysPressed::futureKeys ->
call.DirectPost( PersistToStorage ) // Every new call, tell the agent to persist and reforce replay
r :: runIt futureKeys (call.StepSync keysPressed)
call.StartSync() |> runIt listOfKeyPresses
do runTestScenarios runCallViaAgent "CallHandler direct with rewind"
#time
Testing.testCallAgent()
Testing.testHttp()
Testing.testHttpForwarded()
Testing.testRewind()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment