diff --git a/src/Api.elm b/src/Api.elm index b116c30..714e57b 100644 --- a/src/Api.elm +++ b/src/Api.elm @@ -13,6 +13,8 @@ module Api exposing , fetchClaimsOf , fetchLoot , fetchSession + , getLoot + , printError , replaceShopItems ) @@ -421,23 +423,25 @@ replaceShopItems toMsg loot = } - --- This is where the error happened +fetchSession = + Http.task + { method = "GET" + , url = "http://localhost:8088/session" + , headers = [] + , body = Http.emptyBody + , resolver = Http.stringResolver <| handleJsonResponse Api.Player.playerDecoder + , timeout = Nothing + } -fetchSession toMsg = - let - gotResponse r = - case Debug.log "got session:" r of - Ok player -> - toMsg (Just player) - - Err _ -> - toMsg Nothing - in - Http.get - { url = "http://localhost:8088/session" - , expect = Http.expectJson gotResponse Api.Player.playerDecoder +getLoot id = + Http.task + { method = "GET" + , url = "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/loot" + , headers = [] + , body = Http.emptyBody + , resolver = Http.stringResolver <| handleJsonResponse (valueDecoder lootDecoder) + , timeout = Nothing } @@ -445,11 +449,44 @@ fetchSession toMsg = -- UTILS +handleJsonResponse : Decoder a -> Http.Response String -> Result Http.Error a +handleJsonResponse decoder response = + case response of + Http.BadUrl_ url -> + Err (Http.BadUrl url) + + Http.Timeout_ -> + Err Http.Timeout + + Http.BadStatus_ { statusCode } _ -> + Err (Http.BadStatus statusCode) + + Http.NetworkError_ -> + Err Http.NetworkError + + Http.GoodStatus_ _ body -> + case D.decodeString decoder body of + Err _ -> + Err (Http.BadBody body) + + Ok result -> + Ok result + + printError : Http.Error -> String printError error = case error of Http.NetworkError -> - "Le serveur ne répond pas" + "Le réseau ne fonctionne pas" - _ -> - "Erreur inconnue" + Http.Timeout -> + "Le serveur ne réponse pas (timeout)" + + Http.BadUrl url -> + "La resource " ++ url ++ "n'existe pas" + + Http.BadStatus statusCode -> + "Le serveur a renvoyé une erreur (" ++ String.fromInt statusCode ++ ")" + + Http.BadBody body -> + "La réponse n'a pas pu être lue : " ++ body diff --git a/src/Main.elm b/src/Main.elm index b128cbd..13f0a0a 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -7,7 +7,6 @@ import Html.Attributes exposing (..) import Html.Events exposing (..) import Json.Encode as E import Page exposing (Page) -import Page.Admin as Admin import Page.Chest as Chest exposing (Msg) import Route exposing (..) import Session exposing (..) @@ -130,7 +129,7 @@ viewHeaderBar navbarTitle navbarLinks navbar = type Msg = UrlChanged Url.Url | LinkClicked Browser.UrlRequest - | SessionLoaded (Maybe Session) + | SessionLoaded (Result String Session) | PageMsg Page.PageMsg | SwitchMenuOpen @@ -140,14 +139,18 @@ update msg model = case ( msg, model.page ) of ( SessionLoaded session, _ ) -> case session of - Just logged -> + Ok logged -> let ( page, cmd ) = Page.initHome logged in ( model |> setPage page, Cmd.map PageMsg cmd ) - Nothing -> + Err error -> + let + _ = + Debug.log "SessionLoaded Error" error + in ( model |> setPage Page.About, Cmd.none ) ( LinkClicked urlRequest, _ ) -> diff --git a/src/Page.elm b/src/Page.elm index 314d235..4361ea9 100644 --- a/src/Page.elm +++ b/src/Page.elm @@ -5,7 +5,6 @@ import Api.Player import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import Page.Admin as Admin import Page.Dashboard as Dashboard import Page.GroupChest as GroupChest import Page.Shop as Shop @@ -33,7 +32,7 @@ mapMsg toMsg = maybeSession page = case page of Dashboard model -> - Just <| Session.getSession model + Just <| Dashboard.getSession model GroupChest model -> Just <| Session.getSession model @@ -83,7 +82,7 @@ view page = case maybeSession page of Just session -> case Session.user session of - Session.Player player _ -> + Session.Player player _ _ -> player.name Session.Admin -> @@ -96,7 +95,7 @@ view page = case maybeSession page of Just session -> case Session.user session of - Session.Player player _ -> + Session.Player player _ _ -> let linkWithGem = navLink "fas fa-gem" @@ -131,7 +130,7 @@ viewSessionBar session controls = Nothing -> [ text "" ] - Just (Session.Player player wealth) -> + Just (Session.Player player wealth _) -> let _ = Debug.log "viewSessionBar wealth" player.wealth @@ -179,8 +178,6 @@ navLink icon linkText url = -- UPDATE -- --- Note : All pages 'update' function --- shall return (subMode, Cmd Api.Msg) type PageMsg @@ -203,7 +200,7 @@ map func page = Just session -> case page of Dashboard model -> - Dashboard { model | session = func session } + Dashboard <| Dashboard.updateSession model (func session) GroupChest model -> GroupChest { model | session = func session } @@ -224,6 +221,9 @@ update msg page = ( GotGroupChestMsg _, _, _ ) -> ( page, Cmd.none ) + ( GotDashboardMsg (Dashboard.Api apiMsg), Dashboard home, _ ) -> + update (ApiMsg apiMsg) page + ( GotDashboardMsg subMsg, Dashboard home, _ ) -> Dashboard.update subMsg home |> updatePage Dashboard GotDashboardMsg @@ -231,6 +231,9 @@ update msg page = ( GotDashboardMsg _, _, _ ) -> ( page, Cmd.none ) + ( GotShopMsg (Shop.Api apiMsg), Shop shop, _ ) -> + update (ApiMsg apiMsg) page + ( GotShopMsg subMsg, Shop shop, _ ) -> Shop.update subMsg shop |> updatePage Shop GotShopMsg @@ -244,7 +247,7 @@ update msg page = Session.wealth session in case Session.user session of - Session.Player player aModel -> + Session.Player player aModel _ -> let ( newWealth, maybeEdit ) = Wealth.update wealthMsg aModel @@ -328,15 +331,16 @@ applyUpdate u user = in {- Note: DbUpdates always refer to the active player -} case user of - Session.Player player wealthModel -> + Session.Player player wealthModel loot -> case u of Api.ItemRemoved item -> - --List.filter (\i -> i.id /= item.id) model.state.playerLoot - user + Session.Player player wealthModel <| + List.filter + (\i -> i.id /= item.id) + loot Api.ItemAdded item -> - --{ model | state = { state | playerLoot = item :: model.state.playerLoot } } - user + Session.Player player wealthModel (item :: loot) Api.WealthUpdated diff -> let @@ -356,6 +360,7 @@ applyUpdate u user = (wealth.pp + diff.pp) } wealthModel + loot Api.ClaimAdded claim -> -- { model | claims = claim :: model.claims } diff --git a/src/Page/Admin.elm b/src/Page/Admin.elm.old similarity index 98% rename from src/Page/Admin.elm rename to src/Page/Admin.elm.old index d8c7001..d96dcb2 100644 --- a/src/Page/Admin.elm +++ b/src/Page/Admin.elm.old @@ -1,4 +1,4 @@ -module Page.Admin exposing (Model, Msg, getSession, init, routeChanged, update, view) +module Page.Admin exposing (Model) import Api exposing (Loot) import Api.Player as Player exposing (Player, Wealth) diff --git a/src/Page/Chest.elm b/src/Page/Chest.elm index 8431445..685bcdc 100644 --- a/src/Page/Chest.elm +++ b/src/Page/Chest.elm @@ -1,4 +1,4 @@ -module Page.Chest exposing (Chest, Msg, init, initCreate, initSelection, update, view) +module Page.Chest exposing (Chest, Msg, confirmAdd, confirmBuy, confirmSell, init, initCreate, initSelection, update, view) import Api exposing (Item, Loot) import Html exposing (..) @@ -11,12 +11,40 @@ type alias RowRenderer msg = Item -> List (Html msg) + +{- + + A chest is a component that acts on a list of items (loot) + + It can render it's content as a table. + + It does not hold any loot itself, it is given in view only ! + + + type Chest + = Chest (RowRenderer Never) +-} + + type Chest = View | Selection Selection.Model | Create NewFromInventory.Model + +{- + + View : RowRenderer -> Chest.View + + Selection : RowRenderer -> { confirm: Cmd msg, cancel: Cmd msg } -> Chest.Selection + + NewFromInventory : RowRenderer -> { confirm: Cmd msg, cancel: Cmd msg } -> Chest.NewFromInventory + + +-} + + init = View @@ -70,3 +98,71 @@ updateChest toMsg toChest ( model, cmd ) = ( toChest model , Cmd.map toMsg cmd ) + + + +-- Api actions +-- + + +confirmBuy : Int -> Chest -> Loot -> Cmd Api.Msg +confirmBuy playerId model loot = + case model of + Selection chest -> + let + items = + Selection.selected chest loot + + priceMods = + Selection.modifiers chest items + + payload = + Api.BuyPayload items Nothing priceMods + in + Api.confirmAction + (String.fromInt playerId) + payload + + _ -> + Cmd.none + + +confirmSell : Int -> Chest -> Loot -> List Int -> Cmd Api.Msg +confirmSell playerId model loot players = + case model of + Selection chest -> + let + items = + Selection.selected chest loot + + priceMods = + Selection.modifiers chest items + + payload = + Api.SellPayload items Nothing priceMods players + in + Api.confirmAction + (String.fromInt playerId) + payload + + _ -> + Cmd.none + + +confirmAdd : Int -> String -> Chest -> Cmd Api.Msg +confirmAdd playerId sourceName model = + case model of + Create chest -> + let + items = + NewFromInventory.allLoot chest + + payload = + Api.AddPayload sourceName items + in + Api.confirmAction + (String.fromInt playerId) + payload + + _ -> + Cmd.none diff --git a/src/Page/Chest/Selection.elm b/src/Page/Chest/Selection.elm index 99550c8..8a27b49 100644 --- a/src/Page/Chest/Selection.elm +++ b/src/Page/Chest/Selection.elm @@ -1,37 +1,176 @@ -module Page.Chest.Selection exposing (Model, Msg, init, update, view) +module Page.Chest.Selection exposing (Model, Msg, init, modifiers, selected, update, view) -import Api exposing (Loot) +import Api exposing (Item, Loot) +import Dict exposing (Dict) import Html exposing (..) import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Set exposing (Set) import Table -type Selection - = Selection +type alias Selection = + Set Int + + +type alias Data a = + Dict Int a type Model - = Model Selection + = Model Selection (Data Int) init = - Model Selection + Model Set.empty Dict.empty view : Model -> Loot -> Html Msg -view model loot = +view (Model selection data) loot = + let + isSelected = + itemInSelection selection + + renderItem item = + let + maybeMod = + Dict.get item.id data + in + [ viewPriceWithModApplied + (Maybe.map (\i -> toFloatingMod i) maybeMod) + (toFloat item.base_price) + , if isSelected item then + viewPriceModifier item.id <| + case Dict.get item.id data of + Just mod -> + String.fromInt mod + + Nothing -> + "0" + + else + text "" + ] + in Table.view - (Table.renderRowLevel - (\item -> [ p [] [ text <| item.name ++ "selectable" ] ]) - (\item -> [ input [ type_ "checkbox" ] [] ]) + (Table.renderSelectableRow + (\item -> [ p [] [ text item.name ] ]) + (\item -> renderItem item) + (\item _ -> SwitchSelectionState item.id) + isSelected ) loot +toFloatingMod : Int -> Float +toFloatingMod percent = + (100 + Debug.log "toFloat" (toFloat percent)) / 100 + + + +-- Renderers : Item -> Html Msg + + +viewPriceWithModApplied : Maybe Float -> Float -> Html Msg +viewPriceWithModApplied maybeMod basePrice = + case maybeMod of + Just mod -> + p [ class "level-item has-text-weight-bold" ] + [ (Debug.log "withMod" (String.fromFloat (basePrice * mod)) ++ "po") + |> text + ] + + Nothing -> + p [ class "level-item" ] [ (String.fromFloat basePrice ++ "po") |> text ] + + +viewPriceModifier : Int -> String -> Html Msg +viewPriceModifier id modValue = + div [ class "level-item field has-addons" ] + [ div [ class "control has-icons-left" ] + [ input + [ type_ "number" + , value modValue + , class "input is-small" + , size 3 + , style "width" "6em" + , Html.Attributes.min "-50" + , Html.Attributes.max "50" + , step "5" + , onInput (PriceModifierChanged id) + ] + [] + , span [ class "icon is-left" ] [ i [ class "fas fa-percent" ] [] ] + ] + ] + + + +-- Selection +-- Get list of selected items + + +selected : Model -> Loot -> Loot +selected (Model selection data) loot = + List.filter (itemInSelection selection) loot + + +modifiers : Model -> Loot -> List (Maybe Float) +modifiers (Model selection data) items = + List.map + (\item -> + Dict.get item.id data + |> Maybe.map (\i -> toFloatingMod i) + ) + items + + +itemInSelection : Selection -> Item -> Bool +itemInSelection selection item = + Set.member item.id selection + + + +{- + itemInClaims : Claims -> Item -> Bool + itemInClaims claims item = + List.any (\c -> c.loot_id == item.id) claims +-} + + +switchSelectionState : Int -> Selection -> Selection +switchSelectionState id selection = + case Set.member id selection of + True -> + Set.remove id selection + + False -> + Set.insert id selection + + type Msg - = Msg + = SwitchSelectionState Int + | PriceModifierChanged Int String update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - ( model, Cmd.none ) +update msg (Model selection data) = + case msg of + PriceModifierChanged id value -> + ( Model selection + (Dict.insert + id + (case String.toInt value of + Just i -> + i + + Nothing -> + 0 + ) + data + ) + , Cmd.none + ) + + SwitchSelectionState id -> + ( Model (switchSelectionState id selection) data, Cmd.none ) diff --git a/src/Page/Dashboard.elm b/src/Page/Dashboard.elm index 337cf79..502294a 100644 --- a/src/Page/Dashboard.elm +++ b/src/Page/Dashboard.elm @@ -1,5 +1,7 @@ -module Page.Dashboard exposing (Model, Msg, init, update, view) +module Page.Dashboard exposing (Model, Msg(..), getSession, init, update, updateSession, view) +import Api +import Api.Player as Player exposing (Player, Wealth) import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) @@ -7,43 +9,327 @@ import Page.Chest as Chest exposing (Chest) import Session exposing (Session) -type alias Model = - { session : Session - , chest : Mode +getSession model = + case model of + Admin (AdminConfig session _ _) -> + session + + Player (PlayerConfig session _) -> + session + + +updateSession model session = + case model of + Admin (AdminConfig _ a b) -> + Admin (AdminConfig session a b) + + Player (PlayerConfig _ a) -> + Player (PlayerConfig session a) + + +type Model + = Admin AdminConfig + | Player PlayerConfig + + +type alias NewPlayerForm = + { name : String + , wealth : Float } +type PlayerConfig + = PlayerConfig Session Mode + + +type AdminConfig + = AdminConfig Session (List Player) NewPlayerForm + + type Mode - = View Chest + = PlayerChest Chest + | GroupChest Chest + | Sell Chest + | Add Chest init : Session -> ( Model, Cmd Msg ) init session = - ( Model session (View Chest.init) - , Cmd.none - ) + case Session.user session of + Session.Admin -> + ( Admin <| AdminConfig session [] initForm + , Player.list (AdminViewer << GotPlayers) + ) + + Session.Player player wealth loot -> + ( Player <| + PlayerConfig session + (if player.id == 0 then + -- TODO: render claimed items + GroupChest Chest.init + + else + PlayerChest Chest.init + ) + , Cmd.none + ) + + +initForm = + NewPlayerForm "" 0.0 + + +modeButton t msg = + button [ class "button", onClick msg ] [ text t ] + + +buttons bs = + div [ class "buttons" ] bs view : Model -> ( Html Msg, List (Html Msg) ) view model = - case Session.user model.session of - Session.Player player _ -> - ( text "" - , [ if player.id == 0 then - p [] [ text "Groupe" ] + case model of + Player (PlayerConfig session mode) -> + case Session.user session of + Session.Player player _ loot -> + Tuple.mapBoth + (Html.map PlayerViewer) + (List.map (Html.map PlayerViewer)) + <| + case mode of + PlayerChest chest -> + ( modeButton "Vendre" IntoSell + , [ Html.map GotChestMsg <| Chest.view chest loot ] + ) - else - p [] [ text "Joueur" ] + GroupChest chest -> + ( buttons [ modeButton "Vendre" IntoSell, modeButton "Ajouter" IntoAdd ] + , [ Html.map GotChestMsg <| Chest.view chest loot ] + ) + + Sell chest -> + ( buttons [ modeButton "Ok" ConfirmSell, modeButton "Annuler" IntoView ] + , [ Html.map GotChestMsg <| Chest.view chest loot ] + ) + + Add chest -> + ( buttons [ modeButton "Ok" ConfirmAdd, modeButton "Annuler" IntoView ] + , [ Html.map GotChestMsg <| Chest.view chest [] ] + ) + + _ -> + let + _ = + Debug.log "Admin in PlayerDashboard !!" () + in + ( text "", [] ) + + Admin (AdminConfig session players newPlayer) -> + ( text "" + , [ div [ class "container" ] + [ p [ class "title" ] [ text "Administration" ] + , div [ class "section" ] + [ table [ class "table is-fullwidth is-striped" ] + [ thead [ class "table-header" ] + [ th [] [ text "Joueurs" ] ] + , tbody [] <| + editNewPlayer newPlayer + :: List.map viewPlayer players + ] + ] + , div [ class "section" ] + [ p [] [ text "Campagnes" ] ] + ] ] ) - Session.Admin -> - ( text "", [ p [] [ text "Joueur" ] ] ) + +viewPlayer : Player -> Html Msg +viewPlayer player = + tr [] [ td [] [ p [] [ text (player.name ++ " (" ++ String.fromInt player.id ++ ")") ] ] ] + + +editNewPlayer : NewPlayerForm -> Html Msg +editNewPlayer newPlayer = + tr [] + [ td [] + [ div [ class "field is-horizontal" ] + [ div [ class "field-body" ] + [ div [ class "field" ] + [ input + [ class "input" + , type_ "text" + , value newPlayer.name + , onInput <| NameChanged + ] + [] + ] + , div [ class "field" ] + [ input + [ class "input" + , type_ "text" + , value <| String.fromFloat newPlayer.wealth + , onInput <| WealthChanged + ] + [] + ] + ] + ] + ] + ] + |> Html.map (AdminViewer << GotFormMsg) type Msg - = Msg + = Api Api.Msg + | AdminViewer AdminMsg + | PlayerViewer PlayerMsg + + +type AdminMsg + = GotPlayers (List Player) + | GotFormMsg FormMsg + + + +-- Player + + +type PlayerMsg + = GotChestMsg Chest.Msg + | IntoSell + | IntoAdd + | ConfirmSell + | ConfirmAdd + | IntoView + + +mapChest : (Chest -> a) -> Mode -> a +mapChest fn mode = + case mode of + PlayerChest chest -> + fn chest + + GroupChest chest -> + fn chest + + Add chest -> + fn chest + + Sell chest -> + fn chest + + +updateChest : Model -> Chest -> Model +updateChest model new = + case model of + Admin _ -> + model + + Player (PlayerConfig s mode) -> + case mode of + PlayerChest _ -> + Player (PlayerConfig s (PlayerChest new)) + + GroupChest _ -> + Player (PlayerConfig s (GroupChest new)) + + Add _ -> + Player (PlayerConfig s (Add new)) + + Sell _ -> + Player (PlayerConfig s (Sell new)) update msg model = - ( model, Cmd.none ) + case ( msg, model ) of + ( AdminViewer aMsg, Admin (AdminConfig session players form) ) -> + (case aMsg of + GotPlayers newPlayers -> + ( Admin (AdminConfig session newPlayers form) + , Cmd.none + ) + + GotFormMsg subMsg -> + ( Admin (AdminConfig session players (updateForm subMsg form)) + , Cmd.none + ) + ) + |> Tuple.mapSecond (Cmd.map AdminViewer) + + ( PlayerViewer ConfirmSell, Player (PlayerConfig session mode) ) -> + ( model + , Cmd.map Api <| + case Session.user session of + Session.Player player _ loot -> + -- TODO: handle list of players when Viewer is group + mapChest (\chest -> Chest.confirmSell player.id chest loot []) mode + + _ -> + Cmd.none + ) + + ( PlayerViewer ConfirmAdd, Player (PlayerConfig session mode) ) -> + ( model + , Cmd.map Api <| + case Session.user session of + Session.Player player _ _ -> + let + sourceName = + "nouveau loot #1" + in + mapChest (\chest -> Chest.confirmAdd 0 sourceName chest) mode + + _ -> + Cmd.none + ) + + ( PlayerViewer aMsg, Player (PlayerConfig session mode) ) -> + (case aMsg of + GotChestMsg chestMsg -> + mapChest (Chest.update chestMsg) mode + |> Tuple.mapBoth + (updateChest model) + (Cmd.map GotChestMsg) + + IntoSell -> + ( Player (PlayerConfig session (Sell Chest.initSelection)), Cmd.none ) + + IntoAdd -> + ( Player (PlayerConfig session (Add Chest.initCreate)), Cmd.none ) + + IntoView -> + -- TODO: add the necessary test on group/player + ( Player (PlayerConfig session (PlayerChest Chest.init)), Cmd.none ) + + _ -> + ( model, Cmd.none ) + ) + |> Tuple.mapSecond (Cmd.map PlayerViewer) + + ( _, _ ) -> + let + _ = + Debug.log "unhandled msg" msg + in + ( model, Cmd.none ) + + + +-- Player form + + +type FormMsg + = NameChanged String + | WealthChanged String + + +updateForm : FormMsg -> NewPlayerForm -> NewPlayerForm +updateForm msg form = + case msg of + NameChanged newName -> + { form | name = newName } + + WealthChanged newWealth -> + { form | wealth = Maybe.withDefault 0.0 <| String.toFloat newWealth } diff --git a/src/Page/GroupChest.elm b/src/Page/GroupChest.elm index ad459b6..f3082b1 100644 --- a/src/Page/GroupChest.elm +++ b/src/Page/GroupChest.elm @@ -41,7 +41,7 @@ view model = Session.Admin -> text "" - Session.Player p _ -> + Session.Player p _ _ -> if p.id == 0 then button [ class "button" ] [ text "Vendre" ] diff --git a/src/Page/Shop.elm b/src/Page/Shop.elm index d46d18b..b78ebb4 100644 --- a/src/Page/Shop.elm +++ b/src/Page/Shop.elm @@ -1,4 +1,4 @@ -module Page.Shop exposing (Model, Msg, init, update, view) +module Page.Shop exposing (Model, Msg(..), init, update, view) import Api exposing (HttpResult, Item, Loot) import Dict exposing (Dict) @@ -6,7 +6,6 @@ import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) import Page.Chest as Chest exposing (Chest) -import Page.Chest.NewFromInventory as NewChest import Page.Chest.Selection as Selection import Session exposing (Session, getSession) import Set exposing (Set) @@ -44,21 +43,23 @@ getChest mode = c - -{- - | View Loot - | Refresh NewChest.Model - | Buy Selection.Model - | Sending --} - - init session = ( Model session Loading <| View Chest.init, fetchShopItems ) fetchShopItems = Api.fetchLoot GotLoot Api.OfShop + |> Cmd.map Internal + + +btn : String -> Msg -> Html Msg +btn t msg = + button [ class "button", onClick msg ] [ text t ] + + +buttons : List (Html Msg) -> Html Msg +buttons bs = + div [ class "buttons" ] bs view : Model -> ( Html Msg, List (Html Msg) ) @@ -77,61 +78,45 @@ view model = Loaded loot -> let controls = - case model.chest of - View chest -> - case Session.user model.session of - Session.Admin -> - button [ class "button", onClick IntoRefresh ] [ text "Remplacer" ] + case ( model.chest, Session.user model.session ) of + ( View chest, Session.Admin ) -> + btn "Remplacer" (Internal IntoRefresh) - Session.Player _ _ -> - button [ class "button" ] [ text "Acheter" ] + ( View chest, Session.Player _ _ _ ) -> + btn "Acheter" (Internal IntoBuy) - Buy chest -> - text "" + ( Buy chest, Session.Player p _ _ ) -> + buttons [ btn "Ok" (Internal ConfirmBuy), btn "Annuler" (Internal IntoView) ] - Refresh chest -> + ( Refresh chest, Session.Admin ) -> + buttons [ btn "Ok" (Internal ConfirmRefresh), btn "Annuler" (Internal IntoView) ] + + _ -> text "" in ( controls - , [ Chest.view (getChest model.chest) loot |> Html.map GotChestMsg ] + , [ Chest.view (getChest model.chest) loot |> Html.map (Internal << GotChestMsg) ] ) -{- - Buy selection -> - let - ( controls, content ) = - Selection.view selection - - toMsg = - Html.map GotBuyMsg - in - ( toMsg controls - , List.map toMsg content - ) - - Refresh chest -> - let - ( controls, content ) = - NewChest.view chest - - toMsg = - Html.map GotChestMsg - in - ( toMsg controls - , List.map toMsg content - ) - - Sending -> - ( text "", [ p [] [ text "En attente du serveur..." ] ] ) --} +-- Api msg are not handled by the page type Msg + = Api Api.Msg + | Internal ShopMsg + + +type ShopMsg = GotLoot Api.ToChest (HttpResult Loot) | IntoRefresh + | ConfirmRefresh + | GotRefreshResult (Maybe ()) | IntoBuy + | ConfirmBuy + | GotBuyResult + | IntoView | GotChestMsg Chest.Msg @@ -159,72 +144,90 @@ updateChest model chest = update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of - GotLoot Api.OfShop response -> - case response of - Ok loot -> - ( { model | loot = Loaded loot }, Cmd.none ) - - -- TODO: handle error - Err e -> - ( { model | loot = LoadError <| Debug.toString e }, Cmd.none ) - - -- Refresh mode - IntoRefresh -> - case Session.user (getSession model) of - Session.Admin -> - ( { model | chest = Refresh Chest.initCreate }, Cmd.none ) + Internal ConfirmBuy -> + case ( Session.user (getSession model), model.loot, model.chest ) of + ( Session.Player player _ _, Loaded loot, Buy chest ) -> + ( model + , Chest.confirmBuy + player.id + chest + loot + |> Cmd.map Api + ) _ -> ( model, Cmd.none ) - -- Buy mode - IntoBuy -> - case Session.user (getSession model) of - Session.Player _ _ -> - ( { model | chest = Buy Chest.initSelection }, Cmd.none ) + Internal (GotRefreshResult result) -> + case result of + Just _ -> + init <| getSession model - _ -> - ( model, Cmd.none ) + Nothing -> + ( { model | loot = LoadError "L'ajout a échoué. Vous devez recommencer :'( " } + , Cmd.none + ) - GotChestMsg subMsg -> - Chest.update subMsg (getChest model.chest) - |> Tuple.mapBoth - (updateChest model) - (Cmd.map GotChestMsg) + Internal shopMsg -> + let + ( nModel, cmd ) = + case shopMsg of + GotLoot Api.OfShop response -> + case response of + Ok loot -> + ( { model | loot = Loaded loot }, Cmd.none ) - {- - (GotChestMsg chestMsg, Refresh chest ) -> - let - ( newState, cmd, exit ) = - NewChest.update chestMsg chest - in - case exit of - Just status -> - case status of - NewChest.Confirmed loot -> - ( model, Api.replaceShopItems GotRefreshResult loot ) + -- TODO: handle error + Err e -> + ( { model | loot = LoadError <| Debug.toString e }, Cmd.none ) - NewChest.Canceled -> - init <| getSession model + -- Refresh mode + IntoRefresh -> + case Session.user (getSession model) of + Session.Admin -> + ( { model | chest = Refresh Chest.initCreate }, Cmd.none ) - Nothing -> - ( { model | state = Refresh newState }, Cmd.map GotChestMsg cmd ) + _ -> + ( model, Cmd.none ) - ( GotRefreshResult result, _ ) -> - case result of - Just _ -> - init <| getSession model + ConfirmRefresh -> + case Session.user (getSession model) of + Session.Admin -> + let + loot = + [] + in + ( model, Api.replaceShopItems GotRefreshResult loot ) - Nothing -> - ( { model | state = LoadError "L'ajout a échoué. Vous devez recommencer :'( " } - , Cmd.none - ) + _ -> + let + _ = + Debug.log "Forbidden action ! (is not admin)" () + in + ( model, Cmd.none ) + + -- Buy mode + IntoBuy -> + case Session.user (getSession model) of + Session.Player _ _ _ -> + ( { model | chest = Buy Chest.initSelection }, Cmd.none ) + + _ -> + ( model, Cmd.none ) + + IntoView -> + ( { model | chest = View Chest.init }, Cmd.none ) + + GotChestMsg subMsg -> + Chest.update subMsg (getChest model.chest) + |> Tuple.mapBoth + (updateChest model) + (Cmd.map GotChestMsg) + + _ -> + ( model, Cmd.none ) + in + ( nModel, Cmd.map Internal cmd ) - ( GotBuyMsg subMsg, Buy subModel ) -> - Selection.update subMsg subModel - |> Tuple.mapBoth - (\m -> { model | state = Buy m }) - (\c -> Cmd.map GotBuyMsg c) - -} _ -> ( model, Cmd.none ) diff --git a/src/Session.elm b/src/Session.elm index 654a6db..1d6ec8b 100644 --- a/src/Session.elm +++ b/src/Session.elm @@ -1,15 +1,16 @@ module Session exposing (Session, User(..), getSession, init, key, updateUser, updateWealth, user, wealth) -import Api +import Api exposing (Loot) import Api.Player as Player exposing (Player) import Browser.Navigation as Nav import Http import Json.Decode as D +import Task exposing (Task) import Wealth type User - = Player Player Wealth.Model + = Player Player Wealth.Model Loot | Admin @@ -17,19 +18,32 @@ type Session = Session Nav.Key User -init : (Maybe Session -> msg) -> Nav.Key -> Cmd msg +init : (Result String Session -> msg) -> Nav.Key -> Cmd msg init toMsg navKey = let - toSession : Maybe Player -> msg - toSession response = - case response of - Just player -> - toMsg <| Just (Session navKey (Player player Wealth.init)) + toSession : Result String ( Player, Loot ) -> msg + toSession result = + case result of + Ok ( player, loot ) -> + toMsg <| Ok (Session navKey (Player player Wealth.init loot)) - Nothing -> - toMsg Nothing + Err error -> + toMsg <| Err error in - Api.fetchSession toSession + Task.attempt toSession initFullSession + + +initFullSession : Task String ( Player, Loot ) +initFullSession = + Api.fetchSession + |> Task.andThen wrapLoot + |> Task.mapError Api.printError + + +wrapLoot : Player -> Task Http.Error ( Player, Loot ) +wrapLoot player = + Api.getLoot player.id + |> Task.andThen (\loot -> Task.succeed ( player, loot )) getSession : { r | session : Session } -> Session @@ -58,7 +72,7 @@ user session = wealth : Session -> Maybe Wealth.Model wealth session = case user session of - Player _ model -> + Player _ model _ -> Just model Admin -> @@ -71,8 +85,8 @@ setWealth wealthModel session = session in case isUser of - Player p _ -> - Session navKey (Player p wealthModel) + Player p _ loot -> + Session navKey (Player p wealthModel loot) Admin -> Session navKey Admin @@ -85,8 +99,8 @@ updateWealth newWealthModel model = model in case loggedUser of - Player player _ -> - Session navKey (Player player newWealthModel) + Player player _ loot -> + Session navKey (Player player newWealthModel loot) Admin -> Session navKey Admin diff --git a/src/Table.elm b/src/Table.elm index a5fb67f..c29f7ea 100644 --- a/src/Table.elm +++ b/src/Table.elm @@ -1,7 +1,8 @@ -module Table exposing (name, renderRowLevel, view) +module Table exposing (name, renderRowLevel, renderSelectableRow, view) import Html exposing (..) import Html.Attributes exposing (..) +import Html.Events exposing (..) type alias RowRenderer a msg = @@ -24,6 +25,26 @@ view rowRenderer content = ] +renderSelectableRow : ItemRenderer a msg -> ItemRenderer a msg -> (a -> Bool -> msg) -> (a -> Bool) -> RowRenderer a msg +renderSelectableRow left right onCheckMsg isSelected item = + tr [] + [ td [] + [ label [ class "level checkbox" ] + [ div [ class "level-left" ] <| left item + , div [ class "level-right" ] <| + input + [ class "checkbox level-item" + , type_ "checkbox" + , checked <| isSelected item + , onCheck <| onCheckMsg item + ] + [] + :: right item + ] + ] + ] + + renderRowLevel : ItemRenderer a msg -> ItemRenderer a msg -> RowRenderer a msg renderRowLevel left right item = tr []