diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs new file mode 100644 index 0000000..4edb657 --- /dev/null +++ b/src/Haboli/Euphoria/Api.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.Api + ( + -- * Basic types + AuthOption(..) + , Message(..) + , PersonalAccountView + , SessionView(..) + , Snowflake + , UserType(..) + , UserId(..) + -- * Asynchronous events + , BounceEvent + , DisconnectEvent + , HelloEvent + , JoinEvent + , LoginEvent + , LogoutEvent + , NetworkEvent + , NickEvent + , EditMessageEvent + , PartEvent + , PingEvent + , PmInitiateEvent + , SendEvent + , SnapshotEvent + -- * Session commands + -- ** auth + , AuthCommand + , AuthReply + -- ** ping + , PingCommand + , PingReply + ) where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T +import Data.Time +import Data.Time.Clock.POSIX + +{- Basic types -} + +data AuthOption = Passcode + deriving (Show) + +instance ToJSON AuthOption where + toJSON Passcode = String "passcode" + +instance FromJSON AuthOption where + parseJSON (String "passcode") = pure Passcode + 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 +-- . +data Message = Message + { msgId :: Snowflake + , msgParent :: Maybe Snowflake + -- , msgPreviousEditId :: Maybe Snowflake + , msgTime :: UTCTime + , msgSender :: SessionView + , msgContent :: T.Text + -- , msgEncryptionKeyId :: Maybe T.Text + -- , msgEdited :: Maybe UTCTime + , msgDeleted :: Maybe UTCTime + , msgTruncated :: Bool + } deriving (Show) + +instance FromJSON Message where + parseJSON (Object v) = Message + <$> v .: "id" + <*> v .:? "parent" + -- <*> v .:? "previous_edit_id" + <*> (posixSecondsToUTCTime <$> v .: "time") + <*> v .: "sender" + <*> v .: "content" + -- <*> v .:? "encryption_key_id" + -- <*> v .:? "edited" + <*> (fmap posixSecondsToUTCTime <$> v .:? "deleted") + <*> v .:? "truncated" .!= False + parseJSON v = typeMismatch "Object" v + +data PersonalAccountView = PersonalAccountView + { pavId :: Snowflake + , pavName :: T.Text + , pavEmail :: T.Text + } deriving (Show) + +-- | A 'SessionView' describes a session and its identity. See +-- . +data SessionView = SessionView + { svId :: UserId + , svNick :: T.Text + , svServerId :: T.Text + , svServerEra :: T.Text + , svSessionId :: T.Text + , svIsStaff :: Bool + , svIsManager :: Bool + -- , svClientAddress :: Maybe T.Text + -- , svRealClientAddress :: Maybe T.Text + } deriving (Show) + +instance FromJSON SessionView where + parseJSON (Object v) = SessionView + <$> v .: "id" + <*> v .: "name" + <*> v .: "server_id" + <*> v .: "server_era" + <*> v .: "session_id" + <*> v .:? "is_staff" .!= False + <*> v .:? "is_manager" .!= False + -- <*> v .:? "client_address" + -- <*> v .:? "real_client_address" + parseJSON v = typeMismatch "Object" v + +-- | 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. See . +type Snowflake = T.Text + +-- | The type of session a client may have. +data UserType + = Agent + -- ^ The client is a person that is not logged in to any account. + | Account + -- ^ The client is a person that is logged into an account. + | Bot + -- ^ The client is a bot. Bots can never be logged in. + | Other + -- ^ The client has none of the other user types. While this value does not + -- occur nowadays, some messages in the room logs are still from a time before + -- the distinction of user types were introduced. + deriving (Show, Eq) + +-- | A 'UserId' identifies a user. It consists of two parts: The type of +-- session, and a unique value for that type of session. See +-- . +data UserId = UserId + { userType :: UserType + , userSnowflake :: Snowflake + } deriving (Show, Eq) + +instance FromJSON UserId where + parseJSON (String v) = case T.breakOn ":" v of + (snowflake, "") -> pure $ UserId Other snowflake + ("agent", snowflake) -> pure $ UserId Agent $ T.drop 1 snowflake + ("account", snowflake) -> pure $ UserId Account $ T.drop 1 snowflake + ("bot", snowflake) -> pure $ UserId Bot $ T.drop 1 snowflake + _ -> fail "invalid user id label" + parseJSON v = typeMismatch "String" v + +{- Asynchronous events -} + +data BounceEvent = BounceEvent + { bounceReason :: Maybe T.Text + , bounceAuthOption :: [AuthOption] + } deriving (Show) + +data DisconnectEvent = DisconnectEvent + { disconnectReason :: T.Text + } deriving (Show) + +--TODO: Merge the account stuff with the PersonalAccountView? +data HelloEvent = HelloEvent + { helloAccount :: Maybe PersonalAccountView + , helloSessionView :: SessionView + , helloAccountHasAccess :: Maybe Bool + , helloAccountEmailVerified :: Maybe Bool + , helloRoomIsPrivate :: Bool + , helloVersion :: T.Text + } deriving (Show) + +data JoinEvent = JoinEvent + { joinSession :: SessionView + } deriving (Show) + +data LoginEvent = LoginEvent + { loginAccountId :: Snowflake + } deriving (Show) + +data LogoutEvent = LogoutEvent + deriving (Show) + +data NetworkEvent = NetworkEvent + { networkType :: T.Text -- always "partition" + , networkServerId :: T.Text + , networkServerEra :: T.Text + } deriving (Show) + +data NickEvent = NickEvent + { nickSessionId :: T.Text + , nickId :: UserId + , nickFrom :: T.Text + , nickTo :: T.Text + } deriving (Show) + +data EditMessageEvent = EditMessageEvent + { editMessageMessage :: Message + , editMessageEditId :: Snowflake + } deriving (Show) + +data PartEvent = PartEvent + { partSession :: SessionView + } deriving (Show) + +data PingEvent = PingEvent + { pingTime :: UTCTime + , pingNext :: UTCTime + } deriving (Show) + +data PmInitiateEvent = PmInitiateEvent + { pmInitiateFrom :: UserId + , pmInitiateFromNick :: T.Text + , pmInitiateFromRoom :: T.Text + , pmInitiatePmId :: Snowflake + } deriving (Show) + +data SendEvent = SendEvent + { sendMessage :: Message + } deriving (Show) + +data SnapshotEvent = SnapshotEvent + { snapshotIdentity :: UserId + , snapshotVersion :: T.Text + , snapshotListing :: [SessionView] + , snapshotLog :: [Message] + , snapshotNick :: Maybe T.Text + , snapshotPmWithNick :: T.Text + , snapshotPmWithUserId :: UserId + } deriving (Show) + +{- Session commands -} + +{- auth -} + +data AuthCommand = AuthWithPasscode T.Text + deriving (Show) + +data AuthReply = AuthSuccessful | AuthFailed T.Text + deriving (Show) + +{- ping -} + +data PingCommand = PingCommand UTCTime + deriving (Show) + +data PingReply = PingReply UTCTime + deriving (Show) + +{- Chat room commands -} + +{- nick -} + +data NickCommand = NickCommand T.Text + deriving (Show) + +instance ToJSON NickCommand where + toJSON (NickCommand nick) = object + [ "type" .= String "nick" + , "data" .= object ["name" .= nick] + ] + +data NickReply = NickReply + { nickReplySessionId :: T.Text + , nickReplyId :: UserId + , nickReplyFrom :: T.Text + , nickReplyTo :: T.Text + } deriving (Show) + +instance FromJSON NickReply where + parseJSON (Object 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 new file mode 100644 index 0000000..4251eed --- /dev/null +++ b/src/Haboli/Euphoria/Client.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} + +module Haboli.Euphoria.Client where + +import Control.Exception +import Control.Concurrent +import Control.Concurrent.Chan +import Data.Foldable +import Control.Monad.Trans.Class +import Data.Traversable +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.IO.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 qualified Data.Map.Strict as Map +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 +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. + deriving (Show) + +--TODO: Decide between Exception and Error +--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) + -- ^ @'ServerError' error throttled@ is an error sent by the server in + -- response to a command. @error@ is a message that appears if a command + -- fails. @throttled@ is a message that appears if the client should slow down + -- its command rate. + | StoppedException + | DecodeException T.Text + -- ^ At some point during decoding a websocket packet, something went wrong. + | CustomError e + deriving (Show) + +-- | 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) + +-- | 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)) + +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 + } + +-- This type declaration feels lispy in its parenthesisness +newtype Client e a = Client (ReaderT (ClientInfo e) + (ExceptT (ClientException e) + IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +{- The websocket listening thread -} + +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)) + +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 + 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 + +{- Running the Client monad -} + +data ConnectionDetails = ConnectionDetails + { cdHost :: HostName + , cdPort :: PortNumber + , cdPath :: String + , cdPingInterval :: Int + } deriving (Show) + +defaultDetails :: ConnectionDetails +defaultDetails = ConnectionDetails + { cdHost = "euphoria.io" + , cdPort = 443 + , cdPath = "/room/test/ws" + , cdPingInterval = 10 + } + +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 + 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 + , ciStopped = stopped + } + runExceptT $ runReaderT stack info + +{- Private operations -} + +throwRaw :: ClientException e -> Client e a +throwRaw e = Client $ lift $ throwE e + +getClientInfo :: Client e (ClientInfo e) +getClientInfo = Client ask + +newPacketId :: Client e T.Text +newPacketId = do + packetIdTVar <- ciPacketId <$> getClientInfo + liftIO $ atomically $ do + currentId <- readTVar packetIdTVar + modifyTVar packetIdTVar (+1) + pure $ T.pack $ show currentId + +-- | Attempt to send a message via the websocket connection, catching and +-- re-throwing all relevant exceptions inside the 'Client' monad. +safeSend :: ToJSON a => WS.Connection -> a -> Client e () +safeSend connection packet = do + result <- liftIO + $ handle convertToException + $ Nothing <$ WS.sendTextData connection (encode packet) + case result of + Nothing -> pure () + Just e -> throwRaw e + where + convertToException :: WS.ConnectionException -> IO (Maybe (ClientException e)) + convertToException (WS.CloseRequest _ _) = pure $ Just StoppedException + convertToException WS.ConnectionClosed = pure $ Just StoppedException + convertToException (WS.ParseException message) = pure $ Just $ DecodeException + $ "could not parse websockets stream, client sent garbage: " <> T.pack message + convertToException (WS.UnicodeException message) = pure $ Just $ DecodeException + $ "could not decode unicode: " <> T.pack message + +-- | Send a packet and automatically add a packet id +sendPacket :: Object -> 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) + safeSend connection packetWithId + pure packetId + +-- | Send a packet and wait for a reply from the server. +sendPacketWithReply :: FromJSON r => Object -> Client e r +sendPacketWithReply packet = do + info <- getClientInfo + packetId <- sendPacket packet + maybeReplyVar <- liftIO $ atomically $ do + stopped <- readTVar $ ciStopped info + if stopped + then pure Nothing + else do + replyVar <- newEmptyTMVar + modifyTVar (ciAwaiting info) (Map.insert packetId 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 + case reply of + Left e -> throwRaw e + Right r -> pure r + +{- Public operations -} + +getHost :: Client e HostName +getHost = cdHost . ciDetails <$> getClientInfo + +getPort :: Client e PortNumber +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" diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..16e6de6 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 524155 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/19.yaml + sha256: 9f79f6494473c9b46911364b94c4b5ef19ca8d35ebf62e46697cf651f198ee19 + original: lts-14.19