diff --git a/examples/DebugMCPI.hs b/examples/DebugMCPI.hs new file mode 100644 --- /dev/null +++ b/examples/DebugMCPI.hs @@ -0,0 +1,80 @@ +{- +License: + +This code is placed in the Public Domain. + +Author: + +Douglas Burke (dburke.gw@gmail.com) + +Usage: + + ./debugmcpi + +Similar to MCPI.hs except that the user input is converted into +a library call. The \"command language\" is + + command name [arg1 .. argn] + query name [arg1 .. argn] + quit + exit + +and is case sensitive. + +This is to support debugging the interface. + +-} + +module Main where + +import Control.Monad (void) +import Control.Monad.IO.Class + +import Data.Char (isSpace) + +import Network.MineCraft.Pi.Client.Internal (MCPI, runMCPI', command, query) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStrLn, stderr) + +import Utils (printVersion) + +-- | Remove leading and trailing whitespace. +strip :: String -> String +strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- | Ask the user for a command, execute it and, if necessary, +-- wait for a response. +-- +userInteract :: MCPI () +userInteract = do + user <- liftIO getLine + handleUser (strip user) + userInteract + +-- | For queries I am currently relying on the debug output of +-- @query@ rather than handle the output here. +handleUser :: String -> MCPI () +handleUser [] = return () +handleUser "quit" = liftIO $ exitSuccess +handleUser "exit" = liftIO $ exitSuccess +handleUser user = + case words user of + ("command":comm:args) -> command comm args + ("query":qry:args) -> void (query qry args) + _ -> liftIO $ putStrLn "Expected quit, exit, command ..., or query ..." + +usage :: IO () +usage = do + progName <- getProgName + hPutStrLn stderr $ "Usage: " ++ progName + exitFailure + +main :: IO () +main = do + args <- getArgs + if null args + then printVersion >> runMCPI' True userInteract + else usage + diff --git a/examples/README.md b/examples/README.md --- a/examples/README.md +++ b/examples/README.md @@ -6,9 +6,18 @@ When called with the `--debug` argument the programs will print, to `stderr`, the messages they send to, and receive from, the -MineCraft program. This is true for all the examples except for -`hmcpi`. +MineCraft program. +These programs are built by setting the `build-examples` flag, +which is set by default, so either of the following will work + + cabal configure + cabal configure -fbuild-examples + +To avoid building the programs, use: + + cabal configure -f-build-examples + freefall -------- @@ -45,6 +54,39 @@ There is no check that the blocks that are added are actually supported, although this could be added by an enterprising programmer. +isongold +-------- + +Source code: [IsOnGold.hs](https://github.com/DougBurke/hmcpi/blob/master/examples/IsOnGold.hs) + +Usage: + + isongold [--debug] + +Tells the user to look down if they are standing on a gold ore block. + +xjump +----- + +Source code: [XJump.hs](https://github.com/DougBurke/hmcpi/blob/master/examples/XJump.hs) + +Usage: + + xjump [--debug] + +Move the player by 10 tiles in the X direction if the tile is not +filled. + +Debug programs +============== + +The following are useful when trying to debug the module. + +These programs are built by setting the `build-debug` flag, +which is *not* set by default: + + cabal configure -fbuild-debug + hmcpi ----- @@ -66,25 +108,22 @@ Note that this program does not take use the `mcpi` library, since it is provides a direct connection to the MineCraft-Pi program. -isongold --------- +debugmcpi +--------- -Source code: [IsOnGold.hs](https://github.com/DougBurke/hmcpi/blob/master/examples/IsOnGold.hs) +Source code: [DebugMCPI.hs](https://github.com/DougBurke/hmcpi/blob/master/examples/DebugMCPI.hs) Usage: - isongold [--debug] - -Tells the user to look down if they are standing on a gold ore block. - -xjump ------ - -Source code: [XJump.hs](https://github.com/DougBurke/hmcpi/blob/master/examples/XJump.hs) + debugmcpi -Usage: +This provides a simple interface for sending commands and queries +to MineCraft. It differs from hmcpi in that you do not talk +directly to MineCraft, instead you have the following commands - xjump [--debug] + exit + quit + command name [arg1 .. argn] + query name [arg1 .. argn] -Move the player by 10 tiles in the X direction if the tile is not -filled. +Everything is treated as a string. diff --git a/mcpi.cabal b/mcpi.cabal --- a/mcpi.cabal +++ b/mcpi.cabal @@ -1,5 +1,5 @@ Name: mcpi -Version: 0.0.0.3 +Version: 0.0.0.4 Homepage: https://github.com/DougBurke/hmcpi Bug-Reports: https://github.com/DougBurke/hmcpi/issues Stability: experimental @@ -38,6 +38,10 @@ Description: Build the example programs (defaults to True) Default: True +Flag build-debug + Description: Build programs for debugging the module (defaults to False) + Default: False + Library Build-Depends: base >=3 && < 5, @@ -59,6 +63,7 @@ ghc-options: -Wall +-- Examples Executable flatten if !flag(build-examples) Buildable: False @@ -95,11 +100,11 @@ mcpi, transformers -Executable hmcpi +Executable isongold if !flag(build-examples) Buildable: False - Main-Is: HMCPI.hs + Main-Is: IsOnGold.hs Hs-Source-Dirs: examples/ Other-Modules: Paths_mcpi @@ -110,14 +115,13 @@ Build-Depends: base, - network, - pipes >= 3.0 && < 3.2 + mcpi -Executable isongold +Executable xjump if !flag(build-examples) Buildable: False - Main-Is: IsOnGold.hs + Main-Is: XJump.hs Hs-Source-Dirs: examples/ Other-Modules: Paths_mcpi @@ -130,11 +134,12 @@ base, mcpi -Executable xjump - if !flag(build-examples) +-- Debug programs +Executable hmcpi + if !flag(build-debug) Buildable: False - Main-Is: XJump.hs + Main-Is: HMCPI.hs Hs-Source-Dirs: examples/ Other-Modules: Paths_mcpi @@ -145,4 +150,23 @@ Build-Depends: base, - mcpi + network, + pipes >= 3.0 && < 3.2 + +Executable debugmcpi + if !flag(build-debug) + Buildable: False + + Main-Is: DebugMCPI.hs + Hs-Source-Dirs: examples/ + + Other-Modules: Paths_mcpi + Utils + + ghc-options: + -Wall + + Build-Depends: + base, + mcpi, + transformers diff --git a/src/Network/MineCraft/Pi/Client/Internal.hs b/src/Network/MineCraft/Pi/Client/Internal.hs --- a/src/Network/MineCraft/Pi/Client/Internal.hs +++ b/src/Network/MineCraft/Pi/Client/Internal.hs @@ -27,12 +27,16 @@ import qualified Control.Exception as CE import Control.Exception (bracket) -import Control.Monad (when) +import Control.Monad (unless, when) import Control.Monad.IO.Class import Control.Monad.Trans.Reader +import Data.Char (isSpace) import Data.List (intercalate) +import Foreign +import Foreign.C.String + import Network.BSD import Network.Socket @@ -48,6 +52,11 @@ type MCPI = ReaderT ConnInfo IO -- | Connection information. +-- +-- /TODO:/ Should the buffer used by @flushChannel@ be stored here, to +-- avoid repeated allocation/de-allocation? It is unlikely (I +-- speculate) to be a major optimisation in time or space. +-- data ConnInfo = ConnInfo { _ciHandle :: Handle -- ^ Connection to the MineCraft program , _ciDebug :: Bool -- ^ Should messages to and from MineCraft @@ -69,8 +78,8 @@ -- /TODO:/ Change the retun value to @Maybe ConnInfo@ and -- make this public. openMCPI :: - Bool -- ^ Set to @True@ to get debugging messages printed to @stderr@. - -> IO ConnInfo + Bool -- ^ Set to @True@ to get debugging messages printed to @stderr@. + -> IO ConnInfo openMCPI flag = do let ehdl :: CE.IOException -> IO () ehdl _ = @@ -81,6 +90,7 @@ let a = head as -- note: getAddrInfo never returns an empty list sock <- socket (addrFamily a) Stream defaultProtocol setSocketOption sock KeepAlive 1 + setSocketOption sock NoDelay 1 connect sock (addrAddress a) `CE.catch` ehdl h <- socketToHandle sock ReadWriteMode hSetBuffering h LineBuffering @@ -93,65 +103,86 @@ closeMCPI :: ConnInfo -> IO () closeMCPI = hClose . _ciHandle -logMsg :: ConnInfo -> String -> String -> MCPI () +-- | Write a debug message to @stderr@ if the debug flag is set. The +-- format is \"[type] msg\". +-- +logMsg :: + ConnInfo + -> String -- ^ The type of message (ideally 8 characters or less to + -- keep the output aligned, but can be larger). Trailing + -- white space is ignored. + -> String -- ^ The message to display. + -> IO () logMsg ConnInfo {..} hdr msg = - when _ciDebug $ liftIO $ hPutStrLn stderr + when _ciDebug $ hPutStrLn stderr $ "[" ++ hdr ++ replicate (8 - length hdr) ' ' ++ - "] " ++ msg + "] " ++ reverse (dropWhile isSpace (reverse msg)) --- It might be nice to do the argument marshalling here, i.e. have --- something like @command :: Command -> [Argument] -> MCPI ()@ --- which would be run like @command "player.setTile" [Pos 0 0 0]@, --- but I do not want to deal with heterogeneous lists at this time. --- Instead, we force the caller to do the conversion. --- +-- | Add arguments to a query or command to create the +-- string to send to MineCraft. addArgs :: String -> [Argument] -> String addArgs a bs = a ++ "(" ++ intercalate "," bs ++ ")" -{- +-- | At present the only "error" message I have seen is "Fail\0", +-- so we use a small buffer size. +bufSize :: Int +bufSize = 16 + +-- | Return from MineCraft that indicates an error. +connectionError :: String +connectionError = "Fail" + -- | Remove any output from the handle. A debug message is written -- to let the user know this has happened, presumably because of -- a previous invalid call. The previous call could be stored in -- ConnInfo to make the message more useful, but leave that for now. -- flushChannel :: ConnInfo -> IO () -flushChannel ConnInfo {..} = do - -Hmm, do I need the socket as well as the handle? - - while True: - readable, _, _ = select.select([self.socket], [], [], 0.0) - if not readable: - break - data = self.socket.recv(1500) - e = "Drained Data: <%s>\n"%data.strip() - e += "Last Message: <%s>\n"%self.lastSent.strip() - sys.stderr.write(e) - --} +flushChannel ci@ConnInfo {..} = do + -- Should the buffer be stored in ConnInfo so we don't have + -- to repeatedly allocate it? It's only small (at present), + -- so probably not an issue. + fbuf <- mallocForeignPtrBytes bufSize + withForeignPtr fbuf $ \bufPtr -> + let loop store = do + nrec <- hGetBufNonBlocking _ciHandle bufPtr bufSize + if (nrec > 0) + then peekCStringLen (bufPtr, nrec) >>= \str -> loop (store ++ str) + else unless (null store) $ logMsg ci "FLUSH" store + in loop [] --- | Run a MineCraft command. +-- | Run a MineCraft command. command :: Command -> [Argument] -> MCPI () command comm args = do ci <- ask let commstr = addArgs comm args - logMsg ci "COMMAND" commstr - liftIO $ hPutStrLn (_ciHandle ci) commstr + liftIO $ + flushChannel ci + >> logMsg ci "COMMAND" commstr + >> hPutStrLn (_ciHandle ci) commstr --- | Run a MineCraft query, returning the response. +-- | Run a MineCraft query, returning the response. An +-- @IOError@ is raised if the response is @Fail@ (this +-- might be due to a previous command failing, depending +-- on the time taken by MineCraft to respond). +-- query :: Query -> [Argument] -> MCPI String query qry args = do ci <- ask - let qrystr = addArgs qry args - logMsg ci "QUERY" qrystr - liftIO $ hPutStrLn (_ciHandle ci) qrystr + let qryStr = addArgs qry args + liftIO $ + flushChannel ci + >> logMsg ci "QUERY" qryStr + >> hPutStrLn (_ciHandle ci) qryStr ans <- liftIO $ hGetLine (_ciHandle ci) - logMsg ci "RESPONSE" ans + liftIO $ logMsg ci "RESPONSE" ans + when (ans == connectionError) $ + liftIO $ ioError $ userError $ "Query failed: " ++ qryStr return ans -- | Run a Raspberry-PI program. The flag determines whether the -- messages sent to, and received from, the server, are --- printed to @stderr@. +-- printed to @stderr@ as a diagnostic. -- -- An exception is raised if the server is not running, or -- can not be contacted.