diff --git a/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm b/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm index 6b140538..ba06cf32 100644 --- a/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm +++ b/implement/elm-fullstack/ElmFullstack/compile-elm-program/src/CompileFullstackApp.elm @@ -619,12 +619,95 @@ type alias DeserializedState = (""" ++ buildTypeAnnotationText stateTypeAnnotation ++ """) +type alias DeserializedStateWithTaskFramework = + { stateLessFramework : DeserializedState + , nextTaskIndex : Int + , posixTimeMilli : Int + , createVolatileProcessTasks : Dict.Dict TaskId (CreateVolatileProcessResult -> DeserializedState -> ( DeserializedState, BackendCmds DeserializedState )) + , requestToVolatileProcessTasks : Dict.Dict TaskId (RequestToVolatileProcessResult -> DeserializedState -> ( DeserializedState, BackendCmds DeserializedState )) + , terminateVolatileProcessTasks : Dict.Dict TaskId () + } + + +initDeserializedStateWithTaskFramework : DeserializedState -> DeserializedStateWithTaskFramework +initDeserializedStateWithTaskFramework stateLessFramework = + { stateLessFramework = stateLessFramework + , nextTaskIndex = 0 + , posixTimeMilli = 0 + , createVolatileProcessTasks = Dict.empty + , requestToVolatileProcessTasks = Dict.empty + , terminateVolatileProcessTasks = Dict.empty + } + + +type ResponseOverSerialInterface + = DecodeEventError String + | DecodeEventSuccess BackendEventResponse + + type State = DeserializeFailed String - | DeserializeSuccessful DeserializedState + | DeserializeSuccessful DeserializedStateWithTaskFramework + +type BackendEvent + = HttpRequestEvent ElmFullstack.HttpRequestEventStruct + | TaskCompleteEvent TaskCompleteEventStruct + | PosixTimeHasArrivedEvent { posixTimeMilli : Int } -interfaceToHost_initState = """ ++ rootModuleNameBeforeLowering ++ """.backendMain.init |> DeserializeSuccessful + +type alias BackendEventResponse = + { startTasks : List StartTaskStructure + , notifyWhenPosixTimeHasArrived : Maybe { minimumPosixTimeMilli : Int } + , completeHttpResponses : List RespondToHttpRequestStruct + } + + +type alias TaskCompleteEventStruct = + { taskId : TaskId + , taskResult : TaskResultStructure + } + + +type TaskResultStructure + = CreateVolatileProcessResponse (Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete) + | RequestToVolatileProcessResponse (Result RequestToVolatileProcessError RequestToVolatileProcessComplete) + | CompleteWithoutResult + + +type alias StartTaskStructure = + { taskId : TaskId + , task : Task + } + + +type Task + = CreateVolatileProcess CreateVolatileProcessLessUpdateStruct + | RequestToVolatileProcess RequestToVolatileProcessLessUpdateStruct + | TerminateVolatileProcess TerminateVolatileProcessStruct + + +type alias CreateVolatileProcessLessUpdateStruct = + { programCode : String + } + + +type alias RequestToVolatileProcessLessUpdateStruct = + { processId : String + , request : String + } + + +type alias TaskId = + String + + +interfaceToHost_initState = + """ ++ rootModuleNameBeforeLowering ++ """.backendMain.init + -- TODO: Expand the runtime to consider the tasks from init. + |> Tuple.first + |> initDeserializedStateWithTaskFramework + |> DeserializeSuccessful interfaceToHost_processEvent hostEvent stateBefore = @@ -634,7 +717,7 @@ interfaceToHost_processEvent hostEvent stateBefore = DeserializeSuccessful deserializedState -> deserializedState - |> wrapForSerialInterface_processEvent """ ++ rootModuleNameBeforeLowering ++ """.backendMain.update hostEvent + |> wrapForSerialInterface_processEvent Backend.Main.backendMain.subscriptions hostEvent |> Tuple.mapFirst DeserializeSuccessful @@ -653,7 +736,11 @@ main = { init = \\_ -> ( interfaceToHost_initState, Cmd.none ) , update = \\event stateBefore -> - interfaceToHost_processEvent event (stateBefore |> interfaceToHost_serializeState |> interfaceToHost_deserializeState) |> Tuple.mapSecond (always Cmd.none) + { a = interfaceToHost_processEvent + , b = interfaceToHost_serializeState + , c = interfaceToHost_deserializeState + } + |> always ( stateBefore, Cmd.none ) , subscriptions = \\_ -> Sub.none } @@ -681,10 +768,14 @@ jsonEncodeState : State -> Json.Encode.Value jsonEncodeState state = case state of DeserializeFailed error -> - [ ( "Interface_DeserializeFailed", [ ( "error", error |> Json.Encode.string ) ] |> Json.Encode.object ) ] |> Json.Encode.object + [ ( "Interface_DeserializeFailed" + , [ ( "error", error |> Json.Encode.string ) ] |> Json.Encode.object + ) + ] + |> Json.Encode.object DeserializeSuccessful deserializedState -> - deserializedState |> jsonEncodeDeserializedState + deserializedState.stateLessFramework |> jsonEncodeDeserializedState deserializeState : String -> State @@ -699,13 +790,19 @@ jsonDecodeState : Json.Decode.Decoder State jsonDecodeState = Json.Decode.oneOf [ Json.Decode.field "Interface_DeserializeFailed" (Json.Decode.field "error" Json.Decode.string |> Json.Decode.map DeserializeFailed) - , jsonDecodeDeserializedState |> Json.Decode.map DeserializeSuccessful + , jsonDecodeDeserializedState |> Json.Decode.map (initDeserializedStateWithTaskFramework >> DeserializeSuccessful) ] + ---- -wrapForSerialInterface_processEvent : (BackendEvent -> state -> ( state, BackendEventResponse )) -> String -> state -> ( state, String ) -wrapForSerialInterface_processEvent update serializedEvent stateBefore = + +wrapForSerialInterface_processEvent : + (DeserializedState -> BackendSubs DeserializedState) + -> String + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, String ) +wrapForSerialInterface_processEvent subscriptions serializedEvent stateBefore = let ( state, response ) = case serializedEvent |> Json.Decode.decodeString decodeBackendEvent of @@ -717,12 +814,282 @@ wrapForSerialInterface_processEvent update serializedEvent stateBefore = Ok hostEvent -> stateBefore - |> update hostEvent + |> processEvent subscriptions hostEvent |> Tuple.mapSecond DecodeEventSuccess in ( state, response |> encodeResponseOverSerialInterface |> Json.Encode.encode 0 ) +processEvent : + (DeserializedState -> BackendSubs DeserializedState) + -> BackendEvent + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +processEvent subscriptions hostEvent stateBefore = + let + maybeEventPosixTimeMilli = + case hostEvent of + HttpRequestEvent httpRequestEvent -> + Just httpRequestEvent.posixTimeMilli + + PosixTimeHasArrivedEvent posixTimeHasArrivedEvent -> + Just posixTimeHasArrivedEvent.posixTimeMilli + + _ -> + Nothing + + state = + case maybeEventPosixTimeMilli of + Nothing -> + stateBefore + + Just eventPosixTimeMilli -> + { stateBefore | posixTimeMilli = max stateBefore.posixTimeMilli eventPosixTimeMilli } + in + processEventLessRememberTime subscriptions hostEvent state + + +processEventLessRememberTime : + (DeserializedState -> BackendSubs DeserializedState) + -> BackendEvent + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +processEventLessRememberTime subscriptions hostEvent stateBefore = + let + discardEvent = + ( stateBefore + , { startTasks = [] + , notifyWhenPosixTimeHasArrived = Nothing + , completeHttpResponses = [] + } + ) + + continueWithUpdateToTasks updateToTasks stateBeforeUpdateToTasks = + let + ( stateLessFramework, runtimeTasks ) = + updateToTasks stateBeforeUpdateToTasks.stateLessFramework + in + backendEventResponseFromRuntimeTasksAndSubscriptions + subscriptions + runtimeTasks + { stateBeforeUpdateToTasks | stateLessFramework = stateLessFramework } + in + case hostEvent of + HttpRequestEvent httpRequestEvent -> + continueWithUpdateToTasks + ((subscriptions stateBefore.stateLessFramework).httpRequest httpRequestEvent) + stateBefore + + PosixTimeHasArrivedEvent posixTimeHasArrivedEvent -> + case (subscriptions stateBefore.stateLessFramework).posixTimeIsPast of + Nothing -> + discardEvent + + Just posixTimeIsPastSub -> + if posixTimeHasArrivedEvent.posixTimeMilli < posixTimeIsPastSub.minimumPosixTimeMilli then + discardEvent + + else + continueWithUpdateToTasks + (posixTimeIsPastSub.update { currentPosixTimeMilli = posixTimeHasArrivedEvent.posixTimeMilli }) + stateBefore + + TaskCompleteEvent taskCompleteEvent -> + case taskCompleteEvent.taskResult of + CreateVolatileProcessResponse createVolatileProcessResponse -> + case Dict.get taskCompleteEvent.taskId stateBefore.createVolatileProcessTasks of + Nothing -> + discardEvent + + Just taskEntry -> + continueWithUpdateToTasks + (taskEntry createVolatileProcessResponse) + { stateBefore + | createVolatileProcessTasks = + stateBefore.createVolatileProcessTasks |> Dict.remove taskCompleteEvent.taskId + } + + RequestToVolatileProcessResponse requestToVolatileProcessResponse -> + case Dict.get taskCompleteEvent.taskId stateBefore.requestToVolatileProcessTasks of + Nothing -> + discardEvent + + Just taskEntry -> + continueWithUpdateToTasks + (taskEntry requestToVolatileProcessResponse) + { stateBefore + | requestToVolatileProcessTasks = + stateBefore.requestToVolatileProcessTasks |> Dict.remove taskCompleteEvent.taskId + } + + CompleteWithoutResult -> + ( { stateBefore + | terminateVolatileProcessTasks = + stateBefore.terminateVolatileProcessTasks |> Dict.remove taskCompleteEvent.taskId + } + , { startTasks = [] + , notifyWhenPosixTimeHasArrived = Nothing + , completeHttpResponses = [] + } + ) + + +backendEventResponseFromRuntimeTasksAndSubscriptions : + (DeserializedState -> BackendSubs DeserializedState) + -> List (BackendCmd DeserializedState) + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +backendEventResponseFromRuntimeTasksAndSubscriptions subscriptions tasks stateBefore = + let + subscriptionsForState = + subscriptions stateBefore.stateLessFramework + in + tasks + |> List.foldl + (\\task ( previousState, previousResponse ) -> + let + ( newState, newResponse ) = + backendEventResponseFromRuntimeTask task previousState + in + ( newState, newResponse :: previousResponse ) + ) + ( stateBefore + , [ { startTasks = [] + , completeHttpResponses = [] + , notifyWhenPosixTimeHasArrived = + subscriptionsForState.posixTimeIsPast + |> Maybe.map (\\posixTimeIsPast -> { minimumPosixTimeMilli = posixTimeIsPast.minimumPosixTimeMilli }) + } + ] + ) + |> Tuple.mapSecond concatBackendEventResponse + + +backendEventResponseFromRuntimeTask : + BackendCmd DeserializedState + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +backendEventResponseFromRuntimeTask task stateBefore = + let + createTaskId stateBeforeCreateTaskId = + let + taskId = + String.join "-" + [ String.fromInt stateBeforeCreateTaskId.posixTimeMilli + , String.fromInt stateBeforeCreateTaskId.nextTaskIndex + ] + in + ( { stateBeforeCreateTaskId + | nextTaskIndex = stateBeforeCreateTaskId.nextTaskIndex + 1 + } + , taskId + ) + in + case task of + RespondToHttpRequest respondToHttpRequest -> + ( stateBefore + , passiveBackendEventResponse + |> withCompleteHttpResponsesAdded [ respondToHttpRequest ] + ) + + ElmFullstack.CreateVolatileProcess createVolatileProcess -> + let + ( stateAfterCreateTaskId, taskId ) = + createTaskId stateBefore + in + ( { stateAfterCreateTaskId + | createVolatileProcessTasks = + stateAfterCreateTaskId.createVolatileProcessTasks + |> Dict.insert taskId createVolatileProcess.update + } + , passiveBackendEventResponse + |> withStartTasksAdded + [ { taskId = taskId + , task = CreateVolatileProcess { programCode = createVolatileProcess.programCode } + } + ] + ) + + ElmFullstack.RequestToVolatileProcess requestToVolatileProcess -> + let + ( stateAfterCreateTaskId, taskId ) = + createTaskId stateBefore + in + ( { stateAfterCreateTaskId + | requestToVolatileProcessTasks = + stateAfterCreateTaskId.requestToVolatileProcessTasks + |> Dict.insert taskId requestToVolatileProcess.update + } + , passiveBackendEventResponse + |> withStartTasksAdded + [ { taskId = taskId + , task = + RequestToVolatileProcess + { processId = requestToVolatileProcess.processId + , request = requestToVolatileProcess.request + } + } + ] + ) + + ElmFullstack.TerminateVolatileProcess terminateVolatileProcess -> + let + ( stateAfterCreateTaskId, taskId ) = + createTaskId stateBefore + in + ( { stateAfterCreateTaskId + | terminateVolatileProcessTasks = + stateAfterCreateTaskId.terminateVolatileProcessTasks |> Dict.insert taskId () + } + , passiveBackendEventResponse + |> withStartTasksAdded + [ { taskId = taskId + , task = TerminateVolatileProcess terminateVolatileProcess + } + ] + ) + + +concatBackendEventResponse : List BackendEventResponse -> BackendEventResponse +concatBackendEventResponse responses = + let + notifyWhenPosixTimeHasArrived = + responses + |> List.filterMap .notifyWhenPosixTimeHasArrived + |> List.map .minimumPosixTimeMilli + |> List.minimum + |> Maybe.map (\\posixTimeMilli -> { minimumPosixTimeMilli = posixTimeMilli }) + + startTasks = + responses |> List.concatMap .startTasks + + completeHttpResponses = + responses |> List.concatMap .completeHttpResponses + in + { notifyWhenPosixTimeHasArrived = notifyWhenPosixTimeHasArrived + , startTasks = startTasks + , completeHttpResponses = completeHttpResponses + } + + +passiveBackendEventResponse : BackendEventResponse +passiveBackendEventResponse = + { startTasks = [] + , completeHttpResponses = [] + , notifyWhenPosixTimeHasArrived = Nothing + } + + +withStartTasksAdded : List StartTaskStructure -> BackendEventResponse -> BackendEventResponse +withStartTasksAdded startTasksToAdd responseBefore = + { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } + + +withCompleteHttpResponsesAdded : List RespondToHttpRequestStruct -> BackendEventResponse -> BackendEventResponse +withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = + { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } + + decodeBackendEvent : Json.Decode.Decoder BackendEvent decodeBackendEvent = Json.Decode.oneOf @@ -731,13 +1098,13 @@ decodeBackendEvent = , Json.Decode.field "PosixTimeHasArrivedEvent" (Json.Decode.field "posixTimeMilli" Json.Decode.int) |> Json.Decode.map (\\posixTimeMilli -> PosixTimeHasArrivedEvent { posixTimeMilli = posixTimeMilli }) , Json.Decode.field "TaskCompleteEvent" decodeTaskCompleteEventStructure |> Json.Decode.map TaskCompleteEvent - , Json.Decode.field "HttpRequestEvent" decodeHttpRequestEventStructure |> Json.Decode.map HttpRequestEvent + , Json.Decode.field "HttpRequestEvent" decodeHttpRequestEventStruct |> Json.Decode.map HttpRequestEvent ] -decodeTaskCompleteEventStructure : Json.Decode.Decoder TaskCompleteEventStructure +decodeTaskCompleteEventStructure : Json.Decode.Decoder TaskCompleteEventStruct decodeTaskCompleteEventStructure = - Json.Decode.map2 TaskCompleteEventStructure + Json.Decode.map2 TaskCompleteEventStruct (Json.Decode.field "taskId" Json.Decode.string) (Json.Decode.field "taskResult" decodeTaskResult) @@ -780,9 +1147,9 @@ decodeRequestToVolatileProcessError = ] -decodeHttpRequestEventStructure : Json.Decode.Decoder HttpRequestEventStructure -decodeHttpRequestEventStructure = - Json.Decode.map4 HttpRequestEventStructure +decodeHttpRequestEventStruct : Json.Decode.Decoder HttpRequestEventStruct +decodeHttpRequestEventStruct = + Json.Decode.map4 HttpRequestEventStruct (Json.Decode.field "httpRequestId" Json.Decode.string) (Json.Decode.field "posixTimeMilli" Json.Decode.int) (Json.Decode.field "requestContext" decodeHttpRequestContext) @@ -811,23 +1178,6 @@ decodeHttpHeader = (Json.Decode.field "values" (Json.Decode.list Json.Decode.string)) -decodeOptionalField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) -decodeOptionalField fieldName decoder = - let - finishDecoding json = - case Json.Decode.decodeValue (Json.Decode.field fieldName Json.Decode.value) json of - Ok _ -> - -- The field is present, so run the decoder on it. - Json.Decode.map Just (Json.Decode.field fieldName decoder) - - Err _ -> - -- The field was missing, which is fine! - Json.Decode.succeed Nothing - in - Json.Decode.value - |> Json.Decode.andThen finishDecoding - - encodeResponseOverSerialInterface : ResponseOverSerialInterface -> Json.Encode.Value encodeResponseOverSerialInterface responseOverSerialInterface = (case responseOverSerialInterface of @@ -896,7 +1246,7 @@ encodeTask task = ] -encodeHttpResponseRequest : HttpResponseRequest -> Json.Encode.Value +encodeHttpResponseRequest : RespondToHttpRequestStruct -> Json.Encode.Value encodeHttpResponseRequest httpResponseRequest = Json.Encode.object [ ( "httpRequestId", httpResponseRequest.httpRequestId |> Json.Encode.string ) @@ -921,6 +1271,8 @@ encodeHttpHeader httpHeader = |> Json.Encode.object +""" ++ encodeFunction ++ "\n\n" ++ decodeFunction ++ """ + decodeResult : Json.Decode.Decoder error -> Json.Decode.Decoder ok -> Json.Decode.Decoder (Result error ok) decodeResult errorDecoder okDecoder = Json.Decode.oneOf @@ -941,7 +1293,23 @@ jsonDecodeSucceedWhenNotNull valueIfNotNull = Json.Decode.succeed valueIfNotNull ) -""" ++ encodeFunction ++ "\n\n" ++ decodeFunction + +decodeOptionalField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) +decodeOptionalField fieldName decoder = + let + finishDecoding json = + case Json.Decode.decodeValue (Json.Decode.field fieldName Json.Decode.value) json of + Ok _ -> + -- The field is present, so run the decoder on it. + Json.Decode.map Just (Json.Decode.field fieldName decoder) + + Err _ -> + -- The field was missing, which is fine! + Json.Decode.succeed Nothing + in + Json.Decode.value + |> Json.Decode.andThen finishDecoding +""" composeAppRootElmModuleText_Before_2021_08 : diff --git a/implement/elm-fullstack/Program.cs b/implement/elm-fullstack/Program.cs index 7ff98c43..1060e634 100644 --- a/implement/elm-fullstack/Program.cs +++ b/implement/elm-fullstack/Program.cs @@ -14,7 +14,7 @@ namespace elm_fullstack { public class Program { - static public string AppVersionId => "2021-08-12"; + static public string AppVersionId => "2021-08-14"; static int AdminInterfaceDefaultPort => 4000; diff --git a/implement/elm-fullstack/elm-fullstack.csproj b/implement/elm-fullstack/elm-fullstack.csproj index e379e59a..ee43ef65 100644 --- a/implement/elm-fullstack/elm-fullstack.csproj +++ b/implement/elm-fullstack/elm-fullstack.csproj @@ -5,8 +5,8 @@ netcoreapp3.1 elm_fullstack elm-fs - 2021.0812.0.0 - 2021.0812.0.0 + 2021.0814.0.0 + 2021.0814.0.0 diff --git a/implement/example-apps/elm-editor/src/CompileFullstackApp.elm b/implement/example-apps/elm-editor/src/CompileFullstackApp.elm index 6b140538..ba06cf32 100644 --- a/implement/example-apps/elm-editor/src/CompileFullstackApp.elm +++ b/implement/example-apps/elm-editor/src/CompileFullstackApp.elm @@ -619,12 +619,95 @@ type alias DeserializedState = (""" ++ buildTypeAnnotationText stateTypeAnnotation ++ """) +type alias DeserializedStateWithTaskFramework = + { stateLessFramework : DeserializedState + , nextTaskIndex : Int + , posixTimeMilli : Int + , createVolatileProcessTasks : Dict.Dict TaskId (CreateVolatileProcessResult -> DeserializedState -> ( DeserializedState, BackendCmds DeserializedState )) + , requestToVolatileProcessTasks : Dict.Dict TaskId (RequestToVolatileProcessResult -> DeserializedState -> ( DeserializedState, BackendCmds DeserializedState )) + , terminateVolatileProcessTasks : Dict.Dict TaskId () + } + + +initDeserializedStateWithTaskFramework : DeserializedState -> DeserializedStateWithTaskFramework +initDeserializedStateWithTaskFramework stateLessFramework = + { stateLessFramework = stateLessFramework + , nextTaskIndex = 0 + , posixTimeMilli = 0 + , createVolatileProcessTasks = Dict.empty + , requestToVolatileProcessTasks = Dict.empty + , terminateVolatileProcessTasks = Dict.empty + } + + +type ResponseOverSerialInterface + = DecodeEventError String + | DecodeEventSuccess BackendEventResponse + + type State = DeserializeFailed String - | DeserializeSuccessful DeserializedState + | DeserializeSuccessful DeserializedStateWithTaskFramework + +type BackendEvent + = HttpRequestEvent ElmFullstack.HttpRequestEventStruct + | TaskCompleteEvent TaskCompleteEventStruct + | PosixTimeHasArrivedEvent { posixTimeMilli : Int } -interfaceToHost_initState = """ ++ rootModuleNameBeforeLowering ++ """.backendMain.init |> DeserializeSuccessful + +type alias BackendEventResponse = + { startTasks : List StartTaskStructure + , notifyWhenPosixTimeHasArrived : Maybe { minimumPosixTimeMilli : Int } + , completeHttpResponses : List RespondToHttpRequestStruct + } + + +type alias TaskCompleteEventStruct = + { taskId : TaskId + , taskResult : TaskResultStructure + } + + +type TaskResultStructure + = CreateVolatileProcessResponse (Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete) + | RequestToVolatileProcessResponse (Result RequestToVolatileProcessError RequestToVolatileProcessComplete) + | CompleteWithoutResult + + +type alias StartTaskStructure = + { taskId : TaskId + , task : Task + } + + +type Task + = CreateVolatileProcess CreateVolatileProcessLessUpdateStruct + | RequestToVolatileProcess RequestToVolatileProcessLessUpdateStruct + | TerminateVolatileProcess TerminateVolatileProcessStruct + + +type alias CreateVolatileProcessLessUpdateStruct = + { programCode : String + } + + +type alias RequestToVolatileProcessLessUpdateStruct = + { processId : String + , request : String + } + + +type alias TaskId = + String + + +interfaceToHost_initState = + """ ++ rootModuleNameBeforeLowering ++ """.backendMain.init + -- TODO: Expand the runtime to consider the tasks from init. + |> Tuple.first + |> initDeserializedStateWithTaskFramework + |> DeserializeSuccessful interfaceToHost_processEvent hostEvent stateBefore = @@ -634,7 +717,7 @@ interfaceToHost_processEvent hostEvent stateBefore = DeserializeSuccessful deserializedState -> deserializedState - |> wrapForSerialInterface_processEvent """ ++ rootModuleNameBeforeLowering ++ """.backendMain.update hostEvent + |> wrapForSerialInterface_processEvent Backend.Main.backendMain.subscriptions hostEvent |> Tuple.mapFirst DeserializeSuccessful @@ -653,7 +736,11 @@ main = { init = \\_ -> ( interfaceToHost_initState, Cmd.none ) , update = \\event stateBefore -> - interfaceToHost_processEvent event (stateBefore |> interfaceToHost_serializeState |> interfaceToHost_deserializeState) |> Tuple.mapSecond (always Cmd.none) + { a = interfaceToHost_processEvent + , b = interfaceToHost_serializeState + , c = interfaceToHost_deserializeState + } + |> always ( stateBefore, Cmd.none ) , subscriptions = \\_ -> Sub.none } @@ -681,10 +768,14 @@ jsonEncodeState : State -> Json.Encode.Value jsonEncodeState state = case state of DeserializeFailed error -> - [ ( "Interface_DeserializeFailed", [ ( "error", error |> Json.Encode.string ) ] |> Json.Encode.object ) ] |> Json.Encode.object + [ ( "Interface_DeserializeFailed" + , [ ( "error", error |> Json.Encode.string ) ] |> Json.Encode.object + ) + ] + |> Json.Encode.object DeserializeSuccessful deserializedState -> - deserializedState |> jsonEncodeDeserializedState + deserializedState.stateLessFramework |> jsonEncodeDeserializedState deserializeState : String -> State @@ -699,13 +790,19 @@ jsonDecodeState : Json.Decode.Decoder State jsonDecodeState = Json.Decode.oneOf [ Json.Decode.field "Interface_DeserializeFailed" (Json.Decode.field "error" Json.Decode.string |> Json.Decode.map DeserializeFailed) - , jsonDecodeDeserializedState |> Json.Decode.map DeserializeSuccessful + , jsonDecodeDeserializedState |> Json.Decode.map (initDeserializedStateWithTaskFramework >> DeserializeSuccessful) ] + ---- -wrapForSerialInterface_processEvent : (BackendEvent -> state -> ( state, BackendEventResponse )) -> String -> state -> ( state, String ) -wrapForSerialInterface_processEvent update serializedEvent stateBefore = + +wrapForSerialInterface_processEvent : + (DeserializedState -> BackendSubs DeserializedState) + -> String + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, String ) +wrapForSerialInterface_processEvent subscriptions serializedEvent stateBefore = let ( state, response ) = case serializedEvent |> Json.Decode.decodeString decodeBackendEvent of @@ -717,12 +814,282 @@ wrapForSerialInterface_processEvent update serializedEvent stateBefore = Ok hostEvent -> stateBefore - |> update hostEvent + |> processEvent subscriptions hostEvent |> Tuple.mapSecond DecodeEventSuccess in ( state, response |> encodeResponseOverSerialInterface |> Json.Encode.encode 0 ) +processEvent : + (DeserializedState -> BackendSubs DeserializedState) + -> BackendEvent + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +processEvent subscriptions hostEvent stateBefore = + let + maybeEventPosixTimeMilli = + case hostEvent of + HttpRequestEvent httpRequestEvent -> + Just httpRequestEvent.posixTimeMilli + + PosixTimeHasArrivedEvent posixTimeHasArrivedEvent -> + Just posixTimeHasArrivedEvent.posixTimeMilli + + _ -> + Nothing + + state = + case maybeEventPosixTimeMilli of + Nothing -> + stateBefore + + Just eventPosixTimeMilli -> + { stateBefore | posixTimeMilli = max stateBefore.posixTimeMilli eventPosixTimeMilli } + in + processEventLessRememberTime subscriptions hostEvent state + + +processEventLessRememberTime : + (DeserializedState -> BackendSubs DeserializedState) + -> BackendEvent + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +processEventLessRememberTime subscriptions hostEvent stateBefore = + let + discardEvent = + ( stateBefore + , { startTasks = [] + , notifyWhenPosixTimeHasArrived = Nothing + , completeHttpResponses = [] + } + ) + + continueWithUpdateToTasks updateToTasks stateBeforeUpdateToTasks = + let + ( stateLessFramework, runtimeTasks ) = + updateToTasks stateBeforeUpdateToTasks.stateLessFramework + in + backendEventResponseFromRuntimeTasksAndSubscriptions + subscriptions + runtimeTasks + { stateBeforeUpdateToTasks | stateLessFramework = stateLessFramework } + in + case hostEvent of + HttpRequestEvent httpRequestEvent -> + continueWithUpdateToTasks + ((subscriptions stateBefore.stateLessFramework).httpRequest httpRequestEvent) + stateBefore + + PosixTimeHasArrivedEvent posixTimeHasArrivedEvent -> + case (subscriptions stateBefore.stateLessFramework).posixTimeIsPast of + Nothing -> + discardEvent + + Just posixTimeIsPastSub -> + if posixTimeHasArrivedEvent.posixTimeMilli < posixTimeIsPastSub.minimumPosixTimeMilli then + discardEvent + + else + continueWithUpdateToTasks + (posixTimeIsPastSub.update { currentPosixTimeMilli = posixTimeHasArrivedEvent.posixTimeMilli }) + stateBefore + + TaskCompleteEvent taskCompleteEvent -> + case taskCompleteEvent.taskResult of + CreateVolatileProcessResponse createVolatileProcessResponse -> + case Dict.get taskCompleteEvent.taskId stateBefore.createVolatileProcessTasks of + Nothing -> + discardEvent + + Just taskEntry -> + continueWithUpdateToTasks + (taskEntry createVolatileProcessResponse) + { stateBefore + | createVolatileProcessTasks = + stateBefore.createVolatileProcessTasks |> Dict.remove taskCompleteEvent.taskId + } + + RequestToVolatileProcessResponse requestToVolatileProcessResponse -> + case Dict.get taskCompleteEvent.taskId stateBefore.requestToVolatileProcessTasks of + Nothing -> + discardEvent + + Just taskEntry -> + continueWithUpdateToTasks + (taskEntry requestToVolatileProcessResponse) + { stateBefore + | requestToVolatileProcessTasks = + stateBefore.requestToVolatileProcessTasks |> Dict.remove taskCompleteEvent.taskId + } + + CompleteWithoutResult -> + ( { stateBefore + | terminateVolatileProcessTasks = + stateBefore.terminateVolatileProcessTasks |> Dict.remove taskCompleteEvent.taskId + } + , { startTasks = [] + , notifyWhenPosixTimeHasArrived = Nothing + , completeHttpResponses = [] + } + ) + + +backendEventResponseFromRuntimeTasksAndSubscriptions : + (DeserializedState -> BackendSubs DeserializedState) + -> List (BackendCmd DeserializedState) + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +backendEventResponseFromRuntimeTasksAndSubscriptions subscriptions tasks stateBefore = + let + subscriptionsForState = + subscriptions stateBefore.stateLessFramework + in + tasks + |> List.foldl + (\\task ( previousState, previousResponse ) -> + let + ( newState, newResponse ) = + backendEventResponseFromRuntimeTask task previousState + in + ( newState, newResponse :: previousResponse ) + ) + ( stateBefore + , [ { startTasks = [] + , completeHttpResponses = [] + , notifyWhenPosixTimeHasArrived = + subscriptionsForState.posixTimeIsPast + |> Maybe.map (\\posixTimeIsPast -> { minimumPosixTimeMilli = posixTimeIsPast.minimumPosixTimeMilli }) + } + ] + ) + |> Tuple.mapSecond concatBackendEventResponse + + +backendEventResponseFromRuntimeTask : + BackendCmd DeserializedState + -> DeserializedStateWithTaskFramework + -> ( DeserializedStateWithTaskFramework, BackendEventResponse ) +backendEventResponseFromRuntimeTask task stateBefore = + let + createTaskId stateBeforeCreateTaskId = + let + taskId = + String.join "-" + [ String.fromInt stateBeforeCreateTaskId.posixTimeMilli + , String.fromInt stateBeforeCreateTaskId.nextTaskIndex + ] + in + ( { stateBeforeCreateTaskId + | nextTaskIndex = stateBeforeCreateTaskId.nextTaskIndex + 1 + } + , taskId + ) + in + case task of + RespondToHttpRequest respondToHttpRequest -> + ( stateBefore + , passiveBackendEventResponse + |> withCompleteHttpResponsesAdded [ respondToHttpRequest ] + ) + + ElmFullstack.CreateVolatileProcess createVolatileProcess -> + let + ( stateAfterCreateTaskId, taskId ) = + createTaskId stateBefore + in + ( { stateAfterCreateTaskId + | createVolatileProcessTasks = + stateAfterCreateTaskId.createVolatileProcessTasks + |> Dict.insert taskId createVolatileProcess.update + } + , passiveBackendEventResponse + |> withStartTasksAdded + [ { taskId = taskId + , task = CreateVolatileProcess { programCode = createVolatileProcess.programCode } + } + ] + ) + + ElmFullstack.RequestToVolatileProcess requestToVolatileProcess -> + let + ( stateAfterCreateTaskId, taskId ) = + createTaskId stateBefore + in + ( { stateAfterCreateTaskId + | requestToVolatileProcessTasks = + stateAfterCreateTaskId.requestToVolatileProcessTasks + |> Dict.insert taskId requestToVolatileProcess.update + } + , passiveBackendEventResponse + |> withStartTasksAdded + [ { taskId = taskId + , task = + RequestToVolatileProcess + { processId = requestToVolatileProcess.processId + , request = requestToVolatileProcess.request + } + } + ] + ) + + ElmFullstack.TerminateVolatileProcess terminateVolatileProcess -> + let + ( stateAfterCreateTaskId, taskId ) = + createTaskId stateBefore + in + ( { stateAfterCreateTaskId + | terminateVolatileProcessTasks = + stateAfterCreateTaskId.terminateVolatileProcessTasks |> Dict.insert taskId () + } + , passiveBackendEventResponse + |> withStartTasksAdded + [ { taskId = taskId + , task = TerminateVolatileProcess terminateVolatileProcess + } + ] + ) + + +concatBackendEventResponse : List BackendEventResponse -> BackendEventResponse +concatBackendEventResponse responses = + let + notifyWhenPosixTimeHasArrived = + responses + |> List.filterMap .notifyWhenPosixTimeHasArrived + |> List.map .minimumPosixTimeMilli + |> List.minimum + |> Maybe.map (\\posixTimeMilli -> { minimumPosixTimeMilli = posixTimeMilli }) + + startTasks = + responses |> List.concatMap .startTasks + + completeHttpResponses = + responses |> List.concatMap .completeHttpResponses + in + { notifyWhenPosixTimeHasArrived = notifyWhenPosixTimeHasArrived + , startTasks = startTasks + , completeHttpResponses = completeHttpResponses + } + + +passiveBackendEventResponse : BackendEventResponse +passiveBackendEventResponse = + { startTasks = [] + , completeHttpResponses = [] + , notifyWhenPosixTimeHasArrived = Nothing + } + + +withStartTasksAdded : List StartTaskStructure -> BackendEventResponse -> BackendEventResponse +withStartTasksAdded startTasksToAdd responseBefore = + { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } + + +withCompleteHttpResponsesAdded : List RespondToHttpRequestStruct -> BackendEventResponse -> BackendEventResponse +withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = + { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } + + decodeBackendEvent : Json.Decode.Decoder BackendEvent decodeBackendEvent = Json.Decode.oneOf @@ -731,13 +1098,13 @@ decodeBackendEvent = , Json.Decode.field "PosixTimeHasArrivedEvent" (Json.Decode.field "posixTimeMilli" Json.Decode.int) |> Json.Decode.map (\\posixTimeMilli -> PosixTimeHasArrivedEvent { posixTimeMilli = posixTimeMilli }) , Json.Decode.field "TaskCompleteEvent" decodeTaskCompleteEventStructure |> Json.Decode.map TaskCompleteEvent - , Json.Decode.field "HttpRequestEvent" decodeHttpRequestEventStructure |> Json.Decode.map HttpRequestEvent + , Json.Decode.field "HttpRequestEvent" decodeHttpRequestEventStruct |> Json.Decode.map HttpRequestEvent ] -decodeTaskCompleteEventStructure : Json.Decode.Decoder TaskCompleteEventStructure +decodeTaskCompleteEventStructure : Json.Decode.Decoder TaskCompleteEventStruct decodeTaskCompleteEventStructure = - Json.Decode.map2 TaskCompleteEventStructure + Json.Decode.map2 TaskCompleteEventStruct (Json.Decode.field "taskId" Json.Decode.string) (Json.Decode.field "taskResult" decodeTaskResult) @@ -780,9 +1147,9 @@ decodeRequestToVolatileProcessError = ] -decodeHttpRequestEventStructure : Json.Decode.Decoder HttpRequestEventStructure -decodeHttpRequestEventStructure = - Json.Decode.map4 HttpRequestEventStructure +decodeHttpRequestEventStruct : Json.Decode.Decoder HttpRequestEventStruct +decodeHttpRequestEventStruct = + Json.Decode.map4 HttpRequestEventStruct (Json.Decode.field "httpRequestId" Json.Decode.string) (Json.Decode.field "posixTimeMilli" Json.Decode.int) (Json.Decode.field "requestContext" decodeHttpRequestContext) @@ -811,23 +1178,6 @@ decodeHttpHeader = (Json.Decode.field "values" (Json.Decode.list Json.Decode.string)) -decodeOptionalField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) -decodeOptionalField fieldName decoder = - let - finishDecoding json = - case Json.Decode.decodeValue (Json.Decode.field fieldName Json.Decode.value) json of - Ok _ -> - -- The field is present, so run the decoder on it. - Json.Decode.map Just (Json.Decode.field fieldName decoder) - - Err _ -> - -- The field was missing, which is fine! - Json.Decode.succeed Nothing - in - Json.Decode.value - |> Json.Decode.andThen finishDecoding - - encodeResponseOverSerialInterface : ResponseOverSerialInterface -> Json.Encode.Value encodeResponseOverSerialInterface responseOverSerialInterface = (case responseOverSerialInterface of @@ -896,7 +1246,7 @@ encodeTask task = ] -encodeHttpResponseRequest : HttpResponseRequest -> Json.Encode.Value +encodeHttpResponseRequest : RespondToHttpRequestStruct -> Json.Encode.Value encodeHttpResponseRequest httpResponseRequest = Json.Encode.object [ ( "httpRequestId", httpResponseRequest.httpRequestId |> Json.Encode.string ) @@ -921,6 +1271,8 @@ encodeHttpHeader httpHeader = |> Json.Encode.object +""" ++ encodeFunction ++ "\n\n" ++ decodeFunction ++ """ + decodeResult : Json.Decode.Decoder error -> Json.Decode.Decoder ok -> Json.Decode.Decoder (Result error ok) decodeResult errorDecoder okDecoder = Json.Decode.oneOf @@ -941,7 +1293,23 @@ jsonDecodeSucceedWhenNotNull valueIfNotNull = Json.Decode.succeed valueIfNotNull ) -""" ++ encodeFunction ++ "\n\n" ++ decodeFunction + +decodeOptionalField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) +decodeOptionalField fieldName decoder = + let + finishDecoding json = + case Json.Decode.decodeValue (Json.Decode.field fieldName Json.Decode.value) json of + Ok _ -> + -- The field is present, so run the decoder on it. + Json.Decode.map Just (Json.Decode.field fieldName decoder) + + Err _ -> + -- The field was missing, which is fine! + Json.Decode.succeed Nothing + in + Json.Decode.value + |> Json.Decode.andThen finishDecoding +""" composeAppRootElmModuleText_Before_2021_08 : diff --git a/implement/example-apps/minimal-backend-hello-world/src/Backend/Main.elm b/implement/example-apps/minimal-backend-hello-world/src/Backend/Main.elm index 3631d248..5b1ff586 100644 --- a/implement/example-apps/minimal-backend-hello-world/src/Backend/Main.elm +++ b/implement/example-apps/minimal-backend-hello-world/src/Backend/Main.elm @@ -12,39 +12,37 @@ type alias State = () -backendMain : ElmFullstack.BackendConfiguration () +backendMain : ElmFullstack.BackendConfig () backendMain = - { init = () - , update = processEvent + { init = ( (), [] ) + , subscriptions = subscriptions } -processEvent : ElmFullstack.BackendEvent -> State -> ( State, ElmFullstack.BackendEventResponse ) -processEvent hostEvent stateBefore = - case hostEvent of - ElmFullstack.HttpRequestEvent httpRequestEvent -> - let - httpResponse = - { statusCode = 200 - , bodyAsBase64 = - "Hello, World!" - |> Bytes.Encode.string - |> Bytes.Encode.encode - |> Base64.fromBytes - , headersToAdd = [] - } - in - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withCompleteHttpResponsesAdded - [ { httpRequestId = httpRequestEvent.httpRequestId - , response = httpResponse - } - ] - ) - - ElmFullstack.TaskCompleteEvent _ -> - ( stateBefore, ElmFullstack.passiveBackendEventResponse ) - - ElmFullstack.PosixTimeHasArrivedEvent _ -> - ( stateBefore, ElmFullstack.passiveBackendEventResponse ) +subscriptions : State -> ElmFullstack.BackendSubs State +subscriptions _ = + { httpRequest = updateForHttpRequestEvent + , posixTimeIsPast = Nothing + } + + +updateForHttpRequestEvent : ElmFullstack.HttpRequestEventStruct -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpRequestEvent event state = + let + httpResponse = + { statusCode = 200 + , bodyAsBase64 = + "Hello, World!" + |> Bytes.Encode.string + |> Bytes.Encode.encode + |> Base64.fromBytes + , headersToAdd = [] + } + in + ( state + , [ ElmFullstack.RespondToHttpRequest + { httpRequestId = event.httpRequestId + , response = httpResponse + } + ] + ) diff --git a/implement/example-apps/minimal-backend-hello-world/src/ElmFullstack.elm b/implement/example-apps/minimal-backend-hello-world/src/ElmFullstack.elm index a72fa493..15930cc8 100644 --- a/implement/example-apps/minimal-backend-hello-world/src/ElmFullstack.elm +++ b/implement/example-apps/minimal-backend-hello-world/src/ElmFullstack.elm @@ -1,72 +1,33 @@ module ElmFullstack exposing (..) -type BackendEvent - = HttpRequestEvent HttpRequestEventStructure - | TaskCompleteEvent TaskCompleteEventStructure - | PosixTimeHasArrivedEvent { posixTimeMilli : Int } - - -type alias BackendEventResponse = - { startTasks : List StartTaskStructure - , notifyWhenPosixTimeHasArrived : Maybe { minimumPosixTimeMilli : Int } - , completeHttpResponses : List HttpResponseRequest +type alias BackendConfig state = + { init : ( state, BackendCmds state ) + , subscriptions : state -> BackendSubs state } -type alias TaskCompleteEventStructure = - { taskId : TaskId - , taskResult : TaskResultStructure +type alias BackendSubs state = + { httpRequest : HttpRequestEventStruct -> state -> ( state, BackendCmds state ) + , posixTimeIsPast : + Maybe + { minimumPosixTimeMilli : Int + , update : { currentPosixTimeMilli : Int } -> state -> ( state, BackendCmds state ) + } } -type TaskResultStructure - = CreateVolatileProcessResponse (Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete) - | RequestToVolatileProcessResponse (Result RequestToVolatileProcessError RequestToVolatileProcessComplete) - | CompleteWithoutResult - - -type alias StartTaskStructure = - { taskId : TaskId - , task : Task - } +type alias BackendCmds state = + List (BackendCmd state) -type Task - = CreateVolatileProcess CreateVolatileProcessStruct - | RequestToVolatileProcess RequestToVolatileProcessStruct +type BackendCmd state + = RespondToHttpRequest RespondToHttpRequestStruct + | CreateVolatileProcess (CreateVolatileProcessStruct state) + | RequestToVolatileProcess (RequestToVolatileProcessStruct state) | TerminateVolatileProcess TerminateVolatileProcessStruct -type alias HttpRequestEventStructure = - { httpRequestId : String - , posixTimeMilli : Int - , requestContext : HttpRequestContext - , request : HttpRequestProperties - } - - -type ResponseOverSerialInterface - = DecodeEventError String - | DecodeEventSuccess BackendEventResponse - - -type alias HttpResponseRequest = - { httpRequestId : String - , response : HttpResponse - } - - -type alias TaskId = - String - - -type alias BackendConfiguration state = - { init : state - , update : BackendEvent -> state -> ( state, BackendEventResponse ) - } - - type alias HttpRequestEventStruct = { httpRequestId : String , posixTimeMilli : Int @@ -107,11 +68,16 @@ type alias HttpHeader = } -type alias CreateVolatileProcessStruct = +type alias CreateVolatileProcessStruct state = { programCode : String + , update : CreateVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias CreateVolatileProcessResult = + Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete + + type alias CreateVolatileProcessErrorStruct = { exceptionToString : String } @@ -121,12 +87,17 @@ type alias CreateVolatileProcessComplete = { processId : String } -type alias RequestToVolatileProcessStruct = +type alias RequestToVolatileProcessStruct state = { processId : String , request : String + , update : RequestToVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias RequestToVolatileProcessResult = + Result RequestToVolatileProcessError RequestToVolatileProcessComplete + + type RequestToVolatileProcessError = ProcessNotFound @@ -140,43 +111,3 @@ type alias RequestToVolatileProcessComplete = type alias TerminateVolatileProcessStruct = { processId : String } - - -passiveBackendEventResponse : BackendEventResponse -passiveBackendEventResponse = - { startTasks = [] - , completeHttpResponses = [] - , notifyWhenPosixTimeHasArrived = Nothing - } - - -withStartTasksAdded : List StartTaskStructure -> BackendEventResponse -> BackendEventResponse -withStartTasksAdded startTasksToAdd responseBefore = - { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } - - -withCompleteHttpResponsesAdded : List HttpResponseRequest -> BackendEventResponse -> BackendEventResponse -withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = - { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } - - -concatBackendEventResponse : List BackendEventResponse -> BackendEventResponse -concatBackendEventResponse responses = - let - notifyWhenPosixTimeHasArrived = - responses - |> List.filterMap .notifyWhenPosixTimeHasArrived - |> List.map .minimumPosixTimeMilli - |> List.minimum - |> Maybe.map (\posixTimeMilli -> { minimumPosixTimeMilli = posixTimeMilli }) - - startTasks = - responses |> List.concatMap .startTasks - - completeHttpResponses = - responses |> List.concatMap .completeHttpResponses - in - { notifyWhenPosixTimeHasArrived = notifyWhenPosixTimeHasArrived - , startTasks = startTasks - , completeHttpResponses = completeHttpResponses - } diff --git a/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/Backend/Main.elm b/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/Backend/Main.elm index 865a970b..d04f0c05 100644 --- a/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/Backend/Main.elm +++ b/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/Backend/Main.elm @@ -19,58 +19,56 @@ type alias CounterEvent = { addition : Int } -backendMain : ElmFullstack.BackendConfiguration State +backendMain : ElmFullstack.BackendConfig State backendMain = - { init = 0 - , update = processEvent + { init = ( 0, [] ) + , subscriptions = subscriptions } -processEvent : ElmFullstack.BackendEvent -> State -> ( State, ElmFullstack.BackendEventResponse ) -processEvent hostEvent stateBefore = - case hostEvent of - ElmFullstack.HttpRequestEvent httpRequestEvent -> - let - ( state, result ) = - case - httpRequestEvent.request.bodyAsBase64 - |> Maybe.map (Base64.toBytes >> Maybe.map (decodeBytesToString >> Maybe.withDefault "Failed to decode bytes to string") >> Maybe.withDefault "Failed to decode from base64") - |> Maybe.withDefault "Missing HTTP body" - |> deserializeCounterEvent - of - Err error -> - ( stateBefore, Err ("Failed to deserialize counter event from HTTP Request content: " ++ error) ) - - Ok counterEvent -> - stateBefore |> processCounterEvent counterEvent |> Tuple.mapSecond Ok - - ( httpResponseCode, httpResponseBodyString ) = - case result of - Err error -> - ( 400, error ) - - Ok message -> - ( 200, message ) - - httpResponse = - { httpRequestId = httpRequestEvent.httpRequestId - , response = - { statusCode = httpResponseCode - , bodyAsBase64 = httpResponseBodyString |> Bytes.Encode.string |> Bytes.Encode.encode |> Base64.fromBytes - , headersToAdd = [] - } - } - in - ( state - , ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withCompleteHttpResponsesAdded [ httpResponse ] - ) - - ElmFullstack.TaskCompleteEvent _ -> - ( stateBefore, ElmFullstack.passiveBackendEventResponse ) - - ElmFullstack.PosixTimeHasArrivedEvent _ -> - ( stateBefore, ElmFullstack.passiveBackendEventResponse ) +subscriptions : State -> ElmFullstack.BackendSubs State +subscriptions _ = + { httpRequest = updateForHttpRequestEvent + , posixTimeIsPast = Nothing + } + + +updateForHttpRequestEvent : ElmFullstack.HttpRequestEventStruct -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpRequestEvent httpRequestEvent stateBefore = + let + ( state, result ) = + case + httpRequestEvent.request.bodyAsBase64 + |> Maybe.map (Base64.toBytes >> Maybe.map (decodeBytesToString >> Maybe.withDefault "Failed to decode bytes to string") >> Maybe.withDefault "Failed to decode from base64") + |> Maybe.withDefault "Missing HTTP body" + |> deserializeCounterEvent + of + Err error -> + ( stateBefore, Err ("Failed to deserialize counter event from HTTP Request content: " ++ error) ) + + Ok counterEvent -> + stateBefore |> processCounterEvent counterEvent |> Tuple.mapSecond Ok + + ( httpResponseCode, httpResponseBodyString ) = + case result of + Err error -> + ( 400, error ) + + Ok message -> + ( 200, message ) + + httpResponse = + { httpRequestId = httpRequestEvent.httpRequestId + , response = + { statusCode = httpResponseCode + , bodyAsBase64 = httpResponseBodyString |> Bytes.Encode.string |> Bytes.Encode.encode |> Base64.fromBytes + , headersToAdd = [] + } + } + in + ( state + , [ ElmFullstack.RespondToHttpRequest httpResponse ] + ) processCounterEvent : CounterEvent -> State -> ( State, String ) diff --git a/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/ElmFullstack.elm b/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/ElmFullstack.elm index a72fa493..15930cc8 100644 --- a/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/ElmFullstack.elm +++ b/implement/test-elm-fullstack/example-elm-apps/counter-webapp/src/ElmFullstack.elm @@ -1,72 +1,33 @@ module ElmFullstack exposing (..) -type BackendEvent - = HttpRequestEvent HttpRequestEventStructure - | TaskCompleteEvent TaskCompleteEventStructure - | PosixTimeHasArrivedEvent { posixTimeMilli : Int } - - -type alias BackendEventResponse = - { startTasks : List StartTaskStructure - , notifyWhenPosixTimeHasArrived : Maybe { minimumPosixTimeMilli : Int } - , completeHttpResponses : List HttpResponseRequest +type alias BackendConfig state = + { init : ( state, BackendCmds state ) + , subscriptions : state -> BackendSubs state } -type alias TaskCompleteEventStructure = - { taskId : TaskId - , taskResult : TaskResultStructure +type alias BackendSubs state = + { httpRequest : HttpRequestEventStruct -> state -> ( state, BackendCmds state ) + , posixTimeIsPast : + Maybe + { minimumPosixTimeMilli : Int + , update : { currentPosixTimeMilli : Int } -> state -> ( state, BackendCmds state ) + } } -type TaskResultStructure - = CreateVolatileProcessResponse (Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete) - | RequestToVolatileProcessResponse (Result RequestToVolatileProcessError RequestToVolatileProcessComplete) - | CompleteWithoutResult - - -type alias StartTaskStructure = - { taskId : TaskId - , task : Task - } +type alias BackendCmds state = + List (BackendCmd state) -type Task - = CreateVolatileProcess CreateVolatileProcessStruct - | RequestToVolatileProcess RequestToVolatileProcessStruct +type BackendCmd state + = RespondToHttpRequest RespondToHttpRequestStruct + | CreateVolatileProcess (CreateVolatileProcessStruct state) + | RequestToVolatileProcess (RequestToVolatileProcessStruct state) | TerminateVolatileProcess TerminateVolatileProcessStruct -type alias HttpRequestEventStructure = - { httpRequestId : String - , posixTimeMilli : Int - , requestContext : HttpRequestContext - , request : HttpRequestProperties - } - - -type ResponseOverSerialInterface - = DecodeEventError String - | DecodeEventSuccess BackendEventResponse - - -type alias HttpResponseRequest = - { httpRequestId : String - , response : HttpResponse - } - - -type alias TaskId = - String - - -type alias BackendConfiguration state = - { init : state - , update : BackendEvent -> state -> ( state, BackendEventResponse ) - } - - type alias HttpRequestEventStruct = { httpRequestId : String , posixTimeMilli : Int @@ -107,11 +68,16 @@ type alias HttpHeader = } -type alias CreateVolatileProcessStruct = +type alias CreateVolatileProcessStruct state = { programCode : String + , update : CreateVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias CreateVolatileProcessResult = + Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete + + type alias CreateVolatileProcessErrorStruct = { exceptionToString : String } @@ -121,12 +87,17 @@ type alias CreateVolatileProcessComplete = { processId : String } -type alias RequestToVolatileProcessStruct = +type alias RequestToVolatileProcessStruct state = { processId : String , request : String + , update : RequestToVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias RequestToVolatileProcessResult = + Result RequestToVolatileProcessError RequestToVolatileProcessComplete + + type RequestToVolatileProcessError = ProcessNotFound @@ -140,43 +111,3 @@ type alias RequestToVolatileProcessComplete = type alias TerminateVolatileProcessStruct = { processId : String } - - -passiveBackendEventResponse : BackendEventResponse -passiveBackendEventResponse = - { startTasks = [] - , completeHttpResponses = [] - , notifyWhenPosixTimeHasArrived = Nothing - } - - -withStartTasksAdded : List StartTaskStructure -> BackendEventResponse -> BackendEventResponse -withStartTasksAdded startTasksToAdd responseBefore = - { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } - - -withCompleteHttpResponsesAdded : List HttpResponseRequest -> BackendEventResponse -> BackendEventResponse -withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = - { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } - - -concatBackendEventResponse : List BackendEventResponse -> BackendEventResponse -concatBackendEventResponse responses = - let - notifyWhenPosixTimeHasArrived = - responses - |> List.filterMap .notifyWhenPosixTimeHasArrived - |> List.map .minimumPosixTimeMilli - |> List.minimum - |> Maybe.map (\posixTimeMilli -> { minimumPosixTimeMilli = posixTimeMilli }) - - startTasks = - responses |> List.concatMap .startTasks - - completeHttpResponses = - responses |> List.concatMap .completeHttpResponses - in - { notifyWhenPosixTimeHasArrived = notifyWhenPosixTimeHasArrived - , startTasks = startTasks - , completeHttpResponses = completeHttpResponses - } diff --git a/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/InterfaceToHost.elm b/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/InterfaceToHost.elm deleted file mode 100644 index 27967d71..00000000 --- a/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/InterfaceToHost.elm +++ /dev/null @@ -1,404 +0,0 @@ -module Backend.InterfaceToHost exposing (..) - -import Json.Decode -import Json.Encode - - -type AppEvent - = HttpRequestEvent HttpRequestEventStructure - | TaskCompleteEvent TaskCompleteEventStructure - | ArrivedAtTimeEvent { posixTimeMilli : Int } - - -type alias AppEventResponse = - { startTasks : List StartTaskStructure - , notifyWhenArrivedAtTime : Maybe { posixTimeMilli : Int } - , completeHttpResponses : List HttpResponseRequest - } - - -type alias TaskCompleteEventStructure = - { taskId : TaskId - , taskResult : TaskResultStructure - } - - -type TaskResultStructure - = CreateVolatileHostResponse (Result CreateVolatileHostErrorStructure CreateVolatileHostComplete) - | RequestToVolatileHostResponse (Result RequestToVolatileHostError RequestToVolatileHostComplete) - | CompleteWithoutResult - - -type alias RequestToVolatileHostComplete = - { exceptionToString : Maybe String - , returnValueToString : Maybe String - , durationInMilliseconds : Int - } - - -type alias CreateVolatileHostErrorStructure = - { exceptionToString : String - } - - -type alias CreateVolatileHostComplete = - { hostId : String } - - -type RequestToVolatileHostError - = HostNotFound - - -type alias StartTaskStructure = - { taskId : TaskId - , task : Task - } - - -type alias RequestToVolatileHostStructure = - { hostId : String - , request : String - } - - -type Task - = CreateVolatileHost CreateVolatileHostStructure - | RequestToVolatileHost RequestToVolatileHostStructure - | ReleaseVolatileHost ReleaseVolatileHostStructure - - -type alias CreateVolatileHostStructure = - { script : String } - - -type alias ReleaseVolatileHostStructure = - { hostId : String } - - -type alias HttpRequestEventStructure = - { httpRequestId : String - , posixTimeMilli : Int - , requestContext : HttpRequestContext - , request : HttpRequestProperties - } - - -type alias HttpRequestContext = - { clientAddress : Maybe String - } - - -type alias HttpRequestProperties = - { method : String - , uri : String - , bodyAsBase64 : Maybe String - , headers : List HttpHeader - } - - -type ResponseOverSerialInterface - = DecodeEventError String - | DecodeEventSuccess AppEventResponse - - -type alias HttpResponseRequest = - { httpRequestId : String - , response : HttpResponse - } - - -type alias HttpResponse = - { statusCode : Int - , bodyAsBase64 : Maybe String - , headersToAdd : List HttpHeader - } - - -type alias HttpHeader = - { name : String - , values : List String - } - - -type alias TaskId = - String - - -passiveAppEventResponse : AppEventResponse -passiveAppEventResponse = - { startTasks = [] - , completeHttpResponses = [] - , notifyWhenArrivedAtTime = Nothing - } - - -withStartTasksAdded : List StartTaskStructure -> AppEventResponse -> AppEventResponse -withStartTasksAdded startTasksToAdd responseBefore = - { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } - - -withCompleteHttpResponsesAdded : List HttpResponseRequest -> AppEventResponse -> AppEventResponse -withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = - { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } - - -concatAppEventResponse : List AppEventResponse -> AppEventResponse -concatAppEventResponse responses = - let - notifyWhenArrivedAtTimePosixMilli = - responses - |> List.filterMap .notifyWhenArrivedAtTime - |> List.map .posixTimeMilli - |> List.minimum - - notifyWhenArrivedAtTime = - case notifyWhenArrivedAtTimePosixMilli of - Nothing -> - Nothing - - Just posixTimeMilli -> - Just { posixTimeMilli = posixTimeMilli } - - startTasks = - responses |> List.concatMap .startTasks - - completeHttpResponses = - responses |> List.concatMap .completeHttpResponses - in - { notifyWhenArrivedAtTime = notifyWhenArrivedAtTime - , startTasks = startTasks - , completeHttpResponses = completeHttpResponses - } - - -wrapForSerialInterface_processEvent : (AppEvent -> state -> ( state, AppEventResponse )) -> String -> state -> ( state, String ) -wrapForSerialInterface_processEvent update serializedEvent stateBefore = - let - ( state, response ) = - case serializedEvent |> Json.Decode.decodeString decodeProcessEvent of - Err error -> - ( stateBefore - , ("Failed to deserialize event: " ++ (error |> Json.Decode.errorToString)) - |> DecodeEventError - ) - - Ok hostEvent -> - stateBefore - |> update hostEvent - |> Tuple.mapSecond DecodeEventSuccess - in - ( state, response |> encodeResponseOverSerialInterface |> Json.Encode.encode 0 ) - - -decodeProcessEvent : Json.Decode.Decoder AppEvent -decodeProcessEvent = - Json.Decode.oneOf - [ Json.Decode.field "ArrivedAtTimeEvent" (Json.Decode.field "posixTimeMilli" Json.Decode.int) - |> Json.Decode.map (\posixTimeMilli -> ArrivedAtTimeEvent { posixTimeMilli = posixTimeMilli }) - , Json.Decode.field "TaskCompleteEvent" decodeTaskCompleteEventStructure |> Json.Decode.map TaskCompleteEvent - , Json.Decode.field "HttpRequestEvent" decodeHttpRequestEventStructure |> Json.Decode.map HttpRequestEvent - ] - - -decodeTaskCompleteEventStructure : Json.Decode.Decoder TaskCompleteEventStructure -decodeTaskCompleteEventStructure = - Json.Decode.map2 TaskCompleteEventStructure - (Json.Decode.field "taskId" Json.Decode.string) - (Json.Decode.field "taskResult" decodeTaskResult) - - -decodeTaskResult : Json.Decode.Decoder TaskResultStructure -decodeTaskResult = - Json.Decode.oneOf - [ Json.Decode.field "CreateVolatileHostResponse" (decodeResult decodeCreateVolatileHostError decodeCreateVolatileHostComplete) - |> Json.Decode.map CreateVolatileHostResponse - , Json.Decode.field "RequestToVolatileHostResponse" (decodeResult decodeRequestToVolatileHostError decodeRequestToVolatileHostComplete) - |> Json.Decode.map RequestToVolatileHostResponse - , Json.Decode.field "CompleteWithoutResult" (jsonDecodeSucceedWhenNotNull CompleteWithoutResult) - ] - - -decodeCreateVolatileHostError : Json.Decode.Decoder CreateVolatileHostErrorStructure -decodeCreateVolatileHostError = - Json.Decode.map CreateVolatileHostErrorStructure - (Json.Decode.field "exceptionToString" Json.Decode.string) - - -decodeCreateVolatileHostComplete : Json.Decode.Decoder CreateVolatileHostComplete -decodeCreateVolatileHostComplete = - Json.Decode.map CreateVolatileHostComplete - (Json.Decode.field "hostId" Json.Decode.string) - - -decodeRequestToVolatileHostComplete : Json.Decode.Decoder RequestToVolatileHostComplete -decodeRequestToVolatileHostComplete = - Json.Decode.map3 RequestToVolatileHostComplete - (decodeOptionalField "exceptionToString" Json.Decode.string) - (decodeOptionalField "returnValueToString" Json.Decode.string) - (Json.Decode.field "durationInMilliseconds" Json.Decode.int) - - -decodeRequestToVolatileHostError : Json.Decode.Decoder RequestToVolatileHostError -decodeRequestToVolatileHostError = - Json.Decode.oneOf - [ Json.Decode.field "HostNotFound" (jsonDecodeSucceedWhenNotNull HostNotFound) - ] - - -decodeHttpRequestEventStructure : Json.Decode.Decoder HttpRequestEventStructure -decodeHttpRequestEventStructure = - Json.Decode.map4 HttpRequestEventStructure - (Json.Decode.field "httpRequestId" Json.Decode.string) - (Json.Decode.field "posixTimeMilli" Json.Decode.int) - (Json.Decode.field "requestContext" decodeHttpRequestContext) - (Json.Decode.field "request" decodeHttpRequest) - - -decodeHttpRequestContext : Json.Decode.Decoder HttpRequestContext -decodeHttpRequestContext = - Json.Decode.map HttpRequestContext - (decodeOptionalField "clientAddress" Json.Decode.string) - - -decodeHttpRequest : Json.Decode.Decoder HttpRequestProperties -decodeHttpRequest = - Json.Decode.map4 HttpRequestProperties - (Json.Decode.field "method" Json.Decode.string) - (Json.Decode.field "uri" Json.Decode.string) - (decodeOptionalField "bodyAsBase64" Json.Decode.string) - (Json.Decode.field "headers" (Json.Decode.list decodeHttpHeader)) - - -decodeHttpHeader : Json.Decode.Decoder HttpHeader -decodeHttpHeader = - Json.Decode.map2 HttpHeader - (Json.Decode.field "name" Json.Decode.string) - (Json.Decode.field "values" (Json.Decode.list Json.Decode.string)) - - -decodeOptionalField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) -decodeOptionalField fieldName decoder = - let - finishDecoding json = - case Json.Decode.decodeValue (Json.Decode.field fieldName Json.Decode.value) json of - Ok _ -> - -- The field is present, so run the decoder on it. - Json.Decode.map Just (Json.Decode.field fieldName decoder) - - Err _ -> - -- The field was missing, which is fine! - Json.Decode.succeed Nothing - in - Json.Decode.value - |> Json.Decode.andThen finishDecoding - - -encodeResponseOverSerialInterface : ResponseOverSerialInterface -> Json.Encode.Value -encodeResponseOverSerialInterface responseOverSerialInterface = - (case responseOverSerialInterface of - DecodeEventError error -> - [ ( "DecodeEventError", error |> Json.Encode.string ) ] - - DecodeEventSuccess response -> - [ ( "DecodeEventSuccess", response |> encodeAppEventResponse ) ] - ) - |> Json.Encode.object - - -encodeAppEventResponse : AppEventResponse -> Json.Encode.Value -encodeAppEventResponse request = - [ ( "notifyWhenArrivedAtTime" - , request.notifyWhenArrivedAtTime - |> Maybe.map (\time -> [ ( "posixTimeMilli", time.posixTimeMilli |> Json.Encode.int ) ] |> Json.Encode.object) - |> Maybe.withDefault Json.Encode.null - ) - , ( "startTasks", request.startTasks |> Json.Encode.list encodeStartTask ) - , ( "completeHttpResponses", request.completeHttpResponses |> Json.Encode.list encodeHttpResponseRequest ) - ] - |> Json.Encode.object - - -encodeStartTask : StartTaskStructure -> Json.Encode.Value -encodeStartTask startTaskAfterTime = - Json.Encode.object - [ ( "taskId", startTaskAfterTime.taskId |> encodeTaskId ) - , ( "task", startTaskAfterTime.task |> encodeTask ) - ] - - -encodeTaskId : TaskId -> Json.Encode.Value -encodeTaskId = - Json.Encode.string - - -encodeTask : Task -> Json.Encode.Value -encodeTask task = - case task of - CreateVolatileHost createVolatileHost -> - Json.Encode.object - [ ( "CreateVolatileHost", Json.Encode.object [ ( "script", createVolatileHost.script |> Json.Encode.string ) ] ) ] - - RequestToVolatileHost processRequestToVolatileHost -> - Json.Encode.object - [ ( "RequestToVolatileHost" - , Json.Encode.object - [ ( "hostId", processRequestToVolatileHost.hostId |> Json.Encode.string ) - , ( "request", processRequestToVolatileHost.request |> Json.Encode.string ) - ] - ) - ] - - ReleaseVolatileHost releaseVolatileHost -> - Json.Encode.object - [ ( "ReleaseVolatileHost" - , Json.Encode.object - [ ( "hostId", releaseVolatileHost.hostId |> Json.Encode.string ) - ] - ) - ] - - -encodeHttpResponseRequest : HttpResponseRequest -> Json.Encode.Value -encodeHttpResponseRequest httpResponseRequest = - Json.Encode.object - [ ( "httpRequestId", httpResponseRequest.httpRequestId |> Json.Encode.string ) - , ( "response", httpResponseRequest.response |> encodeHttpResponse ) - ] - - -encodeHttpResponse : HttpResponse -> Json.Encode.Value -encodeHttpResponse httpResponse = - [ ( "statusCode", httpResponse.statusCode |> Json.Encode.int ) - , ( "headersToAdd", httpResponse.headersToAdd |> Json.Encode.list encodeHttpHeader ) - , ( "bodyAsBase64", httpResponse.bodyAsBase64 |> Maybe.map Json.Encode.string |> Maybe.withDefault Json.Encode.null ) - ] - |> Json.Encode.object - - -encodeHttpHeader : HttpHeader -> Json.Encode.Value -encodeHttpHeader httpHeader = - [ ( "name", httpHeader.name |> Json.Encode.string ) - , ( "values", httpHeader.values |> Json.Encode.list Json.Encode.string ) - ] - |> Json.Encode.object - - -decodeResult : Json.Decode.Decoder error -> Json.Decode.Decoder ok -> Json.Decode.Decoder (Result error ok) -decodeResult errorDecoder okDecoder = - Json.Decode.oneOf - [ Json.Decode.field "Err" errorDecoder |> Json.Decode.map Err - , Json.Decode.field "Ok" okDecoder |> Json.Decode.map Ok - ] - - -jsonDecodeSucceedWhenNotNull : a -> Json.Decode.Decoder a -jsonDecodeSucceedWhenNotNull valueIfNotNull = - Json.Decode.value - |> Json.Decode.andThen - (\asValue -> - if asValue == Json.Encode.null then - Json.Decode.fail "Is null." - - else - Json.Decode.succeed valueIfNotNull - ) diff --git a/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/Main.elm b/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/Main.elm index ca0fbcd7..4be5f384 100644 --- a/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/Main.elm +++ b/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/Backend/Main.elm @@ -1,107 +1,112 @@ -module Backend.Main exposing - ( State - , interfaceToHost_initState - , interfaceToHost_processEvent - ) - -import Backend.InterfaceToHost as InterfaceToHost -import Base64 -import Bytes -import Bytes.Encode - - -type alias State = - { posixTimeMilli : Int - , httpRequestsToRespondTo : List InterfaceToHost.HttpRequestEventStructure - } - - -processEvent : InterfaceToHost.AppEvent -> State -> ( State, InterfaceToHost.AppEventResponse ) -processEvent hostEvent stateBefore = - case hostEvent of - InterfaceToHost.HttpRequestEvent httpRequestEvent -> - let - state = - { stateBefore - | posixTimeMilli = httpRequestEvent.posixTimeMilli - , httpRequestsToRespondTo = httpRequestEvent :: stateBefore.httpRequestsToRespondTo - } - in - state |> updateForHttpResponses - - InterfaceToHost.TaskCompleteEvent _ -> - stateBefore |> updateForHttpResponses - - InterfaceToHost.ArrivedAtTimeEvent { posixTimeMilli } -> - { stateBefore | posixTimeMilli = posixTimeMilli } |> updateForHttpResponses - - -updateForHttpResponses : State -> ( State, InterfaceToHost.AppEventResponse ) -updateForHttpResponses state = - let - httpRequestsWithCompletionTimes = - state.httpRequestsToRespondTo - |> List.map (\requestEvent -> ( requestEvent, completionTimeForHttpRequest requestEvent )) - - nextCompletionPosixTimeMilli = - httpRequestsWithCompletionTimes - |> List.map (Tuple.second >> .completionPosixTimeMilli) - |> List.minimum - - completeHttpRequestsTasks = - httpRequestsWithCompletionTimes - |> List.filter (\( _, { completionPosixTimeMilli } ) -> completionPosixTimeMilli <= state.posixTimeMilli) - |> List.map Tuple.first - |> List.map - (\requestEvent -> - let - ageInMilliseconds = - state.posixTimeMilli - requestEvent.posixTimeMilli - in - { httpRequestId = requestEvent.httpRequestId - , response = - { statusCode = 200 - , bodyAsBase64 = - ("Completed in " ++ (ageInMilliseconds |> String.fromInt) ++ " milliseconds.") - |> encodeStringToBytes - |> Base64.fromBytes - , headersToAdd = [] - } - } - ) - in - ( state - , { completeHttpResponses = completeHttpRequestsTasks - , notifyWhenArrivedAtTime = Just { posixTimeMilli = nextCompletionPosixTimeMilli |> Maybe.withDefault (state.posixTimeMilli + 1000) } - , startTasks = [] - } - ) - - -completionTimeForHttpRequest : InterfaceToHost.HttpRequestEventStructure -> { completionPosixTimeMilli : Int } -completionTimeForHttpRequest httpRequest = - let - delayMilliseconds = - httpRequest.request.headers - |> List.filter (.name >> (==) "delay-milliseconds") - |> List.filterMap (.values >> List.head) - |> List.head - |> Maybe.andThen String.toInt - |> Maybe.withDefault 0 - in - { completionPosixTimeMilli = delayMilliseconds + httpRequest.posixTimeMilli } - - -encodeStringToBytes : String -> Bytes.Bytes -encodeStringToBytes = - Bytes.Encode.string >> Bytes.Encode.encode - - -interfaceToHost_initState : State -interfaceToHost_initState = - { posixTimeMilli = 0, httpRequestsToRespondTo = [] } - - -interfaceToHost_processEvent : String -> State -> ( State, String ) -interfaceToHost_processEvent = - InterfaceToHost.wrapForSerialInterface_processEvent processEvent +module Backend.Main exposing + ( State + , backendMain + ) + +import Base64 +import Bytes +import Bytes.Encode +import ElmFullstack + + +type alias State = + { posixTimeMilli : Int + , httpRequestsToRespondTo : List ElmFullstack.HttpRequestEventStruct + } + + +backendMain : ElmFullstack.BackendConfig State +backendMain = + { init = ( initState, [] ) + , subscriptions = subscriptions + } + + +subscriptions : State -> ElmFullstack.BackendSubs State +subscriptions state = + let + nextCompletionPosixTimeMilli = + state + |> getHttpRequestsWithCompletionTimes + |> List.map (Tuple.second >> .completionPosixTimeMilli) + |> List.minimum + in + { httpRequest = updateForHttpRequestEvent + , posixTimeIsPast = + Just + { minimumPosixTimeMilli = nextCompletionPosixTimeMilli |> Maybe.withDefault (state.posixTimeMilli + 1000) + , update = + \{ currentPosixTimeMilli } stateBefore -> + { stateBefore | posixTimeMilli = currentPosixTimeMilli } |> updateForHttpResponses + } + } + + +updateForHttpRequestEvent : ElmFullstack.HttpRequestEventStruct -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpRequestEvent httpRequestEvent stateBefore = + let + state = + { stateBefore + | posixTimeMilli = httpRequestEvent.posixTimeMilli + , httpRequestsToRespondTo = httpRequestEvent :: stateBefore.httpRequestsToRespondTo + } + in + state |> updateForHttpResponses + + +updateForHttpResponses : State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpResponses state = + ( state + , state + |> getHttpRequestsWithCompletionTimes + |> List.filter (\( _, { completionPosixTimeMilli } ) -> completionPosixTimeMilli <= state.posixTimeMilli) + |> List.map Tuple.first + |> List.map + (\requestEvent -> + let + ageInMilliseconds = + state.posixTimeMilli - requestEvent.posixTimeMilli + in + { httpRequestId = requestEvent.httpRequestId + , response = + { statusCode = 200 + , bodyAsBase64 = + ("Completed in " ++ (ageInMilliseconds |> String.fromInt) ++ " milliseconds.") + |> encodeStringToBytes + |> Base64.fromBytes + , headersToAdd = [] + } + } + ) + |> List.map ElmFullstack.RespondToHttpRequest + ) + + +getHttpRequestsWithCompletionTimes : State -> List ( ElmFullstack.HttpRequestEventStruct, { completionPosixTimeMilli : Int } ) +getHttpRequestsWithCompletionTimes state = + state.httpRequestsToRespondTo + |> List.map (\requestEvent -> ( requestEvent, completionTimeForHttpRequest requestEvent )) + + +completionTimeForHttpRequest : ElmFullstack.HttpRequestEventStruct -> { completionPosixTimeMilli : Int } +completionTimeForHttpRequest httpRequest = + let + delayMilliseconds = + httpRequest.request.headers + |> List.filter (.name >> (==) "delay-milliseconds") + |> List.filterMap (.values >> List.head) + |> List.head + |> Maybe.andThen String.toInt + |> Maybe.withDefault 0 + in + { completionPosixTimeMilli = delayMilliseconds + httpRequest.posixTimeMilli } + + +encodeStringToBytes : String -> Bytes.Bytes +encodeStringToBytes = + Bytes.Encode.string >> Bytes.Encode.encode + + +initState : State +initState = + { posixTimeMilli = 0, httpRequestsToRespondTo = [] } diff --git a/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/ElmFullstack.elm b/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/ElmFullstack.elm new file mode 100644 index 00000000..15930cc8 --- /dev/null +++ b/implement/test-elm-fullstack/example-elm-apps/http-long-polling/src/ElmFullstack.elm @@ -0,0 +1,113 @@ +module ElmFullstack exposing (..) + + +type alias BackendConfig state = + { init : ( state, BackendCmds state ) + , subscriptions : state -> BackendSubs state + } + + +type alias BackendSubs state = + { httpRequest : HttpRequestEventStruct -> state -> ( state, BackendCmds state ) + , posixTimeIsPast : + Maybe + { minimumPosixTimeMilli : Int + , update : { currentPosixTimeMilli : Int } -> state -> ( state, BackendCmds state ) + } + } + + +type alias BackendCmds state = + List (BackendCmd state) + + +type BackendCmd state + = RespondToHttpRequest RespondToHttpRequestStruct + | CreateVolatileProcess (CreateVolatileProcessStruct state) + | RequestToVolatileProcess (RequestToVolatileProcessStruct state) + | TerminateVolatileProcess TerminateVolatileProcessStruct + + +type alias HttpRequestEventStruct = + { httpRequestId : String + , posixTimeMilli : Int + , requestContext : HttpRequestContext + , request : HttpRequestProperties + } + + +type alias HttpRequestContext = + { clientAddress : Maybe String + } + + +type alias HttpRequestProperties = + { method : String + , uri : String + , bodyAsBase64 : Maybe String + , headers : List HttpHeader + } + + +type alias RespondToHttpRequestStruct = + { httpRequestId : String + , response : HttpResponse + } + + +type alias HttpResponse = + { statusCode : Int + , bodyAsBase64 : Maybe String + , headersToAdd : List HttpHeader + } + + +type alias HttpHeader = + { name : String + , values : List String + } + + +type alias CreateVolatileProcessStruct state = + { programCode : String + , update : CreateVolatileProcessResult -> state -> ( state, BackendCmds state ) + } + + +type alias CreateVolatileProcessResult = + Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete + + +type alias CreateVolatileProcessErrorStruct = + { exceptionToString : String + } + + +type alias CreateVolatileProcessComplete = + { processId : String } + + +type alias RequestToVolatileProcessStruct state = + { processId : String + , request : String + , update : RequestToVolatileProcessResult -> state -> ( state, BackendCmds state ) + } + + +type alias RequestToVolatileProcessResult = + Result RequestToVolatileProcessError RequestToVolatileProcessComplete + + +type RequestToVolatileProcessError + = ProcessNotFound + + +type alias RequestToVolatileProcessComplete = + { exceptionToString : Maybe String + , returnValueToString : Maybe String + , durationInMilliseconds : Int + } + + +type alias TerminateVolatileProcessStruct = + { processId : String } diff --git a/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/Backend/Main.elm b/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/Backend/Main.elm index db957abe..e11b2089 100644 --- a/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/Backend/Main.elm +++ b/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/Backend/Main.elm @@ -12,135 +12,47 @@ import Json.Decode type alias State = { volatileProcessId : Maybe String - , httpRequestToForward : Maybe ElmFullstack.HttpRequestEventStructure + , httpRequestToForward : Maybe ElmFullstack.HttpRequestEventStruct } -backendMain : ElmFullstack.BackendConfiguration State +backendMain : ElmFullstack.BackendConfig State backendMain = - { init = { volatileProcessId = Nothing, httpRequestToForward = Nothing } - , update = processEvent + { init = ( { volatileProcessId = Nothing, httpRequestToForward = Nothing }, [] ) + , subscriptions = subscriptions } -processEvent : ElmFullstack.BackendEvent -> State -> ( State, ElmFullstack.BackendEventResponse ) -processEvent hostEvent stateBefore = - case hostEvent of - ElmFullstack.PosixTimeHasArrivedEvent _ -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) - - ElmFullstack.HttpRequestEvent httpRequestEvent -> - let - state = - { stateBefore | httpRequestToForward = Just httpRequestEvent } - in - ( state, state |> httpRequestForwardRequestsFromState ) - - ElmFullstack.TaskCompleteEvent taskComplete -> - case taskComplete.taskResult of - ElmFullstack.CreateVolatileProcessResponse createVolatileProcessResponse -> - case createVolatileProcessResponse of - Err _ -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) +subscriptions : State -> ElmFullstack.BackendSubs State +subscriptions _ = + { httpRequest = updateForHttpRequestEvent + , posixTimeIsPast = Nothing + } - Ok { processId } -> - let - state = - { stateBefore | volatileProcessId = Just processId } - in - ( state, state |> httpRequestForwardRequestsFromState ) - ElmFullstack.RequestToVolatileProcessResponse requestToVolatileProcessResponse -> - case stateBefore.httpRequestToForward of - Nothing -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) +updateForHttpRequestEvent : ElmFullstack.HttpRequestEventStruct -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpRequestEvent event stateBefore = + let + state = + { stateBefore | httpRequestToForward = Just event } + in + ( state, state |> httpRequestForwardRequestsFromState ) - Just httpRequestToForward -> - let - bodyFromString = - Bytes.Encode.string >> Bytes.Encode.encode >> Base64.fromBytes - httpResponse = - case requestToVolatileProcessResponse of - Err _ -> - { statusCode = 500 - , bodyAsBase64 = bodyFromString "Error running in volatile process." - , headersToAdd = [] - } - - Ok requestToVolatileHostComplete -> - case requestToVolatileHostComplete.exceptionToString of - Just exceptionToString -> - { statusCode = 500 - , bodyAsBase64 = bodyFromString ("Exception in volatile process: " ++ exceptionToString) - , headersToAdd = [] - } - - Nothing -> - let - returnValueAsHttpResponseResult = - requestToVolatileHostComplete.returnValueToString - |> Maybe.withDefault "" - |> Json.Decode.decodeString HttpViaVolatileProcess.decodeVolatileProcessHttpResponse - in - case returnValueAsHttpResponseResult of - Err decodeError -> - { statusCode = 500 - , bodyAsBase64 = - bodyFromString ("Error decoding response from volatile process: " ++ (decodeError |> Json.Decode.errorToString)) - , headersToAdd = [] - } - - Ok volatileHostHttpResponse -> - let - headersToAdd = - volatileHostHttpResponse.headers - |> List.filter (.name >> String.toLower >> (/=) "transfer-encoding") - in - { statusCode = 200 - , bodyAsBase64 = volatileHostHttpResponse.bodyAsBase64 - , headersToAdd = headersToAdd - } - - state = - { stateBefore | httpRequestToForward = Nothing } - in - ( state - , ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withCompleteHttpResponsesAdded - [ { httpRequestId = httpRequestToForward.httpRequestId - , response = httpResponse - } - ] - ) - - ElmFullstack.CompleteWithoutResult -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) - - -httpRequestForwardRequestsFromState : State -> ElmFullstack.BackendEventResponse +httpRequestForwardRequestsFromState : State -> ElmFullstack.BackendCmds State httpRequestForwardRequestsFromState state = case state.httpRequestToForward of Nothing -> - ElmFullstack.passiveBackendEventResponse + [] Just httpRequestToForward -> case state.volatileProcessId of Nothing -> - ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withStartTasksAdded - [ { taskId = "create-volatile-process" - , task = ElmFullstack.CreateVolatileProcess { programCode = HttpViaVolatileProcess.programCode } - } - ] + [ ElmFullstack.CreateVolatileProcess + { programCode = HttpViaVolatileProcess.programCode + , update = updateForCreateVolatileProcess + } + ] Just volatileProcessId -> let @@ -154,20 +66,19 @@ httpRequestForwardRequestsFromState state = in case maybeForwardTo of Nothing -> - ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withCompleteHttpResponsesAdded - [ { httpRequestId = httpRequestToForward.httpRequestId - , response = - { statusCode = 400 - , bodyAsBase64 = - "Where to should I forward this HTTP request? Use the 'forward-to' HTTP header to specify a destination." - |> Bytes.Encode.string - |> Bytes.Encode.encode - |> Base64.fromBytes - , headersToAdd = [] - } - } - ] + [ ElmFullstack.RespondToHttpRequest + { httpRequestId = httpRequestToForward.httpRequestId + , response = + { statusCode = 400 + , bodyAsBase64 = + "Where to should I forward this HTTP request? Use the 'forward-to' HTTP header to specify a destination." + |> Bytes.Encode.string + |> Bytes.Encode.encode + |> Base64.fromBytes + , headersToAdd = [] + } + } + ] Just forwardTo -> let @@ -177,17 +88,86 @@ httpRequestForwardRequestsFromState state = , headers = httpRequestToForward.request.headers , bodyAsBase64 = httpRequestToForward.request.bodyAsBase64 } + in + [ ElmFullstack.RequestToVolatileProcess + { processId = volatileProcessId + , request = HttpViaVolatileProcess.requestToVolatileProcess httpRequest + , update = updateForRequestToVolatileProcess + } + ] + - task = - { processId = volatileProcessId - , request = - HttpViaVolatileProcess.requestToVolatileProcess httpRequest +updateForCreateVolatileProcess : ElmFullstack.CreateVolatileProcessResult -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForCreateVolatileProcess createVolatileProcessResponse stateBefore = + case createVolatileProcessResponse of + Err _ -> + ( stateBefore, [] ) + + Ok { processId } -> + let + state = + { stateBefore | volatileProcessId = Just processId } + in + ( state, state |> httpRequestForwardRequestsFromState ) + + +updateForRequestToVolatileProcess : ElmFullstack.RequestToVolatileProcessResult -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForRequestToVolatileProcess requestToVolatileProcessResponse stateBefore = + case stateBefore.httpRequestToForward of + Nothing -> + ( stateBefore, [] ) + + Just httpRequestToForward -> + let + bodyFromString = + Bytes.Encode.string >> Bytes.Encode.encode >> Base64.fromBytes + + httpResponse = + case requestToVolatileProcessResponse of + Err _ -> + { statusCode = 500 + , bodyAsBase64 = bodyFromString "Error running in volatile process." + , headersToAdd = [] + } + + Ok requestToVolatileHostComplete -> + case requestToVolatileHostComplete.exceptionToString of + Just exceptionToString -> + { statusCode = 500 + , bodyAsBase64 = bodyFromString ("Exception in volatile process: " ++ exceptionToString) + , headersToAdd = [] } - |> ElmFullstack.RequestToVolatileProcess - in - ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withStartTasksAdded - [ { taskId = "http-request-forward-" ++ httpRequestToForward.httpRequestId - , task = task - } - ] + + Nothing -> + let + returnValueAsHttpResponseResult = + requestToVolatileHostComplete.returnValueToString + |> Maybe.withDefault "" + |> Json.Decode.decodeString HttpViaVolatileProcess.decodeVolatileProcessHttpResponse + in + case returnValueAsHttpResponseResult of + Err decodeError -> + { statusCode = 500 + , bodyAsBase64 = + bodyFromString ("Error decoding response from volatile process: " ++ (decodeError |> Json.Decode.errorToString)) + , headersToAdd = [] + } + + Ok volatileHostHttpResponse -> + let + headersToAdd = + volatileHostHttpResponse.headers + |> List.filter (.name >> String.toLower >> (/=) "transfer-encoding") + in + { statusCode = 200 + , bodyAsBase64 = volatileHostHttpResponse.bodyAsBase64 + , headersToAdd = headersToAdd + } + in + ( { stateBefore | httpRequestToForward = Nothing } + , [ ElmFullstack.RespondToHttpRequest + { httpRequestId = httpRequestToForward.httpRequestId + , response = httpResponse + } + ] + ) diff --git a/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/ElmFullstack.elm b/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/ElmFullstack.elm index a72fa493..15930cc8 100644 --- a/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/ElmFullstack.elm +++ b/implement/test-elm-fullstack/example-elm-apps/http-proxy/src/ElmFullstack.elm @@ -1,72 +1,33 @@ module ElmFullstack exposing (..) -type BackendEvent - = HttpRequestEvent HttpRequestEventStructure - | TaskCompleteEvent TaskCompleteEventStructure - | PosixTimeHasArrivedEvent { posixTimeMilli : Int } - - -type alias BackendEventResponse = - { startTasks : List StartTaskStructure - , notifyWhenPosixTimeHasArrived : Maybe { minimumPosixTimeMilli : Int } - , completeHttpResponses : List HttpResponseRequest +type alias BackendConfig state = + { init : ( state, BackendCmds state ) + , subscriptions : state -> BackendSubs state } -type alias TaskCompleteEventStructure = - { taskId : TaskId - , taskResult : TaskResultStructure +type alias BackendSubs state = + { httpRequest : HttpRequestEventStruct -> state -> ( state, BackendCmds state ) + , posixTimeIsPast : + Maybe + { minimumPosixTimeMilli : Int + , update : { currentPosixTimeMilli : Int } -> state -> ( state, BackendCmds state ) + } } -type TaskResultStructure - = CreateVolatileProcessResponse (Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete) - | RequestToVolatileProcessResponse (Result RequestToVolatileProcessError RequestToVolatileProcessComplete) - | CompleteWithoutResult - - -type alias StartTaskStructure = - { taskId : TaskId - , task : Task - } +type alias BackendCmds state = + List (BackendCmd state) -type Task - = CreateVolatileProcess CreateVolatileProcessStruct - | RequestToVolatileProcess RequestToVolatileProcessStruct +type BackendCmd state + = RespondToHttpRequest RespondToHttpRequestStruct + | CreateVolatileProcess (CreateVolatileProcessStruct state) + | RequestToVolatileProcess (RequestToVolatileProcessStruct state) | TerminateVolatileProcess TerminateVolatileProcessStruct -type alias HttpRequestEventStructure = - { httpRequestId : String - , posixTimeMilli : Int - , requestContext : HttpRequestContext - , request : HttpRequestProperties - } - - -type ResponseOverSerialInterface - = DecodeEventError String - | DecodeEventSuccess BackendEventResponse - - -type alias HttpResponseRequest = - { httpRequestId : String - , response : HttpResponse - } - - -type alias TaskId = - String - - -type alias BackendConfiguration state = - { init : state - , update : BackendEvent -> state -> ( state, BackendEventResponse ) - } - - type alias HttpRequestEventStruct = { httpRequestId : String , posixTimeMilli : Int @@ -107,11 +68,16 @@ type alias HttpHeader = } -type alias CreateVolatileProcessStruct = +type alias CreateVolatileProcessStruct state = { programCode : String + , update : CreateVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias CreateVolatileProcessResult = + Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete + + type alias CreateVolatileProcessErrorStruct = { exceptionToString : String } @@ -121,12 +87,17 @@ type alias CreateVolatileProcessComplete = { processId : String } -type alias RequestToVolatileProcessStruct = +type alias RequestToVolatileProcessStruct state = { processId : String , request : String + , update : RequestToVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias RequestToVolatileProcessResult = + Result RequestToVolatileProcessError RequestToVolatileProcessComplete + + type RequestToVolatileProcessError = ProcessNotFound @@ -140,43 +111,3 @@ type alias RequestToVolatileProcessComplete = type alias TerminateVolatileProcessStruct = { processId : String } - - -passiveBackendEventResponse : BackendEventResponse -passiveBackendEventResponse = - { startTasks = [] - , completeHttpResponses = [] - , notifyWhenPosixTimeHasArrived = Nothing - } - - -withStartTasksAdded : List StartTaskStructure -> BackendEventResponse -> BackendEventResponse -withStartTasksAdded startTasksToAdd responseBefore = - { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } - - -withCompleteHttpResponsesAdded : List HttpResponseRequest -> BackendEventResponse -> BackendEventResponse -withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = - { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } - - -concatBackendEventResponse : List BackendEventResponse -> BackendEventResponse -concatBackendEventResponse responses = - let - notifyWhenPosixTimeHasArrived = - responses - |> List.filterMap .notifyWhenPosixTimeHasArrived - |> List.map .minimumPosixTimeMilli - |> List.minimum - |> Maybe.map (\posixTimeMilli -> { minimumPosixTimeMilli = posixTimeMilli }) - - startTasks = - responses |> List.concatMap .startTasks - - completeHttpResponses = - responses |> List.concatMap .completeHttpResponses - in - { notifyWhenPosixTimeHasArrived = notifyWhenPosixTimeHasArrived - , startTasks = startTasks - , completeHttpResponses = completeHttpResponses - } diff --git a/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/InterfaceToHost.elm b/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/InterfaceToHost.elm deleted file mode 100644 index 27967d71..00000000 --- a/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/InterfaceToHost.elm +++ /dev/null @@ -1,404 +0,0 @@ -module Backend.InterfaceToHost exposing (..) - -import Json.Decode -import Json.Encode - - -type AppEvent - = HttpRequestEvent HttpRequestEventStructure - | TaskCompleteEvent TaskCompleteEventStructure - | ArrivedAtTimeEvent { posixTimeMilli : Int } - - -type alias AppEventResponse = - { startTasks : List StartTaskStructure - , notifyWhenArrivedAtTime : Maybe { posixTimeMilli : Int } - , completeHttpResponses : List HttpResponseRequest - } - - -type alias TaskCompleteEventStructure = - { taskId : TaskId - , taskResult : TaskResultStructure - } - - -type TaskResultStructure - = CreateVolatileHostResponse (Result CreateVolatileHostErrorStructure CreateVolatileHostComplete) - | RequestToVolatileHostResponse (Result RequestToVolatileHostError RequestToVolatileHostComplete) - | CompleteWithoutResult - - -type alias RequestToVolatileHostComplete = - { exceptionToString : Maybe String - , returnValueToString : Maybe String - , durationInMilliseconds : Int - } - - -type alias CreateVolatileHostErrorStructure = - { exceptionToString : String - } - - -type alias CreateVolatileHostComplete = - { hostId : String } - - -type RequestToVolatileHostError - = HostNotFound - - -type alias StartTaskStructure = - { taskId : TaskId - , task : Task - } - - -type alias RequestToVolatileHostStructure = - { hostId : String - , request : String - } - - -type Task - = CreateVolatileHost CreateVolatileHostStructure - | RequestToVolatileHost RequestToVolatileHostStructure - | ReleaseVolatileHost ReleaseVolatileHostStructure - - -type alias CreateVolatileHostStructure = - { script : String } - - -type alias ReleaseVolatileHostStructure = - { hostId : String } - - -type alias HttpRequestEventStructure = - { httpRequestId : String - , posixTimeMilli : Int - , requestContext : HttpRequestContext - , request : HttpRequestProperties - } - - -type alias HttpRequestContext = - { clientAddress : Maybe String - } - - -type alias HttpRequestProperties = - { method : String - , uri : String - , bodyAsBase64 : Maybe String - , headers : List HttpHeader - } - - -type ResponseOverSerialInterface - = DecodeEventError String - | DecodeEventSuccess AppEventResponse - - -type alias HttpResponseRequest = - { httpRequestId : String - , response : HttpResponse - } - - -type alias HttpResponse = - { statusCode : Int - , bodyAsBase64 : Maybe String - , headersToAdd : List HttpHeader - } - - -type alias HttpHeader = - { name : String - , values : List String - } - - -type alias TaskId = - String - - -passiveAppEventResponse : AppEventResponse -passiveAppEventResponse = - { startTasks = [] - , completeHttpResponses = [] - , notifyWhenArrivedAtTime = Nothing - } - - -withStartTasksAdded : List StartTaskStructure -> AppEventResponse -> AppEventResponse -withStartTasksAdded startTasksToAdd responseBefore = - { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } - - -withCompleteHttpResponsesAdded : List HttpResponseRequest -> AppEventResponse -> AppEventResponse -withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = - { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } - - -concatAppEventResponse : List AppEventResponse -> AppEventResponse -concatAppEventResponse responses = - let - notifyWhenArrivedAtTimePosixMilli = - responses - |> List.filterMap .notifyWhenArrivedAtTime - |> List.map .posixTimeMilli - |> List.minimum - - notifyWhenArrivedAtTime = - case notifyWhenArrivedAtTimePosixMilli of - Nothing -> - Nothing - - Just posixTimeMilli -> - Just { posixTimeMilli = posixTimeMilli } - - startTasks = - responses |> List.concatMap .startTasks - - completeHttpResponses = - responses |> List.concatMap .completeHttpResponses - in - { notifyWhenArrivedAtTime = notifyWhenArrivedAtTime - , startTasks = startTasks - , completeHttpResponses = completeHttpResponses - } - - -wrapForSerialInterface_processEvent : (AppEvent -> state -> ( state, AppEventResponse )) -> String -> state -> ( state, String ) -wrapForSerialInterface_processEvent update serializedEvent stateBefore = - let - ( state, response ) = - case serializedEvent |> Json.Decode.decodeString decodeProcessEvent of - Err error -> - ( stateBefore - , ("Failed to deserialize event: " ++ (error |> Json.Decode.errorToString)) - |> DecodeEventError - ) - - Ok hostEvent -> - stateBefore - |> update hostEvent - |> Tuple.mapSecond DecodeEventSuccess - in - ( state, response |> encodeResponseOverSerialInterface |> Json.Encode.encode 0 ) - - -decodeProcessEvent : Json.Decode.Decoder AppEvent -decodeProcessEvent = - Json.Decode.oneOf - [ Json.Decode.field "ArrivedAtTimeEvent" (Json.Decode.field "posixTimeMilli" Json.Decode.int) - |> Json.Decode.map (\posixTimeMilli -> ArrivedAtTimeEvent { posixTimeMilli = posixTimeMilli }) - , Json.Decode.field "TaskCompleteEvent" decodeTaskCompleteEventStructure |> Json.Decode.map TaskCompleteEvent - , Json.Decode.field "HttpRequestEvent" decodeHttpRequestEventStructure |> Json.Decode.map HttpRequestEvent - ] - - -decodeTaskCompleteEventStructure : Json.Decode.Decoder TaskCompleteEventStructure -decodeTaskCompleteEventStructure = - Json.Decode.map2 TaskCompleteEventStructure - (Json.Decode.field "taskId" Json.Decode.string) - (Json.Decode.field "taskResult" decodeTaskResult) - - -decodeTaskResult : Json.Decode.Decoder TaskResultStructure -decodeTaskResult = - Json.Decode.oneOf - [ Json.Decode.field "CreateVolatileHostResponse" (decodeResult decodeCreateVolatileHostError decodeCreateVolatileHostComplete) - |> Json.Decode.map CreateVolatileHostResponse - , Json.Decode.field "RequestToVolatileHostResponse" (decodeResult decodeRequestToVolatileHostError decodeRequestToVolatileHostComplete) - |> Json.Decode.map RequestToVolatileHostResponse - , Json.Decode.field "CompleteWithoutResult" (jsonDecodeSucceedWhenNotNull CompleteWithoutResult) - ] - - -decodeCreateVolatileHostError : Json.Decode.Decoder CreateVolatileHostErrorStructure -decodeCreateVolatileHostError = - Json.Decode.map CreateVolatileHostErrorStructure - (Json.Decode.field "exceptionToString" Json.Decode.string) - - -decodeCreateVolatileHostComplete : Json.Decode.Decoder CreateVolatileHostComplete -decodeCreateVolatileHostComplete = - Json.Decode.map CreateVolatileHostComplete - (Json.Decode.field "hostId" Json.Decode.string) - - -decodeRequestToVolatileHostComplete : Json.Decode.Decoder RequestToVolatileHostComplete -decodeRequestToVolatileHostComplete = - Json.Decode.map3 RequestToVolatileHostComplete - (decodeOptionalField "exceptionToString" Json.Decode.string) - (decodeOptionalField "returnValueToString" Json.Decode.string) - (Json.Decode.field "durationInMilliseconds" Json.Decode.int) - - -decodeRequestToVolatileHostError : Json.Decode.Decoder RequestToVolatileHostError -decodeRequestToVolatileHostError = - Json.Decode.oneOf - [ Json.Decode.field "HostNotFound" (jsonDecodeSucceedWhenNotNull HostNotFound) - ] - - -decodeHttpRequestEventStructure : Json.Decode.Decoder HttpRequestEventStructure -decodeHttpRequestEventStructure = - Json.Decode.map4 HttpRequestEventStructure - (Json.Decode.field "httpRequestId" Json.Decode.string) - (Json.Decode.field "posixTimeMilli" Json.Decode.int) - (Json.Decode.field "requestContext" decodeHttpRequestContext) - (Json.Decode.field "request" decodeHttpRequest) - - -decodeHttpRequestContext : Json.Decode.Decoder HttpRequestContext -decodeHttpRequestContext = - Json.Decode.map HttpRequestContext - (decodeOptionalField "clientAddress" Json.Decode.string) - - -decodeHttpRequest : Json.Decode.Decoder HttpRequestProperties -decodeHttpRequest = - Json.Decode.map4 HttpRequestProperties - (Json.Decode.field "method" Json.Decode.string) - (Json.Decode.field "uri" Json.Decode.string) - (decodeOptionalField "bodyAsBase64" Json.Decode.string) - (Json.Decode.field "headers" (Json.Decode.list decodeHttpHeader)) - - -decodeHttpHeader : Json.Decode.Decoder HttpHeader -decodeHttpHeader = - Json.Decode.map2 HttpHeader - (Json.Decode.field "name" Json.Decode.string) - (Json.Decode.field "values" (Json.Decode.list Json.Decode.string)) - - -decodeOptionalField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) -decodeOptionalField fieldName decoder = - let - finishDecoding json = - case Json.Decode.decodeValue (Json.Decode.field fieldName Json.Decode.value) json of - Ok _ -> - -- The field is present, so run the decoder on it. - Json.Decode.map Just (Json.Decode.field fieldName decoder) - - Err _ -> - -- The field was missing, which is fine! - Json.Decode.succeed Nothing - in - Json.Decode.value - |> Json.Decode.andThen finishDecoding - - -encodeResponseOverSerialInterface : ResponseOverSerialInterface -> Json.Encode.Value -encodeResponseOverSerialInterface responseOverSerialInterface = - (case responseOverSerialInterface of - DecodeEventError error -> - [ ( "DecodeEventError", error |> Json.Encode.string ) ] - - DecodeEventSuccess response -> - [ ( "DecodeEventSuccess", response |> encodeAppEventResponse ) ] - ) - |> Json.Encode.object - - -encodeAppEventResponse : AppEventResponse -> Json.Encode.Value -encodeAppEventResponse request = - [ ( "notifyWhenArrivedAtTime" - , request.notifyWhenArrivedAtTime - |> Maybe.map (\time -> [ ( "posixTimeMilli", time.posixTimeMilli |> Json.Encode.int ) ] |> Json.Encode.object) - |> Maybe.withDefault Json.Encode.null - ) - , ( "startTasks", request.startTasks |> Json.Encode.list encodeStartTask ) - , ( "completeHttpResponses", request.completeHttpResponses |> Json.Encode.list encodeHttpResponseRequest ) - ] - |> Json.Encode.object - - -encodeStartTask : StartTaskStructure -> Json.Encode.Value -encodeStartTask startTaskAfterTime = - Json.Encode.object - [ ( "taskId", startTaskAfterTime.taskId |> encodeTaskId ) - , ( "task", startTaskAfterTime.task |> encodeTask ) - ] - - -encodeTaskId : TaskId -> Json.Encode.Value -encodeTaskId = - Json.Encode.string - - -encodeTask : Task -> Json.Encode.Value -encodeTask task = - case task of - CreateVolatileHost createVolatileHost -> - Json.Encode.object - [ ( "CreateVolatileHost", Json.Encode.object [ ( "script", createVolatileHost.script |> Json.Encode.string ) ] ) ] - - RequestToVolatileHost processRequestToVolatileHost -> - Json.Encode.object - [ ( "RequestToVolatileHost" - , Json.Encode.object - [ ( "hostId", processRequestToVolatileHost.hostId |> Json.Encode.string ) - , ( "request", processRequestToVolatileHost.request |> Json.Encode.string ) - ] - ) - ] - - ReleaseVolatileHost releaseVolatileHost -> - Json.Encode.object - [ ( "ReleaseVolatileHost" - , Json.Encode.object - [ ( "hostId", releaseVolatileHost.hostId |> Json.Encode.string ) - ] - ) - ] - - -encodeHttpResponseRequest : HttpResponseRequest -> Json.Encode.Value -encodeHttpResponseRequest httpResponseRequest = - Json.Encode.object - [ ( "httpRequestId", httpResponseRequest.httpRequestId |> Json.Encode.string ) - , ( "response", httpResponseRequest.response |> encodeHttpResponse ) - ] - - -encodeHttpResponse : HttpResponse -> Json.Encode.Value -encodeHttpResponse httpResponse = - [ ( "statusCode", httpResponse.statusCode |> Json.Encode.int ) - , ( "headersToAdd", httpResponse.headersToAdd |> Json.Encode.list encodeHttpHeader ) - , ( "bodyAsBase64", httpResponse.bodyAsBase64 |> Maybe.map Json.Encode.string |> Maybe.withDefault Json.Encode.null ) - ] - |> Json.Encode.object - - -encodeHttpHeader : HttpHeader -> Json.Encode.Value -encodeHttpHeader httpHeader = - [ ( "name", httpHeader.name |> Json.Encode.string ) - , ( "values", httpHeader.values |> Json.Encode.list Json.Encode.string ) - ] - |> Json.Encode.object - - -decodeResult : Json.Decode.Decoder error -> Json.Decode.Decoder ok -> Json.Decode.Decoder (Result error ok) -decodeResult errorDecoder okDecoder = - Json.Decode.oneOf - [ Json.Decode.field "Err" errorDecoder |> Json.Decode.map Err - , Json.Decode.field "Ok" okDecoder |> Json.Decode.map Ok - ] - - -jsonDecodeSucceedWhenNotNull : a -> Json.Decode.Decoder a -jsonDecodeSucceedWhenNotNull valueIfNotNull = - Json.Decode.value - |> Json.Decode.andThen - (\asValue -> - if asValue == Json.Encode.null then - Json.Decode.fail "Is null." - - else - Json.Decode.succeed valueIfNotNull - ) diff --git a/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/Main.elm b/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/Main.elm index f06f4649..668d2071 100644 --- a/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/Main.elm +++ b/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/Backend/Main.elm @@ -1,73 +1,67 @@ module Backend.Main exposing ( State - , interfaceToHost_initState - , interfaceToHost_processEvent + , backendMain ) -import Backend.InterfaceToHost as InterfaceToHost import Base64 import Bytes import Bytes.Decode import Bytes.Encode +import ElmFullstack type alias State = String -processEvent : InterfaceToHost.AppEvent -> State -> ( State, InterfaceToHost.AppEventResponse ) -processEvent hostEvent stateBefore = - case hostEvent of - InterfaceToHost.HttpRequestEvent httpRequestEvent -> - let - state = - case httpRequestEvent.request.method |> String.toLower of - "get" -> - stateBefore - - "post" -> - let - addition = - httpRequestEvent.request.bodyAsBase64 - |> Maybe.map (Base64.toBytes >> Maybe.map (decodeBytesToString >> Maybe.withDefault "Failed to decode bytes to string") >> Maybe.withDefault "Failed to decode from base64") - |> Maybe.withDefault "" - in - stateBefore ++ addition - - _ -> - stateBefore - - httpResponse = - { httpRequestId = httpRequestEvent.httpRequestId - , response = - { statusCode = 200 - , bodyAsBase64 = state |> Bytes.Encode.string |> Bytes.Encode.encode |> Base64.fromBytes - , headersToAdd = [] - } - } - in - ( state - , InterfaceToHost.passiveAppEventResponse - |> InterfaceToHost.withCompleteHttpResponsesAdded [ httpResponse ] - ) - - InterfaceToHost.TaskCompleteEvent _ -> - ( stateBefore, InterfaceToHost.passiveAppEventResponse ) - - InterfaceToHost.ArrivedAtTimeEvent _ -> - ( stateBefore, InterfaceToHost.passiveAppEventResponse ) +backendMain : ElmFullstack.BackendConfig State +backendMain = + { init = ( "", [] ) + , subscriptions = subscriptions + } + + +subscriptions : State -> ElmFullstack.BackendSubs State +subscriptions _ = + { httpRequest = updateForHttpRequestEvent + , posixTimeIsPast = Nothing + } + + +updateForHttpRequestEvent : ElmFullstack.HttpRequestEventStruct -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpRequestEvent event stateBefore = + let + state = + case event.request.method |> String.toLower of + "get" -> + stateBefore + + "post" -> + let + addition = + event.request.bodyAsBase64 + |> Maybe.map (Base64.toBytes >> Maybe.map (decodeBytesToString >> Maybe.withDefault "Failed to decode bytes to string") >> Maybe.withDefault "Failed to decode from base64") + |> Maybe.withDefault "" + in + stateBefore ++ addition + + _ -> + stateBefore + + httpResponse = + { httpRequestId = event.httpRequestId + , response = + { statusCode = 200 + , bodyAsBase64 = state |> Bytes.Encode.string |> Bytes.Encode.encode |> Base64.fromBytes + , headersToAdd = [] + } + } + in + ( state + , [ ElmFullstack.RespondToHttpRequest httpResponse ] + ) decodeBytesToString : Bytes.Bytes -> Maybe String decodeBytesToString bytes = bytes |> Bytes.Decode.decode (Bytes.Decode.string (bytes |> Bytes.width)) - - -interfaceToHost_initState : State -interfaceToHost_initState = - "" - - -interfaceToHost_processEvent : String -> State -> ( State, String ) -interfaceToHost_processEvent = - InterfaceToHost.wrapForSerialInterface_processEvent processEvent diff --git a/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/ElmFullstack.elm b/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/ElmFullstack.elm new file mode 100644 index 00000000..15930cc8 --- /dev/null +++ b/implement/test-elm-fullstack/example-elm-apps/migrate-from-int-to-string-builder-web-app/src/ElmFullstack.elm @@ -0,0 +1,113 @@ +module ElmFullstack exposing (..) + + +type alias BackendConfig state = + { init : ( state, BackendCmds state ) + , subscriptions : state -> BackendSubs state + } + + +type alias BackendSubs state = + { httpRequest : HttpRequestEventStruct -> state -> ( state, BackendCmds state ) + , posixTimeIsPast : + Maybe + { minimumPosixTimeMilli : Int + , update : { currentPosixTimeMilli : Int } -> state -> ( state, BackendCmds state ) + } + } + + +type alias BackendCmds state = + List (BackendCmd state) + + +type BackendCmd state + = RespondToHttpRequest RespondToHttpRequestStruct + | CreateVolatileProcess (CreateVolatileProcessStruct state) + | RequestToVolatileProcess (RequestToVolatileProcessStruct state) + | TerminateVolatileProcess TerminateVolatileProcessStruct + + +type alias HttpRequestEventStruct = + { httpRequestId : String + , posixTimeMilli : Int + , requestContext : HttpRequestContext + , request : HttpRequestProperties + } + + +type alias HttpRequestContext = + { clientAddress : Maybe String + } + + +type alias HttpRequestProperties = + { method : String + , uri : String + , bodyAsBase64 : Maybe String + , headers : List HttpHeader + } + + +type alias RespondToHttpRequestStruct = + { httpRequestId : String + , response : HttpResponse + } + + +type alias HttpResponse = + { statusCode : Int + , bodyAsBase64 : Maybe String + , headersToAdd : List HttpHeader + } + + +type alias HttpHeader = + { name : String + , values : List String + } + + +type alias CreateVolatileProcessStruct state = + { programCode : String + , update : CreateVolatileProcessResult -> state -> ( state, BackendCmds state ) + } + + +type alias CreateVolatileProcessResult = + Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete + + +type alias CreateVolatileProcessErrorStruct = + { exceptionToString : String + } + + +type alias CreateVolatileProcessComplete = + { processId : String } + + +type alias RequestToVolatileProcessStruct state = + { processId : String + , request : String + , update : RequestToVolatileProcessResult -> state -> ( state, BackendCmds state ) + } + + +type alias RequestToVolatileProcessResult = + Result RequestToVolatileProcessError RequestToVolatileProcessComplete + + +type RequestToVolatileProcessError + = ProcessNotFound + + +type alias RequestToVolatileProcessComplete = + { exceptionToString : Maybe String + , returnValueToString : Maybe String + , durationInMilliseconds : Int + } + + +type alias TerminateVolatileProcessStruct = + { processId : String } diff --git a/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/Backend/Main.elm b/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/Backend/Main.elm index de202865..293c22d8 100644 --- a/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/Backend/Main.elm +++ b/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/Backend/Main.elm @@ -11,144 +11,109 @@ import ElmFullstack type alias State = { volatileProcessId : Maybe String - , pendingHttpRequest : Maybe ElmFullstack.HttpRequestEventStructure + , pendingHttpRequest : Maybe ElmFullstack.HttpRequestEventStruct } -backendMain : ElmFullstack.BackendConfiguration State +backendMain : ElmFullstack.BackendConfig State backendMain = - { init = { volatileProcessId = Nothing, pendingHttpRequest = Nothing } - , update = processEvent + { init = ( { volatileProcessId = Nothing, pendingHttpRequest = Nothing }, [] ) + , subscriptions = subscriptions } -processEvent : ElmFullstack.BackendEvent -> State -> ( State, ElmFullstack.BackendEventResponse ) -processEvent hostEvent stateBefore = - case hostEvent of - ElmFullstack.PosixTimeHasArrivedEvent _ -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) +subscriptions : State -> ElmFullstack.BackendSubs State +subscriptions _ = + { httpRequest = updateForHttpRequestEvent + , posixTimeIsPast = Nothing + } - ElmFullstack.HttpRequestEvent httpRequestEvent -> - let - state = - { stateBefore | pendingHttpRequest = Just httpRequestEvent } - in - ( state, state |> tasksToVolatileProcessFromState ) - ElmFullstack.TaskCompleteEvent taskComplete -> - let - bodyFromString = - Bytes.Encode.string >> Bytes.Encode.encode >> Base64.fromBytes +updateForHttpRequestEvent : ElmFullstack.HttpRequestEventStruct -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForHttpRequestEvent event stateBefore = + let + state = + { stateBefore | pendingHttpRequest = Just event } + in + ( state, state |> volatileProcessCmdsFromState ) - httpResponseInternalServerError errorMessage = - { statusCode = 500 - , bodyAsBase64 = bodyFromString errorMessage - , headersToAdd = [] - } - in - case taskComplete.taskResult of - ElmFullstack.CreateVolatileProcessResponse createVolatileProcessResponse -> - case createVolatileProcessResponse of - Err error -> - let - httpResponses = - case stateBefore.pendingHttpRequest of - Nothing -> - [] - - Just pendingHttpRequest -> - [ { httpRequestId = pendingHttpRequest.httpRequestId - , response = - httpResponseInternalServerError - ("Failed to create volatile process: " ++ error.exceptionToString) - } - ] - in - ( stateBefore - , ElmFullstack.passiveBackendEventResponse |> ElmFullstack.withCompleteHttpResponsesAdded httpResponses - ) - - Ok { processId } -> - let - state = - { stateBefore | volatileProcessId = Just processId } - in - ( state, state |> tasksToVolatileProcessFromState ) - - ElmFullstack.RequestToVolatileProcessResponse requestToVolatileProcessResponse -> - case stateBefore.pendingHttpRequest of - Nothing -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) - - Just pendingHttpRequest -> - let - httpResponse = - case requestToVolatileProcessResponse of - Err _ -> - httpResponseInternalServerError "Error running in volatile process." - - Ok requestToVolatileProcessComplete -> - case requestToVolatileProcessComplete.exceptionToString of - Just exceptionToString -> - httpResponseInternalServerError ("Exception in volatile process: " ++ exceptionToString) - - Nothing -> - { statusCode = 200 - , bodyAsBase64 = Maybe.andThen bodyFromString requestToVolatileProcessComplete.returnValueToString - , headersToAdd = [] - } - - state = - { stateBefore | pendingHttpRequest = Nothing } - in - ( state - , ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withCompleteHttpResponsesAdded - [ { httpRequestId = pendingHttpRequest.httpRequestId - , response = httpResponse - } - ] - ) - - ElmFullstack.CompleteWithoutResult -> - ( stateBefore - , ElmFullstack.passiveBackendEventResponse - ) - - -tasksToVolatileProcessFromState : State -> ElmFullstack.BackendEventResponse -tasksToVolatileProcessFromState state = + +volatileProcessCmdsFromState : State -> ElmFullstack.BackendCmds State +volatileProcessCmdsFromState state = case state.pendingHttpRequest of Nothing -> - ElmFullstack.passiveBackendEventResponse + [] - Just pendingHttpRequest -> + Just _ -> case state.volatileProcessId of Nothing -> - ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withStartTasksAdded - [ { taskId = "create-volatile-process" - , task = - ElmFullstack.CreateVolatileProcess - { programCode = Backend.VolatileProcess.programCode } - } - ] + [ ElmFullstack.CreateVolatileProcess + { programCode = Backend.VolatileProcess.programCode + , update = updateForCreateVolatileProcess + } + ] Just volatileProcessId -> - let - task = - { processId = volatileProcessId - , request = "" - } - |> ElmFullstack.RequestToVolatileProcess - in - ElmFullstack.passiveBackendEventResponse - |> ElmFullstack.withStartTasksAdded - [ { taskId = "http-request-" ++ pendingHttpRequest.httpRequestId - , task = task - } - ] + [ ElmFullstack.RequestToVolatileProcess + { processId = volatileProcessId + , request = "" + , update = updateForRequestToVolatileProcess + } + ] + + +updateForCreateVolatileProcess : ElmFullstack.CreateVolatileProcessResult -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForCreateVolatileProcess createVolatileProcessResponse stateBefore = + case createVolatileProcessResponse of + Err _ -> + ( stateBefore, [] ) + + Ok { processId } -> + let + state = + { stateBefore | volatileProcessId = Just processId } + in + ( state, state |> volatileProcessCmdsFromState ) + + +updateForRequestToVolatileProcess : ElmFullstack.RequestToVolatileProcessResult -> State -> ( State, ElmFullstack.BackendCmds State ) +updateForRequestToVolatileProcess requestToVolatileProcessResponse stateBefore = + let + bodyFromString = + Bytes.Encode.string >> Bytes.Encode.encode >> Base64.fromBytes + + httpResponseInternalServerError errorMessage = + { statusCode = 500 + , bodyAsBase64 = bodyFromString errorMessage + , headersToAdd = [] + } + in + case stateBefore.pendingHttpRequest of + Nothing -> + ( stateBefore, [] ) + + Just pendingHttpRequest -> + let + httpResponse = + case requestToVolatileProcessResponse of + Err _ -> + httpResponseInternalServerError "Error running in volatile process." + + Ok requestToVolatileProcessComplete -> + case requestToVolatileProcessComplete.exceptionToString of + Just exceptionToString -> + httpResponseInternalServerError ("Exception in volatile process: " ++ exceptionToString) + + Nothing -> + { statusCode = 200 + , bodyAsBase64 = Maybe.andThen bodyFromString requestToVolatileProcessComplete.returnValueToString + , headersToAdd = [] + } + in + ( { stateBefore | pendingHttpRequest = Nothing } + , [ ElmFullstack.RespondToHttpRequest + { httpRequestId = pendingHttpRequest.httpRequestId + , response = httpResponse + } + ] + ) diff --git a/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/ElmFullstack.elm b/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/ElmFullstack.elm index a72fa493..15930cc8 100644 --- a/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/ElmFullstack.elm +++ b/implement/test-elm-fullstack/example-elm-apps/volatile-process-from-local-blob/src/ElmFullstack.elm @@ -1,72 +1,33 @@ module ElmFullstack exposing (..) -type BackendEvent - = HttpRequestEvent HttpRequestEventStructure - | TaskCompleteEvent TaskCompleteEventStructure - | PosixTimeHasArrivedEvent { posixTimeMilli : Int } - - -type alias BackendEventResponse = - { startTasks : List StartTaskStructure - , notifyWhenPosixTimeHasArrived : Maybe { minimumPosixTimeMilli : Int } - , completeHttpResponses : List HttpResponseRequest +type alias BackendConfig state = + { init : ( state, BackendCmds state ) + , subscriptions : state -> BackendSubs state } -type alias TaskCompleteEventStructure = - { taskId : TaskId - , taskResult : TaskResultStructure +type alias BackendSubs state = + { httpRequest : HttpRequestEventStruct -> state -> ( state, BackendCmds state ) + , posixTimeIsPast : + Maybe + { minimumPosixTimeMilli : Int + , update : { currentPosixTimeMilli : Int } -> state -> ( state, BackendCmds state ) + } } -type TaskResultStructure - = CreateVolatileProcessResponse (Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete) - | RequestToVolatileProcessResponse (Result RequestToVolatileProcessError RequestToVolatileProcessComplete) - | CompleteWithoutResult - - -type alias StartTaskStructure = - { taskId : TaskId - , task : Task - } +type alias BackendCmds state = + List (BackendCmd state) -type Task - = CreateVolatileProcess CreateVolatileProcessStruct - | RequestToVolatileProcess RequestToVolatileProcessStruct +type BackendCmd state + = RespondToHttpRequest RespondToHttpRequestStruct + | CreateVolatileProcess (CreateVolatileProcessStruct state) + | RequestToVolatileProcess (RequestToVolatileProcessStruct state) | TerminateVolatileProcess TerminateVolatileProcessStruct -type alias HttpRequestEventStructure = - { httpRequestId : String - , posixTimeMilli : Int - , requestContext : HttpRequestContext - , request : HttpRequestProperties - } - - -type ResponseOverSerialInterface - = DecodeEventError String - | DecodeEventSuccess BackendEventResponse - - -type alias HttpResponseRequest = - { httpRequestId : String - , response : HttpResponse - } - - -type alias TaskId = - String - - -type alias BackendConfiguration state = - { init : state - , update : BackendEvent -> state -> ( state, BackendEventResponse ) - } - - type alias HttpRequestEventStruct = { httpRequestId : String , posixTimeMilli : Int @@ -107,11 +68,16 @@ type alias HttpHeader = } -type alias CreateVolatileProcessStruct = +type alias CreateVolatileProcessStruct state = { programCode : String + , update : CreateVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias CreateVolatileProcessResult = + Result CreateVolatileProcessErrorStruct CreateVolatileProcessComplete + + type alias CreateVolatileProcessErrorStruct = { exceptionToString : String } @@ -121,12 +87,17 @@ type alias CreateVolatileProcessComplete = { processId : String } -type alias RequestToVolatileProcessStruct = +type alias RequestToVolatileProcessStruct state = { processId : String , request : String + , update : RequestToVolatileProcessResult -> state -> ( state, BackendCmds state ) } +type alias RequestToVolatileProcessResult = + Result RequestToVolatileProcessError RequestToVolatileProcessComplete + + type RequestToVolatileProcessError = ProcessNotFound @@ -140,43 +111,3 @@ type alias RequestToVolatileProcessComplete = type alias TerminateVolatileProcessStruct = { processId : String } - - -passiveBackendEventResponse : BackendEventResponse -passiveBackendEventResponse = - { startTasks = [] - , completeHttpResponses = [] - , notifyWhenPosixTimeHasArrived = Nothing - } - - -withStartTasksAdded : List StartTaskStructure -> BackendEventResponse -> BackendEventResponse -withStartTasksAdded startTasksToAdd responseBefore = - { responseBefore | startTasks = responseBefore.startTasks ++ startTasksToAdd } - - -withCompleteHttpResponsesAdded : List HttpResponseRequest -> BackendEventResponse -> BackendEventResponse -withCompleteHttpResponsesAdded httpResponsesToAdd responseBefore = - { responseBefore | completeHttpResponses = responseBefore.completeHttpResponses ++ httpResponsesToAdd } - - -concatBackendEventResponse : List BackendEventResponse -> BackendEventResponse -concatBackendEventResponse responses = - let - notifyWhenPosixTimeHasArrived = - responses - |> List.filterMap .notifyWhenPosixTimeHasArrived - |> List.map .minimumPosixTimeMilli - |> List.minimum - |> Maybe.map (\posixTimeMilli -> { minimumPosixTimeMilli = posixTimeMilli }) - - startTasks = - responses |> List.concatMap .startTasks - - completeHttpResponses = - responses |> List.concatMap .completeHttpResponses - in - { notifyWhenPosixTimeHasArrived = notifyWhenPosixTimeHasArrived - , startTasks = startTasks - , completeHttpResponses = completeHttpResponses - }