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(..),
    loginXmlRpc
    ) where

import Data.Char
import Data.Digest.MD5
import Data.Maybe
import Data.UUID
import Data.Word

import System.Info.MAC

import Network.HTTP.Enumerator

import Text.XML.Expat.Tree
import Text.XML.Expat.Format

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

data MVToken = MVToken {
    tokenAgentID     :: UUID,
    tokenSimIP       :: String,
    tokenSimPort     :: Word16,
    tokenSessionID   :: UUID,
    tokenCircuitCode :: Word32
    }
    deriving Show

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

loginRequest :: String -> String -> String -> String -> L.ByteString
loginRequest first last passwd ethmac = format $ Element "methodCall" [] [
    Element "methodName" [] [ Text "login_to_simulator" ],
    Element "params" [] [ Element "param" [] [ Element "value" [] [ Element "struct" [] [
        Element "member" [] [
            Element "name" [] [ Text "first" ],
            Element "value" [] [ Element "string" [] [ Text first ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "last" ],
            Element "value" [] [ Element "string" [] [ Text last ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "passwd" ],
            Element "value" [] [ Element "string" [] [ Text (hashPassword passwd) ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "start" ],
            Element "value" [] [ Element "string" [] [ Text "last" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "channel" ],
            Element "value" [] [ Element "string" [] [ Text "mvclient" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "version" ],
            Element "value" [] [ Element "string" [] [ Text "0.3" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "platform" ],
            Element "value" [] [ Element "string" [] [ Text "Lin" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "mac" ],
            Element "value" [] [ Element "string" [] [ Text ethmac ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "agree_to_tos" ],
            Element "value" [] [ Element "boolean" [] [ Text "1" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "read_critical" ],
            Element "value" [] [ Element "boolean" [] [ Text "1" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "id0" ],
            Element "value" [] [ Element "string" [] [ Text ethmac ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "last_exec_event" ],
            Element "value" [] [ Element "int" [] [ Text "0" ]]
            ],
        Element "member" [] [
            Element "name" [] [ Text "options" ],
            Element "value" [] [ Element "array" [] [Element "data" [] [
                Element "value" [] [ Element "string" [] [ Text "inventory-root" ]],
                Element "value" [] [ Element "string" [] [ Text "adult_compliant" ]]
                ]]]
            ]
        ]]]]
    ]

stripWhitespace :: Node String String -> Maybe (Node String String)
stripWhitespace (Element n a c) = Just $ Element n a (mapMaybe stripWhitespace c)
stripWhitespace (Text t) | all isSpace t = Nothing
                         | otherwise     = Just $ Text t

tokenFromTree :: Node String String -> MVToken
tokenFromTree (Element "methodResponse" [] [ Element "params" [] [ Element "param" [] [ Element "value" [] [ Element "struct" [] members ]]]]) =
    case lookupMember "login" members of
        "true" -> MVToken {
            tokenAgentID     = read (lookupMember "agent_id"     members),
            tokenSimIP       =       lookupMember "sim_ip"       members,
            tokenSimPort     = read (lookupMember "sim_port"     members),
            tokenSessionID   = read (lookupMember "session_id"   members),
            tokenCircuitCode = read (lookupMember "circuit_code" members)
            }
        _ -> error $ "Login failed: " ++ lookupMember "reason" members
  where lookupMember name members = head (catMaybes (map (field name) members))
        field name (Element "member" [] [ Element "name" [] [ Text n ], Element "value" [] [ Element _ [] [ Text v ]]])
            | name == n = Just v
            | otherwise = Nothing
        field name _ = Nothing
tokenFromTree _ = error "Bad XML format in response"

loginXmlRpc :: String -> String -> String -> IO MVToken
loginXmlRpc first last passwd = mac >>= maybe (error "Couldn't get MAC address") doLogin
    where doLogin ethmac = do
            let msg = loginRequest first last passwd (show ethmac)
            urlReq <- parseUrl loginURL
            let req = urlReq { method      = B.pack (map (fromIntegral . ord) "POST"),
                               requestBody = msg,
                               requestHeaders = (B.pack $ map (fromIntegral . ord) "Content-type", B.pack $ map (fromIntegral . ord) "text/xml") : requestHeaders urlReq
                             }
            resp <- httpLbsRedirect req
            let presult = parse' defaultParseOptions (B.concat $ L.toChunks $ responseBody resp)
            case presult of
                Left err   -> error $ "Bad response: " ++ show err
                Right tree -> return (tokenFromTree (fromJust $ stripWhitespace tree))
          loginURL = "https://login.agni.lindenlab.com/cgi-bin/login.cgi"