Connect to euphoria and run example bots

package.yaml

@@ -20,6 +20,17 @@ description:         Please see the README on GitHub at <https://github.com/Garm
 
 dependencies:
 - base >= 4.7 && < 5
+- aeson
+- bytestring
+- containers
+- network
+- stm
+- text
+- time
+- transformers
+- unordered-containers
+- websockets
+- wuss
 
 library:
   source-dirs: src

src/Haboli/Euphoria/Api.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Haboli.Euphoria.Api
-  (
+  ( ToJSONObject(..)
   -- * Basic types
-    AuthOption(..)
+  , AuthOption(..)
   , Message(..)
   , PersonalAccountView
   , SessionView(..)
@@ -11,35 +11,59 @@ module Haboli.Euphoria.Api
   , UserType(..)
   , UserId(..)
   -- * Asynchronous events
-  , BounceEvent
+  , BounceEvent(..)
-  , DisconnectEvent
+  , DisconnectEvent(..)
-  , HelloEvent
+  , HelloEvent(..)
-  , JoinEvent
+  , JoinEvent(..)
-  , LoginEvent
+  , LoginEvent(..)
-  , LogoutEvent
+  , LogoutEvent(..)
-  , NetworkEvent
+  , NetworkEvent(..)
-  , NickEvent
+  , NickEvent(..)
-  , EditMessageEvent
+  , EditMessageEvent(..)
-  , PartEvent
+  , PartEvent(..)
-  , PingEvent
+  , PingEvent(..)
-  , PmInitiateEvent
+  , PmInitiateEvent(..)
-  , SendEvent
+  , SendEvent(..)
-  , SnapshotEvent
+  , SnapshotEvent(..)
   -- * Session commands
   -- ** auth
-  , AuthCommand
+  , AuthCommand(..)
-  , AuthReply
+  , AuthReply(..)
   -- ** ping
-  , PingCommand
+  , PingCommand(..)
-  , PingReply
+  , PingReply(..)
+  -- * Chat room commands
+  -- ** nick
+  , NickCommand(..)
+  , NickReply(..)
   ) where
 
+import           Control.Monad
 import           Data.Aeson
 import           Data.Aeson.Types
+import qualified Data.HashMap.Strict   as HMap
 import qualified Data.Text             as T
 import           Data.Time
 import           Data.Time.Clock.POSIX
 
+class ToJSONObject a where
+  toJSONObject :: a -> Object
+
+fromPacket :: T.Text -> (Object -> Parser a) -> Value -> Parser a
+fromPacket packetType parser (Object o) = do
+  actualType <- o .: "type"
+  when (actualType /= packetType) $
+    fail $ T.unpack $ "packet type is not " <> packetType
+  packetData <- o .: "data"
+  parser packetData
+fromPacket _ _ v = typeMismatch "Object" v
+
+toPacket :: T.Text -> Value -> Object
+toPacket packetType packetData = HMap.fromList
+  [ "type" .= packetType
+  , "data" .= packetData
+  ]
+
 {- Basic types -}
 
 data AuthOption = Passcode
@@ -50,8 +74,8 @@ instance ToJSON AuthOption where
 
 instance FromJSON AuthOption where
   parseJSON (String "passcode") = pure Passcode
-  parseJSON (String _) = fail "invalid value"
+  parseJSON (String _)          = fail "invalid value"
-  parseJSON v = typeMismatch "String" v
+  parseJSON v                   = typeMismatch "String" v
 
 -- | 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. See
@@ -211,6 +235,11 @@ data PingEvent = PingEvent
   , pingNext :: UTCTime
   } deriving (Show)
 
+instance FromJSON PingEvent where
+  parseJSON = fromPacket "ping-event" $ \o -> PingEvent
+    <$> (posixSecondsToUTCTime <$> o .: "time")
+    <*> (posixSecondsToUTCTime <$> o .: "next")
+
 data PmInitiateEvent = PmInitiateEvent
   { pmInitiateFrom     :: UserId
   , pmInitiateFromNick :: T.Text
@@ -222,16 +251,30 @@ data SendEvent = SendEvent
   { sendMessage :: Message
   } deriving (Show)
 
+{- snapshot-event -}
+
 data SnapshotEvent = SnapshotEvent
   { snapshotIdentity     :: UserId
+  , snapshotSessionId    :: T.Text
   , snapshotVersion      :: T.Text
   , snapshotListing      :: [SessionView]
   , snapshotLog          :: [Message]
   , snapshotNick         :: Maybe T.Text
-  , snapshotPmWithNick   :: T.Text
+  , snapshotPmWithNick   :: Maybe T.Text
-  , snapshotPmWithUserId :: UserId
+  , snapshotPmWithUserId :: Maybe UserId
   } deriving (Show)
 
+instance FromJSON SnapshotEvent where
+  parseJSON = fromPacket "snapshot-event" $ \o -> SnapshotEvent
+    <$> o .: "identity"
+    <*> o .: "session_id"
+    <*> o .: "version"
+    <*> o .: "listing"
+    <*> o .: "log"
+    <*> o .:? "nick"
+    <*> o .:? "pm_with_nick"
+    <*> o .:? "pm_with_user_id"
+
 {- Session commands -}
 
 {- auth -}
@@ -247,9 +290,23 @@ data AuthReply = AuthSuccessful | AuthFailed T.Text
 data PingCommand = PingCommand UTCTime
   deriving (Show)
 
+instance ToJSONObject PingCommand where
+  toJSONObject (PingCommand time) = toPacket "ping-reply" $ object
+    [ "time" .= utcTimeToPOSIXSeconds time
+    ]
+
 data PingReply = PingReply UTCTime
   deriving (Show)
 
+instance ToJSONObject PingReply where
+  toJSONObject (PingReply time) = toPacket "ping-reply" $ object
+    [ "time" .= utcTimeToPOSIXSeconds time
+    ]
+
+instance FromJSON PingReply where
+  parseJSON = fromPacket "ping-reply" $ \o -> PingReply
+    <$> (posixSecondsToUTCTime <$> o .: "time")
+
 {- Chat room commands -}
 
 {- nick -}
@@ -257,23 +314,22 @@ data PingReply = PingReply UTCTime
 data NickCommand = NickCommand T.Text
   deriving (Show)
 
-instance ToJSON NickCommand where
+instance ToJSONObject NickCommand where
-  toJSON (NickCommand nick) = object
+  toJSONObject (NickCommand nick) = HMap.fromList
     [ "type" .= String "nick"
     , "data" .= object ["name" .= nick]
     ]
 
 data NickReply = NickReply
   { nickReplySessionId :: T.Text
-  , nickReplyId :: UserId
+  , nickReplyId        :: UserId
-  , nickReplyFrom :: T.Text
+  , nickReplyFrom      :: T.Text
-  , nickReplyTo :: T.Text
+  , nickReplyTo        :: T.Text
   } deriving (Show)
 
 instance FromJSON NickReply where
-  parseJSON (Object o) = NickReply
+  parseJSON = fromPacket "nick-reply" $ \o -> NickReply
     <$> o .: "session_id"
     <*> o .: "id"
     <*> o .: "from"
     <*> o .: "to"
-  parseJSON v = typeMismatch "Object" v

src/Haboli/Euphoria/Client.hs

@@ -1,27 +1,49 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RankNTypes                 #-}
 
-module Haboli.Euphoria.Client where
+module Haboli.Euphoria.Client
+  (
+  -- * The Client monad
+    Client
+  , runClient
+  , ConnectionDetails(..)
+  , defaultDetails
+  -- ** Getters
+  , getHost
+  , getPort
+  , getPath
+  -- ** Event handling
+  , Event(..)
+  , nextEvent
+  , respondingToPing
+  -- ** Exception handling
+  , ClientException(..)
+  , Haboli.Euphoria.Client.throw
+  -- ** Euphoria commands
+  -- *** Session commands
+  , pingReply
+  -- *** Chat room commands
+  , nick
+  ) where
 
-import Control.Exception
+import           Control.Applicative
 import           Control.Concurrent
-import           Control.Concurrent.Chan
+import           Control.Concurrent.STM
-import Data.Foldable
+import           Control.Exception
-import Control.Monad.Trans.Class
-import Data.Traversable
-import           Control.Concurrent.MVar
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Reader
-import Control.Concurrent.STM
-import Control.Concurrent.STM.TVar
-import Control.Concurrent.STM.TMVar
 import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.ByteString.Lazy       as BS
+import           Data.Foldable
 import qualified Data.Map.Strict            as Map
+import           Data.Maybe
 import qualified Data.Text                  as T
-import qualified Data.Text.IO               as T
 import           Data.Time
 import           Network.Socket
 import qualified Network.WebSockets         as WS
@@ -30,23 +52,18 @@ import qualified Wuss                       as WSS
 import           Haboli.Euphoria.Api
 
 --TODO: Add all the events
--- | An event sent by the server. See
--- <http://api.euphoria.io/#asynchronous-events>.
-data ServerEvent
-  = ServerHello HelloEvent
-  | ServerSnapshot SnapshotEvent
-  deriving (Show)
-
--- | An event coming from the connection to the server.
 data Event
-  = EventServer ServerEvent
+  = EventPing PingEvent
-  -- ^ The server has sent an event.
+  | EventSnapshot SnapshotEvent
-  | EventStopped
+  | PlaceholderEvent --TODO: remove this event
-  -- ^ The connection has been closed. This event is always the last event and
-  -- after this event, no other event will come from the connection.
   deriving (Show)
 
---TODO: Decide between Exception and Error
+instance FromJSON Event where
+  parseJSON v = foldr (<|>) mempty
+    [ EventPing <$> parseJSON v
+    , EventSnapshot <$> parseJSON v
+    ]
+
 --TODO: Add more exceptions for other things that can also go wrong (parsing, connection already closed, ...)
 data ClientException e
   = ServerException (Maybe T.Text) (Maybe T.Text)
@@ -57,31 +74,41 @@ data ClientException e
   | StoppedException
   | DecodeException T.Text
   -- ^ At some point during decoding a websocket packet, something went wrong.
-  | CustomError e
+  | CustomException e
   deriving (Show)
 
+instance FromJSON (ClientException e) where
+  parseJSON (Object o) = do
+    serverError <- o .:? "error"
+    isThrottled <- o .:? "throttled" .!= False
+    throttledReason <- o .:? "throttled_reason"
+    let throttled = if isThrottled then Just (fromMaybe "" throttledReason) else Nothing
+    when (isNothing serverError && isNothing throttled) $
+      fail "there is no error and the client is not throttled"
+    pure $ ServerException serverError throttled
+  parseJSON v = typeMismatch "Object" v
+
 -- | This type is used by the websocket thread to send the server's replies to
 -- the client. Since exceptions like a 'ServerError' may occur, they are
 -- explicitly included in the type stored in the 'MVar'.
 --
 -- The fancy types are there so I don't have to explicitly specify the response
 -- in some sum type or similar.
-newtype AwaitingReply e
+data AwaitingReply e
-  = AwaitingReply (forall r. FromJSON r => Either (ClientException e) r)
+  = forall r. FromJSON r => AwaitingReply (TMVar (Either (ClientException e) r))
 
 -- | A 'Map.Map' of empty 'TMVar's waiting for their respective reply packet
 -- from the server.
-type AwaitingReplies e = Map.Map T.Text (TMVar (AwaitingReply e))
+type AwaitingReplies e = Map.Map T.Text (AwaitingReply e)
 
 data ClientInfo e = ClientInfo
-            { ciDetails :: ConnectionDetails
+  { ciDetails    :: ConnectionDetails
-            , ciConnection        :: WS.Connection
+  , ciConnection :: WS.Connection
-            , ciPacketId          :: TVar Integer
+  , ciAwaiting   :: TVar (AwaitingReplies e)
-            , ciWsThreadId        :: ThreadId
+  , ciEventChan  :: TChan Event
-            , ciAwaiting          :: TVar (AwaitingReplies e)
+  , ciPacketId   :: TVar Integer
-            , ciEventChan         :: Chan Event
+  , ciStopped    :: TVar Bool -- only modified by websocket thread
-            , ciStopped           :: TVar Bool -- only modified by websocket thread
+  }
-            }
 
 -- This type declaration feels lispy in its parenthesisness
 newtype Client e a = Client (ReaderT (ClientInfo e)
@@ -91,35 +118,56 @@ newtype Client e a = Client (ReaderT (ClientInfo e)
 
 {- The websocket listening thread -}
 
+--TODO: This could close the ws connection and stop the client instead
+-- | An exception handler that ignores messages that could not be decoded
+-- properly. It only prints the exceptions via 'putStrLn'.
 ignoringInvalidMessages :: WS.ConnectionException -> IO ()
 ignoringInvalidMessages (WS.ParseException message)   = putStrLn $ "ParseException: " ++ message
 ignoringInvalidMessages (WS.UnicodeException message) = putStrLn $ "UnicodeException: " ++ message
 ignoringInvalidMessages e = throwIO e
 
-cancelAllReplies :: TVar (AwaitingReplies e) -> STM ()
+-- | An exception handler that stops the client if any sort of
-cancelAllReplies awaiting = do
+-- 'WS.ConnectionException' occurs. It does this by setting 'ciStopped' to True
-  replyMap <- readTVar awaiting
+-- and cancelling all 'AwaitingReply'-s in 'ciAwaiting'.
-  for_ replyMap $ \v ->
+cancellingAllReplies :: ClientInfo e -> WS.ConnectionException -> IO ()
-    putTMVar v (AwaitingReply (Left StoppedException))
+cancellingAllReplies info _ = atomically $ do
+  writeTVar (ciStopped info) True
+  -- Cancel all replies
+  replyMap <- readTVar (ciAwaiting info)
+  for_ replyMap $ \(AwaitingReply v) ->
+    putTMVar v (Left StoppedException)
 
-wsThread :: WS.Connection -> Chan Event -> TVar (AwaitingReplies e) -> TVar Bool -> IO ()
+parseAndSendEvent :: BS.ByteString -> TChan Event -> IO ()
-wsThread connection eventChan awaiting stopped
+parseAndSendEvent msg eventChan =
-  = handle stopHandler
+  for_ (decode msg) $ \event ->
-  $ forever
+    atomically $ writeTChan eventChan event
-  $ handle ignoringInvalidMessages
+
-  $ do
+parseAndSendReply :: BS.ByteString -> TVar (AwaitingReplies e) -> IO ()
-    msg <- WS.receiveData connection
+parseAndSendReply msg awaiting = do
-    --TODO: Actually parse the stuff and send it to the event channel
+  let maybePacketId = parseMaybe parsePacketId =<< decode msg
-    T.putStrLn msg
+  for_ maybePacketId $ \packetId -> atomically $ do
+    awaitingMap <- readTVar awaiting
+    for_ (awaitingMap Map.!? packetId) $ \(AwaitingReply replyVar) -> do
+      let maybeExceptionOrReply = (Left <$> decode msg) <|> (Right <$> decode msg)
+          invalidStructureException = Left $ DecodeException "invalid message json structure"
+      putTMVar replyVar $ fromMaybe invalidStructureException maybeExceptionOrReply
+      modifyTVar awaiting $ Map.delete packetId
   where
-    stopHandler :: WS.ConnectionException -> IO ()
+    parsePacketId :: Value -> Parser T.Text
-    stopHandler _ = do
+    parsePacketId (Object o) = o .: "id"
-      -- After 'stopped' is set to True, 'awaiting' is not modified by any
+    parsePacketId v          = typeMismatch "Object" v
-      -- thread. Because of this, the call to 'cancelAllReplies' wouldn't need
+
-      -- to happen atomically with setting 'stopped' to True, but I still do it
+runWebsocketThread :: ClientInfo e -> IO ()
-      -- atomically.
+runWebsocketThread info
-      atomically $ writeTVar stopped True >> cancelAllReplies awaiting
+  = WS.withPingThread (ciConnection info) pingInterval (pure ())
-      writeChan eventChan EventStopped
+  $ handle (cancellingAllReplies info) $ forever
+  $ handle ignoringInvalidMessages $ do
+    msg <- WS.receiveData (ciConnection info)
+    -- print msg
+    parseAndSendEvent msg (ciEventChan info)
+    parseAndSendReply msg (ciAwaiting info)
+  where
+    pingInterval = cdPingInterval $ ciDetails info
 
 {- Running the Client monad -}
 
@@ -138,30 +186,37 @@ defaultDetails = ConnectionDetails
   , cdPingInterval = 10
   }
 
+--TODO: Close connection after client finishes running if it hasn't already been closed
 runClient :: ConnectionDetails -> Client e a -> IO (Either (ClientException e) a)
 runClient details (Client stack)
   = withSocketsDo
   $ WSS.runSecureClient (cdHost details) (cdPort details) (cdPath details)
   $ \connection -> do
-    packetId <- newTVarIO 0
     awaiting <- newTVarIO Map.empty
-    eventChan <- newChan
+    eventChan <- newTChanIO
+    packetId <- newTVarIO 0
     stopped <- newTVarIO False
-
-    wsThreadId <- forkIO
-      $ WS.withPingThread connection (cdPingInterval details) (pure ())
-      $ wsThread connection eventChan awaiting stopped
-
     let info = ClientInfo
           { ciDetails = details
           , ciConnection = connection
-          , ciPacketId = packetId
-          , ciWsThreadId = wsThreadId
           , ciAwaiting = awaiting
           , ciEventChan = eventChan
+          , ciPacketId = packetId
           , ciStopped = stopped
           }
-    runExceptT $ runReaderT stack info
+    -- Start the websocket thread, which will notify this thread when it stops
+    wsThreadFinished <- newEmptyMVar
+    void $ forkFinally (runWebsocketThread info) (\_ -> putMVar wsThreadFinished ())
+    -- Run the actual 'Client' in this thread
+    result <- runExceptT $ runReaderT stack info
+    -- Close the connection if it is not already closed, and wait until the
+    -- websocket thread stops
+    handle ignoreAllExceptions $ WS.sendClose connection $ T.pack "Goodbye :D"
+    takeMVar wsThreadFinished
+    pure result
+  where
+    ignoreAllExceptions :: WS.ConnectionException -> IO ()
+    ignoreAllExceptions _ = pure ()
 
 {- Private operations -}
 
@@ -199,42 +254,42 @@ safeSend connection packet = do
       $ "could not decode unicode: " <> T.pack message
 
 -- | Send a packet and automatically add a packet id
-sendPacket :: Object -> Client e T.Text
+sendPacket :: ToJSONObject o => o -> Client e T.Text
 sendPacket packet = do
   connection <- ciConnection <$> getClientInfo
   -- No need to check if 'ciStopped' is True because 'WS.sendTextData' will
   -- throw an exception anyways.
   packetId <- newPacketId
-  let packetWithId = packet <> ("id" .= packetId)
+  let packetWithId = toJSONObject packet <> ("id" .= packetId)
   safeSend connection packetWithId
   pure packetId
 
 -- | Send a packet and wait for a reply from the server.
-sendPacketWithReply :: FromJSON r => Object -> Client e r
+sendPacketWithReply :: (ToJSONObject o, FromJSON r) => o -> Client e r
 sendPacketWithReply packet = do
   info <- getClientInfo
   packetId <- sendPacket packet
+  -- Create and insert a new empty TMVar into the AwaitingReplies map
   maybeReplyVar <- liftIO $ atomically $ do
     stopped <- readTVar $ ciStopped info
     if stopped
       then pure Nothing
       else do
         replyVar <- newEmptyTMVar
-        modifyTVar (ciAwaiting info) (Map.insert packetId replyVar)
+        modifyTVar (ciAwaiting info) $ Map.insert packetId (AwaitingReply replyVar)
         pure $ Just replyVar
   case maybeReplyVar of
     Nothing -> throwRaw StoppedException
     Just replyVar -> do
-      (AwaitingReply reply) <- liftIO $ atomically $ do
+      reply <- liftIO $ atomically $ readTMVar replyVar
-        reply <- readTMVar replyVar
-        modifyTVar (ciAwaiting info) (Map.delete packetId)
-        pure reply
       case reply of
-        Left e -> throwRaw e
+        Left e  -> throwRaw e
         Right r -> pure r
 
 {- Public operations -}
 
+{- Getters -}
+
 getHost :: Client e HostName
 getHost = cdHost . ciDetails <$> getClientInfo
 
@@ -244,7 +299,45 @@ getPort = cdPort . ciDetails <$> getClientInfo
 getPath :: Client e String
 getPath = cdPath . ciDetails <$> getClientInfo
 
-stop :: Client e ()
+{- Special operations -}
-stop = do
+
-  ci <- getClientInfo
+nextEvent :: Client e Event
-  liftIO $ WS.sendClose (ciConnection ci) $ T.pack "Goodbye :D"
+nextEvent = do
+  info <- getClientInfo
+  exceptionOrEvent <- liftIO $ atomically $ do
+    stopped <- readTVar (ciStopped info)
+    if stopped
+      then pure $ Left StoppedException
+      else Right <$> readTChan (ciEventChan info)
+  case exceptionOrEvent of
+    Left e  -> throwRaw e
+    Right e -> pure e
+
+respondingToPing :: Client e Event -> Client e Event
+respondingToPing holdingEvent = do
+  event <- holdingEvent
+  case event of
+    EventPing e -> pingReply (pingTime e)
+    _           -> pure ()
+  pure event
+
+{- Exception handling -}
+
+--TODO: Add more commands and find more appropriate names
+
+throw :: e -> Client e a
+throw = throwRaw . CustomException
+
+{- Euphoria commands -}
+
+{- Session commands -}
+
+pingReply :: UTCTime -> Client e ()
+pingReply = void . sendPacket . PingReply
+
+{- Chat room commands -}
+
+nick :: T.Text -> Client e T.Text
+nick targetNick = do
+  reply <- sendPacketWithReply $ NickCommand targetNick
+  pure $ nickReplyTo reply

src/Haboli/Euphoria/Example.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module contains a few basic example bots.
+module Haboli.Euphoria.Example where
+
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Haboli.Euphoria.Client
+
+printAllEventsBot :: Client () ()
+printAllEventsBot = forever $ do
+  liftIO $ putStrLn "Waiting for the next event"
+  liftIO . print =<< respondingToPing nextEvent
+
+setNickAndThenWaitBot :: Client () ()
+setNickAndThenWaitBot = forever $ do
+  event <- respondingToPing nextEvent
+  case event of
+    EventSnapshot _ -> void $ nick "HaboliTestBot"
+    _               -> pure ()
+
+throwCustomExceptionBot :: Client String ()
+throwCustomExceptionBot = throw "Hello world"
+
+immediatelyDisconnectBot :: Client () ()
+immediatelyDisconnectBot = pure ()