Begin implementing the euphoria API

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
+-- <http://api.euphoria.io/#message>.
+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
+-- <http://api.euphoria.io/#sessionview>.
+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 <http://api.euphoria.io/#snowflake>.
+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
+-- <http://api.euphoria.io/#userid>.
+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

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
+-- <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.
+  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"

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