From 3dbed10ffd199974a2656542f9058cc8aef52329 Mon Sep 17 00:00:00 2001 From: Joscha Date: Mon, 6 Jan 2020 17:48:36 +0000 Subject: [PATCH] Connect to euphoria and run example bots --- package.yaml | 11 ++ src/Haboli/Euphoria/Api.hs | 118 +++++++++++---- src/Haboli/Euphoria/Client.hs | 259 ++++++++++++++++++++++----------- src/Haboli/Euphoria/Example.hs | 26 ++++ 4 files changed, 300 insertions(+), 114 deletions(-) create mode 100644 src/Haboli/Euphoria/Example.hs diff --git a/package.yaml b/package.yaml index cdef622..06a11e4 100644 --- a/package.yaml +++ b/package.yaml @@ -20,6 +20,17 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- aeson +- bytestring +- containers +- network +- stm +- text +- time +- transformers +- unordered-containers +- websockets +- wuss library: source-dirs: src diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index 4edb657..c1736b5 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/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 - , DisconnectEvent - , HelloEvent - , JoinEvent - , LoginEvent - , LogoutEvent - , NetworkEvent - , NickEvent - , EditMessageEvent - , PartEvent - , PingEvent - , PmInitiateEvent - , SendEvent - , SnapshotEvent + , BounceEvent(..) + , DisconnectEvent(..) + , HelloEvent(..) + , JoinEvent(..) + , LoginEvent(..) + , LogoutEvent(..) + , NetworkEvent(..) + , NickEvent(..) + , EditMessageEvent(..) + , PartEvent(..) + , PingEvent(..) + , PmInitiateEvent(..) + , SendEvent(..) + , SnapshotEvent(..) -- * Session commands -- ** auth - , AuthCommand - , AuthReply + , AuthCommand(..) + , AuthReply(..) -- ** ping - , PingCommand - , PingReply + , PingCommand(..) + , 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 v = typeMismatch "String" v + parseJSON (String _) = fail "invalid value" + 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 - , snapshotPmWithUserId :: UserId + , snapshotPmWithNick :: Maybe T.Text + , 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 - toJSON (NickCommand nick) = object +instance ToJSONObject NickCommand where + toJSONObject (NickCommand nick) = HMap.fromList [ "type" .= String "nick" , "data" .= object ["name" .= nick] ] data NickReply = NickReply { nickReplySessionId :: T.Text - , nickReplyId :: UserId - , nickReplyFrom :: T.Text - , nickReplyTo :: T.Text + , nickReplyId :: UserId + , nickReplyFrom :: 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 diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index 4251eed..a442170 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/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 Data.Foldable -import Control.Monad.Trans.Class -import Data.Traversable -import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Exception 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 --- . -data ServerEvent - = ServerHello HelloEvent - | ServerSnapshot SnapshotEvent - deriving (Show) - --- | An event coming from the connection to the server. data Event - = EventServer ServerEvent - -- ^ The server has sent an event. - | EventStopped - -- ^ The connection has been closed. This event is always the last event and - -- after this event, no other event will come from the connection. + = EventPing PingEvent + | EventSnapshot SnapshotEvent + | PlaceholderEvent --TODO: remove this event 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 - = AwaitingReply (forall r. FromJSON r => Either (ClientException e) r) +data AwaitingReply e + = 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 - , ciConnection :: WS.Connection - , ciPacketId :: TVar Integer - , ciWsThreadId :: ThreadId - , ciAwaiting :: TVar (AwaitingReplies e) - , ciEventChan :: Chan Event - , ciStopped :: TVar Bool -- only modified by websocket thread - } + { ciDetails :: ConnectionDetails + , ciConnection :: WS.Connection + , ciAwaiting :: TVar (AwaitingReplies e) + , ciEventChan :: TChan Event + , ciPacketId :: TVar Integer + , 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 () -cancelAllReplies awaiting = do - replyMap <- readTVar awaiting - for_ replyMap $ \v -> - putTMVar v (AwaitingReply (Left StoppedException)) +-- | An exception handler that stops the client if any sort of +-- 'WS.ConnectionException' occurs. It does this by setting 'ciStopped' to True +-- and cancelling all 'AwaitingReply'-s in 'ciAwaiting'. +cancellingAllReplies :: ClientInfo e -> WS.ConnectionException -> IO () +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 () -wsThread connection eventChan awaiting stopped - = handle stopHandler - $ forever - $ handle ignoringInvalidMessages - $ do - msg <- WS.receiveData connection - --TODO: Actually parse the stuff and send it to the event channel - T.putStrLn msg +parseAndSendEvent :: BS.ByteString -> TChan Event -> IO () +parseAndSendEvent msg eventChan = + for_ (decode msg) $ \event -> + atomically $ writeTChan eventChan event + +parseAndSendReply :: BS.ByteString -> TVar (AwaitingReplies e) -> IO () +parseAndSendReply msg awaiting = do + let maybePacketId = parseMaybe parsePacketId =<< decode 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 () - stopHandler _ = do - -- After 'stopped' is set to True, 'awaiting' is not modified by any - -- thread. Because of this, the call to 'cancelAllReplies' wouldn't need - -- to happen atomically with setting 'stopped' to True, but I still do it - -- atomically. - atomically $ writeTVar stopped True >> cancelAllReplies awaiting - writeChan eventChan EventStopped + parsePacketId :: Value -> Parser T.Text + parsePacketId (Object o) = o .: "id" + parsePacketId v = typeMismatch "Object" v + +runWebsocketThread :: ClientInfo e -> IO () +runWebsocketThread info + = WS.withPingThread (ciConnection info) pingInterval (pure ()) + $ 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 <- readTMVar replyVar - modifyTVar (ciAwaiting info) (Map.delete packetId) - pure reply + reply <- liftIO $ atomically $ readTMVar replyVar 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 () -stop = do - ci <- getClientInfo - liftIO $ WS.sendClose (ciConnection ci) $ T.pack "Goodbye :D" +{- Special operations -} + +nextEvent :: Client e Event +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 diff --git a/src/Haboli/Euphoria/Example.hs b/src/Haboli/Euphoria/Example.hs new file mode 100644 index 0000000..604a3ba --- /dev/null +++ b/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 ()