mvclient-0.3: src/Network/Metaverse.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
This is the high-level interface to the system. At this point, it's not
intended to be a replacement for the low-level interface, but rather just
a set of convenient functions that work when they do what you want. In
the future, this module may grow into a general-purpose replacement to the
low-level interface.
-}
module Network.Metaverse (
-- * Connecting to the simulator
-- $connecting
login,
sendAgentThrottle,
botThrottle,
sendAgentUpdate,
-- * Name/key conversion
agentName2Key,
agentKey2Name,
groupKey2Name,
-- * Communicating
-- $communicating
sendSimpleIM,
ChatMethod(..),
sendChat,
whisper,
say,
shout,
-- * Group management
getGroupRoles,
getGroupMembers,
addGroupRole,
delGroupRole,
inviteToGroup,
acceptGroupInvite,
-- * Miscellaneous
acceptFriendship,
giveMoney,
getBalance,
estateBan,
estateUnban,
-- * Low-level adapters
-- $lowlevel
handlePackets,
handlePackets_,
expectResponse,
bytesToString,
stringToBytes,
module Network.Metaverse.Circuit,
module Network.Metaverse.PacketTypes
) where
import Control.Concurrent
import Control.Monad
import Data.Binary
import Data.Binary.Put
import Data.Binary.IEEE754
import Data.Char
import Data.Maybe
import Data.UUID hiding (null)
import Data.UUID.V1
import Network.Metaverse.PacketTypes
import Network.Metaverse.Circuit
import Network.Metaverse.Login
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
{- ==================================================================
Connecting to the simulator
================================================================== -}
{- $connecting
Logging in to a simulator is done with 'login'. The result is a 'Circuit',
which is then passed to the other functions in this module. The low-level
module "Network.Metaverse.Circuit" also contains functions for managing
circuits.
While open, a circuit will automatically attempt to keep the connection
open by acknowledging packets, responding to pings, and so forth.
-}
{-|
Logs in to a Second Life simulator being tunneled through port 8001 on
localhost. Tunneling is very important, as we don't use SSL here, but
Second Life requires it.
-}
login :: String -- ^ First name of avatar
-> String -- ^ Last name of avatar
-> String -- ^ Password
-> IO Circuit
login firstName lastName password = do
token <- loginXmlRpc firstName lastName password
circ <- circuitConnect token
forkIO $ regionHandshaker circ =<< dupChan (circuitIncoming circ)
circuitSend circ True $ CompleteAgentMovement $ CompleteAgentMovement_AgentData
(tokenAgentID token) (tokenSessionID token) (tokenCircuitCode token)
return circ
{-
This non-exported bit just listens for the RegionHandshake packet, and
responds to it. Without it, the region will give up on us and disconnect
after a minute or so.
-}
regionHandshaker :: Circuit -> Chan (Maybe PacketBody) -> IO ()
regionHandshaker circ source = do
p <- readChan source
case p of
Just (RegionHandshake _ _ _) -> do
circuitSend circ True $ RegionHandshakeReply
(RegionHandshakeReply_AgentData (circuitAgentID circ) (circuitSessionID circ))
(RegionHandshakeReply_RegionInfo 0)
Just _ -> regionHandshaker circ source
Nothing -> return ()
{-|
Sends a message requesting the throttling of certain kinds of data from the
server. This can be used to save some network bandwidth and processing
time.
-}
sendAgentThrottle :: Circuit -- ^ The circuit to operate in
-> Float -- ^ Limit on resent reliable packets
-> Float -- ^ Limit on land shapes and terraforming
-> Float -- ^ Limit on wind speeds and directions
-> Float -- ^ Limit on cloud locations
-> Float -- ^ Limit on tasks such as agents or scripts
-> Float -- ^ Limit on texture data downloads
-> Float -- ^ Limit on asset data from inventory
-> IO ()
sendAgentThrottle circ resend land wind cloud task texture asset = do
let putter = do putFloat32le resend
putFloat32le land
putFloat32le wind
putFloat32le cloud
putFloat32le task
putFloat32le texture
putFloat32le asset
let bin = B.concat (L.toChunks (runPut putter))
circuitSend circ True $ AgentThrottle
(AgentThrottle_AgentData (circuitAgentID circ) (circuitSessionID circ) (circuitCode circ))
(AgentThrottle_Throttle 0 bin)
{-|
Limits bandwidths in a sensible way for a bot: that is, a non-graphical
viewer that does not need to render the scene.
-}
botThrottle :: Circuit -- ^ The circuit to operate in
-> IO ()
botThrottle circ = sendAgentThrottle circ 50000 0 0 0 50000 0 220000
{-|
Sends an agent update message to the sim. This message updates the sim
on the agent's idea of its current location, direction it is facing, etc.
These are not sent automatically, and not sending them will tend to make
the agent non-physical. However, they are not required to remain logged
in, so some bots may not wish to bother with them.
-}
sendAgentUpdate :: Circuit -- ^ The circuit to operate in
-> IO ()
sendAgentUpdate circ =
circuitSend circ True $ AgentUpdate $ AgentUpdate_AgentData
(circuitAgentID circ) (circuitSessionID circ)
(0,0,0,1) (0,0,0,1) 0 (128,128,20) (1,0,0) (0,1,0) (0,0,1) 128.0 0 0
{- ==================================================================
Name/key conversion
================================================================== -}
{-|
Converts an agent name to a key, by searching in the directory and
looking for a matching agent.
-}
agentName2Key :: Circuit -- ^ The circuit to operate in
-> String -- ^ First name of the target avatar
-> String -- ^ Last name of the target avatar
-> IO (Maybe UUID)
agentName2Key circ first last = do
Just qid <- nextUUID
let req = DirFindQuery
(DirFindQuery_AgentData (circuitAgentID circ) (circuitSessionID circ))
(DirFindQuery_QueryData qid (stringToBytes $ first ++ " " ++ last) 1 0)
fmap join $ expectResponse circ req $ \p -> case p of
DirPeopleReply _ (DirPeopleReply_QueryData qid') answers | qid == qid' -> do
let f (DirPeopleReply_QueryReplies key fn ln _ _ _)
| map toLower first == map toLower (bytesToString fn)
&& map toLower last == map toLower (bytesToString ln)
= Just key
f _ = Nothing
return $ Just $ listToMaybe $ catMaybes $ map f answers
_ -> return Nothing
{-|
Converts an agent key to a matching first and last name.
-}
agentKey2Name :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ The key for which to look up a name
-> IO (Maybe (String, String))
agentKey2Name circ key = do
let req = UUIDNameRequest [ UUIDNameRequest_UUIDNameBlock key ]
expectResponse circ req $ \p -> case p of
UUIDNameReply names -> do
let results = catMaybes $ map (\(UUIDNameReply_UUIDNameBlock key' first last) ->
if key == key' then Just (bytesToString first, bytesToString last) else Nothing) names
if null results then return Nothing else return (Just (head results))
_ -> return Nothing
{-|
Converts a group key to a matching group name.
-}
groupKey2Name :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ The key for which to look up a name
-> IO (Maybe String)
groupKey2Name circ key = do
let req = UUIDGroupNameRequest [ UUIDGroupNameRequest_UUIDNameBlock key ]
expectResponse circ req $ \p -> case p of
UUIDGroupNameReply names -> do
let results = catMaybes $ map (\(UUIDGroupNameReply_UUIDNameBlock key' name) ->
if key == key' then Just (bytesToString name) else Nothing) names
if null results then return Nothing else return (Just (head results))
_ -> return Nothing
{- ==================================================================
Communicating
================================================================== -}
{- $communicating
These provide a very simple set of functions for sending communications
to other people in the sim. In general, receiving communication must be
handled with the low-level interface at this time.
-}
{-|
Sends an instant message (IM) to another avatar. Waits for the sim to
acknowledge receipt of the message, and returns True if it was received,
or False if the message could not be sent.
-}
sendSimpleIM :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ The UUID of the intended recipient
-> String -- ^ The message to send
-> IO Bool
sendSimpleIM circ toAgentID msg =
circuitSendSync circ $ ImprovedInstantMessage
(ImprovedInstantMessage_AgentData
(circuitAgentID circ) (circuitSessionID circ))
(ImprovedInstantMessage_MessageBlock
False toAgentID 0 nil (0,0,0) 0 0 nil 0 (B.pack [0])
(stringToBytes msg) B.empty)
{-|
A method of speaking. This controls the distance within which other tasks
and avatars will hear the communication. Other avatar's clients will also
typically display an indication if a communication is a whisper or shout.
-}
data ChatMethod = Whisper -- ^ Audible within 10 meters
| Say -- ^ Audible within 20 meters
| Shout -- ^ Audible within 100 meters
deriving (Eq, Enum)
{-|
Sends a chat communication. This is a more general function: for specific
forms, see 'say', 'shout', and 'whisper'.
-}
sendChat :: Circuit -- ^ The circuit to operate in
-> Int -- ^ The channel number to speak in. 0 is normal chat.
-> ChatMethod -- ^ The method used to speak
-> String -- ^ What to say
-> IO Bool
sendChat circ channel method msg =
circuitSendSync circ $ ChatFromViewer
(ChatFromViewer_AgentData
(circuitAgentID circ) (circuitSessionID circ))
(ChatFromViewer_ChatData
(stringToBytes msg) (fromIntegral $ fromEnum method) (fromIntegral channel))
{-|
Sends a whisper to normal chat.
-}
whisper :: Circuit -- ^ The circuit to operate in
-> String -- ^ What to say
-> IO Bool
whisper circ msg = sendChat circ 0 Whisper msg
{-|
Sends an ordinary message to normal chat.
-}
say :: Circuit -- ^ The circuit to operate in
-> String -- ^ What to say
-> IO Bool
say circ msg = sendChat circ 0 Say msg
{-|
Sends a shout to normal chat.
-}
shout :: Circuit -- ^ The circuit to operate in
-> String -- ^ What to say
-> IO Bool
shout circ msg = sendChat circ 0 Shout msg
{- ==================================================================
Group management
================================================================== -}
{-|
Retrieves a list of role names and their UUIDs in a group. Returns Nothing
if such a list is not available (generally because the request could not
be sent, or the circuit was closed before a reply was received.
-}
getGroupRoles :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the group to ask about
-> IO (Maybe [(String, UUID)])
getGroupRoles circ groupid = do
Just rqid <- nextUUID
let req = GroupRoleDataRequest
(GroupRoleDataRequest_AgentData (circuitAgentID circ) (circuitSessionID circ))
(GroupRoleDataRequest_GroupData groupid rqid)
expectResponse circ req $ \ p -> case p of
GroupRoleDataReply _ (GroupRoleDataReply_GroupData _ rqid' _) roles | rqid == rqid' -> do
let f (GroupRoleDataReply_RoleData rid name _ _ _ _) =
(takeWhile (/= '\0') $ map (chr . fromIntegral) $ B.unpack name, rid)
return $ Just (map f roles)
_ -> return Nothing
{-|
Retrieves a list of members in a group. Returns Nothing if such a list is
not available (generally because the request could not be sent, or the
circuit was closed before a reply was received.
-}
getGroupMembers :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the group to ask about
-> IO (Maybe [UUID])
getGroupMembers circ groupid = do
Just rqid <- nextUUID
memlist <- newMVar []
let req = GroupMembersRequest
(GroupMembersRequest_AgentData (circuitAgentID circ) (circuitSessionID circ))
(GroupMembersRequest_GroupData groupid rqid)
expectResponse circ req $ \p -> case p of
GroupMembersReply _ (GroupMembersReply_GroupData _ rqid' n) recs | rqid == rqid' -> do
let theseMembers = map groupMembersReply_MemberData_AgentID recs
members <- takeMVar memlist
let members' = members ++ theseMembers
putMVar memlist members'
if length members' >= fromIntegral n then return (Just members') else return Nothing
_ -> return Nothing
{-|
Adds a group member to a role. The member must already belong to the
group.
-}
addGroupRole :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the group in which to act
-> UUID -- ^ UUID of the group member to act on
-> UUID -- ^ UUID of the role to add
-> IO ()
addGroupRole circ groupid personid roleid = do
circuitSend circ True $ GroupRoleChanges
(GroupRoleChanges_AgentData (circuitAgentID circ) (circuitSessionID circ) groupid)
[ (GroupRoleChanges_RoleChange roleid personid 0) ]
{-|
Removes a group member from a role. If the group member is not in that
role or the group, has no effect.
-}
delGroupRole :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the group in which to act
-> UUID -- ^ UUID of the group member to act on
-> UUID -- ^ UUID of the role to delete
-> IO ()
delGroupRole circ groupid personid roleid = do
circuitSend circ True $ GroupRoleChanges
(GroupRoleChanges_AgentData (circuitAgentID circ) (circuitSessionID circ) groupid)
[ (GroupRoleChanges_RoleChange roleid personid 1) ]
{-|
Invites an avatar to join a group.
-}
inviteToGroup :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the group to which to invite
-> UUID -- ^ UUID of the avatar to invite
-> UUID -- ^ UUID of the role to invite to. The zero UUID
-- is always the /Everyone/ role.
-> IO ()
inviteToGroup circ groupid personid roleid = do
circuitSend circ True $ InviteGroupRequest
(InviteGroupRequest_AgentData (circuitAgentID circ) (circuitSessionID circ))
(InviteGroupRequest_GroupData groupid)
[ (InviteGroupRequest_InviteData personid roleid) ]
{-|
Accepts a group invitation sent to this avatar. This requires a UUID for
the invitation, which is normally obtained from the
'ImprovedInstantMessage' packet carrying the group invitation.
Note that if the invitation had a cost associated, then accepting it will
cost money, so be careful about automatically accepting invitations.
-}
acceptGroupInvite :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the group to join
-> UUID -- ^ UUID of the invitation we are accepting
-> IO ()
acceptGroupInvite circ groupID inviteID =
circuitSend circ True $
ImprovedInstantMessage
(ImprovedInstantMessage_AgentData
(circuitAgentID circ) (circuitSessionID circ))
(ImprovedInstantMessage_MessageBlock
False groupID 0 nil (0, 0, 0) 0 35 inviteID 0
(stringToBytes "name") (stringToBytes "message") (B.pack [0]))
{- ==================================================================
Miscellaneous
================================================================== -}
{-|
Accepts a friendship offer from another avatar. This requires having a
UUID for the offer, usually obtained from the 'ImprovedInstantMessage'
packet bearing the friendship offer.
-}
acceptFriendship :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ This UUID of the friendship offer
-> IO ()
acceptFriendship circ offerID =
circuitSend circ True $
AcceptFriendship
(AcceptFriendship_AgentData (circuitAgentID circ) (circuitSessionID circ))
(AcceptFriendship_TransactionBlock offerID)
[]
{-|
Pays money to another avatar.
-}
giveMoney :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the avatar to pay
-> Int -- ^ Amount to pay
-> IO ()
giveMoney circ toID amt = do
circuitSend circ True $ MoneyTransferRequest
(MoneyTransferRequest_AgentData (circuitAgentID circ) (circuitSessionID circ))
(MoneyTransferRequest_MoneyData (circuitAgentID circ) toID 0 (fromIntegral amt) 0 0 5001 (B.pack [ 0 ]))
{-|
Requests this avatar's current balance of virtual currency. If the
balance is not available or the circuit is closed before it is received,
the result is 'Nothing'.
-}
getBalance :: Circuit -- ^ The circuit to operate in
-> IO (Maybe Int)
getBalance circ = do
Just txid <- nextUUID
let req = MoneyBalanceRequest
(MoneyBalanceRequest_AgentData (circuitAgentID circ) (circuitSessionID circ))
(MoneyBalanceRequest_MoneyData txid)
fmap join $ expectResponse circ req $ \ p -> case p of
(MoneyBalanceReply (MoneyBalanceReply_MoneyData _ txid' True (fromIntegral -> bal) _ _ _)) | txid == txid' -> return (Just (Just bal))
(MoneyBalanceReply (MoneyBalanceReply_MoneyData _ txid' False _ _ _ _)) | txid == txid' -> return (Just Nothing)
_ -> return Nothing
{-|
Bans a given avatar from the current estate. This requires that the avatar
logged in on the circuit be an estate manager for the estate.
-}
estateBan :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the avatar to ban
-> IO ()
estateBan circ uuid = do
let flag = 64
Just invoice <- nextUUID
circuitSend circ True $ EstateOwnerMessage
(EstateOwnerMessage_AgentData (circuitAgentID circ) (circuitSessionID circ) nil)
(EstateOwnerMessage_MethodData (stringToBytes "estateaccessdelta") invoice)
[ EstateOwnerMessage_ParamList (stringToBytes (show (circuitAgentID circ))),
EstateOwnerMessage_ParamList (stringToBytes (show flag)),
EstateOwnerMessage_ParamList (stringToBytes (show uuid)) ]
{-|
Unbans a given avatar from the current estate. This requires that the
avatar logged in on the circuit be an estate manager for the estate.
-}
estateUnban :: Circuit -- ^ The circuit to operate in
-> UUID -- ^ UUID of the avatar to unban
-> IO ()
estateUnban circ uuid = do
let flag = 128
Just invoice <- nextUUID
circuitSend circ True $ EstateOwnerMessage
(EstateOwnerMessage_AgentData (circuitAgentID circ) (circuitSessionID circ) nil)
(EstateOwnerMessage_MethodData (stringToBytes "estateaccessdelta") invoice)
[ EstateOwnerMessage_ParamList (stringToBytes (show (circuitAgentID circ))),
EstateOwnerMessage_ParamList (stringToBytes (show flag)),
EstateOwnerMessage_ParamList (stringToBytes (show uuid)) ]
{- ==================================================================
Low-level adapters
================================================================== -}
{- $lowlevel
These functions provide a bridge from the high-level interface in this
module to the low-level interface in some other modules. You can use
these to define your own wrappers for parts of the protocol that don't
yet have them.
-}
{-|
Captures the general pattern of handling packets from a circuit channel
such as 'circuitIncoming' or a duplicate. The handler should return
'Nothing' to continue processing packets, or 'Just' @x@ to finish with a
result of @x@. If the circuit is closed before a 'Just' value is returned,
then the result of @handlePackets@ is 'Nothing'.
-}
handlePackets :: Chan (Maybe PacketBody) -- ^ Channel to ask for packets
-> (PacketBody -> IO (Maybe a)) -- ^ Handler for packets
-> IO (Maybe a)
handlePackets chan handler = readChan chan >>= maybe (return Nothing) process
where process p = handler p >>= maybe (handlePackets chan handler) (return . Just)
{-|
A version of handlePackets for handlers that don't finish early. This
will keep retrieving packets from the given channel and passing them off
to the handler until the circuit is closed.
-}
handlePackets_ :: Chan (Maybe PacketBody) -- ^ Channel to ask for packets
-> (PacketBody -> IO ()) -- ^ Handler for packets
-> IO ()
handlePackets_ chan handler = handlePackets chan handler' >> return ()
where handler' p = handler p >> return Nothing
{-|
Sends a packet, and expects another packet (or packets) in response. This
is a common pattern for many kinds of communication. It's implemented by
duplicating 'circuitIncoming' so that we can look ahead for responses while
still leaving other packets for independent tasks.
The handler should return 'Nothing' when the packet it received was not
the response it expected (or did not complete the response), and a 'Just'
value when the response is complete. In turn, @expectResponse@ returns
'Nothing' if the circuit is closed before the response is complete, and
a 'Just' value once the response is complete.
-}
expectResponse :: Circuit -- ^ The circuit to operate on
-> PacketBody -- ^ The request packet to send
-> (PacketBody -> IO (Maybe a)) -- ^ The handler for responses
-> IO (Maybe a)
expectResponse circ req rsp = do
chan <- dupChan (circuitIncoming circ)
result <- circuitSendSync circ req
if result then handlePackets chan rsp else return Nothing
{-|
Converts a sequence of bytes in the form used for packets into a Haskell
String.
-}
bytesToString :: ByteString -> String
bytesToString bs = takeWhile (/= '\0') $ map (chr . fromIntegral) $ B.unpack bs
{-|
Converts a Haskell String into a sequence of bytes suitable to send in a
packet.
-}
stringToBytes :: String -> ByteString
stringToBytes "" = B.empty
stringToBytes s = B.pack $ map (fromIntegral . ord) $ s ++ "\0"