common: data types, parse/serialize for them

src/Pad/ChangeSet.hs

+{-# LANGUAGE InstanceSigs #-}
+module Pad.ChangeSet where
+
+
+
+import Blaze.ByteString.Builder
+import qualified Data.ByteString as BS
+
+import Data.Word
+
+import Pad.NetProtocol
+
+
+
+-- TODO: use template haskell for the newtype and fromT/toT stuff?
+newtype Pos = Pos { fromPos :: Word64 } deriving (Show, Eq)
+newtype Len = Len { fromLen :: Word64 } deriving (Show, Eq)
+
+newtype RemoteAddr = RemoteAddr BS.ByteString
+newtype UserName   = UserName   BS.ByteString
+
+
+-- TODO: maybe have an IdentType typeclass for NetProtocolShow
+data AuthorId = AuthorId BS.ByteString
+            deriving (Show, Eq)
+
+-- TODO: something real
+data Color = Color String
+
+-- authors live in a global (across pads) table and are identified by
+-- an evercookie or else by username+originating hostname
+data Author = Author {
+        getAuthorId   :: AuthorId,
+        getUserName   :: UserName,
+        getColor      :: Color,
+        getRemoteAddr :: RemoteAddr
+}
+
+
+data TextAttribute = AttrAuthorId AuthorId
+                   | AttrFontBold
+                   | AttrFontItalic
+                   deriving (Show, Eq)
+
+data ChangeSet = ChangeSet Author Change
+
+data Change = AddText        Pos     BS.ByteString
+            | RemoveText     Pos Len
+            | SetAttribute   Pos Len TextAttribute
+            | ClearAttribute Pos Len TextAttribute
+            deriving (Show, Eq)
+
+

src/Pad/NetProtocol.hs

+module Pad.NetProtocol where
+
+
+import Blaze.ByteString.Builder
+
+
+{- everything that can be sent through the network connection to clients
+ - typical instances are: changesets, chat messages, meta-messages
+ - (userjoin, userleave, …)
+ --}
+class NetSendable a where
+    netProtoShow :: a -> Builder
+

src/Pad/NetProtocol/Instances.hs

+{-# LANGUAGE InstanceSigs, OverloadedStrings #-}
+module Pad.NetProtocol.Instances where
+
+
+import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder.Char.Utf8 (fromShow)
+import qualified Data.ByteString as BS
+
+import Data.Monoid
+
+import Pad.NetProtocol
+import Pad.ChangeSet
+
+
+
+instance NetSendable ChangeSet where
+    netProtoShow :: ChangeSet -> Builder
+    netProtoShow (ChangeSet author change) =
+        fromByteString "E:" <>
+        netProtoShow (getAuthorId author) <>
+        netProtoShow change
+
+
+-- helper stuff
+pos :: Pos -> Builder
+pos p = fromByteString "@" <> fromShow (fromPos p)
+
+len :: Len -> Builder
+len = fromShow . fromLen
+
+attr :: Pos -> Len -> BS.ByteString -> TextAttribute -> Builder
+attr p l op a =
+       pos p
+    <> fromByteString op
+    <> len l
+    <> fromByteString ":"
+    <> netProtoShow a
+
+-- TODO: document network protocol properly
+instance NetSendable Change where
+    netProtoShow :: Change -> Builder
+    netProtoShow (AddText p txt) =
+           pos p
+        <> fromByteString "+"
+        <> fromByteString txt
+        -- TODO: end-mark(->escaping)? checksum? length-field(marydyd
+        -- says nope..)
+    netProtoShow (RemoveText p l) =
+           pos p
+        <> fromByteString "-"
+        <> len l
+    netProtoShow (SetAttribute p l a) =
+        attr p l "S" a
+    netProtoShow (ClearAttribute p l a) =
+        attr p l "C" a
+
+
+
+instance NetSendable AuthorId where
+    netProtoShow :: AuthorId -> Builder
+    netProtoShow (AuthorId aid) = 
+           fromByteString "A:"
+        <> fromByteString aid
+
+
+-- TODO: maybe enable setting multiple attributes in one go?
+instance NetSendable TextAttribute where
+    netProtoShow :: TextAttribute -> Builder
+    netProtoShow (AttrAuthorId aid) = netProtoShow aid
+    netProtoShow (AttrFontBold) = fromByteString "B"
+    netProtoShow (AttrFontItalic) = fromByteString "I"
+

src/Pad/NetProtocol/Parse.hs

+{-# LANGUAGE OverloadedStrings #-}
+module Pad.NetProtocol.Parse where
+
+
+import qualified Data.ByteString as BS
+
+import Data.Attoparsec.ByteString
+-- warning: do only use stuff from here if sure that ASCII
+import Data.Attoparsec.ByteString.Char8 (decimal)
+
+import Data.Monoid
+import Data.Word
+import Data.Word8 (isDigit)
+
+import Pad.NetProtocol
+import Pad.ChangeSet
+import Pad.PadMessage
+
+import Control.Applicative ( (<*>), (<|>) )
+
+
+parseClientMessage :: Parser PadMessage
+parseClientMessage = word8 (fromIntegral . fromEnum $ 'h') >> return PMPadChange
+
+
+parsePos :: Parser Pos
+parsePos = word8c '@' >> Pos <$> decimal
+
+parseLen :: Parser Len
+parseLen = Len <$> decimal
+
+
+parseAttr :: Parser TextAttribute
+parseAttr =
+        (AttrAuthorId <$> parseAuthorId)
+    <|> (pure AttrFontBold <* string "B")
+    <|> (pure AttrFontItalic <* string "I")
+
+-- TODO: geht nur wenns am ende steht..
+parseAuthorId :: Parser AuthorId
+parseAuthorId = string "A:" >> AuthorId <$> takeByteString
+
+word8c :: Char -> Parser Word8
+word8c = word8 . fromIntegral . fromEnum
+
+parseChange :: Parser Change
+parseChange = 
+        (AddText        <$> parsePos <* word8c '+' <*> takeByteString)
+    <|> (RemoveText     <$> parsePos <* word8c '-' <*> parseLen)
+    <|> (SetAttribute   <$> parsePos <* word8c 'S' <*> parseLen <* word8c ':' <*> parseAttr)
+    <|> (ClearAttribute <$> parsePos <* word8c 'C' <*> parseLen <* word8c ':' <*> parseAttr)
+    <?> "unable to parse Change"
+
+

src/Pad/PadMessage.hs

+module Pad.PadMessage where
+
+
+import Control.Concurrent
+
+
+
+{- PadMessage s are the internal communication form of the different
+ - parts of this server
+ --}
+-- TODO: extend params to reflect real-world usage and add missing constructors
+data PadMessage = PMClientConnect (Chan PadMessage) String
+                | PMClientDisconnect String
+                | PMPadChange
+                | PMPadChatMsg
+                | PMNewClientNotify String
+
+instance Show PadMessage where
+    show (PMClientConnect _ s)  = "PMClientConnect _ " ++ (show s)
+    show (PMClientDisconnect s) = "PMClientDisconnect " ++ (show s)
+    show PMPadChange            = "PMPadChange"
+    show PMPadChatMsg           = "PMPadChatMsg"
+    show (PMNewClientNotify s)  = "PMNewClientNotify" ++ (show s)