diff --git a/src/Api.elm b/src/Api.elm index dbdced6..8705f98 100644 --- a/src/Api.elm +++ b/src/Api.elm @@ -1,6 +1,5 @@ module Api exposing - ( ActionMode(..) - , Claim + ( Claim , Claims , HttpResult , Item @@ -13,6 +12,7 @@ module Api exposing , confirmAction , fetchClaimsOf , fetchLoot + , replaceShopItems ) import Api.Player exposing (Player, Wealth) @@ -57,10 +57,6 @@ type Msg -- Loot -type alias Loot = - List Item - - type alias Item = { id : Int , name : String @@ -68,6 +64,61 @@ type alias Item = } +itemDecoder = + D.map3 Item + (D.field "id" int) + (D.field "name" string) + (D.field "base_price" int) + + +itemEncoder item = + E.object + [ ( "id", E.int item.id ) + , ( "name", E.string item.name ) + , ( "base_price", E.int item.base_price ) + ] + + +type alias Loot = + List Item + + + +-- LOOT +-- Location of a loot + + +lootDecoder : Decoder Loot +lootDecoder = + D.list itemDecoder + + +type ToChest + = OfPlayer Int + | OfGroup + | OfShop + + +fetchLoot : (ToChest -> Result Http.Error Loot -> msg) -> ToChest -> Cmd msg +fetchLoot toMsg dest = + let + url = + case dest of + OfPlayer id -> + "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/loot" + + OfShop -> + "http://localhost:8088/api/shop" + + OfGroup -> + "http://localhost:8088/api/players/0/loot" + in + Http.get + { url = url + , expect = Http.expectJson (toMsg dest) (valueDecoder lootDecoder) + } + + -- Claims @@ -111,57 +162,6 @@ fetchClaimsOf toMsg playerId = --- LOOT --- Location of a loot - - -itemDecoder = - D.map3 Item - (D.field "id" int) - (D.field "name" string) - (D.field "base_price" int) - - -itemEncoder item = - E.object - [ ( "id", E.int item.id ) - , ( "name", E.string item.name ) - , ( "base_price", E.int item.base_price ) - ] - - -lootDecoder : Decoder Loot -lootDecoder = - D.list itemDecoder - - -type ToChest - = OfPlayer Int - | OfGroup - | OfShop - - -fetchLoot : (ToChest -> Result Http.Error Loot -> msg) -> ToChest -> Cmd msg -fetchLoot toMsg dest = - let - url = - case dest of - OfPlayer id -> - "http://localhost:8088/api/players/" ++ String.fromInt id ++ "/loot" - - OfShop -> - "http://localhost:8088/api/shop" - - OfGroup -> - "http://localhost:8088/api/players/0/loot" - in - Http.get - { url = url - , expect = Http.expectJson (toMsg dest) (valueDecoder lootDecoder) - } - - - -- Retrieves items from a list of names @@ -264,14 +264,6 @@ apiResponseDecoder toValue = -} -type ActionMode - = View - | Sell - | Buy - | Grab - | Add - - type RequestData = SellPayload Loot (Maybe Float) (List (Maybe Float)) (List Int) | BuyPayload Loot (Maybe Float) (List (Maybe Float)) @@ -398,6 +390,37 @@ undoLastAction id = +-- ADMIN +-- + + +replaceShopItems : (Maybe () -> msg) -> Loot -> Cmd msg +replaceShopItems toMsg loot = + let + data = + E.list itemEncoder loot + + gotResponse : HttpResult (Response ()) -> msg + gotResponse response = + case response of + Ok apiResponse -> + toMsg apiResponse.value + + Err error -> + toMsg Nothing + in + Http.request + { url = "http://localhost:8088/api/shop" + , method = "POST" + , headers = [] + , body = Http.jsonBody data + , expect = Http.expectJson gotResponse (apiResponseDecoder <| D.succeed ()) + , timeout = Nothing + , tracker = Nothing + } + + + -- UTILS diff --git a/src/Main.elm b/src/Main.elm index 93ff176..15da2ed 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -59,6 +59,21 @@ type Page | Loading + +{- + + type Page + = Dashboard Session + | GroupChest Session + | Shop Shop.Model + | NewLoot Session + | About + | Loading + + +-} + + type alias HasPage r = { r | page : Page } @@ -153,6 +168,9 @@ viewPage page = linkWithGem "Coffre de groupe" "/coffre" ] + Admin _ -> + [ navLink "fas fa-store-alt" "Marchand" "/marchand" ] + _ -> [] in @@ -202,9 +220,9 @@ type Msg = UrlChanged Url.Url | LinkClicked Browser.UrlRequest | SessionLoaded (Maybe Session) - | SwitchMenuOpen | GotChestMsg Chest.Msg | GotAdminMsg Admin.Msg + | SwitchMenuOpen @@ -226,45 +244,35 @@ update msg model = in case user of Session.Player playerId -> - let - ( chest, cmd ) = - Chest.init navKey playerId - in - ( model |> setPage (Chest chest), Cmd.map GotChestMsg cmd ) + updatePage Chest GotChestMsg model <| + Chest.init navKey playerId Session.Admin -> - let - ( admin, cmd ) = - Admin.init navKey - in - ( model |> setPage (Admin admin), Cmd.map GotAdminMsg cmd ) + updatePage Admin GotAdminMsg model <| + Admin.init logged Nothing -> ( model |> setPage About, Cmd.none ) ( LinkClicked urlRequest, _ ) -> - case model.page of - Chest chestModel -> - case urlRequest of - Browser.Internal url -> - ( model, Nav.pushUrl model.navbar.navKey (Url.toString url) ) + case urlRequest of + Browser.Internal url -> + ( model, Nav.pushUrl model.navbar.navKey (Url.toString url) ) - Browser.External href -> - ( model, Cmd.none ) - - _ -> + Browser.External href -> ( model, Cmd.none ) ( UrlChanged url, page ) -> -- Handle routing according to current page case ( Route.fromUrl url, page ) of - ( Just (Route.Home content), Chest _ ) -> - update - (GotChestMsg <| Chest.SetContent content) - model + ( Just (Route.Home content), Chest chest ) -> + ( model |> setPage (Chest (Chest.setContent content chest)) + , Cmd.none + ) - ( Just (Route.Home MerchantLoot), Admin _ ) -> - ( model, Cmd.none ) + ( Just route, Admin admin ) -> + Admin.routeChanged route admin + |> updatePage Admin GotAdminMsg model _ -> ( model |> setPage About, Cmd.none ) @@ -285,8 +293,8 @@ update msg model = updatePage : (pageModel -> Page) -> (pageMsg -> Msg) -> Model -> ( pageModel, Cmd pageMsg ) -> ( Model, Cmd Msg ) -updatePage toModel toMsg model ( pageModel, pageCmd ) = - ( { model | page = toModel pageModel } +updatePage toPage toMsg model ( pageModel, pageCmd ) = + ( { model | page = toPage pageModel } , Cmd.map toMsg pageCmd ) diff --git a/src/Page/Admin.elm b/src/Page/Admin.elm index a06f339..0cd150e 100644 --- a/src/Page/Admin.elm +++ b/src/Page/Admin.elm @@ -1,50 +1,75 @@ -module Page.Admin exposing (..) +module Page.Admin exposing (Model, Msg, init, routeChanged, update, view) +import Api exposing (Loot) import Api.Player as Player exposing (Player, Wealth) import Browser.Navigation as Nav import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) +import Page.Shop as Shop +import Route exposing (Route) +import Session exposing (Session, getSession) -type alias NewPlayer = +type alias NewPlayerForm = { name : String , wealth : Float } -type alias Model = - { navKey : Nav.Key +type alias Status = + { session : Session , players : List Player - , newPlayer : NewPlayer + , newPlayer : NewPlayerForm } -init : Nav.Key -> ( Model, Cmd Msg ) -init navKey = - ( { navKey = navKey - , players = [] - , newPlayer = { name = "", wealth = 0.0 } - } +type Model + = Dashboard Status + | MerchantLoot Shop.Model + + +init : Session -> ( Model, Cmd Msg ) +init session = + ( Dashboard (Status session [] (NewPlayerForm "" 0.0)) , Player.list GotPlayers ) view : Model -> List (Html Msg) view model = - [ p [ class "title" ] [ text "Administration" ] - , div [ class "section" ] - [ table [ class "table is-fullwidth is-striped" ] - [ thead [ class "table-header" ] - [ th [] [ text "Joueurs" ] ] - , tbody [] <| - editNewPlayer model.newPlayer - :: List.map viewPlayer model.players + case model of + Dashboard config -> + [ 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 config.newPlayer + :: List.map viewPlayer config.players + ] + ] + , div [ class "section" ] + [ p [] [ text "Campagnes" ] ] + ] + ] + + MerchantLoot shop -> + let + toShopMsg = + Html.map ShopMsg + + ( controls, viewShop ) = + Shop.view shop + |> Tuple.mapBoth toShopMsg (List.map toShopMsg) + in + [ div [ class "container" ] <| + p [ class "title" ] [ text "Marchand" ] + :: controls + :: viewShop ] - ] - , div [ class "section" ] - [ p [] [ text "Campagnes" ] ] - ] viewPlayer : Player -> Html Msg @@ -52,7 +77,7 @@ viewPlayer player = tr [] [ td [] [ p [] [ text (player.name ++ " (" ++ String.fromInt player.id ++ ")") ] ] ] -editNewPlayer : NewPlayer -> Html Msg +editNewPlayer : NewPlayerForm -> Html Msg editNewPlayer newPlayer = tr [] [ td [] @@ -63,7 +88,7 @@ editNewPlayer newPlayer = [ class "input" , type_ "text" , value newPlayer.name - , onInput NameChanged + , onInput <| GotFormMsg << NameChanged ] [] ] @@ -72,7 +97,7 @@ editNewPlayer newPlayer = [ class "input" , type_ "text" , value <| String.fromFloat newPlayer.wealth - , onInput WealthChanged + , onInput <| GotFormMsg << WealthChanged ] [] ] @@ -84,27 +109,64 @@ editNewPlayer newPlayer = type Msg = GotPlayers (List Player) - | NameChanged String + | GotFormMsg FormMsg + | ShopMsg Shop.Msg + + +type FormMsg + = NameChanged String | WealthChanged String -update msg model = +updateForm : FormMsg -> NewPlayerForm -> NewPlayerForm +updateForm msg form = case msg of - GotPlayers players -> - ( Debug.log "GotPlayers" { model | players = players }, Cmd.none ) - NameChanged newName -> - let - newPlayer = - model.newPlayer - in - ( { model | newPlayer = { newPlayer | name = newName } }, Cmd.none ) + { form | name = newName } WealthChanged newWealth -> - let - newPlayer = - model.newPlayer - in - ( { model | newPlayer = { newPlayer | wealth = Maybe.withDefault 0.0 <| String.toFloat newWealth } } - , Cmd.none - ) + { form | wealth = Maybe.withDefault 0.0 <| String.toFloat newWealth } + + +routeChanged : Route.Route -> Model -> ( Model, Cmd Msg ) +routeChanged route model = + case model of + Dashboard config -> + case route of + Route.Home Route.MerchantLoot -> + Tuple.mapBoth + MerchantLoot + (Cmd.map ShopMsg) + (config.session |> Shop.init) + + _ -> + ( model, Cmd.none ) + + MerchantLoot shop -> + case route of + Route.Home Route.PlayerLoot -> + init shop.session + + _ -> + ( model, Cmd.none ) + + +update msg model = + case ( msg, model ) of + ( GotPlayers players, Dashboard config ) -> + ( Dashboard { config | players = players }, Cmd.none ) + + ( GotFormMsg formMsg, Dashboard config ) -> + ( Dashboard { config | newPlayer = updateForm formMsg config.newPlayer }, Cmd.none ) + + ( _, Dashboard _ ) -> + ( model, Cmd.none ) + + ( ShopMsg shopMsg, MerchantLoot shopModel ) -> + Shop.update shopMsg shopModel + |> Tuple.mapBoth + MerchantLoot + (Cmd.map ShopMsg) + + ( _, MerchantLoot _ ) -> + ( model, Cmd.none ) diff --git a/src/Page/Chest.elm b/src/Page/Chest.elm index 0ad52e0..00a887c 100644 --- a/src/Page/Chest.elm +++ b/src/Page/Chest.elm @@ -1,9 +1,8 @@ -module Page.Chest exposing (..) +module Page.Chest exposing (Model, Msg, init, setContent, update, view) import Api exposing - ( ActionMode(..) - , Claims + ( Claims , HttpResult , Item , Loot @@ -22,8 +21,132 @@ import Set exposing (Set) import Utils exposing (..) +setContent : ChestContent -> Model -> Model +setContent content model = + update (SetContent content) model + |> Tuple.first + + -- MODEL +{- + type alias ViewConfig = + { filterText : String + } + + type alias Selection data = + { selection : Set Int -- Set of selected items + , selectionData : Dict Int data -- Data associated by id + } + + type alias AddConfig = + { showModal : Bool + , autoComplete : Loot + , newItem : Maybe Item + , sourceName : Maybe String + , itemList : Maybe (List String) + } + + + + + + + type ChestMsg + = ConfirmAction + | CancelAction + | EnterMode ActionMode + | ViewMsg + | SelectionMsg + | AddMsg + + type Content + = PlayerLoot Int + | GroupLoot + | MerchantShop + | Inventory + + type Context + = View String + | Sell (Selection Int) + | Buy (Selection Int) + | Grab (Selection ()) + | Add AddConfig + + + type Chest + = Chest Context Loot + + + type Chest + = View ViewConfig Loot + | Sell Selection Loot + | Buy Selection Loot + | Grab Selection Loot + | Add AddConfig Loot + + + type alias Cache = + { playerLoot : ... + , ... + , claims : Claims + } + + + -- Leading to new model + + type alias Model = + { navKey: Nav.Key + , error : Maybe String + , notification : Maybe String + , player : Player + , wealth : Wealth.Model + , cache : Cache + , chest : Chest + } + + -- Hence, + + type ViewMsg + = SetContent ChestContent + | SearchTextChanged String + + type AddMsg + = NewItemAdded Item + | NewItemNameChanged String + | NewItemPriceChanged String + | SourceNameChanged String + | SetNewItem Item + | OpenModal + | FromListChanged String + | FromListConfirmed + | NewItemsFromList Loot (Maybe String) + + type SelectionMsg + = SetSelection (Maybe Selection) + | SwitchSelectionState Int + -- Buy/Sell modes + | PriceModifierChanged Int String + | WealthMsg Wealth.Msg + + + type Msg + = ApiMsg Api.Msg + | GotLoot Api.ToChest (HttpResult Loot) + | GotClaims (HttpResult Claims) + | GotPlayer (HttpResult Player) + | ClearNotification + | GotChestMsg ChestMsg + +-} + + +type ActionMode + = View + | Sell + | Buy + | Grab + | Add type alias State = @@ -31,6 +154,7 @@ type alias State = , error : Maybe String , notification : Maybe String + -- Chest state -- Buy/Sell loot , priceModifiers : Dict Int Int @@ -58,9 +182,13 @@ type alias Selection = type alias Model = { navKey : Nav.Key , state : State + + -- Chest , shown : Route.ChestContent , selection : Maybe Selection , searchText : String + + -- Others , wealth : Wealth.Model , claims : Claims } diff --git a/src/Page/Chest/NewFromInventory.elm b/src/Page/Chest/NewFromInventory.elm new file mode 100644 index 0000000..28a720f --- /dev/null +++ b/src/Page/Chest/NewFromInventory.elm @@ -0,0 +1,213 @@ +module Page.Chest.NewFromInventory exposing (..) + +import Api exposing (Item, Loot) +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Table + + +type ExitStatus + = Confirmed Loot + | Canceled + + +type alias Model = + { itemList : String + , invalidItems : Loot + , validItems : Loot + } + + +init : Model +init = + Model + "" + [] + [] + + +view : Model -> ( Html Msg, List (Html Msg) ) +view model = + let + allLootValid = + if List.length model.invalidItems + List.length model.validItems == 0 then + False + + else + List.all itemIsValid model.invalidItems + in + ( div [ class "buttons" ] + [ button + [ class "button" + , disabled <| not allLootValid + , onClick ConfirmClicked + ] + [ text "Ok" ] + , button + [ class "button" + , onClick CancelClicked + ] + [ text "Annuler" ] + ] + , [ div [ class "section" ] + [ textarea + [ class "textarea" + , value model.itemList + , onInput ItemListInput + , placeholder "Coller une liste d'objets" + ] + [] + , button + [ class "button is-primary is-fullwidth" + , onClick ItemListSend + ] + [ text "Mettre dans le coffre" ] + ] + , div [ class "section" ] + [ model.validItems ++ model.invalidItems |> Table.view viewOrEditRenderer ] + ] + ) + + +itemIsValid item = + item.name /= "" && item.base_price > 0 + + + +-- We fill id with a negative value (nether used by db) +-- to indicate an item that needs to be edited + + +viewOrEditRenderer item = + if item.id <= 0 then + let + nameValid = + item.name /= "" + + priceValid = + item.base_price > 0 + in + [ div [ class "field is-grouped" ] + [ div [ class "control" ] + [ input + [ class "input is-small " + , type_ "text" + , value item.name + , onInput <| InvalidItemNameChanged item.id + ] + [] + ] + , div [ class "control" ] + [ input + [ class "input is-small " + , type_ "text" + , value <| String.fromInt item.base_price + , onInput <| InvalidItemPriceChanged item.id + ] + [] + ] + ] + ] + + else + Table.name item + + +type Msg + = ItemListInput String + | ItemListSend + | InvalidItemNameChanged Int String + | InvalidItemPriceChanged Int String + | GotCheckedItems Loot (Maybe String) + | ConfirmClicked + | CancelClicked + + +update : Msg -> Model -> ( Model, Cmd Msg, Maybe ExitStatus ) +update msg model = + case msg of + ItemListInput newList -> + ( { model | itemList = newList } + , Cmd.none + , Nothing + ) + + ItemListSend -> + ( { model | itemList = "" } + , Api.checkList GotCheckedItems <| + String.split "\n" model.itemList + , Nothing + ) + + GotCheckedItems valid errors -> + let + -- We tranform errors into invalid items. + newInvalidItems = + model.invalidItems + ++ (case errors of + Just items -> + String.split "," (String.trim items) + |> List.filter (\name -> name /= "") + |> List.map (\name -> Item 0 name 0) + + Nothing -> + [] + ) + -- We need to recalculate all invalid negative ids + -- to avoid conflicts if it's used more than once + |> List.indexedMap (\idx item -> { item | id = -idx }) + in + ( { model + | invalidItems = newInvalidItems + , validItems = valid ++ model.validItems + } + , Cmd.none + , Nothing + ) + + InvalidItemNameChanged id newName -> + ( { model + | invalidItems = + model.invalidItems + |> editItem (\item -> { item | name = newName }) id + } + , Cmd.none + , Nothing + ) + + InvalidItemPriceChanged id newPrice -> + let + price = + Maybe.withDefault 0 <| String.toInt newPrice + in + ( { model + | invalidItems = + model.invalidItems |> editItem (\item -> { item | base_price = price }) id + } + , Cmd.none + , Nothing + ) + + ConfirmClicked -> + ( model, Cmd.none, Just (Confirmed <| allLoot model) ) + + CancelClicked -> + ( model, Cmd.none, Just Canceled ) + + +allLoot model = + model.invalidItems ++ model.validItems + + +editItem : (Item -> Item) -> Int -> Loot -> Loot +editItem editor targetId items = + List.map + (\item -> + if item.id == targetId then + editor item + + else + item + ) + items diff --git a/src/Page/Shop.elm b/src/Page/Shop.elm new file mode 100644 index 0000000..7dcc486 --- /dev/null +++ b/src/Page/Shop.elm @@ -0,0 +1,128 @@ +module Page.Shop exposing (Model, Msg, init, update, view) + +import Api exposing (Item, Loot) +import Dict exposing (Dict) +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Http +import Page.Chest.NewFromInventory as NewChest +import Session exposing (Session, getSession) +import Set exposing (Set) +import Table + + +type alias Model = + { session : Session + , state : State + } + + +type State + = Loading + | LoadError String + | View Loot + | Refresh NewChest.Model + | Sending + + +init session = + ( Model session Loading, fetchShopItems ) + + +fetchShopItems = + Api.fetchLoot GotLoot Api.OfShop + + +view : Model -> ( Html Msg, List (Html Msg) ) +view model = + case model.state of + Loading -> + ( text "", [ p [ class "title" ] [ text "loading..." ] ] ) + + LoadError error -> + ( text "", [ p [ class "has-text-danger" ] [ text <| "Error : " ++ error ] ] ) + + View loot -> + ( case Session.user model.session of + Session.Admin -> + button [ class "button", onClick IntoRefresh ] [ text "Remplacer" ] + + Session.Player _ -> + button [ class "button" ] [ text "Acheter" ] + , [ Table.view Table.name loot ] + ) + + 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..." ] ] ) + + +type Msg + = GotLoot Api.ToChest (Result Http.Error Loot) + | IntoRefresh + | GotChestMsg NewChest.Msg + | GotRefreshResult (Maybe ()) + | IntoBuy + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case ( msg, model.state ) of + ( GotLoot Api.OfShop response, Loading ) -> + case response of + Ok loot -> + ( { model | state = View loot }, Cmd.none ) + + -- TODO: handle error + Err e -> + ( { model | state = LoadError <| Debug.toString e }, Cmd.none ) + + ( IntoRefresh, View _ ) -> + case Session.user (getSession model) of + Session.Admin -> + ( { model | state = Refresh NewChest.init }, Cmd.none ) + + _ -> + ( model, 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 ) + + NewChest.Canceled -> + init <| getSession model + + Nothing -> + ( { model | state = Refresh newState }, Cmd.map GotChestMsg cmd ) + + ( GotRefreshResult result, _ ) -> + case result of + Just _ -> + init <| getSession model + + Nothing -> + ( { model | state = LoadError "L'ajout a échoué. Vous devez recommencer :'( " } + , Cmd.none + ) + + _ -> + ( model, Cmd.none ) diff --git a/src/Session.elm b/src/Session.elm index 7c0a055..1c35c92 100644 --- a/src/Session.elm +++ b/src/Session.elm @@ -1,4 +1,4 @@ -module Session exposing (Session, User(..), init, key, user) +module Session exposing (Session, User(..), getSession, init, key, user) import Browser.Navigation as Nav import Http @@ -42,6 +42,11 @@ init toMsg navKey = } +getSession : { r | session : Session } -> Session +getSession r = + .session r + + key : Session -> Nav.Key key session = let diff --git a/src/Table.elm b/src/Table.elm new file mode 100644 index 0000000..83dd3fa --- /dev/null +++ b/src/Table.elm @@ -0,0 +1,24 @@ +module Table exposing (name, view) + +import Html exposing (..) +import Html.Attributes exposing (..) + + +type alias RowRenderer a msg = + a -> List (Html msg) + + +view : RowRenderer a msg -> List a -> Html msg +view rowRenderer content = + table [ class "table is-fullwidth" ] + [ thead [ class "table-header" ] + [ th [] [ text "Nom" ] ] + , tbody [] <| + List.map + (\i -> tr [] [ td [] <| rowRenderer i ]) + content + ] + + +name item = + [ p [] [ text item.name ] ]