| summaryrefslogtreecommitdiff | 
diff options
| author | Nathanael Sensfelder <SpamShield0@MultiAgentSystems.org> | 2018-09-08 05:27:50 +0200 | 
|---|---|---|
| committer | Nathanael Sensfelder <SpamShield0@MultiAgentSystems.org> | 2018-09-08 05:27:50 +0200 | 
| commit | 78862729e6c52ac5bf919079e2a81c5f318cf522 (patch) | |
| tree | 7e99944c079ebe093a91bb27e243861571533cf6 /src | |
| parent | 7cba3a16cb13f8e56f39b434d6278d68e2118145 (diff) | |
Redirects to login (and back) if disconnected.
Diffstat (limited to 'src')
20 files changed, 326 insertions, 417 deletions
| diff --git a/src/battle/src/Comm/Send.elm b/src/battle/src/Comm/Send.elm index 98e3ba4..f501b19 100644 --- a/src/battle/src/Comm/Send.elm +++ b/src/battle/src/Comm/Send.elm @@ -6,7 +6,7 @@ import Http  import Json.Decode  import Json.Encode --- Map ------------------------------------------------------------------- +-- Battle ----------------------------------------------------------------------  import Comm.AddArmor  import Comm.AddChar  import Comm.AddTile @@ -36,6 +36,9 @@ internal_decoder reply_type =        "set_map" -> (Comm.SetMap.decode)        "turn_results" -> (Comm.TurnResults.decode)        "set_timeline" -> (Comm.SetTimeline.decode) +      "disconnected" -> (Json.Decode.succeed Struct.ServerReply.Disconnected) +      "okay" -> (Json.Decode.succeed Struct.ServerReply.Okay) +        other ->           (Json.Decode.fail              ( diff --git a/src/battle/src/Struct/Flags.elm b/src/battle/src/Struct/Flags.elm deleted file mode 100644 index 228d258..0000000 --- a/src/battle/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing -   ( -      Type, -      maybe_get_param -   ) - --- Elm ------------------------------------------------------------------------- -import List - --- Map ------------------------------------------------------------------- -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/battle/src/Struct/Model.elm b/src/battle/src/Struct/Model.elm index c32db67..8722066 100644 --- a/src/battle/src/Struct/Model.elm +++ b/src/battle/src/Struct/Model.elm @@ -23,12 +23,14 @@ import Array  import Dict +-- Shared ---------------------------------------------------------------------- +import Struct.Flags +  -- Battle ----------------------------------------------------------------------  import Struct.Armor  import Struct.Character  import Struct.CharacterTurn  import Struct.Error -import Struct.Flags  import Struct.HelpRequest  import Struct.Location  import Struct.Map @@ -46,6 +48,7 @@ import Util.Array  --------------------------------------------------------------------------------  type alias Type =     { +      flags: Struct.Flags.Type,        help_request: Struct.HelpRequest.Type,        animator: (Maybe Struct.TurnResultAnimator.Type),        map: Struct.Map.Type, @@ -80,6 +83,7 @@ new flags =        maybe_battle_id = (Struct.Flags.maybe_get_param "id" flags)        model =           { +            flags = flags,              help_request = Struct.HelpRequest.None,              animator = Nothing,              map = (Struct.Map.empty), diff --git a/src/battle/src/Struct/ServerReply.elm b/src/battle/src/Struct/ServerReply.elm index 87325a5..28dde0d 100644 --- a/src/battle/src/Struct/ServerReply.elm +++ b/src/battle/src/Struct/ServerReply.elm @@ -2,7 +2,7 @@ module Struct.ServerReply exposing (Type(..))  -- Elm ------------------------------------------------------------------------- --- Map ------------------------------------------------------------------- +-- Battle ----------------------------------------------------------------------  import Struct.Armor  import Struct.Map  import Struct.Character @@ -16,6 +16,7 @@ import Struct.Weapon  type Type =     Okay +   | Disconnected     | AddArmor Struct.Armor.Type     | AddWeapon Struct.Weapon.Type     | AddCharacter (Struct.Character.Type, Int, Int, Int) diff --git a/src/battle/src/Update/HandleServerReply.elm b/src/battle/src/Update/HandleServerReply.elm index 85e7a39..b1506ba 100644 --- a/src/battle/src/Update/HandleServerReply.elm +++ b/src/battle/src/Update/HandleServerReply.elm @@ -11,7 +11,14 @@ import Http  import Time --- Map ------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Action.Ports + +import Struct.Flags + +-- Battle ---------------------------------------------------------------------- +import Constants.IO +  import Struct.Armor  import Struct.Map  import Struct.Character @@ -46,135 +53,151 @@ armor_getter model ref =  ----------- +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 +                     ( +                        "/battle/?" +                        ++ (Struct.Flags.get_params_as_url model.flags) +                     ) +                  ) +               ) +            ) +         ] +      ) +  add_armor : (        Struct.Armor.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_armor ar current_state = -   case current_state of -      (_, (Just _)) -> current_state -      (model, _) -> ((Struct.Model.add_armor ar model), Nothing) +   let (model, cmds) = current_state in +      ((Struct.Model.add_armor ar model), cmds)  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_weapon : (        Struct.Weapon.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_weapon wp current_state = -   case current_state of -      (_, (Just _)) -> current_state -      (model, _) -> ((Struct.Model.add_weapon wp model), Nothing) +   let (model, cmds) = current_state in +      ((Struct.Model.add_weapon wp model), cmds)  add_character : (        (Struct.Character.Type, Int, Int, Int) -> -      (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_character char_and_refs current_state = -   case current_state of -      (_, (Just _)) -> current_state -      (model, _) -> -         let -            (char, awp_ref, swp_ref, ar_ref) = char_and_refs -            awp = (weapon_getter model awp_ref) -            swp = (weapon_getter model swp_ref) -            ar = (armor_getter model ar_ref) -         in -            ( -               (Struct.Model.add_character -                  (Struct.Character.fill_missing_equipment_and_omnimods -                     (Struct.Model.tile_omnimods_fun model) -                     awp -                     swp -                     ar -                     char -                  ) -                  model -               ), -               Nothing +   let +      (model, cmds) = current_state +      (char, awp_ref, swp_ref, ar_ref) = char_and_refs +      awp = (weapon_getter model awp_ref) +      swp = (weapon_getter model swp_ref) +      ar = (armor_getter model ar_ref) +   in +      ( +         (Struct.Model.add_character +            (Struct.Character.fill_missing_equipment_and_omnimods +               (Struct.Model.tile_omnimods_fun model) +               awp +               swp +               ar +               char              ) +            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 +      )  add_to_timeline : (        (List Struct.TurnResult.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_to_timeline turn_results current_state = -   case current_state of -      (_, (Just _)) -> current_state - -      (model, _) -> +   let (model, cmds) = current_state in +      ( +         {model | +            animator = +               (Struct.TurnResultAnimator.maybe_new +                  (List.reverse turn_results) +                  False +               ), +            timeline = +               (Array.append +                  (Array.fromList turn_results) +                  model.timeline +               ), +            ui = +               (Struct.UI.set_displayed_tab +                  Struct.UI.TimelineTab +                  model.ui +               ) +         },           ( -            {model | -               animator = -                  (Struct.TurnResultAnimator.maybe_new -                     (List.reverse turn_results) -                     False -                  ), -               timeline = -                  (Array.append -                     (Array.fromList turn_results) -                     model.timeline -                  ), -               ui = -                  (Struct.UI.set_displayed_tab -                     Struct.UI.TimelineTab -                     model.ui -                  ) -            }, -            Nothing +            (Delay.after 1 Time.millisecond Struct.Event.AnimationEnded) +            :: cmds           ) +      )  set_timeline : (        (List Struct.TurnResult.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_timeline turn_results current_state = -   case current_state of -      (_, (Just _)) -> current_state - -      (model, _) -> -         ( -            {model | timeline = (Array.fromList turn_results)}, -            Nothing -         ) +   let (model, cmds) = current_state in +      ( +         {model | timeline = (Array.fromList turn_results)}, +         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.AddWeapon wp) ->           (add_weapon wp current_state) @@ -219,18 +242,15 @@ apply_to model query_result =        (Result.Ok commands) ->           let -            new_model = -               ( -                  case (List.foldl (apply_command) (model, Nothing) commands) of -                     (updated_model, Nothing) -> updated_model -                     (_, (Just error)) -> (Struct.Model.invalidate error model) -               ) +            (new_model, elm_commands) = +               (List.foldl (apply_command) (model, [Cmd.none]) commands)           in              (                 new_model, -               if (new_model.animator == Nothing) -               then -                  Cmd.none -               else -                  (Delay.after 1 Time.millisecond Struct.Event.AnimationEnded) +               ( +                  case elm_commands of +                     [] -> Cmd.none +                     [cmd] -> cmd +                     _ -> (Cmd.batch elm_commands) +               )              ) diff --git a/src/character/src/Struct/Flags.elm b/src/character/src/Struct/Flags.elm deleted file mode 100644 index 228d258..0000000 --- a/src/character/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing -   ( -      Type, -      maybe_get_param -   ) - --- Elm ------------------------------------------------------------------------- -import List - --- Map ------------------------------------------------------------------- -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/login/src/Struct/Flags.elm b/src/login/src/Struct/Flags.elm deleted file mode 100644 index 228d258..0000000 --- a/src/login/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing -   ( -      Type, -      maybe_get_param -   ) - --- Elm ------------------------------------------------------------------------- -import List - --- Map ------------------------------------------------------------------- -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/login/src/Struct/Model.elm b/src/login/src/Struct/Model.elm index 859c054..7d14239 100644 --- a/src/login/src/Struct/Model.elm +++ b/src/login/src/Struct/Model.elm @@ -9,9 +9,11 @@ module Struct.Model exposing  -- Elm ------------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Struct.Flags +  -- Login -----------------------------------------------------------------------  import Struct.Error -import Struct.Flags  import Struct.HelpRequest  import Struct.UI @@ -22,6 +24,7 @@ type alias Type =     {        help_request: Struct.HelpRequest.Type,        error: (Maybe Struct.Error.Type), +      flags: Struct.Flags.Type,        username: String,        password1: String,        password2: String, @@ -46,6 +49,7 @@ new flags =        model =           {              help_request = Struct.HelpRequest.None, +            flags = flags,              error = Nothing,              username = "",              password1 = "", diff --git a/src/login/src/Update/HandleConnected.elm b/src/login/src/Update/HandleConnected.elm index 2888153..8f6348b 100644 --- a/src/login/src/Update/HandleConnected.elm +++ b/src/login/src/Update/HandleConnected.elm @@ -1,13 +1,16 @@  module Update.HandleConnected exposing (apply_to) +  -- Elm ------------------------------------------------------------------------- +import Http  -- Login -----------------------------------------------------------------------  import Action.Ports  import Constants.IO -import Struct.Model  import Struct.Event +import Struct.Flags +import Struct.Model  --------------------------------------------------------------------------------  -- LOCAL ----------------------------------------------------------------------- @@ -20,5 +23,17 @@ apply_to : Struct.Model.Type -> (Struct.Model.Type, (Cmd Struct.Event.Type))  apply_to model =     (        model, -      (Action.Ports.go_to (Constants.IO.base_url ++"/main-menu/")) +      (Action.Ports.go_to +         (Constants.IO.base_url ++ +            ( +               case (Struct.Flags.maybe_get_param "goto" model.flags) of +                  Nothing -> "/main-menu/" +                  (Just string) -> +                     case (Http.decodeUri string) of +                        Nothing -> "/main-menu/" +                        (Just "") -> "/main-menu/" +                        (Just url) -> url +            ) +         ) +      )     ) diff --git a/src/login/src/Update/HandleServerReply.elm b/src/login/src/Update/HandleServerReply.elm index b0f4e6b..2cbcf08 100644 --- a/src/login/src/Update/HandleServerReply.elm +++ b/src/login/src/Update/HandleServerReply.elm @@ -3,9 +3,10 @@ module Update.HandleServerReply exposing (apply_to)  -- Elm -------------------------------------------------------------------------  import Http --- Map ------------------------------------------------------------------- +-- Shared ----------------------------------------------------------------------  import Action.Ports +-- Login -----------------------------------------------------------------------  import Struct.Error  import Struct.Event  import Struct.Model @@ -21,46 +22,26 @@ import Struct.ServerReply  set_session : (        String ->        String -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.Type)) -      ) -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.Type)) -      ) +      (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> +      (Struct.Model.Type, (List (Cmd Struct.Event.Type)))     )  set_session pid stk current_state = -   case current_state of -      (_, (Just _), _) -> current_state - -      (model, _, cmd_list) -> +   let (model, cmds) = current_state in +      ( +         {model | +            player_id = pid, +            session_token = stk +         },           ( -            {model | -               player_id = pid, -               session_token = stk -            }, -            Nothing, -            ( -               (Action.Ports.store_new_session (pid, stk)) -               :: cmd_list -            ) +            (Action.Ports.store_new_session (pid, stk)) +            :: cmds           ) +      )  apply_command : (        Struct.ServerReply.Type -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.Type)) -      ) -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.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 @@ -89,23 +70,16 @@ apply_to model query_result =           )        (Result.Ok commands) -> -         ( -            case -               (List.foldl -                  (apply_command) -                  (model, Nothing, []) -                  commands +         let +            (new_model, elm_commands) = +               (List.foldl (apply_command) (model, [Cmd.none]) commands) +         in +            ( +               new_model, +               ( +                  case elm_commands of +                     [] -> Cmd.none +                     [cmd] -> cmd +                     _ -> (Cmd.batch elm_commands)                 ) -            of -               (updated_model, Nothing, cmds) -> -                  ( -                     updated_model, -                     (Cmd.batch cmds) -                  ) - -               (_, (Just error), _) -> -                  ( -                     (Struct.Model.invalidate error model), -                     Cmd.none -                  ) -         ) +            ) diff --git a/src/main-menu/src/Comm/Send.elm b/src/main-menu/src/Comm/Send.elm index 925b956..3641e46 100644 --- a/src/main-menu/src/Comm/Send.elm +++ b/src/main-menu/src/Comm/Send.elm @@ -26,6 +26,7 @@ internal_decoder reply_type =     case reply_type of        "okay" -> (Comm.Okay.decode)        "set_plr" -> (Comm.SetPlayer.decode) +      "disconnected" -> (Json.Decode.succeed Struct.ServerReply.Disconnected)        other ->           (Json.Decode.fail              ( diff --git a/src/main-menu/src/Struct/Flags.elm b/src/main-menu/src/Struct/Flags.elm deleted file mode 100644 index 99c7458..0000000 --- a/src/main-menu/src/Struct/Flags.elm +++ /dev/null @@ -1,42 +0,0 @@ -module Struct.Flags exposing -   ( -      Type, -      maybe_get_param -   ) - --- Elm ------------------------------------------------------------------------- -import List - --- Main Menu ------------------------------------------------------------------- -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/main-menu/src/Struct/Model.elm b/src/main-menu/src/Struct/Model.elm index d748cfa..747a39e 100644 --- a/src/main-menu/src/Struct/Model.elm +++ b/src/main-menu/src/Struct/Model.elm @@ -9,9 +9,11 @@ module Struct.Model exposing  -- Elm ------------------------------------------------------------------------- +-- Shared ---------------------------------------------------------------------- +import Struct.Flags +  -- Main Menu -------------------------------------------------------------------  import Struct.Error -import Struct.Flags  import Struct.Player  import Struct.UI @@ -20,6 +22,7 @@ import Struct.UI  --------------------------------------------------------------------------------  type alias Type =     { +      flags: Struct.Flags.Type,        error: (Maybe Struct.Error.Type),        player_id: String,        session_token: String, @@ -37,6 +40,7 @@ type alias Type =  new : Struct.Flags.Type -> Type  new flags =     { +      flags = flags,        error = Nothing,        player_id = flags.user_id,        session_token = flags.token, diff --git a/src/main-menu/src/Struct/ServerReply.elm b/src/main-menu/src/Struct/ServerReply.elm index a0663a8..fb4967b 100644 --- a/src/main-menu/src/Struct/ServerReply.elm +++ b/src/main-menu/src/Struct/ServerReply.elm @@ -11,6 +11,7 @@ import Struct.Player  type Type =     Okay +   | Disconnected     | SetPlayer Struct.Player.Type  -------------------------------------------------------------------------------- diff --git a/src/main-menu/src/Update/HandleServerReply.elm b/src/main-menu/src/Update/HandleServerReply.elm index 96cb0f1..d68496c 100644 --- a/src/main-menu/src/Update/HandleServerReply.elm +++ b/src/main-menu/src/Update/HandleServerReply.elm @@ -3,7 +3,14 @@ module Update.HandleServerReply exposing (apply_to)  -- Elm -------------------------------------------------------------------------  import Http +-- Shared ---------------------------------------------------------------------- +import Action.Ports + +import Struct.Flags +  -- Main Menu ------------------------------------------------------------------- +import Constants.IO +  import Struct.Error  import Struct.Event  import Struct.Model @@ -17,46 +24,48 @@ import Struct.ServerReply  --------------------------------------------------------------------------------  -- LOCAL -----------------------------------------------------------------------  -------------------------------------------------------------------------------- -set_player : ( -      Struct.Player.Type -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.Type)) -      ) -> +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        ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.Type)) +         model, +         [ +            (Action.Ports.go_to +               ( +                  Constants.IO.base_url +                  ++ "/login/?action=disconnect&goto=" +                  ++ +                  (Http.encodeUri +                     ( +                        "/main-menu/?" +                        ++ (Struct.Flags.get_params_as_url model.flags) +                     ) +                  ) +               ) +            ) +         ]        ) + +set_player : ( +      Struct.Player.Type -> +      (Struct.Model.Type, (List (Cmd Struct.Event.Type))) -> +      (Struct.Model.Type, (List (Cmd Struct.Event.Type)))     )  set_player player current_state = -   let -      (model, error, event_list) = current_state -   in -      ( -         {model | -            player = player -         }, -         error, -         event_list -      ) +   let (model, cmds) = current_state in +      ({model | player = player}, cmds)  apply_command : (        Struct.ServerReply.Type -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.Type)) -      ) -> -      ( -         Struct.Model.Type, -         (Maybe Struct.Error.Type), -         (List (Cmd Struct.Event.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.SetPlayer player) -> (set_player player current_state)        Struct.ServerReply.Okay -> current_state @@ -80,23 +89,16 @@ apply_to model query_result =           )        (Result.Ok commands) -> -         ( -            case -               (List.foldl -                  (apply_command) -                  (model, Nothing, []) -                  commands +         let +            (new_model, elm_commands) = +               (List.foldl (apply_command) (model, [Cmd.none]) commands) +         in +            ( +               new_model, +               ( +                  case elm_commands of +                     [] -> Cmd.none +                     [cmd] -> cmd +                     _ -> (Cmd.batch elm_commands)                 ) -            of -               (updated_model, Nothing, cmds) -> -                  ( -                     updated_model, -                     (Cmd.batch cmds) -                  ) - -               (_, (Just error), _) -> -                  ( -                     (Struct.Model.invalidate error model), -                     Cmd.none -                  ) -         ) +            ) 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/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)                 ) +            ) diff --git a/src/map-editor/src/Struct/Flags.elm b/src/shared/elm/Struct/Flags.elm index c0316f0..8cb8aea 100644 --- a/src/map-editor/src/Struct/Flags.elm +++ b/src/shared/elm/Struct/Flags.elm @@ -1,13 +1,14 @@  module Struct.Flags exposing     (        Type, -      maybe_get_param +      maybe_get_param, +      get_params_as_url     )  -- Elm -------------------------------------------------------------------------  import List --- Battlemap ------------------------------------------------------------------- +-- Shared ----------------------------------------------------------------------  import Util.List  -------------------------------------------------------------------------------- @@ -23,6 +24,11 @@ type alias Type =  --------------------------------------------------------------------------------  -- LOCAL -----------------------------------------------------------------------  -------------------------------------------------------------------------------- +param_as_url : (List String) -> String +param_as_url param = +   case param of +      [name, value] -> (name ++ "=" ++ value) +      _ -> ""  --------------------------------------------------------------------------------  -- EXPORTED -------------------------------------------------------------------- @@ -40,3 +46,13 @@ maybe_get_param param flags =           case (List.tail a) of              Nothing -> Nothing              (Just b) -> (List.head b) + +get_params_as_url : Type -> String +get_params_as_url flags = +   (List.foldl +      (\param -> \current_params -> +         (current_params ++ "&" ++ (param_as_url param)) +      ) +      "" +      flags.url_params +   ) | 


