diff --git a/mvclient.cabal b/mvclient.cabal --- a/mvclient.cabal +++ b/mvclient.cabal @@ -1,16 +1,13 @@ Name: mvclient -Version: 0.2 +Version: 0.3 Synopsis: Client library for metaverse systems like Second Life Description: The client side of connections to virtual world environments - like Linden Labs' Second Life or OpenSim - (), sometimes known as the + like Linden Labs' Second Life, sometimes known as the "metaverse". . - Note that due to the lack of SSL implementations for - Haskell, you currently need to set up stunnel for initial - login step for worlds (like Second Life) that use secure - login pages. This is also the main obstacle to an - implementation of the caps system. + As of version 0.3, no longer requires an stunnel proxy for + connecting to Second Life. Thanks for Michael Snoyman and + his http-enumerator package! License: BSD3 License-file: LICENSE @@ -21,28 +18,34 @@ Category: Network Build-type: Custom -Cabal-version: >=1.2 +Cabal-version: >=1.6 Extra-source-files: TODO.txt, BuildTools/Template2Hs.hs, other/LogTranslate.hs +flag network-bytestring + Library Hs-source-dirs: src Exposed-modules: Network.Metaverse, Network.Metaverse.Circuit, Network.Metaverse.PacketTypes, Network.Metaverse.Login - Build-depends: base >=4 && <5, - network >=2.2.3 && <2.4, - bytestring -any, - Crypto -any, - HTTP -any, - maccatcher -any, - haxr -any, - binary -any, - mtl -any, - data-binary-ieee754 -any, - containers -any, - time -any, - control-event >=1.1.0.4 && <1.2, - parsec -any, - uuid -any + Build-depends: base >= 4 && < 5, + bytestring == 0.9.*, + Crypto == 4.2.*, + maccatcher == 1.0.*, + binary == 0.5.*, + mtl >= 1.1 && < 2.1, + data-binary-ieee754 == 0.4.*, + containers == 0.3.*, + time == 1.1.*, + control-event >= 1.1.0.4 && < 1.3, + parsec == 3.1.*, + uuid == 1.2.*, + http-enumerator == 0.2.*, + hexpat == 0.19.* + if flag(network-bytestring) + Build-depends: network >= 2.2.1 && < 2.2.3, + network-bytestring >= 0.1.3 && < 0.2 + else + Build-depends: network >= 2.2.3 && < 2.4 diff --git a/src/Network/Metaverse.hs b/src/Network/Metaverse.hs --- a/src/Network/Metaverse.hs +++ b/src/Network/Metaverse.hs @@ -100,7 +100,7 @@ -> String -- ^ Password -> IO Circuit login firstName lastName password = do - token <- loginXml firstName lastName password + token <- loginXmlRpc firstName lastName password circ <- circuitConnect token forkIO $ regionHandshaker circ =<< dupChan (circuitIncoming circ) diff --git a/src/Network/Metaverse/Circuit.hs b/src/Network/Metaverse/Circuit.hs --- a/src/Network/Metaverse/Circuit.hs +++ b/src/Network/Metaverse/Circuit.hs @@ -39,6 +39,7 @@ import Data.Bits import Data.Time.Clock import Data.UUID hiding (null) + import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString diff --git a/src/Network/Metaverse/Login.hs b/src/Network/Metaverse/Login.hs --- a/src/Network/Metaverse/Login.hs +++ b/src/Network/Metaverse/Login.hs @@ -9,18 +9,34 @@ -} module Network.Metaverse.Login ( MVToken(..), - loginXml + loginXmlRpc ) where -import Control.Monad import Data.Char import Data.Digest.MD5 -import Data.Word +import Data.Maybe import Data.UUID -import Network.XmlRpc.Client -import Network.XmlRpc.Internals +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 @@ -41,64 +57,103 @@ 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" - ]) +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" ]] + ]]] + ] + ]]]] ] -data MVToken = MVToken { - tokenAgentID :: UUID, - tokenSimIP :: String, - tokenSimPort :: Word16, - tokenSessionID :: UUID, - tokenCircuitCode :: Word32, - tokenInvHost :: String, - tokenInvRoot :: UUID - } - deriving Show +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 -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) - } +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" - where loginURL = "http://localhost:8001/cgi-bin/login.cgi" -- stunnel endpoint - loginMethod = "login_to_simulator" +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"