diff --git a/src/Automaton.hs b/src/Automaton.hs index 0adaf64..a896457 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -8,7 +8,7 @@ import Control.Monad.Reader (asks) import Data.Map (Map, (!?)) import qualified Game (new, play) import qualified Hanafuda.KoiKoi as KoiKoi ( - Game, GameBlueprint(..), GameID, Step(..) + Game(..), GameID, Step(..) ) import qualified Hanafuda.Message as Message (FromClient(..), T(..)) import qualified Messaging ( diff --git a/src/Game.hs b/src/Game.hs index fb7a390..dae8463 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -5,34 +5,60 @@ module Game ( , play ) where -import qualified App (T, update) +import qualified App (T, server, update) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Reader (lift) import Control.Monad.Writer (runWriterT) +import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..)) +import Crypto.Saltine.Core.SecretBox (newNonce, secretbox) import Crypto.Saltine.Core.Sign (signDetached) -import Data.Aeson (encode) -import Data.Map ((!), mapWithKey) -import qualified Hanafuda (empty) -import Hanafuda.KoiKoi (Game, GameID, Mode(..), PlayerID) +import Data.Aeson (ToJSON, encode) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Map (Map) +import qualified Hanafuda (Pack) +import Hanafuda.KoiKoi (Game, GameID, Mode(..), Player, PlayerID, Players) import qualified Hanafuda.KoiKoi as KoiKoi ( Action, Game(..), Move(..), play, new ) import Hanafuda.Message (PrivateState(..), PublicGame(..), PublicPlayer(..), PublicState(..)) -import qualified Hanafuda.Player (Player(..), Players(..)) -import qualified Server (register) +import qualified Hanafuda.Player as Player (Player(..), Players(..), get, next) +import Keys (T(..), secret) +import qualified Server (T(..), register) new :: (PlayerID, PlayerID) -> App.T GameID new (for, to) = Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update +exportPlayers :: Game -> Map PlayerID Player +exportPlayers game = + let (Player.Players players) = KoiKoi.players game in + players + extractPrivateState :: PlayerID -> Game -> PrivateState -extractPrivateState playerID game = undefined +extractPrivateState playerID game = PrivateState { + opponentHand = getHand opponentID players + , deck = KoiKoi.deck game + } + where + players = KoiKoi.players game + opponentID = Player.next players playerID + +getHand :: PlayerID -> Players -> Hanafuda.Pack +getHand playerID = Player.hand . (Player.get playerID) + +publicPlayer :: Player -> PublicPlayer +publicPlayer player = PublicPlayer { + meld = Player.meld player + , yakus = Player.yakus player + } extractPublicState :: Game -> PublicState extractPublicState game = PublicState { mode = KoiKoi.mode game , scores = KoiKoi.scores game , month = KoiKoi.month game + , players = publicPlayer <$> exportPlayers game , playing = KoiKoi.playing game , winning = KoiKoi.winning game , oyake = KoiKoi.oyake game @@ -44,19 +70,23 @@ extractPublicState game = PublicState { export :: PlayerID -> Game -> App.T PublicGame export playerID game = do - secretKey <- asks $ fst . keypair . mServer + Keys.T {encrypt, sign} <- Server.keys <$> App.server + n <- lift newNonce return $ PublicGame { - playerHand = hand $ players ! playerID - , privateState = extractPrivateState playerID game + nonce = Saltine.encode n + , playerHand = getHand playerID (KoiKoi.players game) + , privateState = secretbox encrypt n $ toJSON privateState , publicState - , publicSignature = signDetached secretKey publicState + , publicSignature = signDetached (secret sign) $ toJSON publicState } where - Hanafuda.Player.Players players = KoiKoi.players game - publicState = encode $ extractPublicState game + publicState = extractPublicState game + privateState = extractPrivateState playerID game + toJSON :: ToJSON a => a -> ByteString + toJSON = toStrict . encode play :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action]) play playerID move game = lift . runWriterT . runExceptT $ - if playing game == playerID + if KoiKoi.playing game == playerID then KoiKoi.play move game else throwError "Not your turn" diff --git a/src/Keys.hs b/src/Keys.hs index 6e0b8d4..2bd75dd 100644 --- a/src/Keys.hs +++ b/src/Keys.hs @@ -1,8 +1,26 @@ module Keys ( - getKeyPair + T(..) + , getKeys + , public + , secret ) where -import Crypto.Saltine.Core.Box (Keypair, newKeypair) +import qualified Crypto.Saltine.Core.SecretBox as Encrypt (Key, newKey) +import qualified Crypto.Saltine.Core.Sign as Sign ( + Keypair, PublicKey, SecretKey, newKeypair + ) -getKeyPair :: IO Keypair -getKeyPair = newKeypair +data T = T { + encrypt :: Encrypt.Key + , sign :: Sign.Keypair + } + +getKeys :: IO T +getKeys = do + T <$> Encrypt.newKey <*> Sign.newKeypair + +public :: Sign.Keypair -> Sign.PublicKey +public = snd + +secret :: Sign.Keypair -> Sign.SecretKey +secret = fst diff --git a/src/Messaging.hs b/src/Messaging.hs index c592c14..1fc0b81 100644 --- a/src/Messaging.hs +++ b/src/Messaging.hs @@ -20,7 +20,7 @@ import Data.ByteString.Lazy.Char8 (unpack) import Data.Foldable (forM_) import Data.List (intercalate) import Data.Map (keys) -import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game, GameBlueprint(..), PlayerID) +import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID) import Hanafuda.Message (FromClient(..), T(..)) import qualified Hanafuda.Message as Message (T) import Network.WebSockets (receiveData, sendTextData) @@ -72,6 +72,6 @@ update = Update {alone = [], paired = []} notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T () notifyPlayers game logs = - forM_ (keys $ KoiKoi.scores game) $ \k -> - game <- Game.export k game - sendTo [k] $ Game {game, logs} + forM_ (keys $ KoiKoi.scores game) $ \k -> do + state <- Game.export k game + sendTo [k] $ Game {state, logs} diff --git a/src/Server.hs b/src/Server.hs index 73275ee..e185c8b 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -16,7 +16,6 @@ module Server ( , update ) where -import Crypto.Saltine.Core.Box (Keypair) import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey) import qualified Data.Map as Map (empty) import Data.Set (Set, member) @@ -24,7 +23,8 @@ import qualified Data.Set as Set (delete, empty, insert) import Data.Text (Text) import Hanafuda.KoiKoi (Game, GameID, PlayerID) import Hanafuda.Message (PlayerStatus(..), Room) -import Keys (getKeyPair) +import Keys (getKeys) +import qualified Keys (T) import qualified RW (RW(..)) import qualified Session (Status(..), T(..), Update) @@ -37,7 +37,7 @@ data T = T { , players :: Players , sessions :: Sessions , games :: Games - , keypair :: Keypair + , keys :: Keys.T } instance RW.RW Names T where @@ -68,12 +68,12 @@ room :: T -> Room room (T {players, sessions}) = mapWithKey (export sessions) players new :: IO T -new = getKeyPair >>= \keypair -> return $ T { +new = getKeys >>= \keys -> return $ T { names = Set.empty , players = Map.empty , sessions = Map.empty , games = Map.empty - , keypair + , keys } register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a)