{-# 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,
    setTerrainVariables,

    -- * 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)) ]

{-|
    Sets variables that control region terrain.
-}
setTerrainVariables :: Circuit -- ^ The circuit to operate in
                    -> Float   -- ^ Height of water, in meters
                    -> Float   -- ^ Limit for raising terrain
                    -> Float   -- ^ Limit for lowering terrain
                    -> Bool    -- ^ Use estate sun
                    -> Bool    -- ^ Use fixed sun
                    -> Float   -- ^ Sun position
                    -> IO ()
setTerrainVariables circ water raise lower esun fsun sunpos = do
    Just invoice <- nextUUID
    circuitSend circ True $ EstateOwnerMessage
        (EstateOwnerMessage_AgentData (circuitAgentID circ) (circuitSessionID circ) nil)
        (EstateOwnerMessage_MethodData (stringToBytes "setregionterrain") invoice)
        [ EstateOwnerMessage_ParamList (stringToBytes (show water)),
          EstateOwnerMessage_ParamList (stringToBytes (show raise)),
          EstateOwnerMessage_ParamList (stringToBytes (show lower)),
          EstateOwnerMessage_ParamList (stringToBytes (if esun then "Y" else "N")),
          EstateOwnerMessage_ParamList (stringToBytes (if fsun then "Y" else "N")),
          EstateOwnerMessage_ParamList (stringToBytes (show sunpos)),
          EstateOwnerMessage_ParamList (stringToBytes "Y"),
          EstateOwnerMessage_ParamList (stringToBytes "N"),
          EstateOwnerMessage_ParamList (stringToBytes "0.00") ]

{- ==================================================================
   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"