module Network.Metaverse.Login where
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.Digest.MD5
import Data.Word
import Data.Int
import Data.Bits
import Data.List
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Binary.IEEE754
import Data.Time.Clock
import Network.XmlRpc.Client
import Network.XmlRpc.Internals
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Network.Metaverse.Utils
import Network.Metaverse.Packets
import System.Random
import System.Info.MAC
import System.IO.Unsafe
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
hashPassword :: String -> String
hashPassword = ("$1$" ++) . toHexString . hash . map (fromIntegral . ord)
loginPacket :: String -> String -> String -> String -> Value
loginPacket firstName lastName password ethmac = ValueStruct [
("first", ValueString firstName),
("last", ValueString lastName),
("passwd", ValueString (hashPassword password)),
("start", ValueString "last"),
("channel", ValueString "WillowdaleBot"),
("version", ValueString "0.9"),
("platform", ValueString "Lin"),
("mac", ValueString ethmac),
("agree_to_tos", ValueBool True),
("read_critical", ValueBool True),
("id0", ValueString ethmac),
("last_exec_event", ValueInt 0),
("options", ValueArray [
ValueString "inventory-root",
ValueString "adult_compliant"
])
]
data MVToken = MVToken {
tokenAgentID :: UUID,
tokenSimIP :: String,
tokenSimPort :: Word16,
tokenSessionID :: UUID,
tokenCircuitCode :: Word32,
tokenInvHost :: String,
tokenInvRoot :: UUID
}
deriving Show
loginXml :: String -> String -> String -> IO MVToken
loginXml firstName lastName password = do
maybemac <- mac
case maybemac of
Nothing -> error "Unable to fetch Ethernet MAC"
Just ethmac -> do
let msg = loginPacket firstName lastName password (show ethmac)
ValueStruct rsp <- handleError error
(call loginURL loginMethod [ msg ])
let Just (ValueString loginAns) = lookup "login" rsp
when (loginAns /= "true") $ error $ "Login did not succeed: " ++ loginAns
let Just (ValueString agentID) = lookup "agent_id" rsp
let Just (ValueString simIP) = lookup "sim_ip" rsp
let Just (ValueInt simPort) = lookup "sim_port" rsp
let Just (ValueString sessionID) = lookup "session_id" rsp
let Just (ValueInt circuitCode) = lookup "circuit_code" rsp
let Just (ValueString invHost) = lookup "inventory_host" rsp
let Just (ValueArray [ ValueStruct [ (_, ValueString invRoot) ] ])
= lookup "inventory-root" rsp
return $ MVToken { tokenAgentID = read (agentID),
tokenSimIP = simIP,
tokenSimPort = fromIntegral simPort,
tokenSessionID = read (sessionID),
tokenCircuitCode = fromIntegral circuitCode,
tokenInvHost = invHost,
tokenInvRoot = read (invRoot)
}
where loginURL = "http://localhost:8001/cgi-bin/login.cgi"
loginMethod = "login_to_simulator"