From e7133882fe69d8f718cbaf910a22512153db11ee Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Mon, 2 Nov 2020 00:00:23 +0100
Subject: mock: Start writing a mock server implementation

This is intended to be used for property testing later. Doing this in
Haskell should make it easy enough that maintaining a double
implementation is not _too_ bad.
---
 mock/Types.hs | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 101 insertions(+)
 create mode 100644 mock/Types.hs

(limited to 'mock/Types.hs')

diff --git a/mock/Types.hs b/mock/Types.hs
new file mode 100644
index 0000000..be73231
--- /dev/null
+++ b/mock/Types.hs
@@ -0,0 +1,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")
-- 
cgit v1.2.3-70-g09d2