Garmelon/haboli
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Connect to euphoria and run example bots

Browse source
This commit is contained in:
Joscha 2020-01-06 17:48:36 +00:00
parent ee55f84c34
commit 3dbed10ffd
4 changed files with 300 additions and 114 deletions
Download patch file Download diff file Expand all files Collapse all files

11
package.yaml
View file

@ -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

118
src/Haboli/Euphoria/Api.hs
View file

@ -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

259
src/Haboli/Euphoria/Client.hs
View file

@ -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
-- <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
-- ^ 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

26
src/Haboli/Euphoria/Example.hs Normal file
View file

@ -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 ()