Add all session and chat room commands

The account, room host and staff commands are still missing though.

src/Haboli/Euphoria/Api.hs

@@ -11,19 +11,33 @@ module Haboli.Euphoria.Api
   , UserType(..)
   , UserId(..)
   -- * Asynchronous events
+  -- ** bounce-event
   , BounceEvent(..)
+  -- ** disconnect-event
   , DisconnectEvent(..)
+  -- ** hello-event
   , HelloEvent(..)
+  -- ** join-event
   , JoinEvent(..)
+  -- ** login-event
   , LoginEvent(..)
+  -- ** logout-event
   , LogoutEvent(..)
+  -- ** network-event
   , NetworkEvent(..)
+  -- ** nick-event
   , NickEvent(..)
+  -- ** edit-message-event
   , EditMessageEvent(..)
+  -- ** part-event
   , PartEvent(..)
+  -- ** ping-event
   , PingEvent(..)
+  -- ** pm-initiate-event
   , PmInitiateEvent(..)
+  -- ** send-event
   , SendEvent(..)
+  -- ** snapshot-event
   , SnapshotEvent(..)
   -- * Session commands
   -- ** auth
@@ -33,12 +47,24 @@ module Haboli.Euphoria.Api
   , PingCommand(..)
   , PingReply(..)
   -- * Chat room commands
+  -- ** get-message
+  , GetMessageCommand(..)
+  , GetMessageReply(..)
+  -- ** log
+  , LogCommand(..)
+  , LogReply(..)
   -- ** nick
   , NickCommand(..)
   , NickReply(..)
+  -- ** pm-initiate
+  , PmInitiateCommand(..)
+  , PmInitiateReply(..)
   -- ** send
   , SendCommand(..)
   , SendReply(..)
+  -- ** who
+  , WhoCommand(..)
+  , WhoReply(..)
   ) where
 
 import           Control.Monad
@@ -53,13 +79,12 @@ class ToJSONObject a where
   toJSONObject :: a -> Object
 
 fromPacket :: T.Text -> (Object -> Parser a) -> Value -> Parser a
-fromPacket packetType parser (Object o) = do
+fromPacket packetType parser v = parseJSON v >>= \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
@@ -84,31 +109,30 @@ instance FromJSON AuthOption where
 -- 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
+  { msgId              :: Snowflake
-  , msgParent    :: Maybe Snowflake
+  , msgParent          :: Maybe Snowflake
-  -- , msgPreviousEditId  :: Maybe Snowflake
+  , msgPreviousEditId  :: Maybe Snowflake
-  , msgTime      :: UTCTime
+  , msgTime            :: UTCTime
-  , msgSender    :: SessionView
+  , msgSender          :: SessionView
-  , msgContent   :: T.Text
+  , msgContent         :: T.Text
-  -- , msgEncryptionKeyId :: Maybe T.Text
+  , msgEncryptionKeyId :: Maybe T.Text
-  -- , msgEdited          :: Maybe UTCTime
+  , msgEdited          :: Maybe UTCTime
-  , msgDeleted   :: Maybe UTCTime
+  , msgDeleted         :: Maybe UTCTime
-  , msgTruncated :: Bool
+  , msgTruncated       :: Bool
   } deriving (Show)
 
 instance FromJSON Message where
-  parseJSON (Object v) = Message
+  parseJSON v = parseJSON v >>= \o -> Message
-    <$> v .: "id"
+    <$> o .: "id"
-    <*> v .:? "parent"
+    <*> o .:? "parent"
-    -- <*> v .:? "previous_edit_id"
+    <*> o .:? "previous_edit_id"
-    <*> (posixSecondsToUTCTime <$> v .: "time")
+    <*> (posixSecondsToUTCTime <$> o .: "time")
-    <*> v .: "sender"
+    <*> o .: "sender"
-    <*> v .: "content"
+    <*> o .: "content"
-    -- <*> v .:? "encryption_key_id"
+    <*> o .:? "encryption_key_id"
-    -- <*> v .:? "edited"
+    <*> o .:? "edited"
-    <*> (fmap posixSecondsToUTCTime <$> v .:? "deleted")
+    <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted")
-    <*> v .:? "truncated" .!= False
+    <*> o .:? "truncated" .!= False
-  parseJSON v = typeMismatch "Object" v
 
 data PersonalAccountView = PersonalAccountView
   { pavId    :: Snowflake
@@ -116,32 +140,37 @@ data PersonalAccountView = PersonalAccountView
   , pavEmail :: T.Text
   } deriving (Show)
 
+instance FromJSON PersonalAccountView where
+  parseJSON v = parseJSON v >>= \o -> PersonalAccountView
+    <$> o .: "id"
+    <*> o .: "name"
+    <*> o .: "email"
+
 -- | A 'SessionView' describes a session and its identity. See
 -- <http://api.euphoria.io/#sessionview>.
 data SessionView = SessionView
-  { svId        :: UserId
+  { svId                :: UserId
-  , svNick      :: T.Text
+  , svNick              :: T.Text
-  , svServerId  :: T.Text
+  , svServerId          :: T.Text
-  , svServerEra :: T.Text
+  , svServerEra         :: T.Text
-  , svSessionId :: T.Text
+  , svSessionId         :: T.Text
-  , svIsStaff   :: Bool
+  , svIsStaff           :: Bool
-  , svIsManager :: Bool
+  , svIsManager         :: Bool
-  -- , svClientAddress     :: Maybe T.Text
+  , svClientAddress     :: Maybe T.Text
-  -- , svRealClientAddress :: Maybe T.Text
+  , svRealClientAddress :: Maybe T.Text
   } deriving (Show)
 
 instance FromJSON SessionView where
-  parseJSON (Object v) = SessionView
+  parseJSON v = parseJSON v >>= \o -> SessionView
-    <$> v .: "id"
+    <$> o .: "id"
-    <*> v .: "name"
+    <*> o .: "name"
-    <*> v .: "server_id"
+    <*> o .: "server_id"
-    <*> v .: "server_era"
+    <*> o .: "server_era"
-    <*> v .: "session_id"
+    <*> o .: "session_id"
-    <*> v .:? "is_staff" .!= False
+    <*> o .:? "is_staff" .!= False
-    <*> v .:? "is_manager" .!= False
+    <*> o .:? "is_manager" .!= False
-    -- <*> v .:? "client_address"
+    <*> o .:? "client_address"
-    -- <*> v .:? "real_client_address"
+    <*> o .:? "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
@@ -170,27 +199,49 @@ data UserId = UserId
   , userSnowflake :: Snowflake
   } deriving (Show, Eq)
 
+instance ToJSON UserId where
+  toJSON uid =
+    let prefix = case userType uid of
+          Agent   -> "agent:"
+          Account -> "account:"
+          Bot     -> "bot:"
+          Other   -> ""
+    in  String $ prefix <> userSnowflake uid
+
 instance FromJSON UserId where
-  parseJSON (String v) = case T.breakOn ":" v of
+  parseJSON v = parseJSON v >>= \s -> case T.breakOn ":" s 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 -}
 
+{- bounce-event -}
+
 data BounceEvent = BounceEvent
   { bounceReason     :: Maybe T.Text
   , bounceAuthOption :: [AuthOption]
   } deriving (Show)
 
-data DisconnectEvent = DisconnectEvent
+instance FromJSON BounceEvent where
+  parseJSON = fromPacket "bounce-event" $ \o -> BounceEvent
+    <$> o .: "reason"
+    <*> o .: "auth_options"
+
+{- disconnect-event -}
+
+newtype DisconnectEvent = DisconnectEvent
   { disconnectReason :: T.Text
   } deriving (Show)
 
---TODO: Merge the account stuff with the PersonalAccountView?
+instance FromJSON DisconnectEvent where
+  parseJSON = fromPacket "disconnect-evnet" $ \o -> DisconnectEvent
+    <$> o .: "reason"
+
+{- hello-event -}
+
 data HelloEvent = HelloEvent
   { helloAccount              :: Maybe PersonalAccountView
   , helloSessionView          :: SessionView
@@ -200,7 +251,18 @@ data HelloEvent = HelloEvent
   , helloVersion              :: T.Text
   } deriving (Show)
 
-data JoinEvent = JoinEvent
+instance FromJSON HelloEvent where
+  parseJSON = fromPacket "hello-event" $ \o -> HelloEvent
+    <$> o .: "account"
+    <*> o .: "session"
+    <*> o .:? "account_has_access"
+    <*> o .:? "account_email_verified"
+    <*> o .: "room_is_private"
+    <*> o .: "version"
+
+{- join-event -}
+
+newtype JoinEvent = JoinEvent
   { joinSession :: SessionView
   } deriving (Show)
 
@@ -208,19 +270,40 @@ instance FromJSON JoinEvent where
   parseJSON = fromPacket "join-event" $ \o -> JoinEvent
     <$> parseJSON (Object o)
 
-data LoginEvent = LoginEvent
+{- login-event -}
+
+newtype LoginEvent = LoginEvent
   { loginAccountId :: Snowflake
   } deriving (Show)
 
+instance FromJSON LoginEvent where
+  parseJSON = fromPacket "login-event" $ \o -> LoginEvent
+    <$> o .: "acount_id"
+
+{- logout-event -}
+
 data LogoutEvent = LogoutEvent
   deriving (Show)
 
+instance FromJSON LogoutEvent where
+  parseJSON = fromPacket "logout-event" $ const (pure LogoutEvent)
+
+{- network-event -}
+
 data NetworkEvent = NetworkEvent
   { networkType      :: T.Text -- always "partition"
   , networkServerId  :: T.Text
   , networkServerEra :: T.Text
   } deriving (Show)
 
+instance FromJSON NetworkEvent where
+  parseJSON = fromPacket "network-event" $ \o -> NetworkEvent
+    <$> o .: "type"
+    <*> o .: "server_id"
+    <*> o .: "server_era"
+
+{- nick-event -}
+
 data NickEvent = NickEvent
   { nickSessionId :: T.Text
   , nickId        :: UserId
@@ -228,12 +311,28 @@ data NickEvent = NickEvent
   , nickTo        :: T.Text
   } deriving (Show)
 
+instance FromJSON NickEvent where
+  parseJSON = fromPacket "nick-event" $ \o -> NickEvent
+    <$> o .: "session_id"
+    <*> o .: "id"
+    <*> o .: "from"
+    <*> o .: "to"
+
+{- edit-message-event -}
+
 data EditMessageEvent = EditMessageEvent
   { editMessageMessage :: Message
   , editMessageEditId  :: Snowflake
   } deriving (Show)
 
-data PartEvent = PartEvent
+instance FromJSON EditMessageEvent where
+  parseJSON = fromPacket "EditMessageEvent" $ \o -> EditMessageEvent
+    <$> parseJSON (Object o)
+    <*> o .: "edit_id"
+
+{- part-event -}
+
+newtype PartEvent = PartEvent
   { partSession :: SessionView
   } deriving (Show)
 
@@ -241,6 +340,8 @@ instance FromJSON PartEvent where
   parseJSON = fromPacket "part-event" $ \o -> PartEvent
     <$> parseJSON (Object o)
 
+{- ping-event -}
+
 data PingEvent = PingEvent
   { pingTime :: UTCTime
   , pingNext :: UTCTime
@@ -251,6 +352,8 @@ instance FromJSON PingEvent where
     <$> (posixSecondsToUTCTime <$> o .: "time")
     <*> (posixSecondsToUTCTime <$> o .: "next")
 
+{- pm-initiate-event -}
+
 data PmInitiateEvent = PmInitiateEvent
   { pmInitiateFrom     :: UserId
   , pmInitiateFromNick :: T.Text
@@ -258,7 +361,16 @@ data PmInitiateEvent = PmInitiateEvent
   , pmInitiatePmId     :: Snowflake
   } deriving (Show)
 
-data SendEvent = SendEvent
+instance FromJSON PmInitiateEvent where
+  parseJSON = fromPacket "pm-initiate-event" $ \o -> PmInitiateEvent
+    <$> o .: "from"
+    <*> o .: "from_nick"
+    <*> o .: "from_room"
+    <*> o .: "pm_id"
+
+{- send-event -}
+
+newtype SendEvent = SendEvent
   { sendMessage :: Message
   } deriving (Show)
 
@@ -294,15 +406,30 @@ instance FromJSON SnapshotEvent where
 
 {- auth -}
 
-data AuthCommand = AuthWithPasscode T.Text
+newtype AuthCommand = AuthWithPasscode T.Text
   deriving (Show)
 
+instance ToJSONObject AuthCommand where
+  toJSONObject (AuthWithPasscode password) = toPacket "auth" $ object
+    [ "type" .= Passcode
+    , "passcode" .= password
+    ]
+
 data AuthReply = AuthSuccessful | AuthFailed T.Text
   deriving (Show)
 
+instance FromJSON AuthReply where
+  parseJSON = fromPacket "auth-reply" $ \o -> do
+    success <- o .: "success"
+    if success
+      then pure AuthSuccessful
+      -- The "reason" field *should* be filled in if the authentication fails,
+      -- but I'm always treating it as optional to be on the safe side.
+      else AuthFailed <$> o .:? "reason" .!= ""
+
 {- ping -}
 
-data PingCommand = PingCommand UTCTime
+newtype PingCommand = PingCommand UTCTime
   deriving (Show)
 
 instance ToJSONObject PingCommand where
@@ -310,7 +437,7 @@ instance ToJSONObject PingCommand where
     [ "time" .= utcTimeToPOSIXSeconds time
     ]
 
-data PingReply = PingReply UTCTime
+newtype PingReply = PingReply UTCTime
   deriving (Show)
 
 instance ToJSONObject PingReply where
@@ -324,9 +451,48 @@ instance FromJSON PingReply where
 
 {- Chat room commands -}
 
+{- get-message -}
+
+newtype GetMessageCommand = GetMessageCommand Snowflake
+  deriving (Show)
+
+instance ToJSONObject GetMessageCommand where
+  toJSONObject (GetMessageCommand mId) = toPacket "get-message" $ object
+    [ "id" .= mId
+    ]
+
+newtype GetMessageReply = GetMessageReply Message
+  deriving (Show)
+
+instance FromJSON GetMessageReply where
+  parseJSON = fromPacket "get-message-reply" $ \o -> GetMessageReply
+    <$> parseJSON (Object o)
+
+{- log -}
+
+data LogCommand = LogCommand Int (Maybe Snowflake)
+  deriving (Show)
+
+instance ToJSONObject LogCommand where
+  toJSONObject (LogCommand n Nothing) = toPacket "log" $ object
+    [ "n" .= n
+    ]
+  toJSONObject (LogCommand n (Just before)) = toPacket "log" $ object
+    [ "n" .= n
+    , "before" .= before
+    ]
+
+data LogReply = LogReply [Message] (Maybe Snowflake)
+  deriving (Show)
+
+instance FromJSON LogReply where
+  parseJSON = fromPacket "log-reply" $ \o -> LogReply
+    <$> o .: "log"
+    <*> o .:? "before"
+
 {- nick -}
 
-data NickCommand = NickCommand T.Text
+newtype NickCommand = NickCommand T.Text
   deriving (Show)
 
 instance ToJSONObject NickCommand where
@@ -348,6 +514,24 @@ instance FromJSON NickReply where
     <*> o .: "from"
     <*> o .: "to"
 
+{- pm-initiate -}
+
+newtype PmInitiateCommand = PmInitiateCommand UserId
+  deriving (Show)
+
+instance ToJSONObject PmInitiateCommand where
+  toJSONObject (PmInitiateCommand userId) = toPacket "pm-initiate" $ object
+    [ "user_id" .= userId
+    ]
+
+data PmInitiateReply = PmInitiateReply Snowflake T.Text
+  deriving (Show)
+
+instance FromJSON PmInitiateReply where
+  parseJSON = fromPacket "pm-intiate-reply" $ \o -> PmInitiateReply
+    <$> o .: "pm_id"
+    <*> o .: "to_nick"
+
 {- send -}
 
 data SendCommand = SendCommand T.Text (Maybe Snowflake)
@@ -359,9 +543,24 @@ instance ToJSONObject SendCommand where
   toJSONObject (SendCommand content (Just parent)) =
     toPacket "send" $ object ["content" .= content, "parent" .= parent]
 
-data SendReply = SendReply Message
+newtype SendReply = SendReply Message
   deriving (Show)
 
 instance FromJSON SendReply where
   parseJSON = fromPacket "send-reply" $ \o -> SendReply
     <$> parseJSON (Object o)
+
+{- who -}
+
+data WhoCommand = WhoCommand
+  deriving (Show)
+
+instance ToJSONObject WhoCommand where
+  toJSONObject WhoCommand = toPacket "who" $ object []
+
+newtype WhoReply = WhoReply [SessionView]
+  deriving (Show)
+
+instance FromJSON WhoReply where
+  parseJSON = fromPacket "who-reply" $ \o -> WhoReply
+    <$> o .: "listing"

src/Haboli/Euphoria/Client.hs

@@ -27,12 +27,19 @@ module Haboli.Euphoria.Client
   , wait
   -- ** Euphoria commands
   -- *** Session commands
+  , auth
+  , ping
   , pingReply
   -- *** Chat room commands
+  , getMessage
+  , getLog
+  , getLogBefore
   , nick
-  , Haboli.Euphoria.Client.send
+  , initiatePm
+  , send
   , reply
   , reply'
+  , who
   ) where
 
 import           Control.Applicative
@@ -51,7 +58,7 @@ import qualified Data.Map.Strict            as Map
 import           Data.Maybe
 import qualified Data.Text                  as T
 import           Data.Time
-import           Network.Socket
+import qualified Network.Socket             as S
 import qualified Network.WebSockets         as WS
 import qualified Wuss                       as WSS
 
@@ -172,8 +179,8 @@ runWebsocketThread info =
 -- | Configuration for the websocket connection. The websocket connection always
 -- uses https.
 data ConnectionConfig = ConnectionConfig
-  { cdHost         :: HostName
+  { cdHost         :: S.HostName
-  , cdPort         :: PortNumber
+  , cdPort         :: S.PortNumber
   , cdPath         :: String
   , cdPingInterval :: Int
   } deriving (Show)
@@ -205,7 +212,7 @@ withRoom room config = config{cdPath = "/room/" ++ room ++ "/ws"}
 -- connection are not caught. This will probably change soon.
 runClient :: ConnectionConfig -> Client e a -> IO (Either (ClientException e) a)
 runClient details (Client stack) =
-  withSocketsDo $
+  S.withSocketsDo $
   WSS.runSecureClient (cdHost details) (cdPort details) (cdPath details) $ \connection -> do
     awaiting <- newTVarIO Map.empty
     eventChan <- newTChanIO
@@ -457,22 +464,67 @@ sendPacketWithReply packet = do
 
 {- Session commands -}
 
+-- | Try to authenticate with a password and return the error reason if it
+-- *doesn't* succeed.
+auth :: T.Text -> Client e (Either T.Text ())
+auth password = do
+  answer <- sendPacketWithReply $ AuthWithPasscode password
+  pure $ case answer of
+    AuthSuccessful    -> Right ()
+    AuthFailed reason -> Left reason
+
+-- | Send a ping (not a websocket ping) to the server, who has to reply with the
+-- same time stamp.
+ping :: UTCTime -> Client e UTCTime
+ping time = do
+  PingReply time' <- sendPacketWithReply $ PingCommand time
+  pure time'
+
 -- | Send a reply to a 'PingEvent' sent by the server.
 pingReply :: UTCTime -> Client e ()
 pingReply = void . sendPacket . PingReply
 
 {- Chat room commands -}
 
--- | Change your own nick. Returns the new nick.
+-- | Retrieve the full content of a single message in the room.
-nick :: T.Text -> Client e T.Text
+getMessage :: Snowflake -> Client e Message
+getMessage mId = do
+  GetMessageReply msg <- sendPacketWithReply $ GetMessageCommand mId
+  pure msg
+
+-- | @'getLog' n@ requests @n@ messages from the room's log, starting with the
+-- latest message and going backwards by the send time/message id.
+getLog :: Int -> Client e [Message]
+getLog n = do
+  LogReply msgs _ <- sendPacketWithReply $ LogCommand n Nothing
+  pure msgs
+
+-- | @'getLogBefore' n before@ works similar to @'getLog' n@, but it requests
+-- messages starting with the latest message before the message with id
+-- @before@.
+getLogBefore :: Int -> Snowflake -> Client e [Message]
+getLogBefore n before = do
+  LogReply msgs _ <- sendPacketWithReply $ LogCommand n (Just before)
+  pure msgs
+
+-- | Initiate a PM with another user. Returns a tuple @(pmId, toNick)@, where
+-- @pmId@ is the id of the PM room, and @toNick@ is the nick of the user the
+-- request was sent to.
+initiatePm :: UserId -> Client e (Snowflake, T.Text)
+initiatePm uId = do
+  PmInitiateReply pmId toNick <- sendPacketWithReply $ PmInitiateCommand uId
+  pure (pmId, toNick)
+
+-- | Change your own nick. Returns a tuple @(oldNick, newNick)@.
+nick :: T.Text -> Client e (T.Text, T.Text)
 nick targetNick = do
   answer <- sendPacketWithReply $ NickCommand targetNick
-  pure $ nickReplyTo answer
+  pure (nickReplyFrom answer, nickReplyTo answer)
 
 -- | Send a new top-level message. Returns the sent message.
 send :: T.Text -> Client e Message
 send content = do
-  (SendReply msg) <- sendPacketWithReply $ SendCommand content Nothing
+  SendReply msg <- sendPacketWithReply $ SendCommand content Nothing
   pure msg
 
 -- | Reply to a message via its id. Returns the sent message.
@@ -486,3 +538,9 @@ reply' messageId content = do
 -- This function is equivalent to @'reply'' . 'msgId'@.
 reply :: Message -> T.Text -> Client e Message
 reply = reply' . msgId
+
+-- | See who is currently connected to the room.
+who :: Client e [SessionView]
+who = do
+  WhoReply sessions <- sendPacketWithReply WhoCommand
+  pure sessions