{-# 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 <- loginXml 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"