Clean up Types

package.yaml

@@ -24,12 +24,14 @@ dependencies:
   # basic stuff
 - time
 - text
+- transformers
   # websocket connection
 - websockets
 - wuss
   # parsing json
 - aeson
 - bytestring
+- unordered-containers
   # other
 - stm
 

src/EuphApi/Threads.hs

@@ -1,7 +1,61 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecordWildCards           #-}
 
 -- | Setup consisting of a few threads to send and receive packets to and from
 -- the euphoria api using a websocket connection.
+--
+-- @
+-- m: main thread
+-- r: recvThread
+-- f: fetchThread
+-- s: sendThread
+--
+-- On creation:
+--  m: Create WS connection
+--  m: Create channels
+--  m: Start recvThread with all necessary info
+--  r: Start fetchThread and sendThread using async
+--  m: Return SendChan and EventChan
+--
+-- On disconnect:
+--  s: close connection (optional)
+--  f: detect exception
+--  f: RDisconnected -> RecvChan
+--  f: *stops*
+--  r: RecvChan -> RDisconnected
+--  r: close SendChan
+--  s: *stops*
+--  r: wait for f and s to stop
+--  r: clean up SendChan
+--  r: clean up RecvChan
+--  r: clean up response list
+--  r: EventStopped -> EventChan
+--  r: *stops*
+--  -> All MVars are dealt with
+--
+--                        ↓
+--                        │
+--                    (SendChan)
+--                        │
+-- ┌─────────────────────╴│╶──────┐
+-- │                      │       │
+-- │ (WS.Connection)      │       │
+-- │        │             │       │
+-- │  [fetchThread]  [sendThread] │
+-- │        │             │       │
+-- │        └──────┬──────┘       │
+-- │               │              │
+-- │           (RecvChan)         │
+-- │               │              │
+-- │          [recvThread]        │
+-- │               │              │
+-- └──────────────╴│╶─────────────┘
+--                 │
+--             (EventChan)
+--                 │
+--                 ↓
+-- @
 
 module EuphApi.Threads (
   -- * Events and replies
@@ -13,22 +67,55 @@ module EuphApi.Threads (
 
 import           Control.Concurrent
 import           Control.Exception
-import           Data.Aeson
+import           Control.Monad
-import           Data.Text
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.State
+import           Data.Aeson                as A
+import qualified Data.ByteString.Lazy      as BS
+import qualified Data.HashMap.Strict       as HM
+import qualified Data.Text                 as T
+import qualified EuphApi.CloseableChan     as E
 import qualified EuphApi.Types             as E
 import qualified Network.WebSockets        as WS
 
--- Some useful type aliases
-type PacketID = Text
-
 {-
- - Events and replies
+ - Some stuff
  -}
 
+-- Some useful type aliases
+type PacketID = T.Text
+type Reply = Either Failure
+
 -- | The ways in which getting a reply from the server can fail.
 data Failure = FailDisconnect   -- ^ Disconnected from the server while waiting for the reply.
+             | FailError T.Text -- ^ The server replied with an error.
              | FailParse        -- ^ Could not parse the server's reply correctly.
 
+class ToJSONObject a where
+  toJSONObject :: a -> Object
+
+(.?=) :: (ToJSON v, KeyValue kv) => T.Text -> Maybe v -> [kv]
+k .?= (Just v) = [k .= v]
+k .?= Nothing  = []
+
+packetOfType :: T.Text -> Value -> Object
+packetOfType packetType packetData =
+  HM.fromList [("type", A.String packetType), ("data", packetData)]
+
+{-
+ - Commands
+ -}
+
+data SendCommand = SendCommand
+  { sendCommandContent :: T.Text
+  , sendCommandParent  :: Maybe E.Snowflake
+  } deriving (Show)
+
+instance ToJSONObject SendCommand where
+  toJSONObject (SendCommand{..}) =
+    let obj = object $ ["content" .= sendCommandContent] ++ ("parent" .?= sendCommandParent)
+    in  packetOfType "data" obj
+
 -- send-reply
 data SendReply = SendReply
   { sendReplyMessage :: E.Message
@@ -41,94 +128,95 @@ instance FromJSON SendReply where
  - API functions
  -}
 
-send :: SendChan -> Text -> IO (Either Failure E.Message)
+send :: SendChan -> T.Text -> IO (Reply E.Message)
 send = undefined
 
-reply :: SendChan -> PacketID -> Text -> IO (Either Failure E.Message)
+reply :: SendChan -> PacketID -> T.Text -> IO (Reply E.Message)
 reply = undefined
 
+{-
+ - Channels
+ -}
 
+type RecvChan = E.CloseableChan Recv
+data Recv = RDisconnected
+          | RPacket BS.ByteString
+          | forall a . (FromJSON a) => RReply PacketID (MVar (Reply a))
 
+type SendChan = E.CloseableChan Send
+data Send = SDisconnect
+          | forall p . (ToJSONObject p) => SNoReply p
+          | forall p r . (ToJSONObject p, FromJSON r) => SReply p (MVar (Reply r))
 
-
+type EventChan e = E.CloseableChan (Event e)
-
+data Event e = EDisconnected
-
+             | EStopped
-
+             | EEuphEventPlaceholder
-
+             | ECustomEvent e
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
 
 {-
-data Packet = Packet
+ - Fetch thread
-  { packetID :: Maybe PacketID
+ -}
-  , packetType :: Text
-  , packetContent :: Content
-  , packetThrottled :: Maybe Text
-  }
--}
 
-type SendChan = Chan Send
+fetchThread :: RecvChan -> WS.Connection -> IO ()
--- Contents of sendChan
+fetchThread cRecv con = handle handleException $ forever $ do
-data Send = SPacket Text --Value -- packet type, content
+  message <- WS.receiveData con
-          | SDisconnect
+  void $ E.writeChan cRecv (RPacket message) -- will never be closed while thread running
-
-type RecvChan = Chan Recv
--- Contents of recvChan
-data Recv = RConnectionClosed -- Ws connection closed
--- | RPacket ByteString -- Packet received from the ws connection
--- | forall c . (FromJSON c) => RReply PacketID (MVar (Response c)) -- Request for a reply with a certain ID
-
-{-
-sendPacket :: Connection -> Packet -> IO ()
-sendPacket = undefined
-
-recvPacket :: Connection -> IO Packet
-recvPacket = undefined
-
-sendThread :: SendChan -> RecvChan -> Connection -> IO ()
-sendThread s r c = do
-  return ()
-
-type EventChan = Chan Event
--- Contents of eventChan
-data Event = EPlaceholder
-
-fetchMessage :: RecvChan -> Connection -> IO ()
-fetchMessage recv con = do
-  message <- receiveData con
-  writeChan recv (RPacket message)
-  fetchMessage recv con
-
-fetchThread :: RecvChan -> Connection -> IO ()
-fetchThread recv con = fetchMessage recv con `catch` handleException
   where
-    handleException (CloseRequest _ _) = writeChan recv RConnectionClosed
+    handleException (WS.CloseRequest _ _) = void $ E.writeChan cRecv RDisconnected
-    handleException ConnectionClosed   = writeChan recv RConnectionClosed
+    handleException WS.ConnectionClosed   = void $ E.writeChan cRecv RDisconnected
-    handleException _                  = fetchThread recv con
+    handleException _                     = fetchThread cRecv con
 
-sendMessage :: SendChan -> RecvChan -> Connection -> IO ()
+{-
-sendMessage send recv con = do
+ - Send thread
-  message <- readChan send
+-}
+
+type SendState = StateT Integer IO
+
+-- Prepare a single packet for sending
+preparePacket :: (ToJSONObject p) => p -> SendState (BS.ByteString, PacketID)
+preparePacket packet = do
+  packetNr <- get
+  put $ packetNr + 1
+  let packetID = T.pack $ show packetNr
+      obj      = HM.insert "id" (A.String packetID) $ toJSONObject packet
+      bytestr  = encode $ Object obj
+  return (bytestr, packetID)
+
+
+sendThread :: SendChan -> RecvChan -> WS.Connection -> SendState ()
+sendThread cSend cRecv con = do
+  item <- liftIO $ E.readChan cSend
+  case item of
+    Nothing -> do
       return ()
 
-sendThread :: SendChan -> RecvChan -> Connection -> IO ()
+    Just SDisconnect -> do
-sendThread = undefined
+      liftIO $ WS.sendClose con ("Bye." :: T.Text)
--}
+
+    Just (SNoReply value) -> do
+      (packet, _) <- preparePacket value
+      liftIO $ WS.sendTextData con packet
+      continue <- liftIO $ sendSafely packet
+      if continue
+        then sendThread cSend cRecv con
+        else return ()
+
+    Just (SReply value reply) -> do
+      (packet, packetID) <- preparePacket value
+      liftIO $ E.writeChan cRecv $ RReply packetID reply
+      continue <- liftIO $ sendSafely packet
+      if continue
+        then sendThread cSend cRecv con
+        else return ()
+  where
+    sendSafely packet = (WS.sendTextData con packet >> return True) `catch` handleException
+    handleException (WS.CloseRequest _ _) = return False
+    handleException WS.ConnectionClosed   = return False
+    handleException _                     = return True
+
+{-
+ - RecvThread
+ -}
+
+-- TODO

src/EuphApi/Types.hs

@@ -1,11 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 
--- | This module implements parts of the Euphoria API at
+-- | This module implements a few types from the Euphoria API at
 -- <http://api.euphoria.io/#overview>.
---
--- Currently, accounts are not implemented.
--- This means that all account, room host and staff commands are not implemented.
 
 module EuphApi.Types
   ( Snowflake
@@ -23,7 +20,8 @@ import           Data.Time
 
 -- | Represents <http://api.euphoria.io/#snowflake>.
 --
--- A 'Snowflake' is a 13-character string, usually used as a unique identifier for some type of object.
+-- A 'Snowflake' is a 13-character string, usually used as a unique identifier
+-- for some type of object.
 -- It is the base-36 encoding of an unsigned, 64-bit integer.
 type Snowflake = T.Text
 
@@ -45,8 +43,8 @@ instance FromJSON UserID where
         userType = findUserType tp
         userSnowflake = T.drop 1 sf
     in  return $ if userType == Other
-                   then UserID {userSnowflake=t, ..}
+                   then UserID{userSnowflake=t, ..}
-                   else UserID {..}
+                   else UserID{..}
     where
       findUserType txt
         | txt == "account" = Account
@@ -67,7 +65,8 @@ data UserType = Agent
 -- | Represents <http://api.euphoria.io/#message>.
 --
 -- A 'Message' is a node in a Room’s Log.
--- It corresponds to a chat message, or a post, or any broadcasted event in a room that should appear in the log.
+-- It corresponds to a chat message, or a post, or any broadcasted event in a room
+-- that should appear in the log.
 --
 -- The fields @previous_edit_id@ and @encryption_key_id@ are not implemented.
 data Message = Message
@@ -108,7 +107,7 @@ instance FromJSON Message where
     msgEdited    <- o .:? "edited"
     msgDeleted   <- o .:? "deleted"
     msgTruncated <- o .:? "truncated" .!= False
-    return $ Message {..}
+    return $ Message{..}
 
 -- | Represents <http://api.euphoria.io/#sessionview>.
 --
@@ -136,4 +135,4 @@ instance FromJSON SessionView where
     sessSessionID <- o .: "session_id"
     isStaff       <- o .:? "is_staff" .!= False
     isManager     <- o .:? "is_manager" .!= False
-    return $ SessionView {..}
+    return $ SessionView{..}