Login.hs

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

{-|
    This module implements the XML-RPC based login protocol provided
    by Linden Labs' Second Life system.  Since Linden Labs' login requires
    SSL which is not widely implemented in Haskell, this requires an stunnel
    proxy listening on port 8001 of localhost.
-}
module Network.Metaverse.Login (
    MVToken(..),
    loginXml
    ) where

import Control.Monad
import Data.Char
import Data.Digest.MD5
import Data.Word
import Data.UUID
import Network.XmlRpc.Client
import Network.XmlRpc.Internals
import System.Info.MAC

{-
    Convert a list of bytes to a hexadecimal string; needed for building
    the login packet
-}

toHexString :: [Word8] -> String
toHexString = concatMap toHex
    where toHex n    = [ hexDigit (n `div` 16), hexDigit (n `mod` 16) ]
          hexDigit d | d < 10    = chr (ord '0' + fromIntegral d)
                     | otherwise = chr (ord 'a' + fromIntegral d - 10)

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