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
import Data.ByteString.Char8 ()
data MVToken = MVToken {
tokenAgentID :: UUID,
tokenSimIP :: String,
tokenSimPort :: Word16,
tokenSessionID :: UUID,
tokenCircuitCode :: Word32
}
deriving Show
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)
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" :: String) [] [
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 "home" ]]
],
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 = "POST",
requestBody = RequestBodyLBS msg,
requestHeaders = ("Content-type", "text/xml") : requestHeaders urlReq
}
resp <- withManager $ 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"