1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
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
|