mvclient 0.2 → 0.3
raw patch · 4 files changed
+146/−87 lines, 4 filesdep +hexpatdep +http-enumeratordep +network-bytestringdep −HTTPdep −haxrdep ~Cryptodep ~binarydep ~bytestring
Dependencies added: hexpat, http-enumerator, network-bytestring
Dependencies removed: HTTP, haxr
Dependency ranges changed: Crypto, binary, bytestring, containers, control-event, data-binary-ieee754, maccatcher, mtl, network, parsec, time, uuid
Files
- mvclient.cabal +27/−24
- src/Network/Metaverse.hs +1/−1
- src/Network/Metaverse/Circuit.hs +1/−0
- src/Network/Metaverse/Login.hs +117/−62
mvclient.cabal view
@@ -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- (<http://opensimulator.org>), 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
src/Network/Metaverse.hs view
@@ -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)
src/Network/Metaverse/Circuit.hs view
@@ -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
src/Network/Metaverse/Login.hs view
@@ -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"