From 3aee238cd9904bd63ed08a75e43100bf08132010 Mon Sep 17 00:00:00 2001 From: Artus Date: Mon, 11 Nov 2019 15:49:39 +0100 Subject: [PATCH] makes it compile as is --- index.html | 1 + src/Api.elm | 59 ++-- src/Chest.elm | 771 --------------------------------------------- src/Main.elm | 83 ++--- src/Page/Chest.elm | 710 ++++++++++++++++++++++++++++++++++++++++- src/Session.elm | 15 +- 6 files changed, 794 insertions(+), 845 deletions(-) delete mode 100644 src/Chest.elm diff --git a/index.html b/index.html index eff6a9c..f866963 100644 --- a/index.html +++ b/index.html @@ -20,6 +20,7 @@ diff --git a/src/Api.elm b/src/Api.elm index 95e3053..5c358f2 100644 --- a/src/Api.elm +++ b/src/Api.elm @@ -1,15 +1,21 @@ -module Api exposing (..) +module Api exposing (Update(..), Msg(..) + , HttpResult + , Player, Wealth, fetchPlayer, blankPlayer + , Item, Loot, fetchLoot + , Claim, Claims, fetchClaims + , ActionMode(..), confirmAction + ) import Http import Json.Decode as D exposing (Decoder, field, int, string, succeed) import Json.Encode as E -import Modes type alias HttpResult a = Result Http.Error a +-- Format of the server's response type alias Response = { value : Maybe String , notification : Maybe String @@ -27,8 +33,7 @@ type Update type Msg - = GotPlayer (HttpResult Player) - | GotActionResult (HttpResult Response) + = GotActionResult (HttpResult Response) @@ -95,10 +100,10 @@ claimDecoder = (D.field "loot_id" int) -fetchClaims : (Result Http.Error Claims -> msg) -> Cmd msg -fetchClaims toMsg = +fetchClaims : (Result Http.Error Claims -> msg) -> Int -> Cmd msg +fetchClaims toMsg playerId = Http.get - { url = "http://localhost:8088/api/claims" + { url = "http://localhost:8088/api/claims" -- TODO: ++ playerId , expect = valueDecoder (D.list claimDecoder) |> Http.expectJson toMsg @@ -109,11 +114,12 @@ fetchClaims toMsg = -- -fetchPlayer : Int -> Cmd Msg -fetchPlayer id = + +fetchPlayer : (Result Http.Error Player -> msg) -> Int -> Cmd msg +fetchPlayer toMsg id = Http.get { url = "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/" - , expect = Http.expectJson GotPlayer (valueDecoder playerDecoder) + , expect = Http.expectJson toMsg (valueDecoder playerDecoder) } @@ -214,16 +220,23 @@ undoLastAction id = } -buildPayload : Modes.Model -> List Item -> E.Value +type ActionMode + = Sell + | Buy + | Grab + | Add + | NoMode + +buildPayload : ActionMode -> List Item -> E.Value buildPayload mode items = case mode of - Modes.Buy -> + Buy -> E.object [ ( "items", items |> E.list (\i -> E.list identity [ E.int i.id, E.null ]) ) , ( "global_mod", E.null ) ] - Modes.Sell -> + Sell -> E.object [ ( "items", items |> E.list (\i -> E.list identity [ E.int i.id, E.null ]) ) , ( "global_mod", E.null ) @@ -231,43 +244,43 @@ buildPayload mode items = ] -- API expects the list of claimed loot ids - Modes.Grab -> + Grab -> items |> E.list (\i -> E.int i.id) - Modes.Add -> + Add -> E.object [ ( "items", items |> E.list (\i -> E.int i.id) ) ] - Modes.None -> E.null + NoMode -> E.null -sendRequest : Modes.Model -> String -> List Item -> Cmd Msg -sendRequest mode id items = +confirmAction : ActionMode -> String -> List Item -> Cmd Msg +confirmAction mode id items = let ( endpoint, method ) = case mode of - Modes.Add -> + Add -> ( "http://localhost:8088/api/players/" ++ id ++ "/loot" , "POST" ) - Modes.Buy -> + Buy -> ( "http://localhost:8088/api/players/" ++ id ++ "/loot" , "PUT" ) - Modes.Sell -> + Sell -> ( "http://localhost:8088/api/players/" ++ id ++ "/loot" , "DELETE" ) - Modes.Grab -> + Grab -> ( "http://localhost:8088/api/players/" ++ id ++ "/claims" , "POST" ) -- TODO: ??? - Modes.None -> ("", "GET") + NoMode -> ("", "GET") in Http.request { method = method diff --git a/src/Chest.elm b/src/Chest.elm deleted file mode 100644 index 44739f9..0000000 --- a/src/Chest.elm +++ /dev/null @@ -1,771 +0,0 @@ -module Chest exposing (..) - -import Api exposing (Claims, HttpResult, Item, Loot) -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (onCheck) -import Route exposing (..) -import Set exposing (Set) -import Utils exposing (..) - - - --- MODEL - - -type alias State = - { menuOpen : Bool - , mode : ActionMode - , error : Maybe String - , notification : Maybe String - } - - -type alias Selection = - Set Int - - -type ActionMode - = Sell - | Buy - | Grab - | Add - | NoMode - - -type alias Model = - { state : State - , shown : Route.ChestContent - , playerLoot : Loot - , groupLoot : Loot - , merchantLoot : Loot - , newLoot : Loot - , selection : Maybe Selection - , claims : Claims - } - - -init : Int -> ( Model, Cmd Msg ) -init playerId = - ( Model - (State False Modes.None Nothing Nothing) - [] - [] - [] - [] - Nothing - [] - , Api.fetchClaims (GotClaims playerId) - ) - - -viewNotification : Maybe String -> Html Msg -viewNotification notification = - case notification of - Just t -> - div [ class "notification is-success is-marginless" ] - [ button [ class "delete", onClick ClearNotification ] [] - , text t - ] - - Nothing -> - text "" - - - --- DEBUG SECTION - - -viewDebugSection : Model -> Html Msg -viewDebugSection model = - div [ class "panel is-danger" ] - [ p [ class "panel-heading" ] [ text "Debug" ] - , debugSwitchPlayers - , p [ class "panel-block has-text-danger" ] [ text <| Maybe.withDefault "" model.state.error ] - , p [ class "panel-block" ] [ text ("Route : " ++ Debug.toString model.route) ] - , p [ class "panel-block" ] [ text ("Active Mode : " ++ Debug.toString model.mode) ] - , p [ class "panel-block" ] [ text ("Selection : " ++ Debug.toString model.chest.selection) ] - , p [ class "panel-block" ] [ text ("Claims : " ++ Debug.toString model.chest.claims) ] - , p [] debugSandbox - ] - - -stackedIcon name = - span [ class "icon is-medium" ] - [ span [ class "fa-stack" ] - [ i [ class "fas fa-circle fa-stack-2x" ] [] - , i [ class (name ++ " fa-inverse fa-stack-1x") ] [] - , text "" - ] - ] - - -debugSandbox = - [ stackedIcon "fas fa-coins" - , stackedIcon "fab fa-d-and-d" - , stackedIcon "fas fa-praying-hands" - , stackedIcon "fas fa-gem" - , stackedIcon "fas fa-pen" - , stackedIcon "fas fa-percentage" - , stackedIcon "fas fa-store-alt" - , stackedIcon "fas fa-cart-plus" - , stackedIcon "fas fa-angry" - , stackedIcon "fas fa-plus" - , stackedIcon "fas fa-tools" - , stackedIcon "fas fa-search" - ] - - -debugSwitchPlayers : Html Msg -debugSwitchPlayers = - div [ class "panel-tabs" ] - [ a [ onClick (PlayerChanged 0) ] [ text "Groupe" ] - , a [ onClick (PlayerChanged 1) ] [ text "Lomion" ] - , a [ onClick (PlayerChanged 2) ] [ text "Fefi" ] - ] - - - --- HEADER SECTION - - -viewHeaderBar : String -> Model -> Html Msg -viewHeaderBar title model = - nav [ class "navbar container", class "is-info" ] - [ div [ class "navbar-brand" ] - [ a [ class "navbar-item", href "/" ] - [ renderIcon { icon = "fab fa-d-and-d", size = "medium", ratio = "2x" } - , span [] [ text model.player.name ] - ] - , a [ class "navbar-burger is-active" ] - [ span [ attribute "aria-hidden" "true" ] [] - , span [ attribute "aria-hidden" "true" ] [] - , span [ attribute "aria-hidden" "true" ] [] - ] - ] - , div [ class "navbar-menu is-active" ] - [ div [ class "navbar-end" ] - [ a [ class "navbar-item", href "/marchand" ] - [ renderIcon { icon = "fas fa-store-alt", ratio = "1x", size = "medium" } - , span [] [ text "Marchand" ] - ] - , a - [ class "navbar-item" - , href - (if model.player.id == 0 then - "/nouveau-tresor" - - else - "/coffre" - ) - ] - [ renderIcon { icon = "fas fa-gem", ratio = "1x", size = "medium" } - , span [] - [ text - (if model.player.id == 0 then - "Nouveau loot" - - else - "Coffre de groupe" - ) - ] - ] - ] - ] - ] - - - --- PLAYER BAR - - -viewPlayerBar : Player -> List (Html Msg) -> Html Msg -viewPlayerBar player actionControls = - section [ class "level container is-mobile box" ] - [ div [ class "level-left" ] - ([ div [ class "level-item" ] - [ span [ class "icon is-large" ] - [ i [ class "fas fa-2x fa-piggy-bank" ] [] ] - ] - ] - ++ viewWealth player.wealth - ++ (if player.debt > 0 then - [ div [ class "level-item" ] - [ p [ class "heading is-size-4 has-text-danger" ] - [ text ("Dette : " ++ String.fromInt player.debt ++ "po") ] - ] - ] - - else - [] - ) - ) - , div [ class "level-right" ] actionControls - ] - - -viewWealth : Wealth -> List (Html Msg) -viewWealth wealth = - [ showWealthField "pp" <| String.fromInt wealth.pp - , showWealthField "gp" <| String.padLeft 2 '0' <| String.fromInt wealth.gp - , showWealthField "sp" <| String.fromInt wealth.sp - , showWealthField "cp" <| String.fromInt wealth.cp - ] - - -showWealthField : String -> String -> Html Msg -showWealthField name value = - div [ class "level-item" ] - [ p [ class "has-text-right" ] - [ strong [ class "heading is-marginless" ] [ text name ] - , span [ class <| "is-size-4" ] [ text value ] - ] - ] - - - --- UPDATE - - -initPlayer id = - Cmd.map ApiMsg <| Api.fetchPlayer id - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - PlayerChanged newId -> - let - ( chest, cmd ) = - Chest.init newId - in - ( { model - | player = Api.blankPlayer - , route = PlayerChest - , chest = chest - } - , Cmd.batch - [ initPlayer newId - , Cmd.map ChestMsg cmd - ] - ) - - ApiMsg apiMsg -> - case apiMsg of - Api.GotActionResult response -> - case response of - Ok result -> - let - updates = - Maybe.withDefault [] result.updates - - notification = - result.notification - - errors = - Maybe.withDefault "" result.errors - in - List.foldl applyUpdate model updates - |> setNotification notification - |> setError errors - |> update (ModeMsg (Modes.ModeSwitched Modes.None)) - - Err r -> - ( setError (Debug.toString r) model, Cmd.none ) - - Api.GotPlayer result -> - case result of - Ok player -> - ( { model | player = player } - , Cmd.none - ) - - Err error -> - ( setError ("Fetching player... " ++ Debug.toString error) model - , Cmd.none - ) - - ModeMsg modeMsg -> - case modeMsg of - Modes.ModeSwitched newMode -> - ( { model - | mode = newMode - , chest = - let - ( newChest, _ ) = - Chest.update - (Chest.SetSelection - (case newMode of - Modes.None -> - Nothing - - Modes.Grab -> - -- Currently claimed object are initially selected - Just (Set.fromList <| List.map (\c -> c.loot_id) model.chest.claims) - - others -> - Just Set.empty - ) - ) - model.chest - in - newChest - } - , Cmd.none - ) - - Modes.ConfirmAction -> - case model.mode of - -- This should not happen, so we ignore it - Modes.None -> - ( model, Cmd.none ) - - mode -> - let - items = - Chest.getSelected model.route model.chest - in - ( model - , Cmd.map ApiMsg <| - Api.sendRequest - mode - (String.fromInt model.player.id) - items - ) - - ClearNotification -> - ( setNotification Nothing model, Cmd.none ) - - -setNotification : Maybe String -> Model -> Model -setNotification notification model = - let - state = - model.state - in - { model - | state = - { state | notification = notification } - } - - -setLoot : Loot -> Model -> Model -setLoot items model = - let - chest = - model.chest - in - { model | chest = { chest | loot = items } } - - -setClaims : Claims -> Model -> Model -setClaims claims model = - let - chest = - model.chest - in - { model | chest = { chest | claims = claims } } - - - --- DbUpdates always refer to the active player's loot - - -applyUpdate : Api.Update -> Model -> Model -applyUpdate u model = - case u of - Api.ItemRemoved item -> - model - |> setLoot (List.filter (\i -> i.id /= item.id) model.chest.loot) - - Api.ItemAdded item -> - model |> setLoot (item :: model.chest.loot) - - Api.WealthUpdated diff -> - let - player = - model.player - - wealth = - player.wealth - in - { model - | player = - { player - | wealth = - Wealth - (wealth.cp + diff.cp) - (wealth.sp + diff.sp) - (wealth.gp + diff.gp) - (wealth.pp + diff.pp) - } - } - - Api.ClaimAdded claim -> - model |> setClaims (claim :: model.chest.claims) - - Api.ClaimRemoved claim -> - model - |> setClaims (List.filter (\c -> c.id /= claim.id) model.chest.claims) - - - --- ERRORS - - -setError : String -> Model -> Model -setError error model = - let - state = - model.state - in - { model - | state = - { state | error = Just error } - } - - -type ToChest - = OfPlayer Int - | OfGroup - | OfShop - - -fetchLoot : ToChest -> Cmd Msg -fetchLoot dest = - let - url = - case dest of - OfPlayer id -> - "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/loot" - - OfShop -> - "http://localhost:8088/api/items" - - OfGroup -> - "http://localhost:8088/api/players/0/loot" - in - Api.fetchLoot url (GotLoot dest) - - - --- VIEW - - -view : Modes.Model -> Route.Route -> Model -> Html Msg -view mode route model = - let - renderControls = - Modes.viewControls model.mode model.route - |> List.map (Html.map ModeMsg) - - ( header, shownItems ) = - case route of - Route.PlayerChest -> - ( "Mon coffre", model.loot ) - - Route.GroupLoot -> - ( "Coffre de groupe", model.groupLoot ) - - Route.Merchant -> - ( "Marchand", model.merchantItems ) - - Route.NewLoot -> - ( "Nouveau trésor :)", [] ) - - isSelected = - itemInSelection model.selection - - rowRenderer = - case mode of - Modes.None -> - case route of - Route.GroupLoot -> - let - isClaimed = - itemInClaims model.claims - in - -- Claim controls for Group chest - Just (claimedItemRenderer isClaimed) - - _ -> - Nothing - - activeMode -> - Just (rowRendererForMode isSelected activeMode) - in - [ viewHeaderBar player.name model - , viewPlayerBar model.player renderControls - , main_ - [ class "container" ] - [ viewNotification model.state.notification - , article - [ class "section" ] - [ div [ class "columns" ] - [ div [ class "column is-one-third" ] [ p [ class "title" ] [ text header ] ] - , div [ class "column" ] [ viewSearchBar ] - ] - , table [ class "table is-fullwidth is-striped is-hoverable" ] - [ thead [ class "table-header" ] - [ th [] [ text "Nom" ] ] - , tbody [] <| List.map (viewItemTableRow isSelected rowRenderer) shownItems - ] - ] - ] - , hr [] [] - , section [ class "container" ] [ viewDebugSection model ] - ] - - - --- Renderers --- --- Item -> Html Msg - - -claimedItemRenderer : (Item -> Bool) -> Item -> Html Msg -claimedItemRenderer isClaimed item = - case isClaimed item of - True -> - renderIcon - { icon = "fas fa-praying-hands" - , size = "small" - , ratio = "1x" - } - - False -> - text "" - - -rowRendererForMode : (Item -> Bool) -> Modes.Model -> Item -> Html Msg -rowRendererForMode isSelected mode item = - let - canSelect = - Modes.canSelectIn mode - - renderInfo = - case mode of - Modes.Buy -> - p [ class "level-item" ] [ text (String.fromInt item.base_price ++ "po") ] - - Modes.Sell -> - p [ class "level-item" ] [ text (String.fromFloat (toFloat item.base_price / 2) ++ "po") ] - - Modes.Grab -> - p [ class "level-item" ] [ text "Grab" ] - - Modes.Add -> - p [ class "level-item" ] [ text "New !" ] - - Modes.None -> - text "" - in - div [ class "level-right" ] <| - renderInfo - :: (if canSelect then - [ input - [ class "checkbox level-item" - , type_ "checkbox" - , checked <| isSelected item - , onCheck (\v -> SwitchSelectionState item.id) - ] - [] - ] - - else - [] - ) - - -viewItemTableRow : (Item -> Bool) -> Maybe (Item -> Html Msg) -> Item -> Html Msg -viewItemTableRow isSelected rowRenderer item = - tr [ classList [ ( "is-selected", isSelected item ) ] ] - [ td [] - [ label [ class "level checkbox" ] <| - div [ class "level-left" ] - [ p [ class "level-item" ] [ text item.name ] ] - :: (case rowRenderer of - Just render -> - List.singleton (render item) - - Nothing -> - [] - ) - ] - ] - - - --- Search Bar - - -viewSearchBar : Html Msg -viewSearchBar = - div [ class "field" ] - [ p [ class "control has-icons-left" ] - [ input [ class "input" ] [] - , span [ class "icon is-left" ] [ i [ class "fas fa-search" ] [] ] - ] - ] - - - --- ACTION MODES --- - - -canSelectIn : ActionMode -> Bool -canSelectIn mode = - case mode of - Sell -> - True - - Buy -> - True - - Grab -> - True - - Add -> - False - - NoMode -> - False - - -viewControls : ActionMode -> Route.Route -> List (Html Msg) -viewControls mode route = - case mode of - None -> - case route of - Route.PlayerChest -> - [ actionButton (ModeSwitched Sell) "Vendre" "coins" "danger" ] - - Route.GroupLoot -> - [ actionButton (ModeSwitched Grab) "Demander" "praying-hands" "primary" ] - - Route.Merchant -> - [ actionButton (ModeSwitched Buy) "Acheter" "coins" "success" ] - - Route.NewLoot -> - [ actionButton (ModeSwitched Add) "Nouveau loot" "plus" "primary" ] - - m -> - [ actionButton ConfirmAction "Valider" "check" "primary" - , actionButton (ModeSwitched None) "Annuler" "times" "danger" - ] - - - --- UPDATE - - -type Msg - = ApiMsg Api.Msg - | ModeMsg Modes.Msg - | PlayerChanged Int - | ClearNotification -type Msg - = SetSelection (Maybe Selection) - | GotLoot ToChest (HttpResult Loot) - | GotClaims Int (HttpResult Claims) - | SwitchSelectionState Int - | ModeSwitched ActionMode - | ConfirmAction - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - SwitchSelectionState id -> - ( { model | selection = switchSelectionState id model.selection }, Cmd.none ) - - SetSelection new -> - ( { model | selection = new }, Cmd.none ) - - GotClaims id result -> - case result of - Ok claims -> - ( { model - | claims = - List.filter - (\c -> c.player_id == id) - claims - } - , Cmd.none - ) - - Err error -> - ( model, Cmd.none ) - - GotLoot dest result -> - case result of - Ok loot -> - ( case dest of - OfPlayer _ -> - { model | loot = loot } - - OfGroup -> - { model | groupLoot = loot } - - OfShop -> - { model | merchantItems = loot } - , Cmd.none - ) - - Err error -> - ( model, Cmd.none ) - - - --- Selection --- Get list of selected items - - -getSelected : Route -> Model -> Loot -getSelected route model = - targetItemsFor route model - |> List.filter (itemInSelection model.selection) - - -itemInSelection : Maybe Selection -> Item -> Bool -itemInSelection selection item = - Maybe.map (Set.member item.id) selection - |> Maybe.withDefault False - - -itemInClaims : Claims -> Item -> Bool -itemInClaims claims item = - List.any (\c -> c.loot_id == item.id) claims - - -switchSelectionState : Int -> Maybe Selection -> Maybe Selection -switchSelectionState id selection = - case selection of - Just s -> - Just <| - case Set.member id s of - True -> - Set.remove id s - - False -> - Set.insert id s - - Nothing -> - Debug.log "ignore switchSelectionState" Nothing - - -targetItemsFor : Route -> Model -> List Item -targetItemsFor route model = - case route of - Route.NewLoot -> - model.newLoot - - Route.Merchant -> - model.merchantItems - - Route.PlayerChest -> - model.loot - - Route.GroupLoot -> - model.groupLoot diff --git a/src/Main.elm b/src/Main.elm index c2546ed..66adbd9 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -3,7 +3,7 @@ module Main exposing (..) import Api exposing (Claim, Claims, Item, Loot, Player, Wealth) import Browser import Browser.Navigation as Nav -import Chest exposing (Msg) +import Page.Chest as Chest exposing (Msg) import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -19,7 +19,7 @@ import Session exposing (..) -- Main -main : Program () Model Msg +main : Program (Maybe Int) Model Msg main = Browser.application { init = init @@ -36,7 +36,7 @@ main = type Model = Chest Chest.Model - | Admin Admin.Model +-- | Admin Admin.Model | About -- This is not what we really want. @@ -51,14 +51,14 @@ type Model -- - just loggend in -> See Loading page then Chest -- - coming back being still logged in -> See Chest (or same as above) init : Maybe Int -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) -init flags url key = +init flags _ key = case flags of Just id -> let - session = - Session.LoggedIn key <| Session.User.Player id + session = Session.playerSession key id + (chest, cmd) = Chest.init session in - (Chest <| Chest.init id, Cmd.none) + (Chest chest, Cmd.map GotChestMsg cmd) Nothing -> (About, Cmd.none) @@ -72,65 +72,66 @@ init flags url key = view : Model -> Browser.Document Msg view model = let - (title, body) = + (title, content) = case model of Chest chest -> - ("Loot-a-lot", Chest.view chest) - Admin session -> - ("Administration", Admin.view session) + ("Loot-a-lot", List.map (Html.map GotChestMsg) (Chest.view chest)) + -- Admin admin -> + -- ("Administration", Admin.view admin) About -> - ("A propos", p [] ["A propos"]) + ("A propos", [ p [] [text "A propos"] ]) in { title = title - , body = body } + , body = content } type Msg = UrlChanged Url.Url | LinkClicked Browser.UrlRequest | GotChestMsg Chest.Msg - | GotAdminMsg Admin.Msg +-- | GotAdminMsg Admin.Msg update msg model = + let + updateChest chestMsg = + case model of + Chest chest -> + let + (newChest, cmd) = + Chest.update chestMsg chest + in + (Chest newChest, Cmd.map GotChestMsg cmd) + + _ -> (About, Cmd.none) + + in case msg of LinkClicked urlRequest -> - case urlRequest of - Browser.Internal url -> - ( model, Nav.pushUrl model.navKey (Url.toString url) ) + case model of + Chest chestModel -> + case urlRequest of + Browser.Internal url -> + ( model, Nav.pushUrl chestModel.navKey (Url.toString url) ) - Browser.External href -> - ( setError ("External request '" ++ href ++ "'") model - , Cmd.none - ) + Browser.External href -> + ( model, Cmd.none) + + _ -> (model, Cmd.none) UrlChanged url -> let route = - routeParser url + Route.fromUrl url in case route of - Just page -> - { model | route = page } - |> update - (case page of - -- Directly enter add mode on NewLoot view - NewLoot -> - ModeMsg (Modes.ModeSwitched Modes.Add) - - other -> - ModeMsg (Modes.ModeSwitched Modes.None) - ) - - Nothing -> - ( setError "Invalid route" model, Cmd.none ) + Just (Route.Home content) -> + updateChest (Chest.SetContent content) + _ -> + (About, Cmd.none) GotChestMsg chestMsg -> - let - ( chest, cmd ) = - Chest.update chestMsg model.chest - in - ( Chest chest, Cmd.map GotChestMsg cmd ) + updateChest chestMsg -- STATE Utils -- SUBSCRIPTIONS diff --git a/src/Page/Chest.elm b/src/Page/Chest.elm index 3828374..94f51e2 100644 --- a/src/Page/Chest.elm +++ b/src/Page/Chest.elm @@ -1,6 +1,710 @@ module Page.Chest exposing (..) --- Put the rest of Chest here +import Browser.Navigation as Nav -init = - () +import Api exposing (ActionMode(..), confirmAction, HttpResult + , Wealth, Claims + , Item, Loot) +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (onCheck, onClick) +import Route exposing (ChestContent(..)) +import Set exposing (Set) +import Utils exposing (..) +import Session exposing (Session(..)) + + +-- MODEL + + +type alias State = + { menuOpen : Bool + , mode : ActionMode + , error : Maybe String + , notification : Maybe String + -- Fetched on init + , player : Api.Player + , playerLoot : Loot + , groupLoot : Loot + , merchantLoot : Loot + , newLoot : Loot + } + + +type alias Selection = + Set Int + + +type alias Model = + { navKey : Nav.Key + , state : State + , shown : Route.ChestContent + , selection : Maybe Selection + , claims : Claims + } + +init (Player navKey playerId) = + ( Model + navKey + (State False NoMode Nothing Nothing Api.blankPlayer [] [] [] []) + Route.PlayerLoot + Nothing + [] + , Cmd.batch + [ Api.fetchPlayer GotPlayer playerId + , Api.fetchClaims GotClaims playerId + , fetchLoot (OfPlayer playerId) + , fetchLoot (OfGroup) + , fetchLoot (OfShop) + ] + ) + + +viewNotification : Maybe String -> Html Msg +viewNotification notification = + case notification of + Just t -> + div [ class "notification is-success is-marginless" ] + [ button [ class "delete", onClick ClearNotification ] [] + , text t + ] + + Nothing -> + text "" + + + +-- DEBUG SECTION + + +viewDebugSection : Model -> Html Msg +viewDebugSection model = + div [ class "panel is-danger" ] + [ p [ class "panel-heading" ] [ text "Debug" ] + , p [ class "panel-block has-text-danger" ] [ text <| Maybe.withDefault "" model.state.error ] + , p [ class "panel-block" ] [ text ("Shown content : " ++ Debug.toString model.shown) ] + , p [ class "panel-block" ] [ text ("Active Mode : " ++ Debug.toString model.state.mode) ] + , p [ class "panel-block" ] [ text ("Selection : " ++ Debug.toString model.selection) ] + , p [ class "panel-block" ] [ text ("Claims : " ++ Debug.toString model.claims) ] + , p [] debugSandbox + ] + + +stackedIcon name = + span [ class "icon is-medium" ] + [ span [ class "fa-stack" ] + [ i [ class "fas fa-circle fa-stack-2x" ] [] + , i [ class (name ++ " fa-inverse fa-stack-1x") ] [] + , text "" + ] + ] + + + +debugSandbox = + [ stackedIcon "fas fa-coins" + , stackedIcon "fab fa-d-and-d" + , stackedIcon "fas fa-praying-hands" + , stackedIcon "fas fa-gem" + , stackedIcon "fas fa-pen" + , stackedIcon "fas fa-percentage" + , stackedIcon "fas fa-store-alt" + , stackedIcon "fas fa-cart-plus" + , stackedIcon "fas fa-angry" + , stackedIcon "fas fa-plus" + , stackedIcon "fas fa-tools" + , stackedIcon "fas fa-search" + ] + + + +-- HEADER SECTION + + +viewHeaderBar : String -> Model -> Html Msg +viewHeaderBar title model = + nav [ class "navbar container", class "is-info" ] + [ div [ class "navbar-brand" ] + [ a [ class "navbar-item", href "/" ] + [ renderIcon { icon = "fab fa-d-and-d", size = "medium", ratio = "2x" } + , span [] [ text model.state.player.name ] + ] + , a [ class "navbar-burger is-active" ] + [ span [ attribute "aria-hidden" "true" ] [] + , span [ attribute "aria-hidden" "true" ] [] + , span [ attribute "aria-hidden" "true" ] [] + ] + ] + , div [ class "navbar-menu is-active" ] + [ div [ class "navbar-end" ] + [ a [ class "navbar-item", href "/marchand" ] + [ renderIcon { icon = "fas fa-store-alt", ratio = "1x", size = "medium" } + , span [] [ text "Marchand" ] + ] + , a + [ class "navbar-item" + , href + (if model.state.player.id == 0 then + "/nouveau-tresor" + + else + "/coffre" + ) + ] + [ renderIcon { icon = "fas fa-gem", ratio = "1x", size = "medium" } + , span [] + [ text + (if model.state.player.id == 0 then + "Nouveau loot" + + else + "Coffre de groupe" + ) + ] + ] + ] + ] + ] + + + +-- PLAYER BAR + + +viewPlayerBar : Api.Player -> List (Html Msg) -> Html Msg +viewPlayerBar player actionControls = + section [ class "level container is-mobile box" ] + [ div [ class "level-left" ] + ([ div [ class "level-item" ] + [ span [ class "icon is-large" ] + [ i [ class "fas fa-2x fa-piggy-bank" ] [] ] + ] + ] + ++ viewWealth player.wealth + ++ (if player.debt > 0 then + [ div [ class "level-item" ] + [ p [ class "heading is-size-4 has-text-danger" ] + [ text ("Dette : " ++ String.fromInt player.debt ++ "po") ] + ] + ] + + else + [] + ) + ) + , div [ class "level-right" ] actionControls + ] + + +viewWealth : Wealth -> List (Html Msg) +viewWealth wealth = + [ showWealthField "pp" <| String.fromInt wealth.pp + , showWealthField "gp" <| String.padLeft 2 '0' <| String.fromInt wealth.gp + , showWealthField "sp" <| String.fromInt wealth.sp + , showWealthField "cp" <| String.fromInt wealth.cp + ] + + +showWealthField : String -> String -> Html Msg +showWealthField name value = + div [ class "level-item" ] + [ p [ class "has-text-right" ] + [ strong [ class "heading is-marginless" ] [ text name ] + , span [ class <| "is-size-4" ] [ text value ] + ] + ] + + + + +-- VIEW + + +view : Model -> List (Html Msg) +view model = + let + renderControls = + viewControls model.state.mode model.shown + + header = + case model.shown of + PlayerLoot -> + "Mon coffre" + + GroupLoot -> + "Coffre de groupe" + + MerchantLoot -> + "Marchand" + + NewLoot -> + "Nouveau trésor :)" + + shownItems = + selectContent model.shown + + isSelected = + itemInSelection model.selection + + rowRenderer = + case model.state.mode of + NoMode -> + case model.shown of + GroupLoot -> + let + isClaimed = + itemInClaims model.claims + in + -- Claim controls for Group chest + Just (claimedItemRenderer isClaimed) + + _ -> + Nothing + + activeMode -> + Just (rowRendererForMode isSelected activeMode) + in + [ viewHeaderBar model.state.player.name model + , viewPlayerBar model.state.player renderControls + , main_ + [ class "container" ] + [ viewNotification model.state.notification + , article + [ class "section" ] + [ div [ class "columns" ] + [ div [ class "column is-one-third" ] [ p [ class "title" ] [ text header ] ] + , div [ class "column" ] [ viewSearchBar ] + ] + , table [ class "table is-fullwidth is-striped is-hoverable" ] + [ thead [ class "table-header" ] + [ th [] [ text "Nom" ] ] + , tbody [] <| List.map (viewItemTableRow isSelected rowRenderer) <| shownItems model + ] + ] + ] + , hr [] [] + , section [ class "container" ] [ viewDebugSection model ] + ] + + + +-- Renderers +-- +-- Item -> Html Msg + + +claimedItemRenderer : (Item -> Bool) -> Item -> Html Msg +claimedItemRenderer isClaimed item = + case isClaimed item of + True -> + renderIcon + { icon = "fas fa-praying-hands" + , size = "small" + , ratio = "1x" + } + + False -> + text "" + + +rowRendererForMode : (Item -> Bool) -> ActionMode -> Item -> Html Msg +rowRendererForMode isSelected mode item = + let + canSelect = + canSelectIn mode + + renderInfo = + case mode of + Buy -> + p [ class "level-item" ] [ text (String.fromInt item.base_price ++ "po") ] + + Sell -> + p [ class "level-item" ] [ text (String.fromFloat (toFloat item.base_price / 2) ++ "po") ] + + Grab -> + p [ class "level-item" ] [ text "Grab" ] + + Add -> + p [ class "level-item" ] [ text "New !" ] + + NoMode -> + text "" + in + div [ class "level-right" ] <| + renderInfo + :: (if canSelect then + [ input + [ class "checkbox level-item" + , type_ "checkbox" + , checked <| isSelected item + , onCheck (\v -> SwitchSelectionState item.id) + ] + [] + ] + + else + [] + ) + + +viewItemTableRow : (Item -> Bool) -> Maybe (Item -> Html Msg) -> Item -> Html Msg +viewItemTableRow isSelected rowRenderer item = + tr [ classList [ ( "is-selected", isSelected item ) ] ] + [ td [] + [ label [ class "level checkbox" ] <| + div [ class "level-left" ] + [ p [ class "level-item" ] [ text item.name ] ] + :: (case rowRenderer of + Just render -> + List.singleton (render item) + + Nothing -> + [] + ) + ] + ] + + + +-- Search Bar + + +viewSearchBar : Html Msg +viewSearchBar = + div [ class "field" ] + [ p [ class "control has-icons-left" ] + [ input [ class "input" ] [] + , span [ class "icon is-left" ] [ i [ class "fas fa-search" ] [] ] + ] + ] + + + +-- ACTION MODES +-- + + +canSelectIn : ActionMode -> Bool +canSelectIn mode = + case mode of + Sell -> + True + + Buy -> + True + + Grab -> + True + + Add -> + False + + NoMode -> + False + + +viewControls : ActionMode -> ChestContent -> List (Html Msg) +viewControls mode content = + case mode of + NoMode -> + case content of + PlayerLoot -> + [ actionButton (ModeSwitched Sell) "Vendre" "coins" "danger" ] + + GroupLoot -> + [ actionButton (ModeSwitched Grab) "Demander" "praying-hands" "primary" ] + + MerchantLoot -> + [ actionButton (ModeSwitched Buy) "Acheter" "coins" "success" ] + + NewLoot -> + [ actionButton (ModeSwitched Add) "Nouveau loot" "plus" "primary" ] + + m -> + [ actionButton ConfirmAction "Valider" "check" "primary" + , actionButton (ModeSwitched NoMode) "Annuler" "times" "danger" + ] + + + +-- UPDATE + + +type Msg + = ApiMsg Api.Msg + | ClearNotification + | SetContent (ChestContent) + | SetSelection (Maybe Selection) + | GotLoot ToChest (HttpResult Loot) + | GotClaims (HttpResult Claims) + | GotPlayer (HttpResult Api.Player) + | SwitchSelectionState Int + | ModeSwitched ActionMode + | ConfirmAction + + +-- UPDATE + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + ApiMsg apiMsg -> + case apiMsg of + Api.GotActionResult response -> + case response of + Ok result -> + let + updates = + Maybe.withDefault [] result.updates + + notification = + result.notification + + errors = + Maybe.withDefault "" result.errors + in + List.foldl applyUpdate model updates + |> setNotification notification + |> setError errors + |> update (ModeSwitched NoMode) + + Err r -> + ( setError (Debug.toString r) model, Cmd.none ) + + SetContent content -> + ( { model | shown = content }, Cmd.none ) + + GotPlayer result -> + case result of + Ok player -> + let + state = model.state + in + ( { model | state = { state | player = player }} , Cmd.none) + + Err error -> + ( setError ("Fetching player... " ++ Debug.toString error) model + , Cmd.none + ) + + ModeSwitched newMode -> + let state = model.state in + { model | state = { state | mode = newMode }} + |> update + (SetSelection + (case newMode of + NoMode -> + Nothing + + Grab -> + -- Currently claimed object are initially selected + Just (Set.fromList <| List.map (\c -> c.loot_id) model.claims) + + others -> + Just Set.empty + ) + ) + + + ConfirmAction -> + case model.state.mode of + -- This should not happen, so we ignore it + NoMode -> + ( model, Cmd.none ) + + mode -> + let + items = + getSelected model.shown model + in + ( model + , Cmd.map ApiMsg <| + Api.confirmAction + mode + (String.fromInt model.state.player.id) + items + ) + + ClearNotification -> + ( setNotification Nothing model, Cmd.none ) + + SwitchSelectionState id -> + ( { model | selection = switchSelectionState id model.selection }, Cmd.none ) + + SetSelection new -> + ( { model | selection = new }, Cmd.none ) + + GotClaims (Ok claims )-> + ( { model | claims = claims } , Cmd.none ) + + GotClaims (Err error) -> + ( setError (Debug.toString error) model, Cmd.none ) + + GotLoot dest (Ok loot) -> + ( + let + state = model.state + in + case dest of + OfPlayer _ -> + { model | state = { state | playerLoot = loot }} + + OfGroup -> + { model | state = { state | groupLoot = loot }} + + OfShop -> + { model | state = { state | merchantLoot = loot }} + , Cmd.none + ) + + GotLoot _ (Err error) -> + ( setError (Debug.toString error) model, Cmd.none ) + + +setNotification : Maybe String -> Model -> Model +setNotification notification model = + let + state = + model.state + in + { model + | state = + { state | notification = notification } + } + +-- ERRORS + + +setError : String -> Model -> Model +setError error model = + let + state = + model.state + in + { model + | state = + { state | error = Just error } + } + + + +-- DbUpdates always refer to the active player's loot + + +applyUpdate : Api.Update -> Model -> Model +applyUpdate u model = + let + state = model.state + in + case u of + Api.ItemRemoved item -> + { model | state = { state | playerLoot = + List.filter (\i -> i.id /= item.id) model.state.playerLoot }} + + Api.ItemAdded item -> + { model | state = { state | playerLoot = (item :: model.state.playerLoot) }} + + Api.WealthUpdated diff -> + let + player = + model.state.player + + wealth = + player.wealth + in + { model | state = { state + | player = + { player + | wealth = + Wealth + (wealth.cp + diff.cp) + (wealth.sp + diff.sp) + (wealth.gp + diff.gp) + (wealth.pp + diff.pp) + } + }} + + Api.ClaimAdded claim -> + { model | claims = (claim :: model.claims) } + + Api.ClaimRemoved claim -> + { model | claims = List.filter (\c -> c.id /= claim.id) model.claims } + + + +type ToChest + = OfPlayer Int + | OfGroup + | OfShop + + +fetchLoot : ToChest -> Cmd Msg +fetchLoot dest = + let + url = + case dest of + OfPlayer id -> + "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/loot" + + OfShop -> + "http://localhost:8088/api/items" + + OfGroup -> + "http://localhost:8088/api/players/0/loot" + in + Api.fetchLoot url (GotLoot dest) + + + +-- Selection +-- Get list of selected items + + +getSelected : ChestContent -> Model -> Loot +getSelected content model = + selectContent content model + |> List.filter (itemInSelection model.selection) + + +itemInSelection : Maybe Selection -> Item -> Bool +itemInSelection selection item = + Maybe.map (Set.member item.id) selection + |> Maybe.withDefault False + + +itemInClaims : Claims -> Item -> Bool +itemInClaims claims item = + List.any (\c -> c.loot_id == item.id) claims + + +switchSelectionState : Int -> Maybe Selection -> Maybe Selection +switchSelectionState id selection = + case selection of + Just s -> + Just <| + case Set.member id s of + True -> + Set.remove id s + + False -> + Set.insert id s + + Nothing -> + Debug.log "ignore switchSelectionState" Nothing + + +selectContent : ChestContent -> Model -> List Item +selectContent content model = + case content of + NewLoot -> + model.state.newLoot + + MerchantLoot -> + model.state.merchantLoot + + PlayerLoot -> + model.state.playerLoot + + GroupLoot -> + model.state.groupLoot diff --git a/src/Session.elm b/src/Session.elm index 6d769d4..c083bb7 100644 --- a/src/Session.elm +++ b/src/Session.elm @@ -1,12 +1,13 @@ -module Session exposing (..) +module Session exposing (Session(..), playerSession) import Browser.Navigation as Nav +import Api -type User - = Player Int - | Admin +type Session + = Player Nav.Key Int +-- | Admin Nav.Key -type Model - = LoggedIn Nav.Key User - | LoggedOut Nav.Key + +playerSession navKey playerId = + Player navKey playerId