diff options
| -rw-r--r-- | client/index.html | 1 | ||||
| -rw-r--r-- | client/src/Client.elm | 142 | ||||
| -rw-r--r-- | client/src/Messages.elm | 9 | ||||
| -rw-r--r-- | client/style.css | 48 | ||||
| -rw-r--r-- | config.mk | 2 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 3 |
7 files changed, 142 insertions, 64 deletions
diff --git a/client/index.html b/client/index.html index 9b09840..518b71d 100644 --- a/client/index.html +++ b/client/index.html @@ -4,6 +4,7 @@ <meta charset="UTF-8"> <title>Client</title> <link rel="stylesheet" type="text/css" href="$CAFP_BASE/assets/style.css"> + <meta name="viewport" content="width=device-width"> </head> <body> <div id="main"></div> diff --git a/client/src/Client.elm b/client/src/Client.elm index 6d64050..2d43ae2 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -32,7 +32,8 @@ type Msg type alias Cards = {black : Array String, white : Array String} type alias GameState = - { cards : Cards + { room : Maybe String + , cards : Cards , view : GameView , changeMyName : String , selectedWhiteCards : List WhiteCard @@ -41,58 +42,87 @@ type alias GameState = type Model = Error String - | Connecting + | Connecting (Maybe String) | Game GameState -viewPlayer : Messages.PlayerView -> Html msg -viewPlayer player = Html.div [] <| - [ Html.text player.name - ] ++ - (if player.admin then [Html.text " 👑"] else []) ++ - (if player.ready then [Html.text " ✅"] else []) ++ - [Html.text <| " (" ++ String.fromInt player.points ++ " points)"] +viewPlayers : List Messages.PlayerView -> Html msg +viewPlayers players = Html.table [] <| + Html.tr [] + [ Html.th + [Html.Attributes.style "width" "100%"] + [Html.text "Name"] + , Html.th [] [Html.text "Score"] + ] :: + List.map (\player -> Html.tr [] + [ Html.td [] [Html.text player.name] + , Html.td + [Html.Attributes.style "text-align" "right"] + [Html.text <| String.fromInt player.points] + , Html.td [] + (if player.admin then [Html.text " 👑"] else []) + , Html.td [] + (if player.ready then [Html.text " ✅"] else []) + ]) + (List.sortBy (\player -> (-player.points, player.name)) players) -view : Model -> List (Html Msg) +view : Model -> Browser.Document Msg view model = case model of Error str -> - [ Html.h1 [] [Html.text "Error"] - , Html.p [] [Html.text str] - ] - Connecting -> [Html.h1 [] [Html.text "Connecting to room..."]] + { title = "CaFP: Error" + , body = + [ Html.h1 [] [Html.text "Error"] + , Html.p [] [Html.text str] + ] + } + Connecting roomId -> + { title = "CaFP: Connecting" + , body = + [ Html.h1 [] + [ Html.text <| + "Connecting to room " ++ Maybe.withDefault "??" roomId + ] + ] + } Game game -> - [ Html.div [Html.Attributes.class "players"] - [ Html.h1 [] [Html.text "Players"] - , Html.ul [] <| List.map - (\o -> Html.li [] [viewPlayer o]) - (game.view.me :: game.view.players) - , Html.form - [ Html.Attributes.action "" - , Html.Events.onSubmit SubmitMyName + { title = case game.room of + Nothing -> "CaFP" + Just room -> "CaFP | " ++ room + , body = + [ Html.div [Html.Attributes.class "main"] <| + [ Html.div [Html.Attributes.class "table"] + [Html.h1 [] [Html.text "Table"] + , viewTable game + ] + , Html.h1 [] [Html.text "Your cards"] ] - [ Html.input - [ Html.Attributes.value game.changeMyName - , Html.Events.onInput ChangeMyName + ++ + (List.map + (\c -> whiteCard game.cards c (cardIsSelected game c)) + game.view.hand) + , Html.div [Html.Attributes.class "players"] + [ Html.h1 [] [Html.text "Players"] + , viewPlayers <| game.view.me :: game.view.players + , Html.form + [ Html.Attributes.class "change-name" + , Html.Attributes.action "" + , Html.Events.onSubmit SubmitMyName ] - [] - , Html.button - [ Html.Attributes.type_ "submit" - , Html.Attributes.disabled <| - game.view.me.name == game.changeMyName || - String.length game.changeMyName > 32 + [ Html.input + [ Html.Attributes.value game.changeMyName + , Html.Events.onInput ChangeMyName + ] + [] + , Html.button + [ Html.Attributes.type_ "submit" + , Html.Attributes.disabled <| + game.view.me.name == game.changeMyName || + String.length game.changeMyName > 32 + ] + [Html.text "Change my name"] ] - [Html.text "Change name"] ] ] - , Html.div [Html.Attributes.class "main"] <| - [ Html.h1 [] [Html.text "Table"] - , viewTable game - , Html.h1 [] [Html.text "Your cards"] - ] - ++ - (List.map - (\c -> whiteCard game.cards c (cardIsSelected game c)) - game.view.hand) - ] + } tableBlackCard : GameState -> Maybe BlackCard tableBlackCard game = case game.view.table of @@ -111,7 +141,14 @@ cardIsSelected game card = List.member card <| selectedWhiteCards game viewTable : GameState -> Html Msg viewTable game = case game.view.table of Messages.Proposing c my -> Html.div [] <| - [ blackCard [] game.cards c <| selectedWhiteCards game + [ Html.p [] + [ Html.text <| "Select " ++ + String.fromInt (blackCardBlanks game.cards c) ++ + " card" ++ + (if blackCardBlanks game.cards c < 2 then "" else "s") ++ + " from your hand" + ] + , blackCard [] game.cards c <| selectedWhiteCards game , Html.button [ Html.Attributes.disabled <| List.length my > 0 || @@ -122,8 +159,7 @@ viewTable game = case game.view.table of [Html.text "Propose"] ] Messages.Voting black proposals myProposal myVote -> Html.div [] <| - [ Html.h2 [] [Html.text "Opponent proposals"] - ] ++ + [Html.p [] [Html.text <| "Vote for the funniest combination"]] ++ List.indexedMap (\i proposal -> let attrs = if Just i == myProposal then @@ -148,7 +184,7 @@ viewTable game = case game.view.table of ] Messages.Tally black results -> Html.div [] <| - [Html.h2 [] [Html.text "Vote results"]] ++ + [Html.p [] [Html.text "Vote results"]] ++ List.map (\voted -> let attrs = if List.length voted.winners > 0 then @@ -227,14 +263,18 @@ update msg model = case msg of WebSocketIn json -> case Json.Decode.decodeString Messages.jsonDecServerMessage json of Err str -> (Error <| Json.Decode.errorToString str, Cmd.none) - Ok (Messages.Welcome playerId) -> (model, Cmd.none) - Ok Messages.Bye -> (model, Cmd.none) + Ok (Messages.Welcome roomId) -> case model of + Connecting _ -> (Connecting (Just roomId), Cmd.none) + _ -> (model, Cmd.none) Ok (Messages.SyncGameView gameView) -> case model of Game game -> (Game {game | view = gameView}, Cmd.none) _ -> ( Game - { cards = {black = Array.empty, white = Array.empty} + { room = case model of + Connecting roomId -> roomId + _ -> Nothing + , cards = {black = Array.empty, white = Array.empty} , view = gameView , changeMyName = gameView.me.name , selectedWhiteCards = [] @@ -298,10 +338,10 @@ update msg model = case msg of main : Program () Model Msg main = Browser.application - { init = \() url key -> (Connecting, Cmd.none) + { init = \() url key -> (Connecting Nothing, Cmd.none) , update = update , subscriptions = subscriptions - , view = \model -> {title = "Client", body = view model} + , view = \model -> view model , onUrlChange = \url -> Ignore , onUrlRequest = \urlRequest -> Ignore } diff --git a/client/src/Messages.elm b/client/src/Messages.elm index 434efb0..fb244f9 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -156,28 +156,25 @@ jsonEncGameView val = type ServerMessage = - Welcome Int + Welcome String | SyncCards Cards | SyncGameView GameView - | Bye jsonDecServerMessage : Json.Decode.Decoder ( ServerMessage ) jsonDecServerMessage = let jsonDecDictServerMessage = Dict.fromList - [ ("Welcome", Json.Decode.lazy (\_ -> Json.Decode.map Welcome (Json.Decode.int))) + [ ("Welcome", Json.Decode.lazy (\_ -> Json.Decode.map Welcome (Json.Decode.string))) , ("SyncCards", Json.Decode.lazy (\_ -> Json.Decode.map SyncCards (jsonDecCards))) , ("SyncGameView", Json.Decode.lazy (\_ -> Json.Decode.map SyncGameView (jsonDecGameView))) - , ("Bye", Json.Decode.lazy (\_ -> Json.Decode.succeed Bye)) ] in decodeSumObjectWithSingleField "ServerMessage" jsonDecDictServerMessage jsonEncServerMessage : ServerMessage -> Value jsonEncServerMessage val = let keyval v = case v of - Welcome v1 -> ("Welcome", encodeValue (Json.Encode.int v1)) + Welcome v1 -> ("Welcome", encodeValue (Json.Encode.string v1)) SyncCards v1 -> ("SyncCards", encodeValue (jsonEncCards v1)) SyncGameView v1 -> ("SyncGameView", encodeValue (jsonEncGameView v1)) - Bye -> ("Bye", encodeValue (Json.Encode.list identity [])) in encodeSumObjectWithSingleField keyval val diff --git a/client/style.css b/client/style.css index 735c5f8..8f1f293 100644 --- a/client/style.css +++ b/client/style.css @@ -1,9 +1,46 @@ html { font-size: 18px; + font-family: sans-serif; + text-align: center; } -body { - display: flex; +h1 { + font-weight: lighter; + text-transform: uppercase; + font-size: 24px; + border-bottom: 1px solid black; +} + +@media screen and (min-width: 800px) { + .players { + position: absolute; + top: 0px; + left: 18px; + width: 250px; + } + + .main { + position: absolute; + top: 0px; + left: 280px; + } +} + +.table { + margin-bottom: 60px; +} + +table { + text-align: left; +} + +.change-name { + margin-top: 18px; +} + +button, input { + display: block; + margin: 12px auto 12px auto; } .card { @@ -12,13 +49,17 @@ body { margin: 18px; padding: 18px; width: 300px; + border: 2px solid black; vertical-align: text-top; + max-width: calc(100% - 76px); + filter: drop-shadow(3px 3px 3px black); } .black { color: white; background: black; - width: 600px; + width: inherit; + margin: 12px auto 12px auto; } .votable { @@ -41,7 +82,6 @@ body { .white { color: black; background: white; - border: 2px solid black; cursor: pointer; } @@ -1,3 +1,3 @@ -CAFP_HOSTNAME=127.0.0.1 +CAFP_HOSTNAME=0.0.0.0 CAFP_PORT=8002 CAFP_BASE=/cafp diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 799f26e..4b1bfe7 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -142,6 +142,7 @@ wsApp server pc = case routePendingConnection pc of roomEmpty <- atomically $ leaveRoom room playerId if roomEmpty then deleteRoom server roomId else syncRoom room) (\playerId -> do + sink . Aeson.encode $ Welcome roomId syncRoom room cards <- fmap (^. gameCards) . atomically . STM.readTVar $ roomGame room diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index b572fb7..a02058f 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -62,10 +62,9 @@ data GameView = GameView } deriving (Show) data ServerMessage - = Welcome !Int + = Welcome !Text | SyncCards !Cards | SyncGameView !GameView - | Bye deriving (Show) data ClientMessage |