Login.hs

{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE ScopedTypeVariables #-}

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 -- for logging

import qualified Data.ByteString      as B
import qualified Data.ByteString.Lazy as L

{-
    Login implementation.  This implements the pure XML-RPC login sequence
    for Second Life (but not the avatar presence piece, which is left until
    later.)
-}

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" -- stunnel endpoint
        loginMethod = "login_to_simulator"