mvclient 0.3 → 0.4
raw patch · 4 files changed
+45/−17 lines, 4 filesdep +base-unicode-symbolsdep −network-bytestringdep ~http-enumeratordep ~network
Dependencies added: base-unicode-symbols
Dependencies removed: network-bytestring
Dependency ranges changed: http-enumerator, network
Files
- mvclient.cabal +5/−10
- src/Network/Metaverse.hs +27/−0
- src/Network/Metaverse/Circuit.hs +4/−1
- src/Network/Metaverse/Login.hs +9/−6
mvclient.cabal view
@@ -1,5 +1,5 @@ Name: mvclient-Version: 0.3+Version: 0.4 Synopsis: Client library for metaverse systems like Second Life Description: The client side of connections to virtual world environments like Linden Labs' Second Life, sometimes known as the@@ -24,13 +24,12 @@ 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,+ base-unicode-symbols == 0.2.1.1, bytestring == 0.9.*, Crypto == 4.2.*, maccatcher == 1.0.*,@@ -42,10 +41,6 @@ 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+ http-enumerator == 0.5.*,+ hexpat == 0.19.*,+ network >= 2.2.3 && < 2.4
src/Network/Metaverse.hs view
@@ -45,6 +45,7 @@ getBalance, estateBan, estateUnban,+ setTerrainVariables, -- * Low-level adapters -- $lowlevel@@ -501,6 +502,32 @@ [ EstateOwnerMessage_ParamList (stringToBytes (show (circuitAgentID circ))), EstateOwnerMessage_ParamList (stringToBytes (show flag)), EstateOwnerMessage_ParamList (stringToBytes (show uuid)) ]++{-|+ Sets variables that control region terrain.+-}+setTerrainVariables :: Circuit -- ^ The circuit to operate in+ -> Float -- ^ Height of water, in meters+ -> Float -- ^ Limit for raising terrain+ -> Float -- ^ Limit for lowering terrain+ -> Bool -- ^ Use estate sun+ -> Bool -- ^ Use fixed sun+ -> Float -- ^ Sun position+ -> IO ()+setTerrainVariables circ water raise lower esun fsun sunpos = do+ Just invoice <- nextUUID+ circuitSend circ True $ EstateOwnerMessage+ (EstateOwnerMessage_AgentData (circuitAgentID circ) (circuitSessionID circ) nil)+ (EstateOwnerMessage_MethodData (stringToBytes "setregionterrain") invoice)+ [ EstateOwnerMessage_ParamList (stringToBytes (show water)),+ EstateOwnerMessage_ParamList (stringToBytes (show raise)),+ EstateOwnerMessage_ParamList (stringToBytes (show lower)),+ EstateOwnerMessage_ParamList (stringToBytes (if esun then "Y" else "N")),+ EstateOwnerMessage_ParamList (stringToBytes (if fsun then "Y" else "N")),+ EstateOwnerMessage_ParamList (stringToBytes (show sunpos)),+ EstateOwnerMessage_ParamList (stringToBytes "Y"),+ EstateOwnerMessage_ParamList (stringToBytes "N"),+ EstateOwnerMessage_ParamList (stringToBytes "0.00") ] {- ================================================================== Low-level adapters
src/Network/Metaverse/Circuit.hs view
@@ -339,7 +339,10 @@ Only does something if the circuit is not closed. -} ifNotClosed :: Monad m => StateT Accounting m () -> StateT Accounting m ()-ifNotClosed action = fmap acctClosed S.get >>= \r -> when (not r) action+ifNotClosed action = do+ acct <- S.get+ let r = acctClosed acct+ when (not r) action {- Sends a packet on the circuit. This is the function that is narrowly
src/Network/Metaverse/Login.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} {-| This module implements the XML-RPC based login protocol provided@@ -28,6 +29,8 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.ByteString.Char8 () -- for string instance+ data MVToken = MVToken { tokenAgentID :: UUID, tokenSimIP :: String,@@ -58,7 +61,7 @@ hashPassword = ("$1$" ++) . toHexString . hash . map (fromIntegral . ord) loginRequest :: String -> String -> String -> String -> L.ByteString-loginRequest first last passwd ethmac = format $ Element "methodCall" [] [+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" [] [@@ -75,7 +78,7 @@ ], Element "member" [] [ Element "name" [] [ Text "start" ],- Element "value" [] [ Element "string" [] [ Text "last" ]]+ Element "value" [] [ Element "string" [] [ Text "home" ]] ], Element "member" [] [ Element "name" [] [ Text "channel" ],@@ -147,11 +150,11 @@ 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+ let req = urlReq { method = "POST",+ requestBody = RequestBodyLBS msg,+ requestHeaders = ("Content-type", "text/xml") : requestHeaders urlReq }- resp <- httpLbsRedirect req+ resp <- withManager $ httpLbsRedirect req let presult = parse' defaultParseOptions (B.concat $ L.toChunks $ responseBody resp) case presult of Left err -> error $ "Bad response: " ++ show err