From fdbc5fdfe128a96328b0c3d0395053057171e92f Mon Sep 17 00:00:00 2001
From: sternenseemann <git@lukasepple.de>
Date: Tue, 29 Oct 2019 21:53:54 +0100
Subject: add protocol mockup for multiplayer

---
 grav2ty.cabal                     |   5 ++
 lib/Grav2ty/Protocol.hs           | 103 ++++++++++++++++++++++++++++++++++++++
 lib/Grav2ty/Util/Serialization.hs |  20 ++++++++
 3 files changed, 128 insertions(+)
 create mode 100644 lib/Grav2ty/Protocol.hs
 create mode 100644 lib/Grav2ty/Util/Serialization.hs

diff --git a/grav2ty.cabal b/grav2ty.cabal
index 97330c1..b244861 100644
--- a/grav2ty.cabal
+++ b/grav2ty.cabal
@@ -22,13 +22,18 @@ library grav2ty-lib
   exposed-modules:     Grav2ty.Core
                      , Grav2ty.Simulation
                      , Grav2ty.Control
+                     , Grav2ty.Protocol
                      , Grav2ty.Util.RelGraph
+                     , Grav2ty.Util.Serialization
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , containers ^>=0.6.0.1
                      , linear ^>=1.20.8
                      , lens ^>= 4.17.1
                      , transformers^>=0.5.6.2
+                     , bytestring ^>=0.10.8.2
+                     , flat^>=0.3.4
+                     , attoparsec^>=0.13.2.3
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
diff --git a/lib/Grav2ty/Protocol.hs b/lib/Grav2ty/Protocol.hs
new file mode 100644
index 0000000..7ac828a
--- /dev/null
+++ b/lib/Grav2ty/Protocol.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE DeriveGeneric  #-}
+{-# LANGUAGE DeriveAnyClass #-}
+module Grav2ty.Protocol where
+
+import Prelude hiding (take)
+
+import Grav2ty.Core
+import Grav2ty.Util.Serialization
+
+import Data.Attoparsec.ByteString
+import Data.Bits
+import Data.ByteString (ByteString (..))
+import qualified Data.ByteString as BS
+import Data.Char
+import Data.Flat
+import Data.Flat.Instances
+import Data.Int
+import Data.Word
+import Linear.V2
+
+data Packet
+  = Packet
+  { pMessageType    :: Word8
+  , pPacketContents :: ByteString
+  } deriving (Show, Eq, Ord)
+
+class ToPacket a where
+  toPacket   :: a -> Packet
+  fromPacket :: Packet -> Maybe a
+
+protocolVersion :: Word8
+protocolVersion = 1
+
+data ErrorType
+  = ErrorServerFull
+  | ErrorVersionMismatch
+  | ErrorNoParse
+  deriving (Show, Eq, Ord, Generic, Flat)
+
+-- | Protocol Version 1
+data Message a
+  = ProtocolVersion Word8
+  | Error ErrorType
+  | AssignMods [Id]
+  | NewWorld Tick (World a)
+  | NewObject Tick Id (Object a)
+  | UpdateMod (ModMap a)
+  deriving (Show, Eq, Ord, Generic, Flat)
+
+toMaybe :: Bool -> a -> Maybe a
+toMaybe True x = Just x
+toMaybe False _ = Nothing
+
+rightToMaybe :: Either e a -> Maybe a
+rightToMaybe (Left _) = Nothing
+rightToMaybe (Right x) = Just x
+
+instance Flat a => ToPacket (Message a) where
+  toPacket (ProtocolVersion v) = Packet 0 (BS.singleton v)
+  toPacket (Error e) = Packet 1 (flat e)
+  toPacket (AssignMods ids) = Packet 2 (flat ids)
+  toPacket (NewWorld tick world) = Packet 3 $ flat (tick, world)
+  toPacket (NewObject tick id obj) = Packet 4 $ flat (tick, id, obj)
+  toPacket (UpdateMod modmap) = Packet 5 (flat modmap)
+  fromPacket (Packet 0 v) = toMaybe (BS.length v == 1) (ProtocolVersion $ BS.head v)
+  fromPacket (Packet 1 e) = Error <$> rightToMaybe (unflat e)
+  fromPacket (Packet 2 m) = AssignMods <$> rightToMaybe (unflat m)
+  fromPacket (Packet 3 w) = case unflat w of
+                              Left _ -> Nothing
+                              Right (tick, world) -> Just $ NewWorld tick world
+  fromPacket (Packet 4 o) = case unflat o of
+                              Left _ -> Nothing
+                              Right (tick, id, obj) -> Just $ NewObject tick id obj
+  fromPacket (Packet 5 m) = UpdateMod <$> rightToMaybe (unflat m)
+  fromPacket (Packet _ _) = Nothing
+
+bytes :: Int64 -> [Word8]
+bytes i = bytes' 7
+  where bytes' :: Int -> [Word8]
+        bytes' (-1) = []
+        bytes' n    = (fromIntegral . (flip shift (-8 * n)) $
+            i .&. shift 0xff (8 * n))
+          : bytes' (n - 1)
+
+unbytes :: [Word8] -> Int64
+unbytes l = unbytes' l 7 0
+  where unbytes' [x] 0 acc    = (fromIntegral x) + acc
+        unbytes' [x] n acc    = shift (fromIntegral x + acc) (-8 * n)
+        unbytes' (x:xs) n acc = unbytes' xs (n - 1) (acc + shift (fromIntegral x) (8 * n))
+
+renderPacket :: Packet -> ByteString
+renderPacket (Packet t content) = BS.pack (t : bytes len) `BS.append` content
+  where len :: Int64
+        len = fromIntegral $ BS.length content
+
+parsePacket :: ByteString -> Result Packet
+parsePacket = parse packetParser
+
+packetParser :: Parser Packet
+packetParser = do
+  t <- anyWord8
+  length <- fromIntegral . unbytes . BS.unpack <$> take 8 -- TODO get rid of unpack
+  Packet t <$> take length
diff --git a/lib/Grav2ty/Util/Serialization.hs b/lib/Grav2ty/Util/Serialization.hs
new file mode 100644
index 0000000..42be957
--- /dev/null
+++ b/lib/Grav2ty/Util/Serialization.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+module Grav2ty.Util.Serialization where
+
+import Data.Flat
+import GHC.Generics
+import Grav2ty.Core (Hitbox (..), Object (..), Modifier (..), Modification (..))
+import Linear.V2 (V2 (..))
+
+deriving instance Generic (Modification a)
+deriving instance Generic (Hitbox a)
+deriving instance Generic (Object a)
+deriving instance Generic Modifier
+
+deriving instance Flat a => Flat (V2 a)
+deriving instance Flat a => Flat (Object a)
+deriving instance Flat a => Flat (Hitbox a)
+deriving instance Flat a => Flat (Modification a)
+deriving instance Flat Modifier
-- 
cgit 1.4.1