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
|
{-# LANGUAGE PatternSynonyms #-}
module Types where
import Prelude hiding (Word)
import Data.List (find)
kPROTOCOL_VERSION :: Int
kPROTOCOL_VERSION = 3
newtype Word = Word_ String
deriving (Show, Eq, Ord)
pattern Word :: String -> Word
pattern Word s <- Word_ s
where Word = Word_ . assertIsWord "Word"
newtype Line = Line_ String
deriving (Show, Eq, Ord)
pattern Line :: String -> Line
pattern Line s <- Line_ s
where Line = Line_ . assertIsLine "Line"
newtype User = User { fromUser :: Word }
deriving (Show, Eq, Ord)
newtype Room = Room { fromRoom :: Word }
deriving (Show, Eq, Ord)
newtype Id = Id_ { fromId :: Int }
deriving (Show, Eq, Ord)
pattern Id :: Int -> Id
pattern Id i <- Id_ i
where Id = Id_ . assertPositive "Id"
data Response
= ROk
| RNumber Int
| RError String
| RName Word
| RList [Word]
| RPong
| RHistory Int
| RHistoryMessage Int Message
| RMessage Message
deriving (Show)
data Push
= POnline Int User
| PMessage Message
| PInvite Room User
| PJoin Room User
| PLeave Room User
| PPing
deriving (Show)
data Message
= Message { msgRoom :: Room
, msgUser :: User
, msgTimestamp :: Int
, msgId :: Id
, msgReplyId :: Maybe Id
, msgLine :: Line }
deriving (Show)
-- Firebase-related commands elided
data Cmd
= CVersion Word
| CRegister User Line
| CLogin User Line
| CChangePassword Line
| CLogout
| CListRooms
| CListMembers Room
| CCreateRoom
| CLeaveRoom Room
| CInvite Room User
| CSend Room (Maybe Id) Line
| CHistory Room Int
| CHistoryBefore Room Int Id
| CGetMessage Id
| CPing
| CIsOnline User
| CUserActive Bool
deriving (Show)
assertIsWord :: String -> String -> String
assertIsWord typ s | Nothing <- find (\c -> c == ' ' || c == '\n') s = s
| otherwise = error ("Value put in " ++ typ ++ " is not a word")
assertIsLine :: String -> String -> String
assertIsLine typ s | Nothing <- find (== '\n') s = s
| otherwise = error ("Value put in " ++ typ ++ " is not a line")
assertPositive :: String -> Int -> Int
assertPositive typ i | i >= 0 = i
| otherwise = error ("Value put in " ++ typ ++ " is not positive")
|
