packages feed

thock (empty) → 0.2.0.0

raw patch · 17 files changed

+1522/−0 lines, 17 filesdep +aesondep +basedep +bricksetup-changed

Dependencies added: aeson, base, brick, containers, file-embed, lens, mtl, network, random, text, text-zipper, thock, time, vector, vty, websockets

Files

+ ChangeLog.md view
@@ -0,0 +1,15 @@+# Changelog for thock++## 0.2.0.0++Fixes:++- [#4](https://github.com/rmehri01/thock/issues/4) Server now generates a random quote for each online game.++Improvements++- [#1](https://github.com/rmehri01/thock/issues/1) Binary size is now around 5 times smaller thanks to [@dpwiz](https://github.com/dpwiz) and [@soywod](https://github.com/soywod).++## 0.1.0.0++Initial release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 Ryan Mehri++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,23 @@+# thock++![An example of an online game](resources/demo.gif)++## Installation++### Binary++Right now there are only binaries for Ubuntu and macOS under [releases](https://github.com/rmehri01/thock/releases). Unfortunately there is no support for Windows but the Ubuntu binary will still work in [WSL](https://docs.microsoft.com/en-us/windows/wsl/about).++To use the binary you will have to put it on your PATH and may have to change permissions using `chmod` or allowing it in system preferences.++### From Source++```console+git clone https://github.com/rmehri01/thock.git+cd thock+stack install thock+```++## Credit++The terminal UI is made using the amazing [brick](https://github.com/jtdaugherty/brick/) library and the online functionality was done using [websockets](https://github.com/jaspervdj/websockets). I also took a great amount of inspiration from other great projects such as [hascard](https://github.com/Yvee1/hascard), [monkeytype](https://github.com/Miodec/monkeytype), and [gotta-go-fast](https://github.com/callum-oakley/gotta-go-fast).
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ app/server/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Server (runServer)+import System.Environment (getEnv)++main :: IO ()+main = do+  port <- read <$> getEnv "PORT"+  runServer port
+ app/thock/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified Brick.Main as M+import Thock (initialGame)+import UI.Offline (localApp)++main :: IO ()+main = do+  _ <- M.defaultMain localApp initialGame+  return ()
+ src/Client.hs view
@@ -0,0 +1,62 @@+-- | This module allows a client to connect to and interact with the websocket server.+module Client+  ( runClient,+  )+where++import Brick (customMain)+import Brick.BChan (newBChan, writeBChan)+import Control.Concurrent (forkFinally)+import Control.Monad (forever)+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Network.Socket (withSocketsDo)+import qualified Network.WebSockets as WS+import Online+  ( ConnectionTick (ConnectionTick),+    Online (WaitingRoom),+    RoomClientState (RoomClientState),+    WaitingRoomState (WaitingRoomState),+    receiveJsonData,+    sendJsonData,+  )+import Thock (RoomFormData (RoomFormData), Username (Username))+import UI.Online (onlineApp)++-- | Sets up the initial state of the 'Online' state using the formData+-- based on if the player is creating the room.+createClientApp :: Bool -> RoomFormData -> WS.ClientApp (Maybe T.Text)+createClientApp isCreating formData@(RoomFormData (Username user) room) conn = do+  _ <- sendJsonData conn (formData, isCreating)++  if isCreating+    then startRoom []+    else do+      res <- receiveJsonData conn+      case res of+        Right others -> startRoom others+        Left msg -> return (Just msg) -- Stop connection due to error message received from server+  where+    localSt = RoomClientState user False+    startRoom others = do+      connChan <- newBChan 10+      -- fork a thread that writes custom events when received from server+      _ <-+        forkFinally+          ( forever $ do+              serverMessage <- receiveJsonData conn+              writeBChan connChan (ConnectionTick serverMessage)+          )+          (const $ return ()) -- terminate when connection is closed and ignore any exceptions+      let buildVty = V.mkVty V.defaultConfig+      initialVty <- buildVty+      let w = WaitingRoom (WaitingRoomState room localSt conn others)+      _ <- customMain initialVty buildVty (Just connChan) onlineApp w+      WS.sendClose conn ("Bye!" :: T.Text)+      return Nothing -- Online connection finished successfully with no errors++-- | Connects to the websocket server and runs the client app+runClient :: Bool -> RoomFormData -> IO (Maybe T.Text)+runClient isCreating formData =+  withSocketsDo $+    WS.runClient "thock-server.herokuapp.com" 80 "/" (createClientApp isCreating formData)
+ src/Online.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module has shared types and functions for communication between the websocket client and server.+module Online where++import Control.Lens (makeFieldsNoPrefix)+import Data.Aeson (FromJSON, ToJSON, decode, encode)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import GHC.Generics (Generic)+import qualified Network.WebSockets as WS+import Quotes (Quote)+import Thock (GameState, HasRoomId (..), HasUsername (..), RoomId)++-- | The state of a client in a waiting room+data RoomClientState = RoomClientState+  { _username :: T.Text,+    _isReady :: Bool+  }+  deriving (Generic)++makeFieldsNoPrefix ''RoomClientState++instance FromJSON RoomClientState++instance ToJSON RoomClientState++-- | The state of a client in an online game+data GameClientState = GameClientState+  { _username :: T.Text,+    _progress :: Float,+    _wpm :: Double+  }+  deriving (Generic)++makeFieldsNoPrefix ''GameClientState++instance FromJSON GameClientState++instance ToJSON GameClientState++-- | A waiting room client with a state and connection to the server+data RoomClient = RoomClient+  { _state :: RoomClientState,+    _connection :: WS.Connection+  }++makeFieldsNoPrefix ''RoomClient++-- | An in-game client with a state and connection to the server+data GameClient = GameClient+  { _state :: GameClientState,+    _connection :: WS.Connection+  }++makeFieldsNoPrefix ''GameClient++-- | A message that a client sends to the server to update their state+data ClientMessage+  = RoomClientUpdate RoomClientState+  | GameClientUpdate GameClientState+  | BackToLobby T.Text+  deriving (Generic)++instance FromJSON ClientMessage++instance ToJSON ClientMessage++-- | A message from the server that updates a client on the state of other clients+data ServerMessage+  = RoomUpdate [RoomClientState]+  | GameUpdate [GameClientState]+  | StartGame Quote [GameClientState]+  deriving (Generic)++instance FromJSON ServerMessage++instance ToJSON ServerMessage++-- | Custom event that triggers when the client receives a 'ServerMessage'+newtype ConnectionTick = ConnectionTick ServerMessage++-- | The state of a player waiting to start an online game+data WaitingRoomState = WaitingRoomState+  { -- | Which room the player is in+    _roomId :: RoomId,+    -- | Information about the player+    _localState :: RoomClientState,+    -- | The player's connection to the server+    _connection :: WS.Connection,+    -- | The states of other players+    _otherPlayers :: [RoomClientState]+  }++makeFieldsNoPrefix ''WaitingRoomState++-- | The state of a player's online game+data OnlineGameState = OnlineGameState+  { -- | The state of the player's personal game+    _localGame :: GameState,+    -- | Room to return to after the game is done+    _roomId :: RoomId,+    -- | The player's username+    _username :: T.Text,+    -- | The player's connection to the server+    _connection :: WS.Connection,+    -- | The states of other players+    _otherPlayers :: [GameClientState]+  }++makeFieldsNoPrefix ''OnlineGameState++-- | The current status of the online connection+data Online+  = WaitingRoom WaitingRoomState+  | OnlineGame OnlineGameState++-- | Sends the given data over the connection as text using 'encode'+sendJsonData :: ToJSON a => WS.Connection -> a -> IO ()+sendJsonData conn a = WS.sendTextData conn (encode a)++-- | Receives JSON text data from the connection and tries to 'decode' it into the given type.+-- Produces an error if the JSON fails to decode (malformed or wrong type).+receiveJsonData :: FromJSON a => WS.Connection -> IO a+receiveJsonData conn = fromMaybe (error "could not decode JSON message into desired type") . decode <$> WS.receiveData conn
+ src/Quotes.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module provides a way to deal with quotes which are used as prompts.+module Quotes where++import Control.Lens (makeLenses)+import Data.Aeson+  ( FromJSON (parseJSON),+    Options (fieldLabelModifier),+    ToJSON (toJSON),+    decodeStrict,+    defaultOptions,+    genericParseJSON,+    genericToJSON,+  )+import Data.FileEmbed (embedFile)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import GHC.Generics (Generic)+import System.Random (Random (randomRIO))++data Quote = Quote+  { -- | The quote text itself+    _text :: T.Text,+    -- | Where the quote came from+    _source :: T.Text,+    -- | The number of characters in the quote+    _numChars :: Int+  }+  deriving (Generic)++makeLenses ''Quote++instance FromJSON Quote where+  parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = drop 1}++instance ToJSON Quote where+  toJSON = genericToJSON defaultOptions {fieldLabelModifier = drop 1}++-- | Produces a random 'Quote' using a JSON file+generateQuote :: IO Quote+generateQuote = randomElem qs+  where+    qs = fromMaybe (error "could not decode JSON into quote") mqs+    mqs = decodeStrict $(embedFile "resources/quotes.json")++-- | Produces a random element in the given list+randomElem :: [a] -> IO a+randomElem xs = (xs !!) <$> randomRIO (0, length xs - 1)
+ src/Server.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module deals with maintaining the state of the server when receiving updates.+module Server where++import Control.Concurrent+  ( MVar,+    modifyMVar,+    modifyMVar_,+    newMVar,+    readMVar,+  )+import Control.Exception (finally)+import Control.Lens (makeLenses, (%~), (&), (.~), (^.))+import Control.Monad (forM_, forever)+import Data.Aeson (ToJSON)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isNothing)+import qualified Data.Text as T+import GHC.Generics (Generic)+import qualified Network.WebSockets as WS+import Online+  ( ClientMessage+      ( BackToLobby,+        GameClientUpdate,+        RoomClientUpdate+      ),+    GameClient (GameClient),+    GameClientState (GameClientState),+    HasConnection (..),+    HasIsReady (isReady),+    HasState (..),+    RoomClient (RoomClient),+    RoomClientState (RoomClientState),+    ServerMessage (GameUpdate, RoomUpdate, StartGame),+    receiveJsonData,+    sendJsonData,+  )+import Quotes (generateQuote)+import Thock+  ( HasUsername (..),+    RoomFormData (RoomFormData),+    RoomId,+    Username (Username),+  )++data ServerState = ServerState+  { _rooms :: Map RoomId [RoomClient],+    _activeGames :: Map RoomId [GameClient]+  }+  deriving (Generic)++makeLenses ''ServerState++-- | Runs the websocket server with a random quote and initial state+runServer :: Int -> IO ()+runServer port = do+  st <- newMVar newServerState+  WS.runServer "0.0.0.0" port $ serverApp st++-- | Handles interacting with incoming client connections+serverApp :: MVar ServerState -> WS.ServerApp+serverApp mState pending = do+  conn <- WS.acceptRequest pending+  WS.withPingThread conn 30 (return ()) $ do+    (RoomFormData (Username user) room, isCreating) <- receiveJsonData conn++    let client = RoomClient (RoomClientState user False) conn+        disconnect = do+          s <- modifyMVar mState $ \s ->+            let s' = removeRoomClient room user s+             in return (s', s')+          roomBroadcastExceptSending room user s++    if isCreating+      then flip finally disconnect $ do+        modifyMVar_ mState $ \s ->+          return (createRoom room client s)+        talk conn mState room+      else do+        ss <- readMVar mState+        let response+              | not $ Map.member room (ss ^. rooms) = sendJsonData conn (Left "room does not exist" :: Either T.Text [RoomClientState])+              | clientExists room user ss = sendJsonData conn (Left "username already exists in that room" :: Either T.Text [RoomClientState])+              | otherwise = flip finally disconnect $ do+                modifyMVar_ mState $ \s -> do+                  let s' = addRoomClient room client s+                  let m = (s' ^. rooms) Map.! room+                  let rsExceptUser = deleteFirstEqualUsername user m+                  sendJsonData conn (Right (map (^. state) rsExceptUser) :: Either T.Text [RoomClientState])+                  roomBroadcastExceptSending room user s'+                  return s'+                talk conn mState room+        response++-- | Communicates with a single client by receiving and sending updates through conn+talk :: WS.Connection -> MVar ServerState -> RoomId -> IO ()+talk conn mState room = forever $ do+  cMessage <- receiveJsonData conn+  case cMessage of+    RoomClientUpdate r -> do+      ss <- modifyMVar mState $ \s ->+        let s' = updateRoomClient room r s in return (s', s')+      -- if can start and game not already in progress, send start game, else just update+      if canStart (map (^. state) $ (ss ^. rooms) Map.! room)+        && isNothing (Map.lookup room (ss ^. activeGames))+        then do+          newS <- modifyMVar mState $ \s -> do+            let s' = makeActive room s in return (s', s')+          q <- generateQuote+          broadcastTo id room (StartGame q) (newS ^. activeGames)+        else roomBroadcastExceptSending room (r ^. username) ss+    GameClientUpdate g -> do+      s <- modifyMVar mState $ \s ->+        let s' = updateGameClient room g s in return (s', s')+      gameBroadcastExceptSending room (g ^. username) s+    BackToLobby user -> do+      s <- modifyMVar mState $ \s ->+        let client = RoomClient (RoomClientState user False) conn+            leftGame = removeGameClient room user s+            s' = addRoomClient room client leftGame+         in return (s', s')+      let m = (s ^. rooms) Map.! room+      let rsExceptUser = deleteFirstEqualUsername user m+      sendJsonData conn (RoomUpdate $ map (^. state) rsExceptUser)+      gameBroadcastExceptSending room user s+      roomBroadcastExceptSending room user s++-- | Creates the initial 'ServerState' with empty rooms and games+newServerState :: ServerState+newServerState = ServerState {_rooms = Map.empty, _activeGames = Map.empty}++-- | Adds a 'RoomClient' into the given waiting room+addRoomClient :: RoomId -> RoomClient -> ServerState -> ServerState+addRoomClient room client ss = ss & rooms %~ Map.adjust (client :) room++-- | Produces true if the given user is in either the waiting room or an active game+clientExists :: RoomId -> T.Text -> ServerState -> Bool+clientExists room user ss = case Map.lookup room (ss ^. activeGames) of+  Nothing -> inRoom+  Just cs -> inRoom || any (equalOnStateUsername user) cs+  where+    inRoom = any (equalOnStateUsername user) ((ss ^. rooms) Map.! room)++-- | Removes a user from the given waiting room.+-- Deletes the room if it is empty and there is no active game for that room.+removeRoomClient :: RoomId -> T.Text -> ServerState -> ServerState+removeRoomClient room user ss =+  case Map.lookup room (ss ^. activeGames) of+    Nothing -> ss & rooms %~ removeClient room user+    _ -> ss & rooms %~ Map.adjust (deleteFirstEqualUsername user) room++-- | Removes a user from the active game and deletes it if empty+removeGameClient :: RoomId -> T.Text -> ServerState -> ServerState+removeGameClient room user ss = ss & activeGames %~ removeClient room user++-- | Remove a user from the room in m and delete the room if it is empty+removeClient :: (Ord k, HasState s a2, HasUsername a2 a1, Eq a1) => k -> a1 -> Map k [s] -> Map k [s]+removeClient room user m =+  if null (withoutUser Map.! room)+    then Map.delete room withoutUser+    else withoutUser+  where+    withoutUser = Map.adjust (deleteFirstEqualUsername user) room m++-- | Updates the state of a 'RoomClient' based on username in the given waiting room+updateRoomClient :: RoomId -> RoomClientState -> ServerState -> ServerState+updateRoomClient room client ss = ss & rooms %~ updateClient room client++-- | Updates the state of a 'GameClient' based on username in the given active game room+updateGameClient :: RoomId -> GameClientState -> ServerState -> ServerState+updateGameClient room client ss = ss & activeGames %~ updateClient room client++-- | Updates the state of a client based on username in the given room in a Map+updateClient :: (Ord k, HasState b a1, HasUsername a1 a2, Eq a2) => k -> a1 -> Map k [b] -> Map k [b]+updateClient room client = Map.adjust (map updateIfClient) room+  where+    updateIfClient other =+      if equalOnStateUsername (client ^. username) other+        then other & state .~ client+        else other++-- | Creates a new waiting room with the given client in it+createRoom :: RoomId -> RoomClient -> ServerState -> ServerState+createRoom room client ss = ss & rooms %~ Map.insert room [client]++-- | Moves all the players in a waiting room to an active game, leaving the waiting room empty.+makeActive :: RoomId -> ServerState -> ServerState+makeActive room ss =+  ss & rooms %~ Map.insert room []+    & activeGames %~ Map.insert room clients+  where+    clients = map (\(RoomClient (RoomClientState user _) conn) -> GameClient (GameClientState user 0 0) conn) states+    states = (ss ^. rooms) Map.! room++-- | Sends an update of the 'ServerState' to everyone in a waiting room+-- except the one who triggered the update+roomBroadcastExceptSending :: RoomId -> T.Text -> ServerState -> IO ()+roomBroadcastExceptSending room sending ss =+  broadcastTo (deleteFirstEqualUsername sending) room RoomUpdate (ss ^. rooms)++-- | Sends an update of the 'ServerState' to everyone in an active game+-- except the one who triggered the update+gameBroadcastExceptSending :: RoomId -> T.Text -> ServerState -> IO ()+gameBroadcastExceptSending room sending ss =+  broadcastTo (deleteFirstEqualUsername sending) room GameUpdate (ss ^. activeGames)++-- | Sends an update of the 'ServerState' to everyone in a room+broadcastTo ::+  ( Eq a1,+    HasConnection b WS.Connection,+    ToJSON d,+    HasState a c,+    HasState b a4,+    HasUsername c a1,+    HasUsername a4 a1,+    Ord k+  ) =>+  -- | Function to filter who to send the updates to+  ([a] -> [b]) ->+  -- | Room to send to+  k ->+  -- | Constructor for creating the desired type to send+  ([c] -> d) ->+  -- | All of the rooms+  Map k [a] ->+  IO ()+broadcastTo f room ctr m =+  forM_+    csFiltered+    $ \a ->+      sendJsonData+        (a ^. connection)+        (ctr . map (^. state) $ deleteFirstEqualUsername (a ^. (state . username)) cs)+  where+    csFiltered = f cs+    cs = fromMaybe [] (Map.lookup room m)++-- | Removes the first in the given list where the inner state's username is equal to user+deleteFirstEqualUsername :: (Eq a1, HasState s a2, HasUsername a2 a1) => a1 -> [s] -> [s]+deleteFirstEqualUsername user = deleteFirstWhere (equalOnStateUsername user)++-- | Removes the first value from the list where the predicate p is satisfied+deleteFirstWhere :: (a -> Bool) -> [a] -> [a]+deleteFirstWhere _ [] = []+deleteFirstWhere p (a : as) = if p a then as else a : deleteFirstWhere p as++-- | Produces true if the inner state's username is equal to the given user+equalOnStateUsername :: (Eq a1, HasState s a2, HasUsername a2 a1) => a1 -> s -> Bool+equalOnStateUsername user c = (c ^. (state . username)) == user++-- | Produces true if there is more than one person in the room and they are all ready+canStart :: [RoomClientState] -> Bool+canStart rs = length rs > 1 && all (^. isReady) rs
+ src/Thock.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | This module provides the core data and functionality for handling the game.+module Thock where++import Brick.Forms (Form)+import qualified Brick.Widgets.Edit as E+import qualified Brick.Widgets.List as L+import Control.Applicative (Applicative (liftA2))+import Control.Lens+  ( makeFieldsNoPrefix,+    makeLenses,+    (%~),+    (&),+    (?~),+    (^.),+  )+import Data.Aeson (FromJSON, ToJSON)+import Data.Char (isAlphaNum, isAscii)+import Data.Function (on)+import qualified Data.Text as T+import Data.Text.Zipper+  ( TextZipper,+    clearZipper,+    currentLine,+    cursorPosition,+    getText,+    moveLeft,+    moveRight,+    textZipper,+  )+import Data.Time (UTCTime, diffUTCTime)+import qualified Data.Vector as Vec+import GHC.Generics (Generic)+import Quotes (Quote, numChars, text)+import System.Random (Random (randoms), getStdGen)++-- | Unique identifiers to describe cursor locations+data ResourceName+  = UsernameField+  | RoomIdField+  | Ordinary+  deriving (Eq, Ord, Show)++-- | The state that tracks a player's progress+data GameState = GameState+  { -- | Current word the player is on, as well as previous and future words+    _prompt :: TextZipper T.Text,+    -- | Player input for the current word+    _input :: E.Editor T.Text ResourceName,+    -- | The quote being typed+    _quote :: Quote,+    -- | The time the game started if it has started+    _start :: Maybe UTCTime,+    -- | The last time the game was updated if it has started+    _lastUpdated :: Maybe UTCTime,+    -- | The number of keyboard strokes made+    _strokes :: Int+  }++makeLenses ''GameState++type MenuList = L.List ResourceName T.Text++newtype Username = Username {_value :: T.Text}+  deriving (Generic)++makeLenses ''Username++instance FromJSON Username++instance ToJSON Username++type RoomId = T.Text++-- | The data needed to join an online room+data RoomFormData = RoomFormData+  { _username :: Username,+    _roomId :: RoomId+  }+  deriving (Generic)++makeFieldsNoPrefix ''RoomFormData++instance FromJSON RoomFormData++instance ToJSON RoomFormData++type RoomForm a = Form a () ResourceName++-- | The current status of the game+data Game+  = MainMenu MenuList+  | OnlineSelect MenuList+  | CreateRoomMenu (RoomForm Username)+  | JoinRoomMenu (RoomForm RoomFormData)+  | Practice GameState+  | ErrorOverlay Game T.Text++makeLenses ''Game++-- | Produces the decimal amount the player has completed correctly+calculateProgress :: GameState -> Float+calculateProgress g = ((/) `on` fromIntegral) correct total+  where+    correct = numCorrectChars g+    total = g ^. (quote . numChars)++-- | Produces the total number of correct characters the player has typed+numCorrectChars :: GameState -> Int+numCorrectChars g = correctBefore + col+  where+    correctBefore = T.length . foldMap (`T.snoc` ' ') . take row $ getText tz+    (row, col) = cursorPosition tz+    tz = g ^. prompt++-- | Updates the prompt to be in sync with the user's input+movePromptCursor :: GameState -> GameState+movePromptCursor g =+  if currentWordFinished+    then g & prompt %~ moveRight & input %~ E.applyEdit clearZipper -- move onto the next word and clear the input box+    else g & prompt %~ movePromptByN moveAmount+  where+    currentWordFinished = currentInput == T.snoc currentWord ' '+    moveAmount = numCorrectCurrentWord g - col+    (_, col) = cursorPosition (g ^. prompt)+    currentInput = head $ E.getEditContents (g ^. input)+    currentWord = currentLine (g ^. prompt)++-- | Moves the prompt by n spaces right if positive and left if negative+movePromptByN :: Int -> TextZipper T.Text -> TextZipper T.Text+movePromptByN n tz+  | n < 0 = movePromptByN (n + 1) (moveLeft tz)+  | n > 0 = movePromptByN (n - 1) (moveRight tz)+  | otherwise = tz++-- | Produces the number of correct characters the player has typed in the current word+numCorrectCurrentWord :: GameState -> Int+numCorrectCurrentWord g = length . takeWhile (uncurry (==)) $ T.zip currentWord currentInput+  where+    currentWord = currentLine (g ^. prompt)+    currentInput = head $ E.getEditContents (g ^. input)++-- | Produces the number of incorrect characters the player has typed+numIncorrectChars :: GameState -> Int+numIncorrectChars g = T.length currentInput - numCorrectCurrentWord g+  where+    currentInput = head $ E.getEditContents (g ^. input)++-- | Starts the timer if it hasn't started already and sets lastUpdated to t+updateTime :: UTCTime -> GameState -> GameState+updateTime t g = g' & lastUpdated ?~ t+  where+    g' = case g ^. start of+      Nothing -> g & start ?~ t+      _ -> g++-- | Calculates typing speed in words per minute where a word is 5 characters+calculateWpm :: GameState -> Double+calculateWpm g = if s == 0 then 0 else cps * (60 / 5)+  where+    cps = fromIntegral (numCorrectChars g) / s+    s = secondsElapsed g++-- | Calculates decimal amount of correct typed / total typed characters+accuracy :: GameState -> Double+accuracy g = ((/) `on` fromIntegral) (g ^. (quote . numChars)) (g ^. strokes)++-- | The number of seconds from start to lastUpdated+secondsElapsed :: GameState -> Double+secondsElapsed g = maybe 0 realToFrac (liftA2 diffUTCTime (g ^. lastUpdated) (g ^. start))++-- | Produces true if the game is done, false otherwise+isDone :: GameState -> Bool+isDone g = numCorrectChars g == g ^. (quote . numChars)++-- | Creates an initial game with the given quote+initializeGameState :: Quote -> GameState+initializeGameState q =+  GameState+    { _prompt = textZipper (T.words (q ^. text)) Nothing,+      _input = E.editor Ordinary (Just 1) "",+      _quote = q,+      _start = Nothing,+      _lastUpdated = Nothing,+      _strokes = 0+    }++-- | Creates an initial 'Game' starting at the main menu+initialGame :: Game+initialGame = MainMenu (L.list Ordinary (Vec.fromList ["Practice", "Online"]) 2)++-- | Creates a 'Game' for the online select menu with options to create or join a room+onlineSelectState :: Game+onlineSelectState = OnlineSelect (L.list Ordinary (Vec.fromList ["Create room", "Join room"]) 2)++-- | Initializes a 'Practice' game with the given quote+startPracticeGame :: Quote -> Game+startPracticeGame q = Practice (initializeGameState q)++-- | Randomly generates an alphanumeric 'RoomId'+generateRoomId :: IO RoomId+generateRoomId = T.pack . take 10 . filter (\c -> isAscii c && isAlphaNum c) . randoms <$> getStdGen
+ src/UI/Attributes.hs view
@@ -0,0 +1,50 @@+-- | This module provides attributes and styling for use within the UI.+module UI.Attributes where++import qualified Brick.AttrMap as A+import Brick.Util (bg, fg, on)+import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.ProgressBar as P+import qualified Graphics.Vty as V++-- | The main attribute used for styling the UI+primaryAttr :: A.AttrName+primaryAttr = A.attrName "primary"++-- | The main color used for styling the UI+primaryColor :: V.Color+primaryColor = V.rgbColor 64 122 (82 :: Int)++-- | The secondary attribute used for styling the UI+secondaryAttr :: A.AttrName+secondaryAttr = A.attrName "secondary"++-- | The secondary color used for styling the UI+secondaryColor :: V.Color+secondaryColor = V.rgbColor 0 100 (66 :: Int)++-- | The attribute for styling correctly typed text+correctAttr :: A.AttrName+correctAttr = A.attrName "correct"++-- | The attribute for styling incorrectly typed text+incorrectAttr :: A.AttrName+incorrectAttr = A.attrName "incorrect"++-- | Attribute for styling red text+redAttr :: A.AttrName+redAttr = A.attrName "red"++-- | Map from an attribute to its corresponding styling for all attributes+attributeMap :: A.AttrMap+attributeMap =+  A.attrMap+    V.defAttr+    [ (primaryAttr, fg primaryColor),+      (secondaryAttr, fg secondaryColor),+      (L.listSelectedAttr, fg secondaryColor `V.withStyle` V.bold),+      (P.progressCompleteAttr, V.white `on` primaryColor),+      (correctAttr, fg V.green),+      (incorrectAttr, bg V.red),+      (redAttr, fg (V.rgbColor 195 39 (43 :: Int)))+    ]
+ src/UI/Common.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TemplateHaskell #-}++-- | This module has common functionality that is used in both the offline and online UIs.+module UI.Common where++import Brick+  ( EventM,+    Size (Fixed),+    Widget (Widget, render),+    availWidthL,+    emptyWidget,+    fill,+    getContext,+    hBox,+    hLimit,+    hLimitPercent,+    handleEventLensed,+    str,+    txt,+    txtWrap,+    vBox,+    vLimit,+    withAttr,+    withBorderStyle,+    (<+>),+    (<=>),+  )+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Border.Style as BS+import qualified Brick.Widgets.Center as C+import qualified Brick.Widgets.Edit as E+import qualified Brick.Widgets.ProgressBar as P+import Control.Lens ((^.))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.FileEmbed (embedFile)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Time (getCurrentTime)+import Graphics.Vty (Event)+import Quotes (source, text)+import Text.Printf (PrintfArg, printf)+import Thock+  ( GameState,+    ResourceName,+    accuracy,+    calculateProgress,+    calculateWpm,+    input,+    isDone,+    movePromptCursor,+    numCorrectChars,+    numIncorrectChars,+    quote,+    secondsElapsed,+    updateTime,+  )+import UI.Attributes+  ( correctAttr,+    incorrectAttr,+    primaryAttr,+    secondaryAttr,+  )++-- | Produces a styled title widget based on the logo file+titleWidget :: Widget n+titleWidget = withAttr primaryAttr logo+  where+    logo = vBox . map txt . T.lines $ decodeUtf8 $(embedFile "resources/logo.txt")++-- | Draws an element of a list based on if it is selected+listDrawElement :: Bool -> T.Text -> Widget n+listDrawElement sel t = C.hCenter $ txt symbol <+> txt t+  where+    symbol =+      if sel+        then "* "+        else "  "++-- | Draws a widget with the player's stats and further+-- instructions if the game is done, otherwise is empty+drawFinished :: GameState -> T.Text -> Widget ResourceName+drawFinished g help = if isDone g then doneWidget else emptyWidget+  where+    doneWidget = C.centerLayer . hLimitPercent 90 $ addBorder "stats" (stats <=> B.hBorder <=> instructions)+    stats = speedStat <=> accuracyStat <=> timeStat <=> sourceStat+    speedStat = makeStatWidget "Speed: " (drawWpm (calculateWpm g))+    accuracyStat = makeStatWidget "Accuracy: " (drawFloatWithSuffix 1 "%" (accuracy g * 100))+    timeStat = makeStatWidget "Time elapsed: " (drawFloatWithSuffix 1 " seconds" (secondsElapsed g))+    sourceStat = makeStatWidget "Quote source: " (txtWrap $ g ^. (quote . source))+    instructions = C.hCenter (txt help)+    makeStatWidget t w = vLimit 1 (hLimit 15 (withAttr secondaryAttr (txt t) <+> fill ' ') <+> w)++-- | Draws a progress bar for a local game+drawProgressBarGameState :: GameState -> Widget ResourceName+drawProgressBarGameState g = drawProgressBar (calculateProgress g) (calculateWpm g) "your progress"++-- | Creates a progress bar widget using the given decimal amount done and WPM+drawProgressBar :: Float -> Double -> T.Text -> Widget ResourceName+drawProgressBar decimalDone wpm label = progressWidget <+> wpmWidget+  where+    progressWidget = addBorder label (P.progressBar (Just percentStr) decimalDone)+    percentStr = roundToStr 1 (decimalDone * 100) ++ "%"+    wpmWidget = addBorder "" (drawWpm wpm)++-- | Creates the WPM widget by rounding the given number to 0 decimal points+drawWpm :: Double -> Widget ResourceName+drawWpm = drawFloatWithSuffix 0 " WPM"++-- | Rounds the given floating point number to n decimal points and attaches s as a suffix+drawFloatWithSuffix :: (PrintfArg a, Floating a) => Int -> String -> a -> Widget ResourceName+drawFloatWithSuffix n s = str . (++ s) . roundToStr n++-- | Rounds the given floating point number to an integer number of decimal points+roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String+roundToStr = printf "%0.*f"++-- | Creates the prompt display for the 'GameState' with+-- highlighting based on correctly or incorrectly typed characters+drawPrompt :: GameState -> Widget ResourceName+drawPrompt g = addBorder "prompt" (C.center $ hLimitPercent 80 textWidget)+  where+    textWidget = Widget Fixed Fixed $ do+      ctx <- getContext+      render $+        drawTextBlock+          (correctWidgets ++ incorrectWidgets ++ restWidgets)+          (lineLengths g (ctx ^. availWidthL))+    correctWidgets = withAttr correctAttr . txt . T.singleton <$> T.unpack correctText+    incorrectWidgets = withAttr incorrectAttr . txt . T.singleton <$> T.unpack incorrectText+    restWidgets = txt . T.singleton <$> T.unpack restText'+    (incorrectText, restText') = T.splitAt (numIncorrectChars g) restText+    (correctText, restText) = T.splitAt (numCorrectChars g) allText+    allText = g ^. (quote . text)++-- | Produces a list of line lengths for the prompt that fit within the given lim+lineLengths :: GameState -> Int -> [Int]+lineLengths g lim =+  let go [] acc = [acc | acc /= 0]+      go allT@(t : ts) acc+        | nextAcc < lim = go ts nextAcc+        | otherwise = acc : go allT 0+        where+          nextAcc = T.length t + acc + lenSpace+          lenSpace = if null ts then 0 else 1+   in go (T.words $ g ^. (quote . text)) 0++-- | Uses a list of line lengths to combine single character widgets into+-- a single widget that is a block of text+drawTextBlock :: [Widget ResourceName] -> [Int] -> Widget ResourceName+drawTextBlock ws ls+  | null ws || null ls = emptyWidget+  | otherwise = hBox row <=> drawTextBlock rest (tail ls)+  where+    (row, rest) = splitAt (head ls) ws++-- | Draws the user input space+drawInput :: GameState -> Widget ResourceName+drawInput g = addBorder "input" (E.renderEditor (txt . T.unlines) True (g ^. input))++-- | Adds a rounded border to a widget with the given label+addBorder :: T.Text -> Widget ResourceName -> Widget ResourceName+addBorder t = withBorderStyle BS.unicodeRounded . B.borderWithLabel (txt t)++-- | Produces the next game state by applying an event and+-- updating the 'GameState' accordingly+updateGameState :: GameState -> Event -> EventM ResourceName GameState+updateGameState g ev = do+  gEdited <- handleEventLensed g input E.handleEditorEvent ev+  currentTime <- liftIO getCurrentTime+  return . updateTime currentTime $ movePromptCursor gEdited
+ src/UI/Offline.hs view
@@ -0,0 +1,222 @@+-- | This module has deals with UI specific to the offline game and for transitioning to online.+module UI.Offline where++import Brick+  ( BrickEvent (VtyEvent),+    EventM,+    Next,+    Padding (Max),+    Widget,+    fill,+    hLimit,+    hLimitPercent,+    padBottom,+    showFirstCursor,+    txt,+    txtWrap,+    vLimit,+    withAttr,+    (<+>),+    (<=>),+  )+import Brick.Forms+  ( Form (formState),+    editTextField,+    handleFormEvent,+    newForm,+    renderForm,+    (@@=),+  )+import qualified Brick.Main as M+import qualified Brick.Widgets.Center as C+import qualified Brick.Widgets.List as L+import Client (runClient)+import Control.Lens ((&), (+~), (^.))+import Control.Monad.IO.Class (MonadIO (liftIO))+import qualified Data.Text as T+import qualified Graphics.Vty as V+import Quotes (generateQuote)+import Thock+  ( Game (..),+    GameState,+    HasRoomId (roomId),+    HasUsername (username),+    MenuList,+    ResourceName (RoomIdField, UsernameField),+    RoomForm,+    RoomFormData (RoomFormData),+    Username (Username),+    generateRoomId,+    initialGame,+    isDone,+    onlineSelectState,+    quote,+    startPracticeGame,+    strokes,+    value,+  )+import UI.Attributes (attributeMap, redAttr, secondaryAttr)+import UI.Common+  ( addBorder,+    drawFinished,+    drawInput,+    drawProgressBarGameState,+    drawPrompt,+    listDrawElement,+    titleWidget,+    updateGameState,+  )++-- | Brick app for handling an offline 'Game'+localApp :: M.App Game () ResourceName+localApp =+  M.App+    { M.appDraw = drawGame,+      M.appChooseCursor = showFirstCursor,+      M.appHandleEvent = handleKeyGame,+      M.appStartEvent = return,+      M.appAttrMap = const attributeMap+    }++-- | Draws the given 'Game' based on its current state+drawGame :: Game -> [Widget ResourceName]+drawGame g = case g of+  MainMenu l -> drawList l+  OnlineSelect l -> drawList l+  CreateRoomMenu form -> drawForm form+  JoinRoomMenu form -> drawForm form+  Practice gs -> drawPractice gs+  ErrorOverlay prev t -> drawError prev t++-- | Renders a list widget under the logo+drawList :: MenuList -> [Widget ResourceName]+drawList l = [drawMenu listWidget]+  where+    listWidget = L.renderList listDrawElement True l++-- | Renders a form widget under the logo+drawForm :: RoomForm a -> [Widget ResourceName]+drawForm form = [drawMenu formWidget]+  where+    formWidget = vLimit 6 $ hLimitPercent 80 (renderForm form)++-- | Draws the title over another widget w+drawMenu :: Widget ResourceName -> Widget ResourceName+drawMenu w = addBorder "" (C.center titleWidget <=> padBottom Max (C.hCenter w))++-- | Draw a practice game based on its 'GameState'+drawPractice :: GameState -> [Widget ResourceName]+drawPractice g =+  [ drawFinished g "Back: Esc | Retry: ^r | Next: ^n",+    drawProgressBarGameState g <=> drawPrompt g <=> drawInput g+  ]++-- | Draws an error popup over the 'Game'+drawError :: Game -> T.Text -> [Widget ResourceName]+drawError g t = errorPopup : drawGame g+  where+    errorPopup = C.centerLayer . hLimitPercent 80 . addBorder "error" $ withAttr redAttr (txtWrap t)++-- | Handles events based on the current state of the 'Game'+handleKeyGame :: Game -> BrickEvent ResourceName () -> EventM ResourceName (Next Game)+handleKeyGame gs ev = case gs of+  MainMenu l -> handleKeyMainMenu l ev+  OnlineSelect l -> handleKeyOnlineSelect l ev+  CreateRoomMenu form -> handleKeyForm CreateRoomMenu (\u -> generateRoomId >>= runClient True . RoomFormData u) (^. value) form ev+  JoinRoomMenu form -> handleKeyForm JoinRoomMenu (runClient False) (^. (username . value)) form ev+  Practice g -> handleKeyPractice g ev+  ErrorOverlay prev _ -> M.continue prev -- after receiving any event, remove the error overlay++-- | Handles key events for navigating the 'MainMenu'+handleKeyMainMenu :: MenuList -> BrickEvent ResourceName e -> EventM ResourceName (Next Game)+handleKeyMainMenu l (VtyEvent e) = case e of+  V.EvKey V.KEsc [] -> M.halt (MainMenu l)+  V.EvKey V.KEnter []+    | Just i <- L.listSelected l ->+      if i == 0+        then liftIO generateQuote >>= M.continue . startPracticeGame+        else M.continue onlineSelectState+  ev -> L.handleListEvent ev l >>= M.continue . MainMenu+handleKeyMainMenu l _ = M.continue (MainMenu l)++-- | Handles key events for creating or joining an online room+handleKeyOnlineSelect :: MenuList -> BrickEvent ResourceName e -> EventM ResourceName (Next Game)+handleKeyOnlineSelect l (VtyEvent e) = case e of+  V.EvKey V.KEsc [] -> M.continue initialGame+  V.EvKey V.KEnter []+    | Just i <- L.listSelected l ->+      M.continue+        ( if i == 0+            then CreateRoomMenu (makeCreateRoomForm emptyUsername)+            else JoinRoomMenu (makeJoinRoomForm emptyRoomFormData)+        )+    where+      emptyUsername = Username ""+      emptyRoomFormData = RoomFormData emptyUsername ""+  ev -> L.handleListEvent ev l >>= M.continue . OnlineSelect+handleKeyOnlineSelect l _ = M.continue (OnlineSelect l)++-- | Handles a key event for a form and its validation+handleKeyForm ::+  -- | Function to construct a Game from the given form+  (RoomForm a -> Game) ->+  -- | Action to run when the form is submitted, returns a possible error+  (a -> IO (Maybe T.Text)) ->+  -- | Function to get the username from the given form+  (a -> T.Text) ->+  RoomForm a ->+  BrickEvent ResourceName () ->+  EventM ResourceName (Next Game)+handleKeyForm ctr onEnter getUser form ev@(VtyEvent e) = case e of+  V.EvKey V.KEsc [] -> M.continue initialGame+  V.EvKey V.KEnter [] ->+    if not . T.null $ getUser (formState form)+      then+        M.suspendAndResume+          (maybe initialGame (ErrorOverlay (ctr form)) <$> onEnter (formState form))+      else M.continue (ErrorOverlay (ctr form) "username cannot be empty")+  _ -> handleFormEvent ev form >>= M.continue . ctr+handleKeyForm ctr _ _ form _ = M.continue (ctr form)++-- | Construct a 'RoomForm' with the given 'Username' as the initial state+makeCreateRoomForm :: Username -> RoomForm Username+makeCreateRoomForm =+  newForm+    [ formLabel "Username"+        @@= addBorder ""+        @@= editTextField value UsernameField (Just 1)+    ]++-- | Construct a 'RoomForm' with the given 'RoomFormData' as the initial state+makeJoinRoomForm :: RoomFormData -> RoomForm RoomFormData+makeJoinRoomForm =+  newForm+    [ formLabel "Username"+        @@= addBorder ""+        @@= editTextField (username . value) UsernameField (Just 1),+      formLabel "Room ID"+        @@= addBorder ""+        @@= editTextField roomId RoomIdField (Just 1)+    ]++-- | Label a widget using the given text in the style of a form+formLabel :: T.Text -> Widget n -> Widget n+formLabel t w = C.vCenter label <+> C.vCenter w+  where+    label = vLimit 1 (hLimit 15 $ withAttr secondaryAttr $ txt t <+> fill ' ')++-- | Handles key events for updating the 'GameState' in a 'Practice' game+handleKeyPractice :: GameState -> BrickEvent ResourceName e -> EventM ResourceName (Next Game)+handleKeyPractice g (VtyEvent ev) =+  case ev of+    V.EvKey V.KEsc [] -> M.continue initialGame+    V.EvKey (V.KChar 'r') [V.MCtrl] -> M.continue (startPracticeGame (g ^. quote))+    V.EvKey (V.KChar 'n') [V.MCtrl] -> liftIO generateQuote >>= M.continue . startPracticeGame+    V.EvKey (V.KChar _) [] -> nextState (g & strokes +~ 1)+    _ -> nextState g+  where+    nextState g' =+      if isDone g'+        then M.continue (Practice g')+        else updateGameState g' ev >>= M.continue . Practice+handleKeyPractice g _ = M.continue (Practice g)
+ src/UI/Online.hs view
@@ -0,0 +1,159 @@+-- | This module provides the UI for a game once an online connection is established.+module UI.Online where++import Brick+  ( BrickEvent (AppEvent, VtyEvent),+    EventM,+    Next,+    Widget,+    showFirstCursor,+    txt,+    txtWrap,+    vBox,+    withAttr,+    (<+>),+    (<=>),+  )+import qualified Brick.Main as M+import qualified Brick.Widgets.Center as C+import Control.Lens ((%~), (&), (+~), (.~), (^.))+import Control.Monad.IO.Class (MonadIO (liftIO))+import qualified Graphics.Vty as V+import Online+  ( ClientMessage (BackToLobby, GameClientUpdate, RoomClientUpdate),+    ConnectionTick (..),+    GameClientState (GameClientState),+    HasConnection (connection),+    HasIsReady (isReady),+    HasLocalGame (localGame),+    HasOtherPlayers (otherPlayers),+    HasProgress (progress),+    HasWpm (wpm),+    Online (..),+    OnlineGameState (OnlineGameState),+    RoomClientState (RoomClientState),+    ServerMessage (GameUpdate, RoomUpdate, StartGame),+    WaitingRoomState (WaitingRoomState),+    sendJsonData,+  )+import Thock+  ( HasRoomId (roomId),+    HasUsername (username),+    ResourceName,+    calculateProgress,+    calculateWpm,+    initializeGameState,+    isDone,+    strokes,+  )+import UI.Attributes (attributeMap, redAttr, secondaryAttr)+import UI.Common+  ( addBorder,+    drawFinished,+    drawInput,+    drawProgressBar,+    drawProgressBarGameState,+    drawPrompt,+    updateGameState,+  )++-- | Brick app for handling an 'Online' game+onlineApp :: M.App Online ConnectionTick ResourceName+onlineApp =+  M.App+    { M.appDraw = drawOnline,+      M.appChooseCursor = showFirstCursor,+      M.appHandleEvent = handleKeyOnline,+      M.appStartEvent = return,+      M.appAttrMap = const attributeMap+    }++-- | Draws given 'Online' based on current state+drawOnline :: Online -> [Widget ResourceName]+drawOnline s = case s of+  WaitingRoom w -> drawWaitingRoom w+  OnlineGame o -> drawOnlineState o++-- | Creates a waiting room widget which displays the 'RoomId',+-- all connected players and their status, as well as a help section+drawWaitingRoom :: WaitingRoomState -> [Widget ResourceName]+drawWaitingRoom (WaitingRoomState room localSt _ ps) =+  [roomIdWidget <=> (playersDisplay <+> statusDisplay) <=> helpWidget]+  where+    roomIdWidget = addBorder "room id" $ C.hCenter (txt room)+    playersDisplay =+      addBorder "players" . C.center . vBox $+        map (txt . (^. username)) allStates+    statusDisplay =+      addBorder "status" . C.center . vBox $+        map (makeReadyTxt . (^. isReady)) allStates+    helpWidget = addBorder "help" $ C.hCenter (txtWrap "Press 'r' to ready up! Once everyone is ready, the match will begin.")+    makeReadyTxt ready =+      if ready+        then withAttr secondaryAttr (txt "ready")+        else withAttr redAttr (txt "not ready")+    allStates = localSt : ps++-- | Creates a display with the local game state and the progress of other players+drawOnlineState :: OnlineGameState -> [Widget ResourceName]+drawOnlineState o =+  [ drawFinished g "Back to lobby: Esc",+    drawProgressBarGameState g <=> otherProgressBars <=> drawPrompt g <=> drawInput g+  ]+  where+    otherProgressBars =+      vBox $+        map+          (\gs -> drawProgressBar (gs ^. progress) (gs ^. wpm) (gs ^. username))+          (o ^. otherPlayers)+    g = o ^. localGame++-- | Handles an event based on current 'Online' state+handleKeyOnline :: Online -> BrickEvent ResourceName ConnectionTick -> EventM ResourceName (Next Online)+handleKeyOnline s ev = case s of+  WaitingRoom w -> handleKeyWaitingRoom w ev+  OnlineGame o -> handleKeyOnlineState o ev++-- | Handles both local and 'ConnectionTick' events when the player is in a 'WaitingRoom'+handleKeyWaitingRoom :: WaitingRoomState -> BrickEvent ResourceName ConnectionTick -> EventM ResourceName (Next Online)+handleKeyWaitingRoom (WaitingRoomState room localSt conn _) (AppEvent (ConnectionTick csReceived)) =+  case csReceived of+    RoomUpdate rs -> M.continue (WaitingRoom $ WaitingRoomState room localSt conn rs)+    StartGame q gs -> M.continue (OnlineGame (OnlineGameState (initializeGameState q) room (localSt ^. username) conn gs))+    _ -> undefined+handleKeyWaitingRoom (WaitingRoomState room localSt conn ps) (VtyEvent ev) =+  case ev of+    V.EvKey V.KEsc [] -> M.halt (WaitingRoom $ WaitingRoomState room localSt conn ps)+    V.EvKey (V.KChar 'r') [] -> do+      let newSt = localSt & isReady %~ not+      liftIO (sendJsonData conn (RoomClientUpdate newSt))+      M.continue (WaitingRoom $ WaitingRoomState room newSt conn ps)+    _ -> M.continue (WaitingRoom $ WaitingRoomState room localSt conn ps)+handleKeyWaitingRoom (WaitingRoomState room localSt conn ps) _ = M.continue (WaitingRoom $ WaitingRoomState room localSt conn ps)++-- | Handles both local and 'ConnectionTick' events when the player is in an 'OnlineGame'+handleKeyOnlineState :: OnlineGameState -> BrickEvent ResourceName ConnectionTick -> EventM ResourceName (Next Online)+handleKeyOnlineState o (AppEvent (ConnectionTick csReceived)) =+  case csReceived of+    RoomUpdate rs -> M.continue (WaitingRoom $ WaitingRoomState (o ^. roomId) (RoomClientState (o ^. username) False) (o ^. connection) rs)+    GameUpdate gs -> M.continue (OnlineGame $ o & otherPlayers .~ gs)+    _ -> undefined+handleKeyOnlineState o (VtyEvent ev) =+  case ev of+    V.EvKey V.KEsc [] -> liftIO (sendJsonData (o ^. connection) (BackToLobby $ o ^. username)) >> M.continue (OnlineGame o)+    V.EvKey (V.KChar _) [] -> nextState (o & (localGame . strokes) +~ 1)+    _ -> nextState o+  where+    nextState o' =+      if isDone (o' ^. localGame)+        then M.continue (OnlineGame o')+        else do+          updatedGame <- updateGameState (o' ^. localGame) ev+          let newClientState = GameClientState (o ^. username) (calculateProgress updatedGame) (calculateWpm updatedGame)+          _ <-+            liftIO $+              sendJsonData+                (o ^. connection)+                (GameClientUpdate newClientState)+          M.continue (OnlineGame $ o' & localGame .~ updatedGame)+handleKeyOnlineState o _ = M.continue (OnlineGame o)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ thock.cabal view
@@ -0,0 +1,134 @@+cabal-version:      1.12+name:               thock+version:            0.2.0.0+license:            MIT+license-file:       LICENSE+copyright:          Copyright (c) 2020 Ryan Mehri+maintainer:         ryan.mehri1@gmail.com+author:             Ryan Mehri+homepage:           https://github.com/rmehri01/thock#readme+bug-reports:        https://github.com/rmehri01/thock/issues+synopsis:+    A modern TUI typing game featuring online racing against friends.++description:+    Please see the README on GitHub at <https://github.com/rmehri01/thock#readme>++category:           Game+build-type:         Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type:     git+    location: https://github.com/rmehri01/thock++library+    exposed-modules:+        Client+        Online+        Quotes+        Server+        Thock+        UI.Attributes+        UI.Common+        UI.Offline+        UI.Online++    hs-source-dirs:     src+    other-modules:      Paths_thock+    default-language:   Haskell2010+    default-extensions: OverloadedStrings+    build-depends:+        aeson >=1.4.7.1 && <1.5,+        base >=4.7 && <5,+        brick >=0.52.1 && <0.53,+        containers >=0.6.2.1 && <0.7,+        file-embed >=0.0.11.2 && <0.1,+        lens >=4.18.1 && <4.19,+        mtl >=2.2.2 && <2.3,+        network >=3.1.1.1 && <3.2,+        random ==1.1.*,+        text >=1.2.4.0 && <1.3,+        text-zipper >=0.10.1 && <0.11,+        time >=1.9.3 && <1.10,+        vector >=0.12.1.2 && <0.13,+        vty >=5.28.2 && <5.29,+        websockets >=0.12.7.1 && <0.13++executable server+    main-is:            server/Main.hs+    hs-source-dirs:     app+    other-modules:      Paths_thock+    default-language:   Haskell2010+    default-extensions: OverloadedStrings+    ghc-options:        -threaded -rtsopts -with-rtsopts=-N -Wall+    build-depends:+        aeson >=1.4.7.1 && <1.5,+        base >=4.7 && <5,+        brick >=0.52.1 && <0.53,+        containers >=0.6.2.1 && <0.7,+        file-embed >=0.0.11.2 && <0.1,+        lens >=4.18.1 && <4.19,+        mtl >=2.2.2 && <2.3,+        network >=3.1.1.1 && <3.2,+        random ==1.1.*,+        text >=1.2.4.0 && <1.3,+        text-zipper >=0.10.1 && <0.11,+        thock -any,+        time >=1.9.3 && <1.10,+        vector >=0.12.1.2 && <0.13,+        vty >=5.28.2 && <5.29,+        websockets >=0.12.7.1 && <0.13++executable thock+    main-is:            thock/Main.hs+    hs-source-dirs:     app+    other-modules:      Paths_thock+    default-language:   Haskell2010+    default-extensions: OverloadedStrings+    ghc-options:        -O3 -threaded -rtsopts -with-rtsopts=-N -Wall+    build-depends:+        aeson >=1.4.7.1 && <1.5,+        base >=4.7 && <5,+        brick >=0.52.1 && <0.53,+        containers >=0.6.2.1 && <0.7,+        file-embed >=0.0.11.2 && <0.1,+        lens >=4.18.1 && <4.19,+        mtl >=2.2.2 && <2.3,+        network >=3.1.1.1 && <3.2,+        random ==1.1.*,+        text >=1.2.4.0 && <1.3,+        text-zipper >=0.10.1 && <0.11,+        thock -any,+        time >=1.9.3 && <1.10,+        vector >=0.12.1.2 && <0.13,+        vty >=5.28.2 && <5.29,+        websockets >=0.12.7.1 && <0.13++test-suite thock-test+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    hs-source-dirs:     test+    other-modules:      Paths_thock+    default-language:   Haskell2010+    default-extensions: OverloadedStrings+    ghc-options:        -threaded -rtsopts -with-rtsopts=-N -Wall+    build-depends:+        aeson >=1.4.7.1 && <1.5,+        base >=4.7 && <5,+        brick >=0.52.1 && <0.53,+        containers >=0.6.2.1 && <0.7,+        file-embed >=0.0.11.2 && <0.1,+        lens >=4.18.1 && <4.19,+        mtl >=2.2.2 && <2.3,+        network >=3.1.1.1 && <3.2,+        random ==1.1.*,+        text >=1.2.4.0 && <1.3,+        text-zipper >=0.10.1 && <0.11,+        thock -any,+        time >=1.9.3 && <1.10,+        vector >=0.12.1.2 && <0.13,+        vty >=5.28.2 && <5.29,+        websockets >=0.12.7.1 && <0.13