From 78862729e6c52ac5bf919079e2a81c5f318cf522 Mon Sep 17 00:00:00 2001 From: Nathanael Sensfelder Date: Sat, 8 Sep 2018 05:27:50 +0200 Subject: Redirects to login (and back) if disconnected. --- src/map-editor/src/Comm/Send.elm | 1 + src/map-editor/src/Struct/Flags.elm | 42 ---------- src/map-editor/src/Struct/Model.elm | 8 +- src/map-editor/src/Struct/ServerReply.elm | 3 +- src/map-editor/src/Update/HandleServerReply.elm | 100 +++++++++++++++--------- 5 files changed, 72 insertions(+), 82 deletions(-) delete mode 100644 src/map-editor/src/Struct/Flags.elm (limited to 'src/map-editor') diff --git a/src/map-editor/src/Comm/Send.elm b/src/map-editor/src/Comm/Send.elm index d70fc13..c61be07 100644 --- a/src/map-editor/src/Comm/Send.elm +++ b/src/map-editor/src/Comm/Send.elm @@ -30,6 +30,7 @@ internal_decoder reply_type = "add_tile_pattern" -> (Comm.AddTilePattern.decode) "set_map" -> (Comm.SetMap.decode) "okay" -> (Comm.Okay.decode) + "disconnected" -> (Json.Decode.succeed Struct.ServerReply.Disconnected) other -> (Json.Decode.fail ( diff --git a/src/map-editor/src/Struct/Flags.elm b/src/map-editor/src/Struct/Flags.elm deleted file mode 100644 index c0316f0..0000000 --- a/src/map-editor/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing - ( - Type, - maybe_get_param - ) - --- Elm ------------------------------------------------------------------------- -import List - --- Battlemap ------------------------------------------------------------------- -import Util.List - --------------------------------------------------------------------------------- --- TYPES ----------------------------------------------------------------------- --------------------------------------------------------------------------------- -type alias Type = - { - user_id : String, - token : String, - url_params : (List (List String)) - } - --------------------------------------------------------------------------------- --- LOCAL ----------------------------------------------------------------------- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- EXPORTED -------------------------------------------------------------------- --------------------------------------------------------------------------------- -maybe_get_param : String -> Type -> (Maybe String) -maybe_get_param param flags = - case - (Util.List.get_first - (\e -> ((List.head e) == (Just param))) - flags.url_params - ) - of - Nothing -> Nothing - (Just a) -> - case (List.tail a) of - Nothing -> Nothing - (Just b) -> (List.head b) diff --git a/src/map-editor/src/Struct/Model.elm b/src/map-editor/src/Struct/Model.elm index 70b840f..a7ec964 100644 --- a/src/map-editor/src/Struct/Model.elm +++ b/src/map-editor/src/Struct/Model.elm @@ -12,9 +12,11 @@ module Struct.Model exposing -- Elm ------------------------------------------------------------------------- import Dict --- Map ------------------------------------------------------------------- -import Struct.Error +-- Shared ---------------------------------------------------------------------- import Struct.Flags + +-- Map Editor ------------------------------------------------------------------ +import Struct.Error import Struct.HelpRequest import Struct.Map import Struct.Tile @@ -27,6 +29,7 @@ import Struct.UI -------------------------------------------------------------------------------- type alias Type = { + flags: Struct.Flags.Type, toolbox: Struct.Toolbox.Type, help_request: Struct.HelpRequest.Type, map: Struct.Map.Type, @@ -53,6 +56,7 @@ new flags = maybe_map_id = (Struct.Flags.maybe_get_param "id" flags) model = { + flags = flags, toolbox = (Struct.Toolbox.default), help_request = Struct.HelpRequest.None, map = (Struct.Map.empty), diff --git a/src/map-editor/src/Struct/ServerReply.elm b/src/map-editor/src/Struct/ServerReply.elm index 177950b..e3116fe 100644 --- a/src/map-editor/src/Struct/ServerReply.elm +++ b/src/map-editor/src/Struct/ServerReply.elm @@ -2,7 +2,7 @@ module Struct.ServerReply exposing (Type(..)) -- Elm ------------------------------------------------------------------------- --- Battlemap ------------------------------------------------------------------- +-- Map Editor ------------------------------------------------------------------ import Struct.Map import Struct.Tile import Struct.TilePattern @@ -13,6 +13,7 @@ import Struct.TilePattern type Type = Okay + | Disconnected | AddTile Struct.Tile.Type | AddTilePattern Struct.TilePattern.Type | SetMap Struct.Map.Type diff --git a/src/map-editor/src/Update/HandleServerReply.elm b/src/map-editor/src/Update/HandleServerReply.elm index 0e69c51..e982ef7 100644 --- a/src/map-editor/src/Update/HandleServerReply.elm +++ b/src/map-editor/src/Update/HandleServerReply.elm @@ -3,7 +3,13 @@ module Update.HandleServerReply exposing (apply_to) -- Elm ------------------------------------------------------------------------- import Http --- Map ------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Action.Ports + +import Struct.Flags + +-- Map Editor ------------------------------------------------------------------ +import Constants.IO import Struct.Map import Struct.Error import Struct.Event @@ -19,61 +25,75 @@ import Struct.TilePattern -------------------------------------------------------------------------------- -- LOCAL ----------------------------------------------------------------------- -------------------------------------------------------------------------------- +disconnected : ( + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) + ) +disconnected current_state = + let (model, cmds) = current_state in + ( + model, + [ + (Action.Ports.go_to + ( + Constants.IO.base_url + ++ "/login/?action=disconnect&goto=" + ++ + (Http.encodeUri + ( + "/map-editor/?" + ++ (Struct.Flags.get_params_as_url model.flags) + ) + ) + ) + ) + ] + ) + add_tile : ( Struct.Tile.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_tile tl current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> ((Struct.Model.add_tile tl model), Nothing) + let (model, cmds) = current_state in + ((Struct.Model.add_tile tl model), cmds) add_tile_pattern : ( Struct.TilePattern.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) add_tile_pattern tp current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( - (Struct.Model.add_tile_pattern tp model), - Nothing - ) + let (model, cmds) = current_state in + ((Struct.Model.add_tile_pattern tp model), cmds) set_map : ( Struct.Map.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) set_map map current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( {model | map = (Struct.Map.solve_tiles model.tiles map)}, Nothing) + let (model, cmds) = current_state in + ({model | map = (Struct.Map.solve_tiles model.tiles map)}, cmds) refresh_map : ( - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) refresh_map current_state = - case current_state of - (_, (Just _)) -> current_state - (model, _) -> - ( - {model | map = (Struct.Map.solve_tiles model.tiles model.map)}, - Nothing - ) + let (model, cmds) = current_state in + ({model | map = (Struct.Map.solve_tiles model.tiles model.map)}, cmds) apply_command : ( Struct.ServerReply.Type -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) -> - (Struct.Model.Type, (Maybe Struct.Error.Type)) + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> + (Struct.Model.Type, (List (Cmd Struct.Event.Type))) ) apply_command command current_state = case command of + Struct.ServerReply.Disconnected -> (disconnected current_state) + (Struct.ServerReply.AddTile tl) -> (add_tile tl current_state) @@ -106,10 +126,16 @@ apply_to model query_result = ) (Result.Ok commands) -> - case (List.foldl (apply_command) (model, Nothing) commands) of - (updated_model, Nothing) -> (updated_model, Cmd.none) - (_, (Just error)) -> + let + (new_model, elm_commands) = + (List.foldl (apply_command) (model, [Cmd.none]) commands) + in + ( + new_model, ( - (Struct.Model.invalidate error model), - Cmd.none + case elm_commands of + [] -> Cmd.none + [cmd] -> cmd + _ -> (Cmd.batch elm_commands) ) + ) -- cgit v1.2.3-70-g09d2