diff --git a/ACKNOWLEDGMENTS.md b/ACKNOWLEDGMENTS.md new file mode 100644 --- /dev/null +++ b/ACKNOWLEDGMENTS.md @@ -0,0 +1,37 @@ + +Acknowledgments +=============== + +EtaMOO follows a long history of MUD tradition involving many people who are +or have been influential to me. This is an attempt to acknowledge some of +these people and their contributions, with my gratitude... + + * __Rémy Evard__ was a valued mentor and friend without whose influence I + probably would never have gotten as involved with MOO as I have. + + * __Pavel Curtis__ maintained the original LambdaMOO server code for many + years long ago, and was kind enough to exchange some ideas with me as I + was writing LPMOO, my first re-implementation of MOO. His thorough + documentation of LambdaMOO (later also by __Erik Ostrom__ and __Roger + Crew__) in the form of the _LambdaMOO Programmer's Manual_ has been an + invaluable technical resource without which I doubt projects such as LPMOO + or EtaMOO would have seemed feasible. + + * __Felix Croes__ created DGD, the platform on which I made LPMOO. Not only + is he an inspiration to me in writing excellent code, I believe he was the + first person to introduce the idea of software transactional memory to me. + + * __Jay Carlson__ was a maintainer of the LambdaMOO server code some time + ago and has often provided valuable insights and supportive feedback on a + wide range of subjects. + + * __Ken Fox__ has been a friend, advocate, and developer extraordinaire for + many years, and his contributions to the MOO community -- particularly in + building and enhancing various databases -- are greatly appreciated. + + * __Kenny Root__ and __James Deikun__ were effective collaborators with me + in the creation of Codepoint, a fork of LambdaMOO (based on the initial + work of __H. Peter Anvin__) to support Unicode. + + * __Dylan Simon__ provided several useful suggestions and feedback on this + Haskell implementation of EtaMOO. diff --git a/DIFFERENCES.md b/DIFFERENCES.md new file mode 100644 --- /dev/null +++ b/DIFFERENCES.md @@ -0,0 +1,110 @@ + +Differences between EtaMOO and LambdaMOO +======================================== + +Besides the most notable differences described in the README, other minor +differences include: + + * EtaMOO fixes a long-standing bug in LambdaMOO that prevents commands using + the "off of" preposition from being parsed correctly. To accomplish this, + the "off/off of" preposition has been changed to "off of/off". + + * Assignment expressions behave somewhat differently in EtaMOO than they do + in LambdaMOO. + + Assuming `x = {1, 2}` and `y = "foo"`: + +| Expression | LambdaMOO | EtaMOO | +| ----------------- | ---------------- | ---------------- | +| `x[1] = x[2] = 3` | `x` => `{3, 2}` | `x` => `{3, 3}` | +| `x[1] = (x = 0)` | `x` => `{0, 2}` | (error) `E_TYPE` | +| `y[$][1] = "b"` | (error) `E_TYPE` | `y` => `"fob"` | + + * EtaMOO provides a visual indication of the point at which MOO code + compilation failed as part of the list of strings returned by + `set_verb_code()` and `eval()`. + + * To mirror and complement the native support for string-key association + list indexing, EtaMOO also extends the `listset()` and `listdelete()` + functions to accept string-key indices for manipulating well-formed + association lists. + + * Versions of LambdaMOO up to 1.8.3 only restrict to wizards the *reading* + of built-in properties protected by `$server_options.protect_`*`prop`*. + EtaMOO, as well as more recent versions of LambdaMOO, also restrict + *writing* to such protected properties. + + * EtaMOO doesn't currently check the validity of built-in function names + when compiling verb code; instead, calling an unknown function raises an + error at runtime. (This is subject to change.) + + * In some cases the semantics of a language construct or built-in function + differ slightly from that of LambdaMOO. Because MOO tasks run inside of an + atomic transaction in EtaMOO, it is sometimes necessary to commit the + transaction prematurely in order to perform some I/O or schedule another + task. In these cases, the effect is the same as if `suspend(0)` had been + called. These cases include: + + `fork` + `listen()` + `open_network_connection()` + `memory_usage()` + + * In both EtaMOO and LambdaMOO, the `crypt()` built-in is a thin wrapper + around the host system's `crypt()` library function. LambdaMOO doesn't + check the return value from this function to see if it failed; it ends up + returning an empty string in this case. EtaMOO raises `E_INVARG` instead. + Note that `crypt()` can fail if an unsupported salt parameter is used. + + * The `value_hash()`, `string_hash()`, and `binary_hash()` built-in + functions in EtaMOO accept two optional arguments in addition to the value + or string to be hashed. The second argument is a string which selects the + particular hash algorithm to use, and defaults to `"MD5"`. The following + algorithms are supported: + + MD2 SHA-256 SHA3-256 Skein-512-256 + MD4 SHA-384 SHA3-384 Skein-512-384 + MD5 SHA-512 SHA3-512 Skein-512-512 + RIPEMD-160 SHA-512/224 Skein-256-224 Tiger + SHA-1 SHA-512/256 Skein-256-256 Whirlpool + SHA-224 SHA3-224 Skein-512-224 + + The third argument, if provided and true, causes the digest value to be + returned as a binary string instead of a string of hexadecimal digits. + + * In LambdaMOO, the strings returned from the `value_hash()`, + `string_hash()`, `binary_hash()`, and `encode_binary()` built-in functions + use uppercase hexadecimal digits. In EtaMOO, these strings use lowercase + digits. + + * EtaMOO expects only printable ASCII characters to be present within MOO + binary strings; in particular, ASCII HT (horizontal tab) is forbidden, and + should be encoded instead as `"~09"`. + + * In LambdaMOO, the `buffered_output_length()` built-in returns the number + of *bytes* currently buffered for output to a connection. In EtaMOO, this + built-in currently returns the number of *items* buffered, where an item + essentially represents all the data from a single call to `notify()`. + (This is subject to change.) + + * EtaMOO accepts an optional argument to the `db_disk_size()` built-in that, + if provided and true, causes the function to return an association list + with various statistics from the persistence layer. + + * The result of the `disassemble()` built-in is very different in EtaMOO + than in LambdaMOO, and currently shows the internal abstract syntax tree + associated with a verb. (This is subject to change.) + + * The effective range of object values in EtaMOO is system-dependent, and + not necessarily the same as the range of integer values. + + * Due to the way regular expression matching is implemented in EtaMOO, the + `match()` built-in function is generally going to be more efficient than + `rmatch()` and may also be able to handle a greater range of patterns + before encountering resource limitations. + + * The numbers returned by the `value_bytes()` and `object_bytes()` built-in + functions, as well as the last number in each list returned by + `queued_tasks()`, are really vague estimates and probably not very + accurate or meaningful due to the nature of the Haskell run time + environment. diff --git a/EtaMOO.cabal b/EtaMOO.cabal --- a/EtaMOO.cabal +++ b/EtaMOO.cabal @@ -1,6 +1,6 @@ name: EtaMOO -version: 0.2.0.0 +version: 0.3.0.0 synopsis: A new implementation of the LambdaMOO server @@ -11,18 +11,18 @@ conferencing systems, and other collaborative software. . EtaMOO is an experimental multithreaded implementation of LambdaMOO in - Haskell with anticipated ready support for 64-bit MOO integers and Unicode - MOO strings. The implementation follows the specifications of the LambdaMOO - Programmer's Manual, and should be compatible with most LambdaMOO databases - as of about version 1.8.3 of the LambdaMOO server code. + Haskell with LMDB-backed persistence and anticipated ready support for + Unicode MOO strings and 64-bit MOO integers. The implementation follows the + specifications of the LambdaMOO Programmer's Manual, and should be + compatible with most LambdaMOO databases as of about version 1.8.3 of the + LambdaMOO server code. . - /N.B./ This is (currently) incomplete software. It is not yet fully usable, - although with further development it is hoped that it soon will be. + /N.B./ This software is still under development and not fully complete. license: BSD3 license-file: LICENSE -copyright: © 2014–2015 Robert Leslie +copyright: © 2014–2016 Robert Leslie author: Rob Leslie maintainer: Rob Leslie @@ -30,14 +30,16 @@ category: Network build-type: Simple -cabal-version: >=1.8 -tested-with: GHC == 7.6.3 +cabal-version: >= 1.22 +tested-with: GHC == 7.10.3 homepage: http://verement.github.io/etamoo bug-reports: https://github.com/verement/etamoo/issues -extra-source-files: README.md - src/cbits/crypt.h +extra-source-files: ACKNOWLEDGMENTS.md + DIFFERENCES.md + README.md + TODO src/cbits/match.h source-repository head @@ -61,6 +63,8 @@ default: False executable etamoo + default-language: Haskell2010 + hs-source-dirs: src main-is: etamoo.hs @@ -68,7 +72,10 @@ MOO.Builtins MOO.Builtins.Common MOO.Builtins.Crypt + MOO.Builtins.Extra + MOO.Builtins.Hash MOO.Builtins.Match + MOO.Builtins.Misc MOO.Builtins.Network MOO.Builtins.Objects MOO.Builtins.Tasks @@ -78,6 +85,7 @@ MOO.Connection MOO.Database MOO.Database.LambdaMOO + MOO.List MOO.Network MOO.Network.Console MOO.Network.TCP @@ -88,62 +96,65 @@ MOO.Task MOO.Types MOO.Unparser + MOO.Util MOO.Verb MOO.Version Paths_EtaMOO - ghc-options: -threaded -rtsopts + ghc-options: -threaded -rtsopts -with-rtsopts=-N if flag(llvm) ghc-options: -fllvm - extensions: CPP + default-extensions: + other-extensions: CPP + DeriveDataTypeable EmptyDataDecls ExistentialQuantification FlexibleInstances ForeignFunctionInterface + GeneralizedNewtypeDeriving OverloadedStrings - TypeSynonymInstances + Rank2Types - extra-libraries: pcre + pkgconfig-depends: libpcre >= 8.20 + if !os(darwin) extra-libraries: crypt if flag(64bit) cpp-options: -DMOO_64BIT_INTEGER - if flag(outbound-network) cpp-options: -DMOO_OUTBOUND_NETWORK - includes: unistd.h pcre.h - - c-sources: src/cbits/crypt.c - src/cbits/match.c + c-sources: src/cbits/match.c build-depends: array - , base ==4.* + , async + , base >= 4.7 && ==4.* , bytestring , case-insensitive , containers >= 0.4 + , cryptonite , hashable , haskeline + , memory , mtl , network - , old-locale , parsec , pipes , pipes-bytestring - , pipes-concurrency + , pipes-concurrency >= 2.0.3 , pipes-network , random , stm , stm-chans - , text >= 1.2 - , time + , text >= 1.2.1.2 + , time >= 1.5 + , transformers , unix , unordered-containers - , pureMD5 - , transformers - , vector + , vcache + , vector >= 0.7 build-tools: hsc2hs diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2015, Robert Leslie +Copyright (c) 2014-2016, Robert Leslie All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,14 +2,12 @@ Important! ========== -**This is experimental and (currently) incomplete software. It is not yet -fully usable, although with further development it is hoped that it soon will -be.** +**This is experimental software. While it is now mostly functional, it is not + yet fully complete.** -_At present, the code will load a database and listen for network -connections. You can connect using any `telnet` client and interact with the -MOO environment, however no changes to the database will be saved, and a few -other features have also yet to be implemented._ +_Until such time as the EtaMOO database format is well tested and considered +stable, please make and keep LambdaMOO-format backup copies of your EtaMOO +databases._ About ===== @@ -31,43 +29,130 @@ also used for network connection management, so for example name lookups do not block the entire server. - * EtaMOO supports 64-bit MOO integers via compile-time build option. + * EtaMOO uses [LMDB][] as a persistent backing store for the MOO database. + Changes are committed on an ongoing basis for instantaneous crash + recovery; checkpoints merely perform a quick synchronization, and are + otherwise unnecessary. EtaMOO provides mechanisms for importing and + exporting LambdaMOO-format databases to and from the EtaMOO-native format. * EtaMOO is Unicode-aware, and will eventually include support for Unicode MOO strings via compile-time build option. + * EtaMOO supports 64-bit MOO integers via compile-time build option. + + * EtaMOO natively supports string-key association lists with efficient + lookup and update operations; the list index syntax has been extended to + allow _`alist`_`[`_`key`_`]` and _`alist`_`[`_`key`_`] = `_`value`_ for + string *`key`*s whenever *`alist`* is a well-formed association list. + + * EtaMOO supports several additional hashing algorithms besides MD5, + including SHA-1, SHA-2, SHA-3, and RIPEMD-160, via optional argument to + `string_hash()`, `binary_hash()`, and `value_hash()`. Hash digests may + also optionally be returned as binary strings. + + * EtaMOO internally handles binary strings in an efficient manner, and only + translates to and from the special MOO *binary string* syntax upon demand. + For example, passing a binary string read from the network directly to + `decode_binary()` does not suffer a round trip through the *binary string* + representation. + + * EtaMOO supports fractional second delays in `suspend()` and `fork`. + * EtaMOO supports IPv6. -The implementation of EtaMOO closely follows the specifications of the -[LambdaMOO Programmer's Manual][Programmer's Manual], and should therefore be -compatible with most LambdaMOO databases as of about version 1.8.3 of the -LambdaMOO server code. + [LMDB]: http://symas.com/mdb/ - [Programmer's Manual]: http://www.ipomoea.org/moo/#progman +The implementation of EtaMOO otherwise closely follows the specifications of +the [LambdaMOO Programmer's Manual][], and should be compatible with most +LambdaMOO databases as of about version 1.8.3 of the LambdaMOO server code. + [LambdaMOO Programmer's Manual]: http://www.ipomoea.org/moo/#progman + Installing ---------- EtaMOO is built with [Cabal][], the Haskell package manager. In the simplest -case, simply running: +case, running: cabal install EtaMOO should automatically download, build, and install the `etamoo` executable after doing the same for all of its Haskell dependencies. - [Cabal]: http://www.haskell.org/cabal/ - Cabal itself is part of the [Haskell Platform][] which is available for many distributions and platforms. + [Cabal]: http://www.haskell.org/cabal/ [Haskell Platform]: http://www.haskell.org/platform/ -EtaMOO has non-Haskell dependencies on two external libraries: _libpcre_ (with -UTF-8 support enabled) for regular expression matching, and, possibly, -_libcrypt_ (often part of the standard libraries) for the MOO `crypt()` -built-in function. You may need to ensure you have these available before -installing EtaMOO. +There are a few options you can give to `cabal install` to customize your +build: + +| Option | Feature | +| --------------------- | --------------------------------------------- | +| `-j` | Build in parallel using multiple processors | +| `-f llvm` | Use GHC's LLVM backend to compile the code | +| `-f 64bit` | Enable 64-bit MOO integers | + +EtaMOO has non-Haskell dependencies on three external libraries: _liblmdb_ for +database persistence, _libpcre_ (with UTF-8 support enabled) for regular +expression matching, and, possibly, _libcrypt_ (often part of the standard +libraries) for the MOO `crypt()` built-in function. You should ensure you have +these available before installing EtaMOO (e.g. on Debian-derived systems, +`sudo apt-get install liblmdb-dev libpcre3-dev`). + +Running +------- + +`etamoo` is nearly a drop-in replacement for the LambdaMOO `moo` executable; +the main difference is that `etamoo` takes a single database path, rather than +both input and output paths. You can run `etamoo --help` for a command-line +synopsis. + +EtaMOO uses a native binary database format that allows quick loading and +checkpointing, and instantaneous crash recovery. You can create a native +database from a LambdaMOO-format database by using `etamoo --import`. You can +also go the other way and convert an EtaMOO database back to a +LambdaMOO-format database with `etamoo --export`. + +If you don't already have a database, you can find LambdaMOO-format cores for +various MOOs online -- for example there is the venerable [LambdaCore][], or +you can request a character on [Waterpoint][] and then perform a live +[JHCore extraction][]. (Note that Waterpoint's core extraction process +requires running an actual LambdaMOO server executable on the precore database +to obtain the final core database; EtaMOO cannot yet do this itself.) + + [LambdaCore]: http://ftp.lambda.moo.mud.org/pub/MOO/ + [Waterpoint]: http://waterpoint.moo.mud.org/ + [JHCore extraction]: http://waterpoint.moo.mud.org:8080/core-extraction/ + +By default, EtaMOO will make use of all available CPUs for maximum +parallelism. If you'd rather limit the number of processors EtaMOO uses, you +can use the command-line option `+RTS -N`_`n`_` -RTS` where _`n`_ is the +number of processors to use. + +If you want to enable statistics from the `memory_usage()` built-in function, +you will need to add `+RTS -T -RTS` to the command line options. + +Limitations +----------- + +The following LambdaMOO features are currently unsupported: + + * The `.program` intrinsic command + * The `verb_cache_stats()` and `log_cache_stats()` built-in functions + * Importing, exporting, or checkpointing of queued tasks in the database + file + * Task time limits (ticks are counted, but seconds are not) + * The `NP_SINGLE` and `NP_LOCAL` network protocols (i.e. stdin/stdout, + UNIX-domain sockets, and/or named pipes; only TCP/IP is supported) + * Customizing `OUT_OF_BAND_PREFIX` and `OUT_OF_BAND_QUOTE_PREFIX` (these are + currently fixed as `#$#` and `#$"`, respectively) + * The `IGNORE_PROP_PROTECTED` compilation option + * `$server_options.name_lookup_timeout` + +See also the `DIFFERENCES.md` file for other differences between EtaMOO and +LambdaMOO. Hacking ------- diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,72 @@ +-*- Outline -*- + +* § 3 The Built-in Command Parser +** hold-input connection option +** .program built-in command +** L.do_command() suspending? + - re-examine all possible results +* § 4 The MOO Programming Language +** § 4.4 Built-in Functions +*** § 4.4.4 Operations on Network Connections +**** open_network_connection() +**** hold-input +*** § 4.4.8 Server Statistics and Miscellaneous Information +**** verb_cache_stats() +**** log_cache_stats() +* § 5 Server Commands and Database Assumptions +** § 5.1 Command Lines That Receive Special Treatment +*** § 5.1.5 The .program Command +**** .program +** § 5.2 Server Assumptions About the Database +*** § 5.2.2 Server Messages Set in the Database +**** server_full_msg +**** timeout_msg +*** § 5.2.6 Player Input Handlers +**** $do_command uncaught exceptions + +* Other +** Gather constants into a single location? + - oob prefix, default port, etc. + - merge MOO.Database.LambdaMOO.default_max_stack_depth +** queue_info() includes owner of current task? +** recycle() object which is a target of a listening point +** PREFIX/SUFFIX on empty input line, uncaught exception +** Handle 'read' parsing errors +** Revisit read() invariant +** Enhance version number with git commit info +** Unicode strings in database file +** Close stdin/stdout + +* Before v1.0 +** Fix read() and OOB +** Emergency Wizard Mode +** L.server_options.connect_timeout +** Top-level Haskell exception handling +** open_network_connection() +** hold-input +** Trap ^C interrupts + +* For v2.0 or later +** General Unicode support +** TLS connection option +** Buffer outgoing data into larger chunks +** Task time limits? +** Optimize MOO AST for compilation + - Bind built-in functions directly to implementations +** Alternative input languages? +** JIT compilation to LLVM? +** Read and write queued tasks +** Intern strings on parsing and database load +** Rewrite database reading using Attoparsec +** Rewrite parser using Happy +** Rewrite regexp translator using Writer monad +** MOO string and list size limits? +** .program +** Release unused memory upon storing property values +** $server_options.{max_list_concat,max_string_concat} +** $server_options.max_concat_catchable + - to govern whether violating new size limits causes out-of-seconds or + E_QUOTA error +** LM-compatible bytecode generation and decompilation +** Use PCRE 16-bit library (libpcre16) +** Avoid space leaks on loop variables diff --git a/src/MOO/AST.hs b/src/MOO/AST.hs --- a/src/MOO/AST.hs +++ b/src/MOO/AST.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveDataTypeable #-} + -- | Data structures representing an abstract syntax tree for MOO code module MOO.AST ( @@ -22,34 +24,95 @@ ) where +import Control.Applicative ((<$>), (<*>), pure) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Database.VCache (VCacheable(put, get), VPut, VGet, putWord8) + import MOO.Types newtype Program = Program [Statement] - deriving Show + deriving (Show, Typeable) +instance VCacheable Program where + put (Program smts) = put smts + get = Program <$> get + instance Sizeable Program where storageBytes (Program stmts) = storageBytes stmts -data Statement = Expression !Int Expr - | If !Int Expr Then [ElseIf] Else - | ForList !Int Id Expr [Statement] - | ForRange !Int Id (Expr, Expr) [Statement] - | While !Int (Maybe Id) Expr [Statement] - | Fork !Int (Maybe Id) Expr [Statement] - | Break (Maybe Id) - | Continue (Maybe Id) - | Return !Int (Maybe Expr) - | TryExcept [Statement] [Except] - | TryFinally [Statement] Finally - deriving Show +data Statement = Expression !LineNo Expr + | If !LineNo Expr Then [ElseIf] Else + | ForList !LineNo Id Expr [Statement] + | ForRange !LineNo Id (Expr, Expr) [Statement] + | While !LineNo (Maybe Id) Expr [Statement] + | Fork !LineNo (Maybe Id) Expr [Statement] + | Break (Maybe Id) + | Continue (Maybe Id) + | Return !LineNo (Maybe Expr) + | TryExcept [Statement] [Except] + | TryFinally [Statement] Finally + deriving (Show, Typeable) -newtype Then = Then [Statement] deriving Show -data ElseIf = ElseIf !Int Expr [Statement] deriving Show -newtype Else = Else [Statement] deriving Show +newtype Then = Then [Statement] deriving (Show, Typeable) -data Except = Except !Int (Maybe Id) Codes [Statement] deriving Show -newtype Finally = Finally [Statement] deriving Show +data ElseIf = ElseIf !LineNo Expr [Statement] deriving (Show, Typeable) +newtype Else = Else [Statement] deriving (Show, Typeable) +data Except = Except !LineNo (Maybe Id) Codes [Statement] + deriving (Show, Typeable) +newtype Finally = Finally [Statement] + deriving (Show, Typeable) + +instance VCacheable Statement where + put s = case s of + Expression line expr -> putTag2 00 line expr + If line expr thens elseIfs elses -> putTag5 01 line expr thens elseIfs elses + ForList line var expr smts -> putTag4 02 line var expr smts + ForRange line var range smts -> putTag4 03 line var range smts + While line var expr smts -> putTag4 04 line var expr smts + Fork line var expr smts -> putTag4 05 line var expr smts + Break var -> putTag1 06 var + Continue var -> putTag1 07 var + Return line expr -> putTag2 08 line expr + TryExcept smts excepts -> putTag2 09 smts excepts + TryFinally smts finally -> putTag2 10 smts finally + + get = get >>= \tag -> case tag of + 00 -> Expression <$> get <*> get + 01 -> If <$> get <*> get <*> get <*> get <*> get + 02 -> ForList <$> get <*> get <*> get <*> get + 03 -> ForRange <$> get <*> get <*> get <*> get + 04 -> While <$> get <*> get <*> get <*> get + 05 -> Fork <$> get <*> get <*> get <*> get + 06 -> Break <$> get + 07 -> Continue <$> get + 08 -> Return <$> get <*> get + 09 -> TryExcept <$> get <*> get + 10 -> TryFinally <$> get <*> get + _ -> unknownTag "Statement" tag + +instance VCacheable Then where + put (Then smts) = put smts + get = Then <$> get + +instance VCacheable ElseIf where + put (ElseIf line expr smts) = put line >> put expr >> put smts + get = ElseIf <$> get <*> get <*> get + +instance VCacheable Else where + put (Else smts) = put smts + get = Else <$> get + +instance VCacheable Except where + put (Except line var codes smts) = + put line >> put var >> put codes >> put smts + get = Except <$> get <*> get <*> get <*> get + +instance VCacheable Finally where + put (Finally smts) = put smts + get = Finally <$> get + instance Sizeable Statement where storageBytes (Expression line expr) = storageBytes () + storageBytes line + storageBytes expr @@ -126,8 +189,74 @@ | Catch Expr Codes Default - deriving Show + deriving (Show, Typeable) +instance VCacheable Expr where + put expr = case expr of + Literal val -> putTag1 00 val + List args -> putTag1 01 args + Variable var -> putTag1 02 var + PropertyRef obj name -> putTag2 03 obj name + Assign var expr -> putTag2 04 var expr + Scatter items expr -> putTag2 05 items expr + VerbCall obj name args -> putTag3 06 obj name args + BuiltinFunc name args -> putTag2 07 name args + expr `Index` index -> putTag2 08 expr index + expr `Range` range -> putTag2 09 expr range + Length -> putTag0 10 + item `In` expr -> putTag2 11 item expr + x `Plus` y -> putTag2 12 x y + x `Minus` y -> putTag2 13 x y + x `Times` y -> putTag2 14 x y + x `Divide` y -> putTag2 15 x y + x `Remain` y -> putTag2 16 x y + x `Power` y -> putTag2 17 x y + Negate expr -> putTag1 18 expr + Conditional cond x y -> putTag3 19 cond x y + x `And` y -> putTag2 20 x y + x `Or` y -> putTag2 21 x y + Not expr -> putTag1 22 expr + x `CompareEQ` y -> putTag2 23 x y + x `CompareNE` y -> putTag2 24 x y + x `CompareLT` y -> putTag2 25 x y + x `CompareLE` y -> putTag2 26 x y + x `CompareGT` y -> putTag2 27 x y + x `CompareGE` y -> putTag2 28 x y + Catch expr codes def -> putTag3 29 expr codes def + + get = get >>= \tag -> case tag of + 00 -> Literal <$> get + 01 -> List <$> get + 02 -> Variable <$> get + 03 -> PropertyRef <$> get <*> get + 04 -> Assign <$> get <*> get + 05 -> Scatter <$> get <*> get + 06 -> VerbCall <$> get <*> get <*> get + 07 -> BuiltinFunc <$> get <*> get + 08 -> Index <$> get <*> get + 09 -> Range <$> get <*> get + 10 -> pure Length + 11 -> In <$> get <*> get + 12 -> Plus <$> get <*> get + 13 -> Minus <$> get <*> get + 14 -> Times <$> get <*> get + 15 -> Divide <$> get <*> get + 16 -> Remain <$> get <*> get + 17 -> Power <$> get <*> get + 18 -> Negate <$> get + 19 -> Conditional <$> get <*> get <*> get + 20 -> And <$> get <*> get + 21 -> Or <$> get <*> get + 22 -> Not <$> get + 23 -> CompareEQ <$> get <*> get + 24 -> CompareNE <$> get <*> get + 25 -> CompareLT <$> get <*> get + 26 -> CompareLE <$> get <*> get + 27 -> CompareGT <$> get <*> get + 28 -> CompareGE <$> get <*> get + 29 -> Catch <$> get <*> get <*> get + _ -> unknownTag "Expr" tag + instance Sizeable Expr where storageBytes (Literal value) = storageBytes () + storageBytes value storageBytes (List args) = storageBytes () + storageBytes args @@ -173,17 +302,33 @@ storageBytes (Catch expr codes (Default dv)) = storageBytes () + storageBytes expr + storageBytes codes + storageBytes dv -data Codes = ANY | Codes [Argument] deriving Show -newtype Default = Default (Maybe Expr) deriving Show +data Codes = ANY | Codes [Argument] deriving (Show, Typeable) +newtype Default = Default (Maybe Expr) deriving (Show, Typeable) +instance VCacheable Codes where + put codes = put $ case codes of + ANY -> Nothing + Codes codes -> Just codes + get = maybe ANY Codes <$> get + +instance VCacheable Default where + put (Default expr) = put expr + get = Default <$> get + instance Sizeable Codes where storageBytes ANY = storageBytes () storageBytes (Codes args) = storageBytes () + storageBytes args data Argument = ArgNormal Expr | ArgSplice Expr - deriving Show + deriving (Show, Typeable) +instance VCacheable Argument where + put arg = put $ case arg of + ArgNormal expr -> Left expr + ArgSplice expr -> Right expr + get = either ArgNormal ArgSplice <$> get + instance Sizeable Argument where storageBytes (ArgNormal expr) = storageBytes () + storageBytes expr storageBytes (ArgSplice expr) = storageBytes () + storageBytes expr @@ -191,8 +336,20 @@ data ScatterItem = ScatRequired Id | ScatOptional Id (Maybe Expr) | ScatRest Id - deriving Show + deriving (Show, Typeable) +instance VCacheable ScatterItem where + put item = case item of + ScatRequired var -> putTag1 0 var + ScatOptional var expr -> putTag2 1 var expr + ScatRest var -> putTag1 2 var + + get = get >>= \tag -> case tag of + 0 -> ScatRequired <$> get + 1 -> ScatOptional <$> get <*> get + 2 -> ScatRest <$> get + _ -> unknownTag "ScatterItem" tag + instance Sizeable ScatterItem where storageBytes (ScatRequired var) = storageBytes () + storageBytes var storageBytes (ScatOptional var expr) = @@ -249,3 +406,29 @@ Range{} -> 9 _ -> 10 + +putTag0 :: Word8 -> VPut () +putTag0 = putWord8 + +putTag1 :: VCacheable a => Word8 -> a -> VPut () +putTag1 tag a = putWord8 tag >> put a + +putTag2 :: (VCacheable a, VCacheable b) => Word8 -> a -> b -> VPut () +putTag2 tag a b = putWord8 tag >> put a >> put b + +putTag3 :: (VCacheable a, VCacheable b, VCacheable c) => + Word8 -> a -> b -> c -> VPut () +putTag3 tag a b c = putWord8 tag >> put a >> put b >> put c + +putTag4 :: (VCacheable a, VCacheable b, VCacheable c, VCacheable d) => + Word8 -> a -> b -> c -> d -> VPut () +putTag4 tag a b c d = putWord8 tag >> put a >> put b >> put c >> put d + +putTag5 :: (VCacheable a, VCacheable b, VCacheable c, VCacheable d, + VCacheable e) => Word8 -> a -> b -> c -> d -> e -> VPut () +putTag5 tag a b c d e = + putWord8 tag >> put a >> put b >> put c >> put d >> put e + +unknownTag :: String -> Word8 -> VGet a +unknownTag what tag = + fail $ "get: unknown " ++ what ++ " tag (" ++ show tag ++ ")" diff --git a/src/MOO/Builtins.hs b/src/MOO/Builtins.hs --- a/src/MOO/Builtins.hs +++ b/src/MOO/Builtins.hs @@ -1,43 +1,34 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module MOO.Builtins ( builtinFunctions, callBuiltin, verifyBuiltins ) where -import Control.Monad (foldM, liftM, join) -import Control.Monad.State (gets) +import Control.Applicative ((<$>)) +import Control.Monad (foldM) +import Data.HashMap.Lazy (HashMap) import Data.List (transpose, inits) -import Data.Map (Map) import Data.Maybe (fromMaybe) -import Data.Time (formatTime, utcToLocalZonedTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) -import System.Locale (defaultTimeLocale) - -# ifdef __GLASGOW_HASKELL__ -import GHC.Stats (GCStats(..), getGCStats, getGCStatsEnabled) -# endif +import Data.Monoid ((<>)) -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM import MOO.Builtins.Common -import MOO.Types -import MOO.Task import MOO.Database import MOO.Object -import MOO.Version +import MOO.Task +import MOO.Types -import MOO.Builtins.Values as Values -import MOO.Builtins.Objects as Objects +import MOO.Builtins.Extra as Extra +import MOO.Builtins.Misc as Misc import MOO.Builtins.Network as Network +import MOO.Builtins.Objects as Objects import MOO.Builtins.Tasks as Tasks - -import qualified MOO.String as Str - -{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} +import MOO.Builtins.Values as Values --- | A 'Map' of all built-in functions, keyed by name -builtinFunctions :: Map Id Builtin +-- | A 'HashMap' of all built-in functions, keyed by name +builtinFunctions :: HashMap Id Builtin builtinFunctions = - M.fromList $ map assoc $ miscBuiltins ++ + HM.fromList $ map assoc $ Extra.builtins ++ Misc.builtins ++ Values.builtins ++ Objects.builtins ++ Network.builtins ++ Tasks.builtins where assoc builtin = (builtinName builtin, builtin) @@ -45,28 +36,39 @@ -- for the appropriate number and types of arguments. Raise 'E_INVARG' if the -- built-in function is unknown. callBuiltin :: Id -> [Value] -> MOO Value -callBuiltin func args = case M.lookup func builtinFunctions of - Just builtin -> checkArgs builtin args >> builtinFunction builtin args - Nothing -> raiseException (Err E_INVARG) - "Unknown built-in function" (Str $ fromId func) +callBuiltin func args = do + isProtected <- ($ func) <$> serverOption protectFunction + case (func `HM.lookup` builtinFunctions, isProtected) of + (Just builtin, False) -> call builtin + (Just builtin, True) -> do + this <- frame initialThis + if this == systemObject then call builtin + else callSystemVerb ("bf_" <> fromId func) args >>= + maybe (checkWizard >> call builtin) return + (Nothing, _) -> let name = fromId func + message = "Unknown built-in function: " <> name + in raiseException (Err E_INVARG) message (Str name) - where checkArgs :: Builtin -> [Value] -> MOO () + where call :: Builtin -> MOO Value + call builtin = checkArgs builtin args >> builtinFunction builtin args + + checkArgs :: Builtin -> [Value] -> MOO () checkArgs Builtin { builtinMinArgs = min , builtinMaxArgs = max , builtinArgTypes = types - } args = - let nargs = length args - in if nargs < min || nargs > fromMaybe nargs max then raise E_ARGS - else checkTypes types args + } args + | nargs < min || maybe False (nargs >) max = raise E_ARGS + | otherwise = checkTypes types args + where nargs = length args :: Int checkTypes :: [Type] -> [Value] -> MOO () - checkTypes (t:ts) (a:as) = - if typeMismatch t (typeOf a) then raise E_TYPE - else checkTypes ts as - checkTypes _ _ = return () + checkTypes (t:ts) (v:vs) + | typeMismatch t (typeOf v) = raise E_TYPE + | otherwise = checkTypes ts vs + checkTypes _ _ = return () typeMismatch :: Type -> Type -> Bool - typeMismatch x y | x == y = False + typeMismatch a b | a == b = False typeMismatch TAny _ = False typeMismatch TNum TInt = False typeMismatch TNum TFlt = False @@ -80,8 +82,12 @@ -- describing an inconsistency, or an integer giving the total number of -- (verified) built-in functions. verifyBuiltins :: Either String Int -verifyBuiltins = foldM accum 0 $ M.elems builtinFunctions - where accum a b = valid b >>= Right . (+ a) +verifyBuiltins = foldM accum 0 $ HM.elems builtinFunctions + + where accum :: Int -> Builtin -> Either String Int + accum a b = valid b >>= Right . (+ a) + + valid :: Builtin -> Either String Int valid Builtin { builtinName = name , builtinMinArgs = min , builtinMaxArgs = max @@ -92,7 +98,8 @@ | maybe False (< min) max = invalid "arg max < min" | length types /= fromMaybe min max = invalid "incorrect # types" | testArgs func min max types = ok - where invalid msg = Left $ "problem with built-in function " ++ + where invalid :: String -> Either String Int + invalid msg = Left $ "problem with built-in function " ++ fromId name ++ ": " ++ msg ok = Right 1 @@ -104,7 +111,7 @@ enumerateArgs argSpec enumerateArgs :: [[Value]] -> [[Value]] - enumerateArgs (a:[]) = transpose [a] + enumerateArgs [a] = transpose [a] enumerateArgs (a:as) = concatMap (combine a) (enumerateArgs as) where combine ps rs = map (: rs) ps enumerateArgs [] = [[]] @@ -119,137 +126,3 @@ mkArgs TObj = [Obj 0] mkArgs TErr = [Err E_NONE] mkArgs TLst = [emptyList] - --- § 4.4 Built-in Functions - -miscBuiltins :: [Builtin] -miscBuiltins = [ - -- § 4.4.1 Object-Oriented Programming - bf_pass - - -- § 4.4.5 Operations Involving Times and Dates - , bf_time - , bf_ctime - - -- § 4.4.7 Administrative Operations - , bf_dump_database - , bf_shutdown - , bf_load_server_options - , bf_server_log - , bf_renumber - , bf_reset_max_object - - -- § 4.4.8 Server Statistics and Miscellaneous Information - , bf_server_version - , bf_memory_usage - , bf_db_disk_size - , bf_verb_cache_stats - , bf_log_cache_stats - ] - --- § 4.4.1 Object-Oriented Programming - -bf_pass = Builtin "pass" 0 Nothing [] TAny $ \args -> do - (name, verbLoc, this) <- frame $ \frame -> - (verbName frame, verbLocation frame, initialThis frame) - maybeMaybeParent <- fmap objectParent `liftM` getObject verbLoc - case join maybeMaybeParent of - Just parent -> callVerb parent this name args - Nothing -> raise E_VERBNF - --- § 4.4.5 Operations Involving Times and Dates - -currentTime :: MOO IntT -currentTime = (floor . utcTimeToPOSIXSeconds) `liftM` gets startTime - -bf_time = Builtin "time" 0 (Just 0) [] TInt $ \[] -> Int `liftM` currentTime - -bf_ctime = Builtin "ctime" 0 (Just 1) [TInt] TStr $ \arg -> case arg of - [] -> ctime =<< currentTime - [Int time] -> ctime time - -ctime :: IntT -> MOO Value -ctime time = do - zonedTime <- unsafeIOtoMOO (utcToLocalZonedTime utcTime) - return $ Str $ Str.fromString $ formatTime defaultTimeLocale format zonedTime - where utcTime = posixSecondsToUTCTime (fromIntegral time) - format = "%a %b %_d %T %Y %Z" - --- § 4.4.7 Administrative Operations - -bf_dump_database = Builtin "dump_database" 0 (Just 0) [] TAny $ \[] -> - notyet "dump_database" - -bf_shutdown = Builtin "shutdown" 0 (Just 1) [TStr] TAny $ \optional -> do - let (message : _) = maybeDefaults optional - - checkWizard - - name <- getObjectName =<< frame permissions - let msg = "shutdown() called by " `Str.append` name - - shutdown $ maybe msg (\(Str reason) -> Str.concat [msg, ": ", reason]) message - return zero - -bf_load_server_options = Builtin "load_server_options" 0 (Just 0) - [] TAny $ \[] -> - checkWizard >> loadServerOptions >> return zero - -bf_server_log = Builtin "server_log" 1 (Just 2) - [TStr, TAny] TAny $ \(Str message : optional) -> - let [is_error] = booleanDefaults optional [False] - in notyet "server_log" - -bf_renumber = Builtin "renumber" 1 (Just 1) [TObj] TObj $ \[Obj object] -> - notyet "renumber" - -bf_reset_max_object = Builtin "reset_max_object" 0 (Just 0) [] TAny $ \[] -> do - checkWizard - getDatabase >>= liftSTM . resetMaxObject >>= putDatabase - return zero - --- § 4.4.8 Server Statistics and Miscellaneous Information - -bf_server_version = Builtin "server_version" 0 (Just 0) [] TStr $ \[] -> - return (Str $ Str.fromText serverVersion) - -bf_memory_usage = Builtin "memory_usage" 0 (Just 0) [] TLst $ \[] -> -# ifdef __GLASGOW_HASKELL__ - -- Server must be run with +RTS -T to enable statistics - do maybeStats <- requestIO $ do - enabled <- getGCStatsEnabled - if enabled then Just `liftM` getGCStats else return Nothing - - return $ case maybeStats of - Just stats -> - let nused = currentBytesUsed stats - nfree = maxBytesUsed stats - nused - maxBlockSize = 2 ^ (floor $ logBase (2 :: Double) $ - fromIntegral $ max nused nfree :: Int) - in fromListBy (fromListBy $ Int . fromIntegral) $ - blocks maxBlockSize nused nfree - Nothing -> emptyList - - where blocks :: (Integral a) => a -> a -> a -> [[a]] - blocks _ 0 0 = [] - blocks blockSize nused nfree = - let nusedBlocks = nused `div` blockSize - nfreeBlocks = nfree `div` blockSize - rest = blocks (blockSize `div` 2) - (nused - nusedBlocks * blockSize) - (nfree - nfreeBlocks * blockSize) - in case (nusedBlocks, nfreeBlocks) of - (0, 0) -> rest - _ -> [blockSize, nusedBlocks, nfreeBlocks] : rest -# else - return emptyList -- ... nothing to see here -# endif - -bf_db_disk_size = Builtin "db_disk_size" 0 (Just 0) [] TInt $ \[] -> - notyet "db_disk_size" - -- raise E_QUOTA - -bf_verb_cache_stats = Builtin "verb_cache_stats" 0 (Just 0) [] TLst $ \[] -> - notyet "verb_cache_stats" -bf_log_cache_stats = Builtin "log_cache_stats" 0 (Just 0) [] TAny $ \[] -> - notyet "log_cache_stats" diff --git a/src/MOO/Builtins.hs-boot b/src/MOO/Builtins.hs-boot --- a/src/MOO/Builtins.hs-boot +++ b/src/MOO/Builtins.hs-boot @@ -2,11 +2,11 @@ module MOO.Builtins ( builtinFunctions, callBuiltin ) where -import Data.Map (Map) +import Data.HashMap.Lazy (HashMap) import MOO.Types import MOO.Task import MOO.Builtins.Common -builtinFunctions :: Map Id Builtin +builtinFunctions :: HashMap Id Builtin callBuiltin :: Id -> [Value] -> MOO Value diff --git a/src/MOO/Builtins/Common.hs b/src/MOO/Builtins/Common.hs --- a/src/MOO/Builtins/Common.hs +++ b/src/MOO/Builtins/Common.hs @@ -20,9 +20,8 @@ defaultOptions :: (Value -> a) -> [Value] -> [a] -> [a] defaultOptions f = defaultOptions' where defaultOptions' (v:vs) (_:ds) = f v : defaultOptions' vs ds - defaultOptions' [] (d:ds) = d : defaultOptions' [] ds - defaultOptions' [] [] = [] - defaultOptions' (_:_) [] = error "excess options" + defaultOptions' [] ds = ds + defaultOptions' vs [] = map f vs -- | @defaults@ /optional/ @[@/default-values/@]@ generates an argument list -- by supplying /default-values/ for any missing from /optional/. diff --git a/src/MOO/Builtins/Crypt.hs b/src/MOO/Builtins/Crypt.hs --- a/src/MOO/Builtins/Crypt.hs +++ b/src/MOO/Builtins/Crypt.hs @@ -1,33 +1,32 @@ {-# LANGUAGE ForeignFunctionInterface #-} -{-# CFILES src/cbits/crypt.c #-} module MOO.Builtins.Crypt (crypt) where -import Control.Monad (liftM) -import Foreign (allocaBytes) -import Foreign.C (CString, CInt(..), withCString, peekCString) +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar) +import Control.Exception (bracket) +import Foreign (nullPtr) +import Foreign.C (CString, withCString, peekCString) import System.IO.Unsafe (unsafePerformIO) --- This must be /unsafe/ to block other threads while it executes, since it --- relies on a non-reentrant C function. -foreign import ccall unsafe "static crypt.h" - crypt_helper :: CString -> CString -> CString -> CInt -> IO CInt +foreign import ccall safe "static unistd.h crypt" + c_crypt :: CString -> CString -> IO CString -- | Encrypt a password using the POSIX @crypt()@ function. -crypt :: String -- ^ key - -> String -- ^ salt - -> Maybe String -- ^ encrypted password (or 'Nothing' on error) +crypt :: String -- ^ key + -> String -- ^ salt + -> IO (Maybe String) -- ^ encrypted password (or 'Nothing' on error) crypt key salt = - unsafePerformIO $ withCString key $ \c_key -> - withCString salt $ \c_salt -> crypt' c_key c_salt 16 + withCString salt $ \c_salt -> + bracket (takeMVar mutex) (putMVar mutex) $ \_ -> do + result <- c_crypt c_key c_salt + if result == nullPtr + then return Nothing + else Just <$> peekCString result -crypt' :: CString -> CString -> CInt -> IO (Maybe String) -crypt' key salt len = - allocaBytes (fromIntegral len) $ \encrypted -> do - result <- crypt_helper key salt encrypted len - case result of - 0 -> Just `liftM` peekCString encrypted - -1 -> return Nothing - req -> crypt' key salt req +-- Shared mutex to prevent simultaneous calls to non-reentrant C crypt() +mutex :: MVar () +{-# NOINLINE mutex #-} +mutex = unsafePerformIO $ newMVar () diff --git a/src/MOO/Builtins/Extra.hs b/src/MOO/Builtins/Extra.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Extra.hs @@ -0,0 +1,9 @@ + +{-# LANGUAGE CPP #-} + +module MOO.Builtins.Extra ( builtins ) where + +import MOO.Builtins.Common + +builtins :: [Builtin] +builtins = [] diff --git a/src/MOO/Builtins/Hash.hs b/src/MOO/Builtins/Hash.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Hash.hs @@ -0,0 +1,102 @@ + +{-# LANGUAGE OverloadedStrings #-} + +module MOO.Builtins.Hash (hashBytesUsing) where + +import Crypto.Hash + ( HashAlgorithm, Digest, hash + , MD2(MD2), MD4(MD4), MD5(MD5), RIPEMD160(RIPEMD160) + , SHA1(SHA1), SHA224(SHA224), SHA256(SHA256), SHA384(SHA384), SHA512(SHA512) + , SHA512t_224(SHA512t_224), SHA512t_256(SHA512t_256) + , SHA3_224(SHA3_224), SHA3_256(SHA3_256) + , SHA3_384(SHA3_384), SHA3_512(SHA3_512) + , Skein256_224(Skein256_224), Skein256_256(Skein256_256) + , Skein512_224(Skein512_224), Skein512_256(Skein512_256) + , Skein512_384(Skein512_384), Skein512_512(Skein512_512) + , Tiger(Tiger), Whirlpool(Whirlpool) + ) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.Map (Map) + +import qualified Data.Map as M + +import MOO.Types + +import qualified MOO.String as Str + +hashBytesUsing :: Id -> Bool -> ByteString -> Maybe StrT +hashBytesUsing algorithm wantBinary bytes = + M.lookup algorithm hashFunctions >>= \f -> return (f wantBinary bytes) + +type HashFunction = Bool -> ByteString -> StrT + +hashFunctions :: Map Id HashFunction +hashFunctions = M.fromList algorithms + + where algorithms :: [(Id, HashFunction)] + algorithms = + [ ("MD2" , hashWith MD2 ) + , ("MD4" , hashWith MD4 ) + , ("MD5" , hashWith MD5 ) + + -- RIPEMD + , ("RIPEMD-160" , hashWith RIPEMD160 ) + , ("RIPEMD160" , alias "RIPEMD-160" ) + + -- SHA-1 + , ("SHA-1" , hashWith SHA1 ) + , ("SHA1" , alias "SHA-1" ) + + -- SHA-2 + , ("SHA-224" , hashWith SHA224 ) + , ("SHA-256" , hashWith SHA256 ) + , ("SHA-384" , hashWith SHA384 ) + , ("SHA-512" , hashWith SHA512 ) + , ("SHA-512/224" , hashWith SHA512t_224 ) + , ("SHA-512/256" , hashWith SHA512t_256 ) + + , ("SHA224" , alias "SHA-224" ) + , ("SHA256" , alias "SHA-256" ) + , ("SHA384" , alias "SHA-384" ) + , ("SHA512" , alias "SHA-512" ) + , ("SHA512/224" , alias "SHA-512/224" ) + , ("SHA512/256" , alias "SHA-512/256" ) + + -- SHA-3 + , ("SHA3-224" , hashWith SHA3_224 ) + , ("SHA3-256" , hashWith SHA3_256 ) + , ("SHA3-384" , hashWith SHA3_384 ) + , ("SHA3-512" , hashWith SHA3_512 ) + + , ("SHA-3-224" , alias "SHA3-224" ) + , ("SHA-3-256" , alias "SHA3-256" ) + , ("SHA-3-384" , alias "SHA3-384" ) + , ("SHA-3-512" , alias "SHA3-512" ) + + -- Skein + , ("Skein-256-224", hashWith Skein256_224) + , ("Skein-256-256", hashWith Skein256_256) + + , ("Skein-512-224", hashWith Skein512_224) + , ("Skein-512-256", hashWith Skein512_256) + , ("Skein-512-384", hashWith Skein512_384) + , ("Skein-512-512", hashWith Skein512_512) + + -- Others + , ("Tiger" , hashWith Tiger ) + , ("Whirlpool" , hashWith Whirlpool ) + ] + + alias :: Id -> HashFunction + alias = (hashFunctions M.!) + +hashWith :: HashAlgorithm a => a -> Bool -> ByteString -> StrT +hashWith algorithm wantBinary = mkResult . hash' algorithm + + where hash' :: HashAlgorithm a => a -> ByteString -> Digest a + hash' _ = hash + + mkResult :: Digest a -> StrT + mkResult | wantBinary = Str.fromBinary . convert + | otherwise = Str.fromString . show diff --git a/src/MOO/Builtins/Match.hsc b/src/MOO/Builtins/Match.hsc --- a/src/MOO/Builtins/Match.hsc +++ b/src/MOO/Builtins/Match.hsc @@ -1,5 +1,6 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, + GeneralizedNewtypeDeriving #-} {-# CFILES src/cbits/match.c #-} -- | Regular expression matching via PCRE through the FFI @@ -13,35 +14,45 @@ -- ** Matching , match , rmatch + + -- ** Miscellaneous + , pcreVersion + , verifyPCRE ) where -import Foreign (Ptr, FunPtr, ForeignPtr, alloca, allocaArray, nullPtr, - peek, peekArray, peekByteOff, pokeByteOff, - newForeignPtr, mallocForeignPtrBytes, withForeignPtr, (.|.)) -import Foreign.C (CString, CInt(..), CULong, peekCString) -import Control.Monad (liftM) +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) +import Control.Monad (unless) +import Data.Bits (Bits(zeroBits, (.|.), (.&.), complement)) +import Data.ByteString (ByteString, useAsCString, useAsCStringLen) +import Data.Function (on) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(mempty, mappend), (<>)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Data.ByteString (ByteString, useAsCString, useAsCStringLen) +import Foreign (Ptr, FunPtr, ForeignPtr, toBool, + Storable(peek, peekByteOff, pokeByteOff), + nullPtr, alloca, allocaArray, peekArray, + newForeignPtr, mallocForeignPtrBytes, withForeignPtr) +import Foreign.C (CString, CInt(CInt), CULong, peekCString) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Text as T import qualified Data.ByteString as BS +import qualified Data.Text as T {-# ANN module ("HLint: ignore Avoid lambda" :: String) #-} - -#include +{-# ANN module ("HLint: ignore Redundant lambda" :: String) #-} +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} -data PCRE -data PCREExtra -data CharacterTables +# include -foreign import ccall unsafe "static pcre.h" - pcre_compile :: CString -> CInt -> Ptr CString -> Ptr CInt -> +foreign import ccall safe "static pcre.h" + pcre_compile :: CString -> PCREOptions -> Ptr CString -> Ptr CInt -> Ptr CharacterTables -> IO (Ptr PCRE) -foreign import ccall unsafe "static pcre.h" - pcre_study :: Ptr PCRE -> CInt -> Ptr CString -> IO (Ptr PCREExtra) +foreign import ccall safe "static pcre.h" + pcre_study :: Ptr PCRE -> PCREStudyOptions -> Ptr CString -> + IO (Ptr PCREExtra) foreign import ccall unsafe "static pcre.h &" pcre_free_study :: FunPtr (Ptr PCREExtra -> IO ()) @@ -49,18 +60,61 @@ foreign import ccall unsafe "static pcre.h &" pcre_free :: Ptr (FunPtr (Ptr a -> IO ())) --- This must be /unsafe/ to block other threads while it executes, since it --- relies on being able to modify and use some PCRE global state. -foreign import ccall unsafe "static match.h" - match_helper :: Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> - CInt -> Ptr CInt -> IO CInt +foreign import ccall unsafe "static pcre.h" + pcre_version :: IO CString --- This must be /unsafe/ to block other threads while it executes, since it --- relies on being able to modify and use some PCRE global state. -foreign import ccall unsafe "static match.h" - rmatch_helper :: Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> - CInt -> Ptr CInt -> IO CInt +foreign import ccall unsafe "static pcre.h" + pcre_config :: PCREConfig a -> Ptr a -> IO CInt +foreign import ccall safe "static match.h" match_helper :: Helper +foreign import ccall safe "static match.h" rmatch_helper :: Helper + +type Helper = Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> + PCREOptions -> Ptr CInt -> IO CInt + +data PCRE +data PCREExtra +data CharacterTables + +newtype BitFlags a = Flags a deriving (Eq, Bits, Storable) + +instance Bits a => Monoid (BitFlags a) where + mempty = zeroBits + mappend = (.|.) + +andNot :: Bits a => a -> a -> a +x `andNot` y = x .&. complement y + +newtype PCREOptions = Options (BitFlags CInt) deriving Monoid + +# enum PCREOptions, (Options . Flags) \ + , PCRE_UTF8 \ + , PCRE_NO_UTF8_CHECK \ + , PCRE_DOLLAR_ENDONLY \ + , PCRE_CASELESS + +newtype PCREStudyOptions = StudyOptions (BitFlags CInt) deriving Monoid + +# enum PCREStudyOptions, (StudyOptions . Flags) \ + , PCRE_STUDY_JIT_COMPILE + +newtype PCREExtraFlags = ExtraFlags (BitFlags CULong) + deriving (Monoid, Eq, Bits, Storable) + +# enum PCREExtraFlags, (ExtraFlags . Flags) \ + , PCRE_EXTRA_MATCH_LIMIT \ + , PCRE_EXTRA_MATCH_LIMIT_RECURSION \ + , PCRE_EXTRA_CALLOUT_DATA + +peekExtraFlags :: Ptr PCREExtra -> IO PCREExtraFlags +peekExtraFlags = #{peek pcre_extra, flags} + +pokeExtraFlags :: Ptr PCREExtra -> PCREExtraFlags -> IO () +pokeExtraFlags = #{poke pcre_extra, flags} + +patchExtraFlags :: Ptr PCREExtra -> (PCREExtraFlags -> PCREExtraFlags) -> IO () +patchExtraFlags ptr f = peekExtraFlags ptr >>= pokeExtraFlags ptr . f + data Regexp = Regexp { pattern :: Text , caseMatters :: Bool @@ -70,9 +124,7 @@ } deriving Show instance Eq Regexp where - Regexp { pattern = p1, caseMatters = cm1 } == - Regexp { pattern = p2, caseMatters = cm2 } = - cm1 == cm2 && p1 == p2 + (==) = (==) `on` (caseMatters &&& pattern) data RewriteState = StateBase | StateEsc @@ -90,9 +142,11 @@ translate :: Text -> Text translate = T.pack . concat . rewrite . T.unpack where + rewrite :: String -> [String] -- wrap entire expression so we can add a callout at the end rewrite s = "(?:" : rewrite' StateBase s + rewrite' :: RewriteState -> String -> [String] rewrite' StateBase ('%':cs) = rewrite' StateEsc cs rewrite' StateBase ('[':cs) = "[" : rewrite' StateCsetInit cs rewrite' StateBase ( c :cs) @@ -133,83 +187,96 @@ -- add callout at end of pattern for rmatch rewrite' state [] = ")(?C)" : rewriteFinal state + rewriteFinal :: RewriteState -> [String] -- don't let a trailing % get away without a syntax error rewriteFinal StateEsc = "\\" : [] rewriteFinal _ = [] + word, nonword :: String word = "[^\\W_]" nonword = "[\\W_]" + + alt :: String -> String -> String alt a b = "(?:" ++ a ++ "|" ++ b ++ ")" + + lbehind, lahead :: String -> String lbehind p = "(?<=" ++ p ++ ")" lahead p = "(?=" ++ p ++ ")" + + lookba :: String -> String -> String lookba b a = lbehind b ++ lahead a + + wordBegin, wordEnd :: String wordBegin = alt "^" (lbehind nonword) ++ lahead word wordEnd = lbehind word ++ alt "$" (lahead nonword) -- | Compile a regular expression pattern into a 'Regexp' value, or return an --- error description if the pattern is malformed. The returned 'Int' is a byte --- offset into an internally translated pattern, and thus is probably not very --- useful. +-- error description if the pattern is malformed. newRegexp :: Text -- ^ pattern -> Bool -- ^ case matters? - -> Either (String, Int) Regexp + -> Either String Regexp newRegexp regexp caseMatters = unsafePerformIO $ useAsCString string $ \pattern -> alloca $ \errorPtr -> alloca $ \errorOffsetPtr -> do - code <- pcre_compile pattern options errorPtr errorOffsetPtr nullPtr + code <- pcre_compile pattern compileOptions errorPtr errorOffsetPtr nullPtr if code == nullPtr - then do - error <- peek errorPtr >>= peekCString - errorOffset <- peek errorOffsetPtr - return $ Left (patchError error, fromIntegral errorOffset) + then Left . patchError <$> (peekCString =<< peek errorPtr) else do extraFP <- mkExtra code setExtraFlags extraFP - codeFP <- peek pcre_free >>= flip newForeignPtr code + codeFP <- flip newForeignPtr code =<< peek pcre_free return $ Right Regexp { pattern = regexp , caseMatters = caseMatters , code = codeFP , extra = extraFP } - where string = encodeUtf8 (translate regexp) + where string = encodeUtf8 (translate regexp) :: ByteString + + compileOptions :: PCREOptions + compileOptions = pcreUtf8 <> pcreNoUtf8Check <> pcreDollarEndonly <> + if caseMatters then mempty else pcreCaseless + + mkExtra :: Ptr PCRE -> IO (ForeignPtr PCREExtra) mkExtra code = alloca $ \errorPtr -> do - extra <- pcre_study code 0 errorPtr + extra <- pcre_study code studyOptions errorPtr if extra == nullPtr then do - extraFP <- mallocForeignPtrBytes #{const sizeof(pcre_extra)} - withForeignPtr extraFP $ \extra -> - #{poke pcre_extra, flags} extra (0 :: CULong) + extraFP <- mallocForeignPtrBytes #{size pcre_extra} + withForeignPtr extraFP $ \extra -> pokeExtraFlags extra mempty return extraFP else newForeignPtr pcre_free_study extra + where studyOptions = pcreStudyJitCompile :: PCREStudyOptions + + setExtraFlags :: ForeignPtr PCREExtra -> IO () setExtraFlags extraFP = withForeignPtr extraFP $ \extra -> do #{poke pcre_extra, match_limit} extra matchLimit #{poke pcre_extra, match_limit_recursion} extra matchLimitRecursion - flags <- #{peek pcre_extra, flags} extra - #{poke pcre_extra, flags} extra $ flags .|. (0 :: CULong) - .|. #{const PCRE_EXTRA_MATCH_LIMIT} - .|. #{const PCRE_EXTRA_MATCH_LIMIT_RECURSION} - matchLimit = 100000 :: CULong - matchLimitRecursion = 5000 :: CULong + patchExtraFlags extra $ \flags -> (flags <> matchLimitFlags) + `andNot` pcreExtraCalloutData + where matchLimit, matchLimitRecursion :: CULong + matchLimit = 100000 + matchLimitRecursion = matchLimit + + matchLimitFlags :: PCREExtraFlags + matchLimitFlags = pcreExtraMatchLimit <> + pcreExtraMatchLimitRecursion + + patchError :: String -> String patchError = concatMap patch where patch '\\' = "%" patch '(' = "%(" patch ')' = "%)" patch c = [c] - options = #{const PCRE_UTF8 | PCRE_NO_UTF8_CHECK} - -- allow PCRE to optimize .* at beginning of pattern by implicit anchor - .|. #{const PCRE_DOTALL} - .|. if caseMatters then 0 else #{const PCRE_CASELESS} - +maxCaptures :: Num a => a maxCaptures = 10 -ovecLen = maxCaptures * 3 data MatchResult = MatchFailed | MatchAborted @@ -224,36 +291,79 @@ rmatch :: Regexp -> Text -> MatchResult rmatch regexp text = unsafePerformIO $ doMatch rmatch_helper regexp text -doMatch :: (Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> - CInt -> Ptr CInt -> IO CInt) -> Regexp -> Text -> IO MatchResult +doMatch :: Helper -> Regexp -> Text -> IO MatchResult doMatch helper Regexp { code = codeFP, extra = extraFP } text = withForeignPtr codeFP $ \code -> withForeignPtr extraFP $ \extra -> useAsCStringLen string $ \(cstring, len) -> - allocaArray ovecLen $ \ovec -> do + allocaArray ovecLen $ \ovec -> - rc <- helper code extra cstring (fromIntegral len) options ovec - if rc < 0 - then case rc of - #{const PCRE_ERROR_NOMATCH} -> return MatchFailed - _ -> return MatchAborted - else mkMatchResult rc ovec subject + helper code extra cstring (fromIntegral len) options ovec >>= + matchResult string (T.length text) ovec - where string = encodeUtf8 text - subject = (string, T.length text) - options = #{const PCRE_NO_UTF8_CHECK} + where string = encodeUtf8 text :: ByteString + ovecLen = maxCaptures * 3 :: Int + options = pcreNoUtf8Check :: PCREOptions -mkMatchResult :: CInt -> Ptr CInt -> (ByteString, Int) -> IO MatchResult -mkMatchResult rc ovec (subject, subjectCharLen) = - (MatchSucceeded . pairs . map (rebase . fromIntegral)) `liftM` - peekArray (n * 2) ovec +matchResult :: ByteString -> Int -> Ptr CInt -> CInt -> IO MatchResult +matchResult subject subjectCharLen ovec rc + | rc == #{const PCRE_ERROR_NOMATCH} = return MatchFailed + | rc < 0 = return MatchAborted + | otherwise = MatchSucceeded . pairs . map (rebase . fromIntegral) <$> + peekArray (n * 2) ovec - where rc' = fromIntegral rc - n = if rc' == 0 || rc' > maxCaptures then maxCaptures else rc' + where n :: Int + n | rc == 0 || rc > maxCaptures = maxCaptures + | otherwise = fromIntegral rc + pairs :: [a] -> [(a, a)] pairs (s:e:rs) = (s, e) : pairs rs pairs [] = [] + rebase :: Int -> Int -- translate UTF-8 byte offset to character offset rebase 0 = 0 rebase i = subjectCharLen - T.length (decodeUtf8 $ BS.drop i subject) + +-- | Return the current version of the linked PCRE library. +pcreVersion :: String +pcreVersion = "PCRE " ++ unsafePerformIO (peekCString =<< pcre_version) + ++ ", JIT target: " ++ fromMaybe "none" jittarget + where jittarget = unsafePerformIO (pcreStringConfig pcreConfigJittarget) + +newtype PCREConfig a = Config CInt + +# enum PCREConfig CInt, Config \ + , PCRE_CONFIG_UTF8 \ + , PCRE_CONFIG_UNICODE_PROPERTIES \ + , PCRE_CONFIG_JIT +# enum PCREConfig CString, Config \ + , PCRE_CONFIG_JITTARGET + +-- | Retrieve a PCRE build-time option. +pcreConfig :: Storable a => PCREConfig a -> IO (Maybe a) +pcreConfig what = alloca $ \ptr -> do + result <- pcre_config what ptr + case result of + 0 -> Just <$> peek ptr + _ -> return Nothing + +pcreBoolConfig :: PCREConfig CInt -> IO (Maybe Bool) +pcreBoolConfig what = fmap toBool <$> pcreConfig what + +pcreStringConfig :: PCREConfig CString -> IO (Maybe String) +pcreStringConfig what = pcreConfig what >>= + maybe (return Nothing) (fmap Just . peekCString) + +-- | Verify the bound PCRE library was built with the required features. +verifyPCRE :: IO () +verifyPCRE = do + verify pcreConfigUtf8 "PCRE is missing UTF-8 support" +{- + verify pcreConfigUnicodeProperties + "PCRE is missing Unicode character properties support" +-} + where verify :: PCREConfig CInt -> String -> IO () + verify config msg = do + supported <- fromMaybe False <$> pcreBoolConfig config + unless supported $ error msg diff --git a/src/MOO/Builtins/Misc.hs b/src/MOO/Builtins/Misc.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Misc.hs @@ -0,0 +1,197 @@ + +{-# LANGUAGE CPP, OverloadedStrings #-} + +module MOO.Builtins.Misc ( builtins ) where + +import Control.Applicative ((<$>)) +import Control.Monad.State (gets) +import Data.Monoid ((<>)) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import Database.VCache (VCacheStats(..), vcacheStats) + +# ifdef __GLASGOW_HASKELL__ +import GHC.Stats (GCStats(currentBytesUsed, maxBytesUsed), + getGCStats, getGCStatsEnabled) +# endif + +import MOO.Builtins.Common +import MOO.Database +import MOO.Object +import MOO.Task +import MOO.Types +import MOO.Util +import MOO.Version + +import qualified MOO.String as Str + +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + +-- | § 4.4 Built-in Functions +builtins :: [Builtin] +builtins = [ + -- § 4.4.1 Object-Oriented Programming + bf_pass + + -- § 4.4.5 Operations Involving Times and Dates + , bf_time + , bf_ctime + + -- § 4.4.7 Administrative Operations + , bf_dump_database + , bf_shutdown + , bf_load_server_options + , bf_server_log + , bf_renumber + , bf_reset_max_object + + -- § 4.4.8 Server Statistics and Miscellaneous Information + , bf_server_version + , bf_memory_usage + , bf_db_disk_size + , bf_verb_cache_stats + , bf_log_cache_stats + ] + +-- § 4.4.1 Object-Oriented Programming + +bf_pass = Builtin "pass" 0 Nothing [] TAny $ \args -> do + (name, verbLoc, this) <- frame $ \frame -> + (verbName frame, verbLocation frame, initialThis frame) + maybeObject <- getObject verbLoc + case maybeObject >>= objectParent of + Just parent -> callVerb this parent name args + Nothing -> raise E_VERBNF + +-- § 4.4.5 Operations Involving Times and Dates + +currentTime :: MOO IntT +currentTime = floor . utcTimeToPOSIXSeconds <$> gets startTime + +bf_time = Builtin "time" 0 (Just 0) [] TInt $ \[] -> Int <$> currentTime + +bf_ctime = Builtin "ctime" 0 (Just 1) [TInt] TStr $ \arg -> case arg of + [] -> ctime' =<< currentTime + [Int time] -> ctime' time + + where ctime' :: IntT -> MOO Value + ctime' time = do + let utcTime = posixSecondsToUTCTime (fromIntegral time) + Str . Str.fromString <$> + ctime utcTime `catchUnsafeIOtoMOO` \_ -> raise E_INVARG + +-- § 4.4.7 Administrative Operations + +bf_dump_database = Builtin "dump_database" 0 (Just 0) [] TAny $ \[] -> + checkWizard >> getWorld >>= liftSTM . checkpoint >> return zero + +bf_shutdown = Builtin "shutdown" 0 (Just 1) [TStr] TAny $ \optional -> do + let (message : _) = maybeDefaults optional + + checkWizard + + name <- getObjectName =<< frame permissions + let msg = "shutdown() called by " <> name + + shutdown $ maybe msg (\(Str reason) -> msg <> ": " <> reason) message + return zero + +bf_load_server_options = Builtin "load_server_options" 0 (Just 0) + [] TAny $ \[] -> + checkWizard >> loadServerOptions >> return zero + +bf_server_log = Builtin "server_log" 1 (Just 2) + [TStr, TAny] TAny $ \(Str message : optional) -> do + let [is_error] = booleanDefaults optional [False] + errorMarker = if is_error then "*** " else "" + logMessage = errorMarker <> "> " <> Str.toText message + + checkWizard + + world <- getWorld + liftSTM $ writeLog world logMessage + + return zero + +bf_renumber = Builtin "renumber" 1 (Just 1) [TObj] TObj $ \[Obj object] -> do + checkValid object + checkWizard + + (new, db) <- liftVTx . renumber object =<< getDatabase + putDatabase db + + return (Obj new) + +bf_reset_max_object = Builtin "reset_max_object" 0 (Just 0) [] TAny $ \[] -> do + checkWizard + getDatabase >>= liftVTx . resetMaxObject >>= putDatabase + return zero + +-- § 4.4.8 Server Statistics and Miscellaneous Information + +bf_server_version = Builtin "server_version" 0 (Just 0) [] TStr $ \[] -> + return (Str $ Str.fromText serverVersion) + +bf_memory_usage = Builtin "memory_usage" 0 (Just 0) [] TLst $ \[] -> +# ifdef __GLASGOW_HASKELL__ + -- Server must be run with +RTS -T to enable statistics + do maybeStats <- requestIO $ do + enabled <- getGCStatsEnabled + if enabled then Just <$> getGCStats else return Nothing + + return $ case maybeStats of + Just stats -> + let nused = currentBytesUsed stats + nfree = maxBytesUsed stats - nused + maxBlockSize = 2 ^ (floor $ logBase (2 :: Double) $ + fromIntegral $ max nused nfree :: Int) + in fromListBy (fromListBy $ Int . fromIntegral) $ + blocks maxBlockSize nused nfree + Nothing -> emptyList + + where blocks :: (Integral a) => a -> a -> a -> [[a]] + blocks _ 0 0 = [] + blocks blockSize nused nfree = + let nusedBlocks = nused `div` blockSize + nfreeBlocks = nfree `div` blockSize + rest = blocks (blockSize `div` 2) + (nused - nusedBlocks * blockSize) + (nfree - nfreeBlocks * blockSize) + in case (nusedBlocks, nfreeBlocks) of + (0, 0) -> rest + _ -> [blockSize, nusedBlocks, nfreeBlocks] : rest +# else + return emptyList -- ... nothing to see here +# endif + +bf_db_disk_size = Builtin "db_disk_size" 0 (Just 1) + [TAny] TAny $ \optional -> do + let [full] = booleanDefaults optional [False] + stats <- unsafeIOtoMOO . vcacheStats =<< getVSpace + + return $ if full + then fromList $ map (keyValue stats) [ + ("file_size", vcstat_file_size) + , ("vref_count", vcstat_vref_count) + , ("pvar_count", vcstat_pvar_count) + , ("root_count", vcstat_root_count) + , ("mem_vrefs", vcstat_mem_vrefs) + , ("mem_pvars", vcstat_mem_pvars) + , ("eph_count", vcstat_eph_count) + , ("alloc_count", vcstat_alloc_count) + , ("cache_limit", vcstat_cache_limit) + , ("cache_size", vcstat_cache_size) + , ("gc_count", vcstat_gc_count) + , ("write_pvars", vcstat_write_pvars) + , ("write_sync", vcstat_write_sync) + , ("write_frames", vcstat_write_frames) + ] + else Int $ fromIntegral (vcstat_file_size stats) + + where keyValue :: VCacheStats -> (StrT, VCacheStats -> Int) -> Value + keyValue stats (key, f) = + fromList [Str key, Int . fromIntegral $ f stats] + +bf_verb_cache_stats = Builtin "verb_cache_stats" 0 (Just 0) [] TLst $ \[] -> + notyet "verb_cache_stats" +bf_log_cache_stats = Builtin "log_cache_stats" 0 (Just 0) [] TAny $ \[] -> + notyet "log_cache_stats" diff --git a/src/MOO/Builtins/Network.hs b/src/MOO/Builtins/Network.hs --- a/src/MOO/Builtins/Network.hs +++ b/src/MOO/Builtins/Network.hs @@ -3,8 +3,9 @@ module MOO.Builtins.Network ( builtins ) where +import Control.Applicative ((<$>)) import Control.Concurrent.STM (readTVar) -import Control.Monad (liftM, unless, (<=<)) +import Control.Monad (unless, (<=<)) import Control.Monad.State (gets) import Data.Time (UTCTime, diffUTCTime) @@ -52,9 +53,7 @@ return $ objectList $ if include_all then objects else filter (>= 0) objects secondsSince :: UTCTime -> MOO Value -secondsSince utcTime = do - now <- gets startTime - return (Int $ floor $ now `diffUTCTime` utcTime) +secondsSince utcTime = Int . floor . (`diffUTCTime` utcTime) <$> gets startTime bf_connected_seconds = Builtin "connected_seconds" 1 (Just 1) [TObj] TInt $ \[Obj player] -> @@ -71,7 +70,7 @@ let [no_flush] = booleanDefaults optional [False] checkPermission conn - truthValue `liftM` notify' no_flush conn string + truthValue <$> notify' no_flush conn string bf_buffered_output_length = Builtin "buffered_output_length" 0 (Just 1) [TObj] TInt $ \optional -> do @@ -85,9 +84,14 @@ return (Int $ fromIntegral len) -bf_read = Builtin "read" 0 (Just 2) [TObj, TAny] TAny $ \optional -> - notyet "read" +bf_read = Builtin "read" 0 (Just 2) [TObj, TAny] TAny $ \optional -> do + (conn, optional) <- case optional of + Obj conn : optional -> checkPermission conn >> return (conn, optional) + [] -> checkWizard >> getPlayer >>= \player -> return (player, []) + let [non_blocking] = booleanDefaults optional [False] + readFromConnection conn non_blocking + bf_force_input = Builtin "force_input" 2 (Just 3) [TObj, TStr, TAny] TAny $ \(Obj conn : Str line : optional) -> do let [at_front] = booleanDefaults optional [False] @@ -118,8 +122,7 @@ bf_connection_name = Builtin "connection_name" 1 (Just 1) [TObj] TStr $ \[Obj player] -> do checkPermission player - (Str . Str.fromString) `liftM` - withConnection player (liftSTM . connectionName) + Str . Str.fromString <$> withConnection player (liftSTM . connectionName) bf_set_connection_option = Builtin "set_connection_option" 3 (Just 3) [TObj, TStr, TAny] @@ -131,7 +134,7 @@ bf_connection_options = Builtin "connection_options" 1 (Just 1) [TObj] TLst $ \[Obj conn] -> do checkPermission conn - (fromListBy pair . M.toList) `liftM` getConnectionOptions conn + fromListBy pair . M.toList <$> getConnectionOptions conn where pair (k, v) = fromList [Str $ fromId k, v] @@ -167,7 +170,7 @@ checkValid object point <- value2point point - point2value `liftM` listen object point print_messages + point2value <$> listen object point print_messages bf_unlisten = Builtin "unlisten" 1 (Just 1) [TAny] TAny $ \[canon] -> do checkWizard @@ -176,7 +179,7 @@ return zero bf_listeners = Builtin "listeners" 0 (Just 0) [] TLst $ \[] -> - (fromListBy formatListener . M.elems . listeners) `liftM` getWorld + fromListBy formatListener . M.elems . listeners <$> getWorld where formatListener Listener { listenerObject = object , listenerPoint = point diff --git a/src/MOO/Builtins/Objects.hs b/src/MOO/Builtins/Objects.hs --- a/src/MOO/Builtins/Objects.hs +++ b/src/MOO/Builtins/Objects.hs @@ -3,23 +3,23 @@ module MOO.Builtins.Objects ( builtins ) where -import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar) -import Control.Monad (when, unless, liftM, void, forM_, foldM, join) +import Control.Applicative ((<$>)) +import Control.Monad (when, unless, void, forM_, foldM) import Data.Maybe (isJust, isNothing, fromJust) +import Data.Monoid (mempty, mappend) import Data.Set (Set) -import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import Database.VCache (VTx, PVar, newPVar, readPVar, writePVar) import Prelude hiding (getContents) import qualified Data.HashMap.Strict as HM -import qualified Data.IntSet as IS import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import qualified Data.Vector as V +import qualified Data.Text.Lazy.Builder as TLB import MOO.AST import MOO.Builtins.Common -import {-# SOURCE #-} MOO.Compiler import MOO.Connection import MOO.Database import MOO.Object @@ -29,6 +29,7 @@ import MOO.Unparser import MOO.Verb +import qualified MOO.List as Lst import qualified MOO.String as Str {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} @@ -112,23 +113,23 @@ Nothing -> return $ objectProperties initObject Just oid -> do -- add to parent's set of children - liftSTM $ modifyObject oid db $ addChild newOid + liftVTx $ modifyObject oid db $ addChild newOid -- properties inherited from parent Just parent <- getObject oid - HM.fromList `liftM` mapM mkProperty (HM.toList $ objectProperties parent) + HM.fromList <$> mapM mkProperty (HM.toList $ objectProperties parent) - where mkProperty :: (StrT, TVar Property) -> MOO (StrT, TVar Property) - mkProperty (name, propTVar) = liftSTM $ do - prop <- readTVar propTVar + where mkProperty :: (StrT, PVar Property) -> MOO (StrT, PVar Property) + mkProperty (name, propPVar) = liftVTx $ do + prop <- readPVar propPVar let prop' = prop { propertyValue = Nothing , propertyInherited = True , propertyOwner = if propertyPermC prop then ownerOid else propertyOwner prop } - propTVar' <- newTVar prop' - return (name, propTVar') + propPVar' <- newPVar prop' + return (name, propPVar') let newObj = initObject { objectParent = maybeParent @@ -136,7 +137,7 @@ , objectProperties = properties } - putDatabase =<< liftSTM (addObject newObj db) + putDatabase =<< liftVTx (addObject newObj db) callFromFunc "create" 0 (newOid, "initialize") [] return (Obj newOid) @@ -149,7 +150,7 @@ Just newParent -> do let props = HM.keys (objectProperties newParent) flip traverseDescendants object $ \obj -> forM_ props $ \propName -> do - maybeProp <- liftSTM $ lookupProperty obj propName + maybeProp <- liftVTx $ lookupProperty obj propName case maybeProp of Just prop | not (propertyInherited prop) -> raise E_INVARG _ -> return () @@ -171,7 +172,7 @@ newProperties <- case maybeNewParent of Just newParent -> allDefinedProperties (underCommon newAncestors) >>= - mapM (liftSTM . liftM fromJust . lookupProperty newParent) + mapM (liftVTx . fmap fromJust . lookupProperty newParent) Nothing -> return [] flip (modifyDescendants db) object $ \obj -> do @@ -179,38 +180,34 @@ foldM (flip addInheritedProperty) obj' newProperties -- Update the parent/child hierarchy - liftSTM $ modifyObject object db $ \obj -> - return obj { objectParent = const new_parent `fmap` maybeNewParent } + liftVTx $ modifyObject object db $ \obj -> + return obj { objectParent = const new_parent <$> maybeNewParent } case objectParent obj of - Just parentOid -> liftSTM $ modifyObject parentOid db $ deleteChild object + Just parentOid -> liftVTx $ modifyObject parentOid db $ deleteChild object Nothing -> return () case maybeNewParent of - Just _ -> liftSTM $ modifyObject new_parent db $ addChild object + Just _ -> liftVTx $ modifyObject new_parent db $ addChild object Nothing -> return () where ancestors :: ObjId -> MOO [ObjId] ancestors oid = do maybeObject <- getObject oid - case join $ objectParent `fmap` maybeObject of - Just parent -> do - ancestors <- ancestors parent - return (parent : ancestors) - Nothing -> return [] + maybe (return []) ancestors' $ maybeObject >>= objectParent ancestors' :: ObjId -> MOO [ObjId] - ancestors' oid = (oid :) `liftM` ancestors oid + ancestors' oid = (oid :) <$> ancestors oid findCommon :: [ObjId] -> [ObjId] -> Maybe ObjId findCommon xs ys = findCommon' (reverse xs) (reverse ys) Nothing - findCommon' (x:xs) (y:ys) _ - | x == y = findCommon' xs ys (Just x) - findCommon' _ _ common = common + where findCommon' (x:xs) (y:ys) _ + | x == y = findCommon' xs ys (Just x) + findCommon' _ _ common = common allDefinedProperties :: [ObjId] -> MOO [StrT] - allDefinedProperties = liftM ($ []) . foldM concatProps id + allDefinedProperties = fmap ($ []) . foldM concatProps id where concatProps acc oid = do Just obj <- getObject oid - props <- liftSTM $ definedProperties obj + props <- liftVTx $ definedProperties obj return (acc props ++) bf_chparent = Builtin "chparent" 2 (Just 2) @@ -230,13 +227,13 @@ return zero bf_valid = Builtin "valid" 1 (Just 1) [TObj] TInt $ \[Obj object] -> - (truthValue . isJust) `liftM` getObject object + truthValue . isJust <$> getObject object bf_parent = Builtin "parent" 1 (Just 1) [TObj] TObj $ \[Obj object] -> - (Obj . getParent) `liftM` checkValid object + Obj . getParent <$> checkValid object bf_children = Builtin "children" 1 (Just 1) [TObj] TLst $ \[Obj object] -> - (objectList . getChildren) `liftM` checkValid object + objectList . getChildren <$> checkValid object bf_recycle = Builtin "recycle" 1 (Just 1) [TObj] TAny $ \[Obj object] -> do obj <- checkValid object @@ -252,7 +249,7 @@ reparent object Nothing setPlayerFlag True object False - getDatabase >>= liftSTM . deleteObject object + getDatabase >>= liftVTx . deleteObject object modifyQuota owner $ return . (+ 1) @@ -261,7 +258,7 @@ where moveContentsToNothing :: ObjId -> MOO () moveContentsToNothing object = do maybeObj <- getObject object - case getContents `fmap` maybeObj of + case getContents <$> maybeObj of Just (oid:_) -> do moveToNothing oid moveContentsToNothing object @@ -273,7 +270,7 @@ reparentChildren :: ObjId -> Maybe ObjId -> MOO () reparentChildren object maybeParent = do maybeObj <- getObject object - case getChildren `fmap` maybeObj of + case getChildren <$> maybeObj of Just (oid:_) -> do reparent oid maybeParent reparentChildren object maybeParent @@ -297,15 +294,15 @@ checkWizard obj <- checkValid object - propertyBytes <- liftM storageBytes $ liftSTM $ - mapM readTVar $ HM.elems (objectProperties obj) - verbBytes <- liftM storageBytes $ liftSTM $ - mapM (readTVar . snd) $ objectVerbs obj + propertyBytes <- fmap storageBytes $ liftVTx $ + mapM readPVar $ HM.elems (objectProperties obj) + verbBytes <- fmap storageBytes $ liftVTx $ + mapM (readPVar . snd) $ objectVerbs obj return $ Int $ fromIntegral $ storageBytes obj + propertyBytes + verbBytes bf_max_object = Builtin "max_object" 0 (Just 0) [] TObj $ \[] -> - (Obj . maxObject) `liftM` getDatabase + Obj . maxObject <$> getDatabase -- § 4.4.3.2 Object Movement @@ -326,17 +323,16 @@ let oldWhere = objectLocation whatObj db <- getDatabase - liftSTM $ modifyObject what db $ \obj -> + liftVTx $ modifyObject what db $ \obj -> return obj { objectLocation = newWhere } case oldWhere of Nothing -> return () - Just oldWhere' -> liftSTM $ modifyObject oldWhere' db $ \obj -> - return obj { objectContents = IS.delete what (objectContents obj) } + Just oldWhere' -> liftVTx $ modifyObject oldWhere' db $ + deleteContent what case newWhere of Nothing -> return () - Just newWhere' -> liftSTM $ modifyObject newWhere' db $ \obj -> - return obj { objectContents = IS.insert what (objectContents obj) } - + Just newWhere' -> liftVTx $ modifyObject newWhere' db $ + addContent what case oldWhere of Nothing -> return () Just oldWhere' -> @@ -354,11 +350,11 @@ what' <- checkValid what where' <- case where_ of -1 -> return Nothing - oid -> Just `liftM` checkValid oid + oid -> Just <$> checkValid oid checkPermission (objectOwner what') when (isJust where') $ do - accepted <- maybe False truthOf `liftM` + accepted <- maybe False truthOf <$> callFromFunc "move" 0 (where_, "accept") [Obj what] unless accepted $ do wizard <- isWizard =<< frame permissions @@ -375,7 +371,7 @@ obj <- checkValid object unless (objectPermR obj) $ checkPermission (objectOwner obj) - stringList `liftM` liftSTM (definedProperties obj) + stringList <$> liftVTx (definedProperties obj) bf_property_info = Builtin "property_info" 2 (Just 2) [TObj, TStr] TLst $ \[Obj object, Str prop_name] -> do @@ -395,9 +391,9 @@ f obj mapM_ (traverseDescendants f) $ getChildren obj -modifyDescendants :: Database -> (Object -> STM Object) -> ObjId -> MOO () +modifyDescendants :: Database -> (Object -> VTx Object) -> ObjId -> MOO () modifyDescendants db f oid = do - liftSTM $ modifyObject oid db f + liftVTx $ modifyObject oid db f Just obj <- getObject oid mapM_ (modifyDescendants db f) $ getChildren obj @@ -409,10 +405,12 @@ unless (S.null $ permSet `S.difference` S.fromList valid) $ raise E_INVARG return permSet +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + bf_set_property_info = Builtin "set_property_info" 3 (Just 3) [TObj, TStr, TLst] TAny $ \[Obj object, Str prop_name, Lst info] -> do - (owner, perms, new_name) <- case V.toList info of + (owner, perms, new_name) <- case Lst.toList info of [Obj owner, Str perms] -> return (owner, perms, Nothing) [_ , _ ] -> raise E_TYPE [Obj owner, Str perms, Str new_name] -> return (owner, perms, Just new_name) @@ -449,19 +447,19 @@ db <- getDatabase flip (modifyDescendants db) object $ \obj -> do - let Just propTVar = lookupPropertyRef obj oldName - prop <- readTVar propTVar - writeTVar propTVar $ prop { propertyName = newName } + let Just propPVar = lookupPropertyRef obj oldName + prop <- readPVar propPVar + writePVar propPVar $ prop { propertyName = newName } return obj { objectProperties = - HM.insert newName propTVar $ + HM.insert newName propPVar $ HM.delete oldName (objectProperties obj) } return zero bf_add_property = Builtin "add_property" 4 (Just 4) [TObj, TStr, TAny, TLst] TAny $ \[Obj object, Str prop_name, value, Lst info] -> do - (owner, perms) <- case V.toList info of + (owner, perms) <- case Lst.toList info of [Obj owner, Str perms] -> return (owner, perms) [_ , _ ] -> raise E_TYPE _ -> raise E_INVARG @@ -487,7 +485,7 @@ } db <- getDatabase - liftSTM $ modifyObject object db (addProperty newProperty) + liftVTx $ modifyObject object db (addProperty newProperty) forM_ (getChildren obj) $ modifyDescendants db $ addInheritedProperty newProperty @@ -536,7 +534,7 @@ obj <- checkValid object unless (objectPermR obj) $ checkPermission (objectOwner obj) - stringList `liftM` liftSTM (definedVerbs obj) + stringList <$> liftVTx (definedVerbs obj) bf_verb_info = Builtin "verb_info" 2 (Just 2) [TObj, TAny] TLst $ \[Obj object, verb_desc] -> do @@ -554,7 +552,7 @@ verbInfo :: LstT -> MOO (ObjId, Set Char, StrT) verbInfo info = do - (owner, perms, names) <- case V.toList info of + (owner, perms, names) <- case Lst.toList info of [Obj owner, Str perms, Str names] -> return (owner, perms, names) [_ , _ , _ ] -> raise E_TYPE _ -> raise E_INVARG @@ -602,7 +600,7 @@ verbArgs :: LstT -> MOO (ObjSpec, PrepSpec, ObjSpec) verbArgs args = do - (dobj, prep, iobj) <- case V.toList args of + (dobj, prep, iobj) <- case Lst.toList args of [Str dobj, Str prep, Str iobj] -> return (dobj, breakSlash prep, iobj) where breakSlash = fst . Str.breakOn "/" [_ , _ , _ ] -> raise E_TYPE @@ -652,7 +650,7 @@ } db <- getDatabase - liftSTM $ modifyObject object db $ addVerb definedVerb + liftVTx $ modifyObject object db $ addVerb definedVerb return $ Int $ fromIntegral $ length (objectVerbs obj) + 1 @@ -662,11 +660,12 @@ getVerb obj verb_desc unless (objectPermW obj) $ checkPermission (objectOwner obj) - case lookupVerbRef obj verb_desc of + numericStrings <- serverOption supportNumericVerbnameStrings + case lookupVerbRef numericStrings obj verb_desc of Nothing -> raise E_VERBNF Just (index, _) -> do db <- getDatabase - liftSTM $ modifyObject object db $ deleteVerb index + liftVTx $ modifyObject object db $ deleteVerb index return zero @@ -677,7 +676,6 @@ obj <- checkValid object verb <- getVerb obj verb_desc unless (verbPermR verb) $ checkPermission (verbOwner verb) - checkProgrammer let code = init $ Str.splitOn "\n" $ Str.fromText $ TL.toStrict $ unparse fully_paren indent (verbProgram verb) @@ -687,24 +685,23 @@ TLst $ \[Obj object, verb_desc, Lst code] -> do obj <- checkValid object verb <- getVerb obj verb_desc - text <- (T.concat . ($ [])) `liftM` V.foldM addLine id code + text <- builder2text . foldr addLine mempty <$> + maybe (raise E_TYPE) return (mapM strValue $ Lst.toList code) unless (verbPermW verb) $ checkPermission (verbOwner verb) checkProgrammer - case parse text of - Left errors -> return $ fromListBy (Str . Str.fromString) errors + case parseProgram text of Right program -> do modifyVerb (object, obj) verb_desc $ \verb -> - return verb { - verbProgram = program - , verbCode = compile program - } + return verb { verbProgram = program } return emptyList + Left errors -> return $ fromListBy (Str . Str.fromString) errors - where addLine :: ([Text] -> [Text]) -> Value -> MOO ([Text] -> [Text]) - addLine add (Str line) = return (add [Str.toText line, "\n"] ++) - addLine _ _ = raise E_INVARG + where addLine :: StrT -> Builder -> Builder + addLine line = mappend (Str.toBuilder line) . mappend newline + newline = TLB.singleton '\n' :: Builder + bf_disassemble = Builtin "disassemble" 2 (Just 2) [TObj, TAny] TLst $ \[Obj object, verb_desc] -> do obj <- checkValid object @@ -717,15 +714,15 @@ -- § 4.4.3.5 Operations on Player Objects bf_players = Builtin "players" 0 (Just 0) [] TLst $ \[] -> - (objectList . allPlayers) `liftM` getDatabase + objectList . allPlayers <$> getDatabase bf_is_player = Builtin "is_player" 1 (Just 1) [TObj] TInt $ \[Obj object] -> - (truthValue . objectIsPlayer) `liftM` checkValid object + truthValue . objectIsPlayer <$> checkValid object setPlayerFlag :: Bool -> ObjId -> Bool -> MOO () setPlayerFlag recycled object isPlayer = do db <- getDatabase - liftSTM $ modifyObject object db $ \obj -> + liftVTx $ modifyObject object db $ \obj -> return obj { objectIsPlayer = isPlayer } putDatabase $ setPlayer isPlayer object db diff --git a/src/MOO/Builtins/Tasks.hs b/src/MOO/Builtins/Tasks.hs --- a/src/MOO/Builtins/Tasks.hs +++ b/src/MOO/Builtins/Tasks.hs @@ -3,22 +3,23 @@ module MOO.Builtins.Tasks ( builtins ) where +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) import Control.Concurrent (forkIO, killThread) import Control.Concurrent.STM (atomically, newEmptyTMVar, takeTMVar, putTMVar) -import Control.Monad (liftM, void) +import Control.Monad (void) import Control.Monad.Cont (callCC) import Control.Monad.Reader (asks) import Control.Monad.State (gets, modify, get) import Data.List (sort) -import Data.Time (getCurrentTime, addUTCTime) +import Data.Time (getCurrentTime, addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as HM import qualified Data.Set as S import MOO.Builtins.Common import {-# SOURCE #-} MOO.Builtins -import {-# SOURCE #-} MOO.Compiler import MOO.Object import MOO.Parser import MOO.Task @@ -62,10 +63,9 @@ bf_function_info = Builtin "function_info" 0 (Just 1) [TStr] TLst $ \args -> case args of - [] -> return $ fromListBy formatInfo $ M.elems builtinFunctions - [Str name] -> case M.lookup (toId name) builtinFunctions of - Just builtin -> return $ formatInfo builtin - Nothing -> raise E_INVARG + [] -> return $ fromListBy formatInfo $ HM.elems builtinFunctions + [Str name] -> maybe (raise E_INVARG) (return . formatInfo) $ + HM.lookup (toId name) builtinFunctions where formatInfo :: Builtin -> Value formatInfo Builtin { builtinName = name @@ -80,16 +80,12 @@ ] bf_eval = Builtin "eval" 1 (Just 1) [TStr] TLst $ \[Str string] -> - checkProgrammer >> case parse (Str.toText string) of - Left errors -> - return $ fromList [truthValue False, - fromListBy (Str . Str.fromString) errors] + checkProgrammer >> case parseProgram (Str.toText string) of Right program -> do (programmer, this, player) <- frame $ \frame -> (permissions frame, initialThis frame, initialPlayer frame) let verb = initVerb { verbNames = "Input to EVAL" , verbProgram = program - , verbCode = compile program , verbOwner = programmer , verbPermD = True } @@ -101,6 +97,9 @@ , initialPlayer = player } return $ fromList [truthValue True, value] + Left errors -> + return $ fromList [truthValue False, + fromListBy (Str . Str.fromString) errors] bf_set_task_perms = Builtin "set_task_perms" 1 (Just 1) [TObj] TAny $ \[Obj who] -> do @@ -109,32 +108,32 @@ return zero bf_caller_perms = Builtin "caller_perms" 0 (Just 0) [] TObj $ \[] -> - (Obj . objectForMaybe) `liftM` caller permissions + Obj . objectForMaybe <$> caller permissions bf_ticks_left = Builtin "ticks_left" 0 (Just 0) [] TInt $ \[] -> - (Int . fromIntegral) `liftM` gets ticksLeft + Int . fromIntegral <$> gets ticksLeft -bf_seconds_left = Builtin "seconds_left" 0 (Just 0) [] TInt $ \[] -> - return (Int 5) -- XXX can this be measured? +bf_seconds_left = Builtin "seconds_left" 0 (Just 0) [] TInt $ \[] -> do + (limit, start) <- gets (secondsLimit &&& startTime) + -- We calculate the elapsed time within the following IO action rather than + -- simply return the current time so that the action depends on some local + -- state and thus will be re-executed each time and not be optimized away to + -- a constant. Unsafe indeed! + elapsed <- unsafeIOtoMOO $ (`diffUTCTime` start) <$> getCurrentTime + return $ Int $ fromIntegral $ limit - round elapsed bf_task_id = Builtin "task_id" 0 (Just 0) [] TInt $ \[] -> - (Int . fromIntegral) `liftM` asks (taskId . task) + Int . fromIntegral <$> asks (taskId . task) bf_suspend = Builtin "suspend" 0 (Just 1) [TNum] TAny $ \optional -> do let (maybeSeconds : _) = maybeDefaults optional - maybeMicroseconds <- case maybeSeconds of - Just (Int secs) - | secs < 0 -> raise E_INVARG - | otherwise -> return (Just $ fromIntegral secs * 1000000) - Just (Flt secs) - | secs < 0 -> raise E_INVARG - | otherwise -> return (Just $ ceiling $ secs * 1000000) - Nothing -> return Nothing + {- maybeMicrosecs <- mapM getDelay maybeSeconds -- requires GHC 7.10 -} + maybeMicrosecs <- maybe (return Nothing) (fmap Just . getDelay) maybeSeconds state <- get - estimatedWakeup <- case maybeMicroseconds of + estimatedWakeup <- case maybeMicrosecs of Just usecs | time < now || time > endOfTime -> raise E_INVARG | otherwise -> return time @@ -143,6 +142,8 @@ Nothing -> return endOfTime -- XXX this is a sad wart in need of remedy + checkQueuedTaskLimit + resumeTMVar <- liftSTM newEmptyTMVar task <- asks task @@ -155,18 +156,19 @@ , taskState = state { startTime = estimatedWakeup } } - case maybeMicroseconds of + case maybeMicrosecs of Just usecs -> delayIO $ void $ forkIO $ delay usecs >> wake zero Nothing -> return () putTask task' - callCC $ interrupt . Suspend maybeMicroseconds . Resume + callCC $ interrupt . Suspend . Resume (now, value) <- liftSTM $ takeTMVar resumeTMVar putTask task' { taskStatus = Running } - modify $ \state -> state { ticksLeft = 15000, startTime = now } -- XXX ticks + resetLimits False + modify $ \state -> state { startTime = now } case value of Err error -> raise error @@ -192,28 +194,29 @@ foldr (S.insert . taskOwner) S.empty [Obj player] -> Int . fromIntegral . length . filter ((== player) . taskOwner) - in info `liftM` queuedTasks + in info <$> queuedTasks bf_queued_tasks = Builtin "queued_tasks" 0 (Just 0) [] TLst $ \[] -> do tasks <- queuedTasks programmer <- frame permissions wizard <- isWizard programmer - let ownedTasks = if wizard then tasks - else filter ((== programmer) . taskOwner) tasks + let ownedTasks | wizard = tasks + | otherwise = filter ((== programmer) . taskOwner) tasks return $ fromListBy formatTask $ sort ownedTasks where formatTask :: Task -> Value formatTask task = fromListBy ($ task) [ Int . fromIntegral . taskId -- task-id - , Int . floor . utcTimeToPOSIXSeconds . startTime . taskState - -- start-time - , const (Int 0) -- clock-id - , const (Int 15000) -- ticks XXX + , Int . floor . utcTimeToPOSIXSeconds . + startTime . taskState -- start-time + , const (Int 0) -- clock-id (obsolete) + , const (Int defaultBgTicks) -- clock-ticks (obsolete) , Obj . taskOwner -- programmer , Obj . verbLocation . activeFrame -- verb-loc , Str . verbFullName . activeFrame -- verb-name - , Int . lineNumber . activeFrame -- line + , Int . fromIntegral . + lineNumber . activeFrame -- line , Obj . initialThis . activeFrame -- this , Int . fromIntegral . storageBytes -- task-size ] @@ -229,7 +232,7 @@ delayIO $ killThread (taskThread task) return zero _ -> do - thisTaskId <- taskId `liftM` asks task + thisTaskId <- taskId <$> asks task if task_id' == thisTaskId then interrupt Suicide else raise E_INVARG diff --git a/src/MOO/Builtins/Values.hs b/src/MOO/Builtins/Values.hs --- a/src/MOO/Builtins/Values.hs +++ b/src/MOO/Builtins/Values.hs @@ -1,31 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, Rank2Types #-} module MOO.Builtins.Values ( builtins ) where -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mplus, unless, liftM, (>=>)) +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Monad (unless, (<=<)) import Data.ByteString (ByteString) -import Data.Char (isDigit) -import Data.Digest.Pure.MD5 (MD5Digest) -import Data.Maybe (fromJust) +import Data.Char (isDigit, digitToInt) +import Data.Monoid ((<>), mconcat) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) import Text.Printf (printf) import qualified Data.ByteString as BS -import qualified Data.Digest.Pure.MD5 as MD5 -import qualified Data.Vector as V -import qualified Data.Text as T import MOO.Builtins.Common import MOO.Builtins.Crypt +import MOO.Builtins.Hash import MOO.Builtins.Match import MOO.Parser (parseNum, parseObj) import MOO.Task import MOO.Types +import qualified MOO.List as Lst import qualified MOO.String as Str {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} @@ -99,7 +97,7 @@ return $ Int $ typeCode $ typeOf value bf_tostr = Builtin "tostr" 0 Nothing [] TStr $ - return . Str . Str.fromText . T.concat . map toText + return . Str . Str.fromText . builder2text . mconcat . map toBuilder bf_toliteral = Builtin "toliteral" 1 (Just 1) [TAny] TStr $ \[value] -> return $ Str $ Str.fromText $ toLiteral value @@ -108,10 +106,9 @@ bf_toint = Builtin "toint" 1 (Just 1) [TAny] TInt $ \[value] -> toint value where toint value = case value of Int _ -> return value - Flt x | x >= 0 -> if x > fromIntegral (maxBound :: IntT) - then raise E_FLOAT else return (Int $ floor x) - | otherwise -> if x < fromIntegral (minBound :: IntT) - then raise E_FLOAT else return (Int $ ceiling x) + Flt x | x < fromIntegral (minBound :: IntT) || + x > fromIntegral (maxBound :: IntT) -> raise E_FLOAT + | otherwise -> return (Int $ truncate x) Obj x -> return (Int $ fromIntegral x) Str x -> maybe (return $ Int 0) toint (parseNum $ Str.toText x) Err x -> return (Int $ fromIntegral $ fromEnum x) @@ -122,13 +119,12 @@ bf_toobj = Builtin "toobj" 1 (Just 1) [TAny] TObj $ \[value] -> toobj value where toobj value = case value of Int x -> return (Obj $ fromIntegral x) - Flt x | x >= 0 -> if x > fromIntegral (maxBound :: ObjT) - then raise E_FLOAT else return (Obj $ floor x) - | otherwise -> if x < fromIntegral (minBound :: ObjT) - then raise E_FLOAT else return (Obj $ ceiling x) + Flt x | x < fromIntegral (minBound :: ObjT) || + x > fromIntegral (maxBound :: ObjT) -> raise E_FLOAT + | otherwise -> return (Obj $ truncate x) Obj _ -> return value Str x -> maybe (return $ Obj 0) toobj $ - parseNum (Str.toText x) `mplus` parseObj (Str.toText x) + parseNum (Str.toText x) <|> parseObj (Str.toText x) Err x -> return (Obj $ fromIntegral $ fromEnum x) Lst _ -> raise E_TYPE @@ -148,36 +144,28 @@ bf_value_bytes = Builtin "value_bytes" 1 (Just 1) [TAny] TInt $ \[value] -> return $ Int $ fromIntegral $ storageBytes value -bf_value_hash = Builtin "value_hash" 1 (Just 1) [TAny] TStr $ - builtinFunction bf_toliteral >=> - builtinFunction bf_string_hash . return +bf_value_hash = Builtin "value_hash" 1 (Just 3) + [TAny, TStr, TAny] TStr $ \(value : optional) -> + builtinFunction bf_toliteral [value] >>= + builtinFunction bf_string_hash . (: optional) -- § 4.4.2.2 Operations on Numbers bf_random = Builtin "random" 0 (Just 1) [TInt] TInt $ \optional -> let [Int mod] = defaults optional [Int maxBound] in if mod < 1 then raise E_INVARG - else Int `liftM` random (1, mod) - -bf_min = Builtin "min" 1 Nothing [TNum] TNum $ \args -> case args of - Int x:xs -> minMaxInt min x xs - Flt x:xs -> minMaxFlt min x xs + else Int <$> random (1, mod) -bf_max = Builtin "max" 1 Nothing [TNum] TNum $ \args -> case args of - Int x:xs -> minMaxInt max x xs - Flt x:xs -> minMaxFlt max x xs +imumBuiltin :: Id -> (forall a. Ord a => [a] -> a) -> Builtin +imumBuiltin name f = Builtin name 1 Nothing [TNum] TNum $ \args -> case args of + Int x:vs -> Int . f . (x :) <$> getValues intValue vs + Flt x:vs -> Flt . f . (x :) <$> getValues fltValue vs -minMaxInt :: (IntT -> IntT -> IntT) -> IntT -> [Value] -> MOO Value -minMaxInt f = go - where go x (Int y:rs) = go (f x y) rs - go x [] = return $ Int x - go _ _ = raise E_TYPE + where getValues :: (Value -> Maybe a) -> [Value] -> MOO [a] + getValues f = maybe (raise E_TYPE) return . mapM f -minMaxFlt :: (FltT -> FltT -> FltT) -> FltT -> [Value] -> MOO Value -minMaxFlt f = go - where go x (Flt y:rs) = go (f x y) rs - go x [] = return $ Flt x - go _ _ = raise E_TYPE +bf_min = imumBuiltin "min" minimum +bf_max = imumBuiltin "max" maximum bf_abs = Builtin "abs" 1 (Just 1) [TNum] TNum $ \[arg] -> case arg of Int x -> return $ Int $ abs x @@ -218,28 +206,37 @@ bf_ceil = floatBuiltin "ceil" $ fromInteger . ceiling bf_floor = floatBuiltin "floor" $ fromInteger . floor -bf_trunc = floatBuiltin "trunc" $ \x -> - fromInteger $ if x < 0 then ceiling x else floor x +bf_trunc = floatBuiltin "trunc" $ fromInteger . truncate -- § 4.4.2.3 Operations on Strings bf_length = Builtin "length" 1 (Just 1) [TAny] TInt $ \[arg] -> case arg of Str string -> return $ Int $ fromIntegral $ Str.length string - Lst list -> return $ Int $ fromIntegral $ V.length list + Lst list -> return $ Int $ fromIntegral $ Lst.length list _ -> raise E_TYPE +caseFold' :: Bool -> StrT -> StrT +caseFold' caseMatters + | caseMatters = id + | otherwise = Str.fromText . Str.toCaseFold + -- XXX this won't work for Unicode in general + bf_strsub = Builtin "strsub" 3 (Just 4) [TStr, TStr, TStr, TAny] TStr $ \(Str subject : Str what : Str with : optional) -> let [case_matters] = booleanDefaults optional [False] - caseFold str = if case_matters then str - else Str.fromText (Str.toCaseFold str) - -- XXX this won't work for Unicode in general + caseFold = caseFold' case_matters :: StrT -> StrT + what' = caseFold what :: StrT + + subs :: StrT -> [StrT] subs "" = [] - subs subject = case Str.breakOn (caseFold what) (caseFold subject) of + subs subject = case Str.breakOn what' (caseFold subject) of (_, "") -> [subject] (prefix, _) -> let (s, r) = Str.splitAt (Str.length prefix) subject in s : with : subs (Str.drop whatLen r) + + whatLen :: Int whatLen = Str.length what + in if Str.null what then raise E_INVARG else return $ Str $ Str.concat $ subs subject @@ -248,9 +245,8 @@ Builtin name 2 (Just 3) [TStr, TStr, TAny] TInt $ \(Str str1 : Str str2 : optional) -> let [case_matters] = booleanDefaults optional [False] - caseFold str = if case_matters then str - else Str.fromText (Str.toCaseFold str) - -- XXX this won't work for Unicode in general + caseFold = caseFold' case_matters :: StrT -> StrT + in return $ Int $ if Str.null str2 then nullCase str1 else mainCase (caseFold str2) (caseFold str1) @@ -277,34 +273,29 @@ bf_decode_binary = Builtin "decode_binary" 1 (Just 2) [TStr, TAny] TLst $ \(Str bin_string : optional) -> let [fully] = booleanDefaults optional [False] - mkResult | fully = fromListBy (Int . fromIntegral) - | otherwise = fromList . groupPrinting ("" ++) - in (mkResult . BS.unpack) `liftM` binaryString bin_string + in fromList . pushString . BS.foldr (decode fully) ([], "") <$> + binaryString bin_string - where groupPrinting :: (String -> String) -> [Word8] -> [Value] - groupPrinting g (w:ws) - | Str.validChar c = groupPrinting (g [c] ++) ws - | null group = Int (fromIntegral w) : groupPrinting g ws - | otherwise = Str (Str.fromString group) : - Int (fromIntegral w) : groupPrinting ("" ++) ws - where c = toEnum (fromIntegral w) - group = g "" - groupPrinting g [] - | null group = [] - | otherwise = [Str $ Str.fromString group] - where group = g "" + where decode :: Bool -> Word8 -> ([Value], String) -> ([Value], String) + decode fully b accum + | not fully && Str.validChar c = (c :) <$> accum + | otherwise = (Int n : pushString accum, "") + where c = toEnum (fromIntegral b) :: Char + n = fromIntegral b :: IntT + pushString :: ([Value], String) -> [Value] + pushString (vs, "") = vs + pushString (vs, s) = Str (Str.fromString s) : vs + bf_encode_binary = Builtin "encode_binary" 0 Nothing [] TStr $ - liftM (Str . Str.fromBinary) . encodeBinary + let mkResult = return . Str . Str.fromBinary . BS.pack + in maybe (raise E_INVARG) mkResult . encode -encodeBinary :: [Value] -> MOO ByteString -encodeBinary = maybe (raise E_INVARG) (return . BS.pack) . encode where encode :: [Value] -> Maybe [Word8] encode (Int n : rest) - | n >= 0 && n <= 255 = (fromIntegral n :) <$> encode rest - | otherwise = Nothing - encode (Str s : rest) = (++) <$> encodeStr s <*> encode rest - encode (Lst v : rest) = (++) <$> encode (V.toList v) <*> encode rest + | n >= 0 && n <= 255 = (fromIntegral n :) <$> encode rest + encode (Str s : rest) = (++) <$> encodeStr s <*> encode rest + encode (Lst v : rest) = (++) <$> encode (Lst.toList v) <*> encode rest encode (_ : _ ) = Nothing encode [] = Just [] @@ -313,9 +304,9 @@ encodeChar :: Char -> Maybe Word8 encodeChar c - | n >= 0 && n <= 255 = Just (fromIntegral n) - | otherwise = Nothing - where n = fromEnum c + | n <= 255 = Just (fromIntegral n) + | otherwise = Nothing + where n = fromEnum c :: Int matchBuiltin :: Id -> (Regexp -> Text -> MatchResult) -> Builtin matchBuiltin name matchFunc = Builtin name 2 (Just 3) [TStr, TStr, TAny] @@ -323,24 +314,23 @@ let [case_matters] = booleanDefaults optional [False] in runMatch matchFunc subject pattern case_matters -bf_match = matchBuiltin "match" match +bf_match = matchBuiltin "match" match bf_rmatch = matchBuiltin "rmatch" rmatch runMatch :: (Regexp -> Text -> MatchResult) -> StrT -> StrT -> Bool -> MOO Value runMatch match subject pattern caseMatters = case Str.toRegexp caseMatters pattern of - Left (err, at) -> raiseException (Err E_INVARG) - (Str.fromString $ "Invalid pattern: " ++ err) - (Int $ fromIntegral at) - Right regexp -> case match regexp (Str.toText subject) of - MatchFailed -> return emptyList - MatchAborted -> raise E_QUOTA + Right regexp -> case regexp `match` Str.toText subject of MatchSucceeded offsets -> let (m : offs) = offsets (start, end) = convert m replacements = repls 9 offs in return $ fromList [Int start, Int end, fromList replacements, Str subject] + MatchFailed -> return emptyList + MatchAborted -> raise E_QUOTA + Left err -> let message = Str.fromString $ "Invalid pattern: " ++ err + in raiseException (Err E_INVARG) message zero where convert :: (Int, Int) -> (IntT, IntT) convert (s, e) = (1 + fromIntegral s, fromIntegral e) @@ -349,27 +339,28 @@ repls :: Int -> [(Int, Int)] -> [Value] repls n (r:rs) = let (s,e) = convert r in fromList [Int s, Int e] : repls (n - 1) rs - repls n [] - | n > 0 = fromList [Int 0, Int (-1)] : repls (n - 1) [] - | otherwise = [] + repls n [] = replicate n $ fromList [Int 0, Int (-1)] bf_substitute = Builtin "substitute" 2 (Just 2) [TStr, TLst] TStr $ \[Str template, Lst subs] -> - case V.toList subs of + case Lst.toList subs of [Int start', Int end', Lst replacements', Str subject'] -> do - let start = fromIntegral start' - end = fromIntegral end' - subject = Str.toString subject' - subjectLen = Str.length subject' + let start = fromIntegral start' :: Int + end = fromIntegral end' :: Int + subject = Str.toString subject' :: String + subjectLen = Str.length subject' :: Int + valid :: Int -> Int -> Bool valid s e = (s == 0 && e == -1) || (s > 0 && e >= s - 1 && e <= subjectLen) + substr :: Int -> Int -> String substr start end = let len = end - start + 1 in take len $ drop (start - 1) subject - substitution (Lst sub) = case V.toList sub of + substitution :: Value -> MOO String + substitution (Lst sub) = case Lst.toList sub of [Int start', Int end'] -> do let start = fromIntegral start' end = fromIntegral end' @@ -378,52 +369,58 @@ _ -> raise E_INVARG substitution _ = raise E_INVARG - unless (valid start end && V.length replacements' == 9) $ - raise E_INVARG - replacements <- (substr start end :) `liftM` - mapM substitution (V.toList replacements') + unless (valid start end && Lst.length replacements' == 9) $ raise E_INVARG + replacements <- (substr start end :) <$> + mapM substitution (Lst.toList replacements') - let walk ('%':c:cs) - | isDigit c = let i = fromEnum c - fromEnum '0' - in (replacements !! i ++) `liftM` walk cs - | c == '%' = ("%" ++) `liftM` walk cs + let walk :: String -> MOO String + walk ('%':c:cs) + | isDigit c = (replacements !! digitToInt c ++) <$> walk cs + | c == '%' = (c :) <$> walk cs | otherwise = raise E_INVARG - walk (c:cs) = ([c] ++) `liftM` walk cs + walk (c:cs) = (c :) <$> walk cs walk [] = return [] - (Str . Str.fromString) `liftM` walk (Str.toString template) + Str . Str.fromString <$> walk (Str.toString template) + _ -> raise E_INVARG bf_crypt = Builtin "crypt" 1 (Just 2) [TStr, TStr] TStr $ \(Str text : optional) -> - let (saltArg : _) = maybeDefaults optional - go salt = case crypt (Str.toString text) (Str.toString salt) of - Just encrypted -> return $ Str $ Str.fromString encrypted - Nothing -> raise E_QUOTA - in if maybe True invalidSalt saltArg - then generateSalt >>= go - else go $ fromStr $ fromJust saltArg + let (salt : _) = maybeDefaults optional + in saltString salt >>= unsafeIOtoMOO . crypt (Str.toString text) >>= + maybe (raise E_INVARG) (return . Str . Str.fromString) - where invalidSalt (Str salt) = salt `Str.compareLength` 2 == LT - generateSalt = do - c1 <- randSaltChar - c2 <- randSaltChar - return $ Str.fromString [c1, c2] - randSaltChar = (saltStuff !!) `liftM` random (0, length saltStuff - 1) - saltStuff = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "./" + where saltString :: Maybe Value -> MOO String + saltString (Just (Str salt)) + | salt `Str.compareLength` 2 /= LT = return (Str.toString salt) + saltString _ = randSaltChar >>= \c1 -> + randSaltChar >>= \c2 -> return [c1, c2] -hash :: ByteString -> Value -hash bs = Str $ Str.fromString $ show md5hash - where md5hash = MD5.hash' bs :: MD5Digest + randSaltChar :: MOO Char + randSaltChar = (saltChars !!) <$> random (0, length saltChars - 1) -bf_string_hash = Builtin "string_hash" 1 (Just 1) - [TStr] TStr $ \[Str text] -> - return $ hash $ encodeUtf8 (Str.toText text) + saltChars :: String + saltChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "./" -bf_binary_hash = Builtin "binary_hash" 1 (Just 1) - [TStr] TStr $ \[Str bin_string] -> - hash `liftM` binaryString bin_string +hashBuiltin :: Id -> ((ByteString -> MOO Value) -> StrT -> MOO Value) -> Builtin +hashBuiltin name f = Builtin name 1 (Just 3) + [TStr, TStr, TAny] TStr $ \(Str input : optional) -> + let (Str algorithm : optional') = defaults optional [Str "MD5"] + [wantBinary] = booleanDefaults optional' [False] + in f (hash algorithm wantBinary) input + where hash :: StrT -> Bool -> ByteString -> MOO Value + hash alg wantBinary = maybe unknown (return . Str) . + hashBytesUsing (toId alg) wantBinary + where unknown = let message = "Unknown hash algorithm: " <> alg + in raiseException (Err E_INVARG) message (Str alg) + +bf_string_hash = hashBuiltin "string_hash" $ + \hash -> hash . encodeUtf8 . Str.toText -- XXX Unicode + +bf_binary_hash = hashBuiltin "binary_hash" (<=< binaryString) + -- § 4.4.2.4 Operations on Lists -- bf_length already defined above @@ -431,36 +428,41 @@ bf_is_member = Builtin "is_member" 2 (Just 2) [TAny, TLst] TInt $ \[value, Lst list] -> return $ Int $ maybe 0 (fromIntegral . succ) $ - V.findIndex (`equal` value) list + Lst.findIndex (`equal` value) list bf_listinsert = Builtin "listinsert" 2 (Just 3) [TLst, TAny, TInt] TLst $ \(Lst list : value : optional) -> let [Int index] = defaults optional [Int 1] - in return $ Lst $ listInsert list (fromIntegral index - 1) value + in return $ Lst $ Lst.insert list (fromIntegral index - 1) value bf_listappend = Builtin "listappend" 2 (Just 3) [TLst, TAny, TInt] TLst $ \(Lst list : value : optional) -> - let [Int index] = defaults optional [Int $ fromIntegral $ V.length list] - in return $ Lst $ listInsert list (fromIntegral index) value + let [Int index] = defaults optional [Int $ fromIntegral $ Lst.length list] + in return $ Lst $ Lst.insert list (fromIntegral index) value +listFunc :: LstT -> Value -> Maybe Value -> MOO Value +listFunc list index newValue = case index of + Int i | i' < 1 || i' > Lst.length list -> raise E_RANGE + | otherwise -> return $ Lst $ + maybe (Lst.delete list) (Lst.set list) newValue (pred i') + where i' = fromIntegral i + Str key -> case Lst.assocLens key list of + Just (_, change) -> return (Lst $ change newValue) + Nothing -> raise E_INVIND + _ -> raise E_TYPE + bf_listdelete = Builtin "listdelete" 2 (Just 2) - [TLst, TInt] TLst $ \[Lst list, Int index] -> - let index' = fromIntegral index - in if index' < 1 || index' > V.length list then raise E_RANGE - else return $ Lst $ listDelete list (index' - 1) + [TLst, TAny] TLst $ \[Lst list, index] -> + listFunc list index Nothing bf_listset = Builtin "listset" 3 (Just 3) - [TLst, TAny, TInt] TLst $ \[Lst list, value, Int index] -> - let index' = fromIntegral index - in if index' < 1 || index' > V.length list then raise E_RANGE - else return $ Lst $ listSet list (index' - 1) value + [TLst, TAny, TAny] TLst $ \[Lst list, value, index] -> + listFunc list index (Just value) bf_setadd = Builtin "setadd" 2 (Just 2) [TLst, TAny] TLst $ \[Lst list, value] -> - return $ Lst $ if value `V.elem` list then list else V.snoc list value + return $ Lst $ if value `Lst.elem` list then list else Lst.snoc list value bf_setremove = Builtin "setremove" 2 (Just 2) [TLst, TAny] TLst $ \[Lst list, value] -> - return $ Lst $ case V.elemIndex value list of - Nothing -> list - Just index -> listDelete list (fromIntegral index) + return $ Lst $ maybe list (Lst.delete list) $ value `Lst.elemIndex` list diff --git a/src/MOO/Command.hs b/src/MOO/Command.hs --- a/src/MOO/Command.hs +++ b/src/MOO/Command.hs @@ -16,7 +16,8 @@ ) where -import Control.Monad (liftM, void, foldM, join) +import Control.Applicative ((<$>)) +import Control.Monad (void, foldM) import Data.Char (isSpace, isDigit) import Data.Monoid (Monoid(mempty, mappend, mconcat), First(First, getFirst)) import Data.Text (Text) @@ -26,7 +27,6 @@ import qualified Data.IntSet as IS import qualified Data.Text as T -import qualified Data.Vector as V import {-# SOURCE #-} MOO.Connection import MOO.Object @@ -34,6 +34,7 @@ import MOO.Types import MOO.Verb +import qualified MOO.List as Lst import qualified MOO.String as Str commandWord :: Parser Text @@ -42,9 +43,9 @@ spaces return (T.concat word) - where wordChar = T.singleton `liftM` satisfy nonspecial <|> - T.pack `liftM` quotedChars <|> - T.singleton `liftM` backslashChar <|> + where wordChar = T.singleton <$> satisfy nonspecial <|> + T.pack <$> quotedChars <|> + T.singleton <$> backslashChar <|> trailingBackslash nonspecial '\"' = False @@ -71,7 +72,7 @@ command :: Parser (Text, Text) command = between spaces eof $ do verb <- builtinCommand <|> commandWord <|> return "" - argstr <- T.pack `liftM` many anyChar + argstr <- T.pack <$> many anyChar return (verb, argstr) matchPrep :: [StrT] -> (StrT, (PrepSpec, StrT), StrT) @@ -95,7 +96,7 @@ , commandPrepSpec :: PrepSpec , commandPrepStr :: StrT , commandIObjStr :: StrT - } deriving Show + } -- | Split a typed command into words according to the MOO rules for quoting -- and escaping. @@ -120,7 +121,7 @@ (dobjstr, (prepSpec, prepstr), iobjstr) = matchPrep args objectNumber :: Parser ObjId -objectNumber = liftM read $ between (char '#') eof $ many1 (satisfy isDigit) +objectNumber = fmap read $ between (char '#') eof $ many1 (satisfy isDigit) matchObject :: ObjId -> StrT -> MOO ObjId matchObject player str @@ -136,7 +137,7 @@ where matchObject' :: ObjId -> StrT -> MOO ObjId matchObject' player str = case str of "me" -> return player - "here" -> maybe nothing (objectForMaybe . objectLocation) `liftM` + "here" -> maybe nothing (objectForMaybe . objectLocation) <$> getObject player _ -> do maybePlayer <- getObject player @@ -147,18 +148,21 @@ maybeRoom = objectLocation player' roomContents <- maybe (return IS.empty) - (liftM (maybe IS.empty objectContents) . getObject) + (fmap (maybe IS.empty objectContents) . getObject) maybeRoom matchName str $ IS.toList (holding `IS.union` roomContents) matchName :: StrT -> [ObjId] -> MOO ObjId - matchName str = liftM (uncurry matchResult) . + matchName str = fmap (uncurry matchResult) . foldM (matchName' str) ([], []) + + matchName' :: StrT -> ([ObjId], [ObjId]) -> ObjId -> + MOO ([ObjId], [ObjId]) matchName' str matches@(exact, prefix) oid = do maybeAliases <- readProperty oid "aliases" maybeObj <- getObject oid let aliases = case maybeAliases of - Just (Lst v) -> V.toList v + Just (Lst v) -> Lst.toList v _ -> [] names = maybe id ((:) . Str . objectName) maybeObj aliases return $ case searchNames str names of @@ -179,8 +183,7 @@ nameMatch str (Str name) | str == name = ExactMatch | str `Str.isPrefixOf` name = PrefixMatch - | otherwise = NoMatch - nameMatch _ _ = NoMatch + nameMatch _ _ = NoMatch data Match = NoMatch | PrefixMatch | ExactMatch @@ -201,26 +204,24 @@ dobj <- matchObject player (commandDObjStr command) iobj <- matchObject player (commandIObjStr command) - room <- (objectForMaybe . join . fmap objectLocation) `liftM` getObject player - maybeVerb <- (getFirst . mconcat . map First) `liftM` + room <- objectForMaybe . (objectLocation =<<) <$> getObject player + maybeVerb <- getFirst . mconcat . map First <$> mapM (locateVerb dobj iobj) [player, room, dobj, iobj] case maybeVerb of - Just (this, spec) -> callCommandVerb player spec this command (dobj, iobj) - Nothing -> do - maybeVerb <- findVerb verbPermX "huh" room - case maybeVerb of - (Just oid, Just verb) -> - callCommandVerb player (oid, verb) room command (dobj, iobj) - _ -> notify player "I couldn't understand that." >> return zero + Just (this, spec) -> callCommandVerb player spec this command dobj iobj + Nothing -> findVerb verbPermX "huh" room >>= \found -> case found of + (Just verbLoc, Just verb) -> + callCommandVerb player (verbLoc, verb) room command dobj iobj + _ -> notify player "I couldn't understand that." >> return zero where locateVerb :: ObjId -> ObjId -> ObjId -> MOO (Maybe (ObjId, (ObjId, Verb))) - locateVerb dobj iobj this = do - location <- findVerb acceptable (commandVerb command) this - case location of - (Just oid, Just verb) -> return $ Just (this, (oid, verb)) - _ -> return Nothing - where acceptable verb = - objMatch this (verbDirectObject verb) dobj && - objMatch this (verbIndirectObject verb) iobj && - prepMatch (verbPreposition verb) (commandPrepSpec command) + locateVerb dobj iobj this = + let acceptable verb = + objMatch this (verbDirectObject verb) dobj && + objMatch this (verbIndirectObject verb) iobj && + prepMatch (verbPreposition verb) (commandPrepSpec command) + in findVerb acceptable (commandVerb command) this >>= \found -> + case found of + (Just verbLoc, Just verb) -> return $ Just (this, (verbLoc, verb)) + _ -> return Nothing diff --git a/src/MOO/Compiler.hs b/src/MOO/Compiler.hs --- a/src/MOO/Compiler.hs +++ b/src/MOO/Compiler.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | Compiling abstract syntax trees into 'MOO' computations module MOO.Compiler ( compile, evaluate ) where -import Control.Monad (when, unless, void, liftM) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (forM_, when, unless, void, join, (<=<)) import Control.Monad.Cont (callCC) import Control.Monad.Reader (asks, local) import Control.Monad.State (gets) +import Data.Monoid ((<>)) -import qualified Data.Map as M -import qualified Data.Vector as V +import qualified Data.HashMap.Lazy as HM -import MOO.Types import MOO.AST -import MOO.Task import MOO.Builtins import MOO.Object +import MOO.Task +import MOO.Types +import qualified MOO.List as Lst import qualified MOO.String as Str -- | Compile a complete MOO program into a computation in the 'MOO' monad that @@ -27,31 +27,28 @@ compileStatements :: [Statement] -> (Value -> MOO Value) -> MOO Value compileStatements (statement:rest) yield = case statement of - Expression lineNumber expr -> do - setLineNumber lineNumber - evaluate expr - compile' rest + Expression lineNo expr -> + setLineNumber lineNo >> evaluate expr >> compile' rest - If lineNumber cond (Then thens) elseIfs (Else elses) -> runTick >> do - compileIf ((lineNumber, cond, thens) : map elseIf elseIfs) elses + If lineNo cond (Then thens) elseIfs (Else elses) -> runTick >> do + compileIf ((lineNo, cond, thens) : map elseIf elseIfs) elses compile' rest - where elseIf (ElseIf lineNumber cond thens) = (lineNumber, cond, thens) + where elseIf :: ElseIf -> (LineNo, Expr, [Statement]) + elseIf (ElseIf lineNo cond thens) = (lineNo, cond, thens) - compileIf ((lineNumber,cond,thens):conds) elses = do - setLineNumber lineNumber + compileIf :: [(LineNo, Expr, [Statement])] -> [Statement] -> MOO Value + compileIf ((lineNo,cond,thens):conds) elses = do + setLineNumber lineNo cond' <- evaluate cond if truthOf cond' then compile' thens else compileIf conds elses compileIf [] elses = compile' elses - ForList lineNumber var expr body -> do + ForList lineNo var expr body -> do handleDebug $ do - setLineNumber lineNumber - expr' <- evaluate expr - elts <- case expr' of - Lst elts -> return $ V.toList elts - _ -> raise E_TYPE + setLineNumber lineNo + elts <- getList =<< evaluate expr callCC $ \break -> do pushLoopContext (Just var) (Continuation break) @@ -61,22 +58,19 @@ compile' rest - where loop var (elt:elts) body = runTick >> do + where loop :: Id -> [Value] -> MOO a -> MOO () + loop var elts body = forM_ elts $ \elt -> runTick >> do storeVariable var elt - callCC $ \continue -> do - setLoopContinue (Continuation continue) - void body - loop var elts body - loop _ [] _ = return () + callCC $ \k -> setLoopContinue (Continuation k) >> void body - ForRange lineNumber var (start, end) body -> do + ForRange lineNo var (start, end) body -> do handleDebug $ do - setLineNumber lineNumber + setLineNumber lineNo start' <- evaluate start end' <- evaluate end (ty, s, e) <- case (start', end') of - (Int s, Int e) -> return (Int . fromIntegral, toInteger s, toInteger e) - (Obj s, Obj e) -> return (Obj . fromIntegral, toInteger s, toInteger e) + (Int s, Int e) -> return (Int . fromInteger, toInteger s, toInteger e) + (Obj s, Obj e) -> return (Obj . fromInteger, toInteger s, toInteger e) (_ , _ ) -> raise E_TYPE callCC $ \break -> do @@ -87,46 +81,36 @@ compile' rest - where loop var ty i end body - | i > end = return () - | otherwise = runTick >> do - storeVariable var (ty i) - callCC $ \continue -> do - setLoopContinue (Continuation continue) - void body - loop var ty (succ i) end body + where loop :: Id -> (Integer -> Value) -> Integer -> Integer -> MOO a -> + MOO () + loop var ty start end body = forM_ [start..end] $ \i -> runTick >> do + storeVariable var (ty i) + callCC $ \k -> setLoopContinue (Continuation k) >> void body - While lineNumber var expr body -> do + While lineNo var expr body -> do callCC $ \break -> do pushLoopContext var (Continuation break) - loop lineNumber var (evaluate expr) (compile' body) + loop lineNo var (evaluate expr) (compile' body) popContext compile' rest - where loop lineNumber var expr body = runTick >> do - setLineNumber lineNumber + where loop :: LineNo -> Maybe Id -> MOO Value -> MOO a -> MOO () + loop lineNo var expr body = runTick >> do + setLineNumber lineNo expr' <- expr maybe return storeVariable var expr' when (truthOf expr') $ do - callCC $ \continue -> do - setLoopContinue (Continuation continue) - void body - loop lineNumber var expr body + callCC $ \k -> setLoopContinue (Continuation k) >> void body + loop lineNo var expr body - Fork lineNumber var delay body -> runTick >> do + Fork lineNo var delay body -> runTick >> do handleDebug $ do - setLineNumber lineNumber - delay' <- evaluate delay - usecs <- case delay' of - Int secs - | secs < 0 -> raise E_INVARG - | otherwise -> return (fromIntegral secs * 1000000) - Flt secs - | secs < 0 -> raise E_INVARG - | otherwise -> return (ceiling $ secs * 1000000) - _ -> raise E_TYPE + setLineNumber lineNo + usecs <- getDelay =<< evaluate delay + checkQueuedTaskLimit + world <- getWorld gen <- newRandomGen let taskId = newTaskId world gen @@ -140,23 +124,26 @@ Break name -> breakLoop name Continue name -> continueLoop name - Return _ Nothing -> runTick >> yield zero - Return lineNumber (Just expr) -> runTick >> do - setLineNumber lineNumber + Return _ Nothing -> runTick >> yield zero + Return lineNo (Just expr) -> runTick >> do + setLineNumber lineNo yield =<< evaluate expr TryExcept body excepts -> runTick >> do - excepts' <- mapM compileExcepts excepts + excepts' <- mapM compileExcept excepts compile' body `catchException` dispatch excepts' compile' rest - where compileExcepts (Except lineNumber var codes handler) = do + where compileExcept :: Except -> MOO (Maybe [Value], Maybe Id, MOO Value) + compileExcept (Except lineNo var codes handler) = do codes' <- case codes of ANY -> return Nothing - Codes args -> setLineNumber lineNumber >> Just `liftM` expand args + Codes args -> setLineNumber lineNo >> Just <$> expand args return (codes', var, compile' handler) + dispatch :: [(Maybe [Value], Maybe Id, MOO Value)] -> Exception -> + MOO Value dispatch ((codes, var, handler):next) except@Exception { exceptionCode = code , exceptionMessage = message @@ -164,12 +151,12 @@ , exceptionCallStack = Stack errorFrames } | maybe True (code `elem`) codes = do - Stack currentFrames <- gets stack - let traceback = formatFrames True $ take stackLen errorFrames - stackLen = length errorFrames - length currentFrames + 1 - errorInfo = fromList [code, Str message, value, traceback] - maybe return storeVariable var errorInfo - handler + Stack currentFrames <- gets stack + let traceback = formatFrames True $ take stackLen errorFrames + stackLen = length errorFrames - length currentFrames + 1 + errorInfo = fromList [code, Str message, value, traceback] + maybe return storeVariable var errorInfo + handler | otherwise = dispatch next except dispatch [] except = passException except @@ -177,17 +164,16 @@ let finally' = compile' finally pushTryFinallyContext finally' - compile' body `catchException` \except -> do - popContext - finally' - passException except + compile' body `catchException` \except -> + popContext >> finally' >> passException except popContext finally' compile' rest - where compile' ss = compileStatements ss yield + where compile' :: [Statement] -> MOO Value + compile' ss = compileStatements ss yield compileStatements [] _ = return zero @@ -198,17 +184,13 @@ evaluate (Literal value) = return value evaluate expr@Variable{} = handleDebug $ fetch (lValue expr) evaluate expr = runTick >>= \_ -> handleDebug $ case expr of - List args -> fromList `liftM` expand args + List args -> fromList <$> expand args PropertyRef{} -> fetch (lValue expr) - Assign what expr -> store (lValue what) =<< evaluate expr + Assign what expr -> evaluate expr >>= store (lValue what) - Scatter items expr -> do - expr' <- evaluate expr - case expr' of - Lst v -> scatterAssign items v - _ -> raise E_TYPE + Scatter items expr -> evaluate expr >>= usingList (scatterAssign items) VerbCall target vname args -> do target' <- evaluate target @@ -221,32 +203,27 @@ callVerb oid oid name args' - BuiltinFunc func args -> callBuiltin func =<< expand args + BuiltinFunc func args -> expand args >>= callBuiltin func - a `Plus` b -> binary plus a b - a `Minus` b -> binary minus a b - a `Times` b -> binary times a b - a `Divide` b -> binary divide a b - a `Remain` b -> binary remain a b - a `Power` b -> binary power a b + x `Plus` y -> binary plus x y + x `Minus` y -> binary minus x y + x `Times` y -> binary times x y + x `Divide` y -> binary divide x y + x `Remain` y -> binary remain x y + x `Power` y -> binary power x y - Negate x -> do - x' <- evaluate x - case x' of - Int z -> return (Int $ negate z) - Flt z -> return (Flt $ negate z) - _ -> raise E_TYPE + Negate x -> evaluate x >>= \x' -> case x' of + Int n -> return (Int $ negate n) + Flt n -> return (Flt $ negate n) + _ -> raise E_TYPE - Conditional cond x y -> do - cond' <- evaluate cond - evaluate $ if truthOf cond' then x else y + Conditional cond x y -> + evaluate cond >>= \cond' -> evaluate $ if truthOf cond' then x else y - x `And` y -> do x' <- evaluate x - if truthOf x' then evaluate y else return x' - x `Or` y -> do x' <- evaluate x - if truthOf x' then return x' else evaluate y + x `And` y -> evaluate x >>= \v -> if truthOf v then evaluate y else return v + x `Or` y -> evaluate x >>= \v -> if truthOf v then return v else evaluate y - Not x -> (truthValue . not . truthOf) `liftM` evaluate x + Not x -> truthValue . not . truthOf <$> evaluate x x `CompareEQ` y -> equality (==) x y x `CompareNE` y -> equality (/=) x y @@ -258,55 +235,52 @@ Index{} -> fetch (lValue expr) Range{} -> fetch (lValue expr) - Length -> liftM (Int . fromIntegral) =<< asks indexLength + Length -> join (asks indexLength) item `In` list -> do - item' <- evaluate item - list' <- evaluate list - case list' of - Lst v -> return $ Int $ maybe 0 (fromIntegral . succ) $ - V.elemIndex item' v - _ -> raise E_TYPE + elt <- evaluate item + evaluate list >>= usingList + (return . Int . maybe 0 (fromIntegral . succ) . Lst.elemIndex elt) Catch expr codes (Default dv) -> do codes' <- case codes of ANY -> return Nothing - Codes args -> Just `liftM` expand args - evaluate expr `catchException` \except@Exception { exceptionCode = code } -> - if maybe True (code `elem`) codes' - then maybe (return code) evaluate dv - else passException except + Codes args -> Just <$> expand args + let handler except@Exception { exceptionCode = code } + | maybe True (code `elem`) codes' = maybe (return code) evaluate dv + | otherwise = passException except + evaluate expr `catchException` handler - where binary op a b = do - a' <- evaluate a - b' <- evaluate b - a' `op` b' + where binary :: (Value -> Value -> MOO Value) -> Expr -> Expr -> MOO Value + binary op x y = evaluate x >>= \x' -> evaluate y >>= \y' -> x' `op` y' + -- binary op x y = join $ op <$> evaluate x <*> evaluate y + equality :: (Value -> Value -> Bool) -> Expr -> Expr -> MOO Value equality op = binary test - where test a b = return $ truthValue (a `op` b) + where test x y = return $ truthValue (x `op` y) + comparison :: (Value -> Value -> Bool) -> Expr -> Expr -> MOO Value comparison op = binary test - where test a b = do when (typeOf a /= typeOf b) $ raise E_TYPE - case a of - Lst{} -> raise E_TYPE - _ -> return $ truthValue (a `op` b) + where test x y | comparable x y = return $ truthValue (x `op` y) + | otherwise = raise E_TYPE fetchVariable :: Id -> MOO Value fetchVariable var = - maybe (raise E_VARNF) return . M.lookup var =<< frame variables + maybe (raise E_VARNF) return . HM.lookup var =<< frame variables storeVariable :: Id -> Value -> MOO Value storeVariable var value = do modifyFrame $ \frame -> - frame { variables = M.insert var value (variables frame) } + frame { variables = HM.insert var value (variables frame) } return value fetchProperty :: (ObjT, StrT) -> MOO Value fetchProperty (oid, name) = do - obj <- getObject oid >>= maybe (raise E_INVIND) return - maybe (search False obj) (return . ($ obj)) $ builtinProperty name + obj <- maybe (raise E_INVIND) return =<< getObject oid + maybe (search False obj) (handleBuiltin obj) $ builtinProperty name - where search skipPermCheck obj = do + where search :: Bool -> Object -> MOO Value + search skipPermCheck obj = do prop <- getProperty obj name unless (skipPermCheck || propertyPermR prop) $ checkPermission (propertyOwner prop) @@ -317,34 +291,46 @@ maybe (error $ "No inherited value for property " ++ Str.toString name) (search True) parentObj + handleBuiltin :: Object -> (Object -> Value) -> MOO Value + handleBuiltin obj prop = checkProtectedProperty (toId name) >> + return (prop obj) + storeProperty :: (ObjT, StrT) -> Value -> MOO Value storeProperty (oid, name) value = do - obj <- getObject oid >>= maybe (raise E_INVIND) return + obj <- maybe (raise E_INVIND) return =<< getObject oid if isBuiltinProperty name - then setBuiltinProperty (oid, obj) name value + then checkProtectedProperty (toId name) >> + setBuiltinProperty (oid, obj) name value else modifyProperty obj name $ \prop -> do unless (propertyPermW prop) $ checkPermission (propertyOwner prop) return prop { propertyValue = Just value } return value withIndexLength :: Value -> MOO a -> MOO a -withIndexLength expr = - local $ \env -> env { indexLength = case expr of - Lst v -> return (V.length v) - Str t -> return (Str.length t) - _ -> raise E_TYPE - } +withIndexLength value = local $ \env -> env { indexLength = valueLength } + where valueLength :: MOO Value + valueLength = Int . fromIntegral <$> case value of + Lst v -> return (Lst.length v) + Str t -> return (Str.length t) + _ -> raise E_TYPE +usingList :: (LstT -> MOO a) -> Value -> MOO a +usingList f (Lst v) = f v +usingList _ _ = raise E_TYPE + +getList :: Value -> MOO [Value] +getList = usingList (return . Lst.toList) + +getIndex :: Value -> MOO Int +getIndex (Int i) = return (fromIntegral i) +getIndex _ = raise E_TYPE + checkLstRange :: LstT -> Int -> MOO () -checkLstRange v i = when (i < 1 || i > V.length v) $ raise E_RANGE +checkLstRange v i = when (i < 1 || i > Lst.length v) $ raise E_RANGE checkStrRange :: StrT -> Int -> MOO () -checkStrRange t i = when (i < 1 || - t `Str.compareLength` i == LT) $ raise E_RANGE - -checkIndex :: Value -> MOO Int -checkIndex (Int i) = return (fromIntegral i) -checkIndex _ = raise E_TYPE +checkStrRange t i = when (i < 1 || t `Str.compareLength` i == LT) $ + raise E_RANGE data LValue = LValue { fetch :: MOO Value @@ -355,15 +341,12 @@ lValue :: Expr -> LValue lValue (Variable var) = LValue fetch store change - where fetch = fetchVariable var - store = storeVariable var - - change = do - value <- fetch - return (value, store) + where fetch = fetchVariable var + store = storeVariable var + change = fetch >>= \value -> return (value, store) lValue (PropertyRef objExpr nameExpr) = LValue fetch store change - where fetch = getRefs >>= fetchProperty + where fetch = getRefs >>= fetchProperty store value = getRefs >>= flip storeProperty value change = do @@ -371,6 +354,7 @@ value <- fetchProperty refs return (value, storeProperty refs) + getRefs :: MOO (ObjT, StrT) getRefs = do objRef <- evaluate objExpr nameRef <- evaluate nameExpr @@ -379,34 +363,55 @@ _ -> raise E_TYPE lValue (expr `Index` index) = LValue fetchIndex storeIndex changeIndex - where fetchIndex = do - (value, _) <- changeIndex - return value + where fetchIndex = fst <$> changeIndex storeIndex newValue = do - (_, change) <- changeIndex + (_, change) <- getLens change newValue return newValue - changeIndex = do + changeIndex :: MOO (Value, Value -> MOO Value) + changeIndex = getLens >>= \(maybeValue, setValue) -> case maybeValue of + Just value -> return (value, setValue) + Nothing -> raise E_RANGE + + getLens :: MOO (Maybe Value, Value -> MOO Value) + getLens = do (value, changeExpr) <- change (lValue expr) - index' <- checkIndex =<< withIndexLength value (evaluate index) - value' <- case value of - Lst v -> checkLstRange v index' >> return (v V.! (index' - 1)) - Str t -> checkStrRange t index' >> - return (Str $ Str.singleton $ t `Str.index` (index' - 1)) + index' <- withIndexLength value (evaluate index) + case index' of + Int i -> getIntLens value (fromIntegral i) changeExpr + Str k -> getStrLens value k changeExpr _ -> raise E_TYPE - return (value', changeValue value index' changeExpr) - changeValue (Lst v) index changeExpr newValue = - changeExpr $ Lst $ listSet v (index - 1) newValue + getIntLens :: Value -> Int -> (Value -> MOO Value) -> + MOO (Maybe Value, Value -> MOO Value) + getIntLens value index' changeExpr = do + let i = index' - 1 :: Int + value' <- case value of + Lst v -> checkLstRange v index' >> return (v Lst.! i) + Str t -> checkStrRange t index' >> return (Str $ Str.singleton $ + t `Str.index` i) + _ -> raise E_TYPE + return (Just value', changeValue value i changeExpr) - changeValue (Str t) index changeExpr (Str c) = do - when (c `Str.compareLength` 1 /= EQ) $ raise E_INVARG - let (s, r) = Str.splitAt (index - 1) t - changeExpr $ Str $ Str.concat [s, c, Str.tail r] + where changeValue :: Value -> Int -> (Value -> MOO Value) -> + Value -> MOO Value + changeValue (Lst v) i changeExpr newValue = + changeExpr $ Lst $ Lst.set v newValue i + changeValue (Str t) i changeExpr (Str c) = do + when (c `Str.compareLength` 1 /= EQ) $ raise E_INVARG + let (s, r) = Str.splitAt i t :: (StrT, StrT) + changeExpr $ Str $ Str.concat [s, c, Str.tail r] + changeValue _ _ _ _ = raise E_TYPE - changeValue _ _ _ _ = raise E_TYPE + getStrLens :: Value -> StrT -> (Value -> MOO Value) -> + MOO (Maybe Value, Value -> MOO Value) + getStrLens (Lst lst) key changeExpr = case Lst.assocLens key lst of + Just (maybeValue, changeList) -> + return (maybeValue, changeExpr . Lst . changeList . Just) + Nothing -> raise E_INVIND + getStrLens _ _ _ = raise E_TYPE lValue (expr `Range` (start, end)) = LValue fetchRange storeRange changeRange where fetchRange = do @@ -419,53 +424,51 @@ _ -> raise E_TYPE else let len = end' - start' + 1 in case value of Lst v -> do checkLstRange v start' >> checkLstRange v end' - return $ Lst $ V.slice (start' - 1) len v + return $ Lst $ Lst.slice (start' - 1) len v Str t -> do checkStrRange t start' >> checkStrRange t end' return $ Str $ Str.take len $ Str.drop (start' - 1) t _ -> raise E_TYPE - getIndices value = withIndexLength value $ do - start' <- checkIndex =<< evaluate start - end' <- checkIndex =<< evaluate end - return (start', end') - storeRange newValue = do (value, changeExpr) <- change (lValue expr) - (start', end') <- getIndices value - changeValue value start' end' changeExpr newValue + startEnd <- getIndices value + changeValue value startEnd changeExpr newValue return newValue - changeValue (Lst v) start end changeExpr (Lst r) = do - let len = V.length v + changeRange = error "Illegal Range as lvalue subexpression" + + getIndices :: Value -> MOO (Int, Int) + getIndices value = withIndexLength value $ + (,) <$> (evaluate start >>= getIndex) + <*> (evaluate end >>= getIndex) + + changeValue :: Value -> (Int, Int) -> (Value -> MOO a) -> Value -> MOO a + changeValue (Lst v) (start, end) changeExpr (Lst r) = do + let len = Lst.length v :: Int when (end < 0 || start > len + 1) $ raise E_RANGE - let pre = sublist v 1 (start - 1) - post = sublist v (end + 1) len + let pre = sublist v 1 (start - 1) :: LstT + post = sublist v (end + 1) len :: LstT + sublist :: LstT -> Int -> Int -> LstT sublist v s e - | e < s = V.empty - | otherwise = V.slice (s - 1) (e - s + 1) v - changeExpr $ Lst $ V.concat [pre, r, post] - - changeValue (Str t) start end changeExpr (Str r) = do - when (end < 0 || - t `Str.compareLength` (start - 1) == LT) $ raise E_RANGE - let pre = substr t 1 (start - 1) - post = substr t (end + 1) (Str.length t) + | e < s = Lst.empty + | otherwise = Lst.slice (s - 1) (e - s + 1) v + changeExpr $ Lst $ Lst.concat [pre, r, post] + changeValue (Str t) (start, end) changeExpr (Str r) = do + when (end < 0 || t `Str.compareLength` (start - 1) == LT) $ + raise E_RANGE + let pre = substr t 1 (start - 1) :: StrT + post = substr t (end + 1) (Str.length t) :: StrT + substr :: StrT -> Int -> Int -> StrT substr t s e | e < s = Str.empty | otherwise = Str.take (e - s + 1) $ Str.drop (s - 1) t changeExpr $ Str $ Str.concat [pre, r, post] - - changeValue _ _ _ _ _ = raise E_TYPE - - changeRange = error "Illegal Range as lvalue subexpression" + changeValue _ _ _ _ = raise E_TYPE lValue expr = LValue fetch store change - where fetch = evaluate expr + where fetch = evaluate expr store _ = error "Unmodifiable LValue" - - change = do - value <- fetch - return (value, store) + change = fetch >>= \value -> return (value, store) scatterAssign :: [ScatterItem] -> LstT -> MOO Value scatterAssign items args = do @@ -473,15 +476,18 @@ walk items args (nargs - nreqs) return (Lst args) - where nargs = V.length args - nreqs = count required items - nopts = count optional items - ntarg = nreqs + nopts - nrest = if haveRest && nargs >= ntarg then nargs - ntarg else 0 + where nargs = Lst.length args :: Int + nreqs = count required items :: Int + nopts = count optional items :: Int + ntarg = nreqs + nopts :: Int + nrest = if haveRest && nargs >= ntarg then nargs - ntarg else 0 :: Int - haveRest = any rest items + count :: (a -> Bool) -> [a] -> Int count p = length . filter p + haveRest = any rest items :: Bool + + required, optional, rest :: ScatterItem -> Bool required ScatRequired{} = True required _ = False optional ScatOptional{} = True @@ -489,84 +495,73 @@ rest ScatRest{} = True rest _ = False - walk (item:items) args noptAvail = - case item of - ScatRequired var -> do - storeVariable var (V.head args) - walk items (V.tail args) noptAvail - ScatOptional var opt - | noptAvail > 0 -> do storeVariable var (V.head args) - walk items (V.tail args) (noptAvail - 1) - | otherwise -> do - case opt of - Nothing -> return () - Just expr -> void $ storeVariable var =<< evaluate expr + walk :: [ScatterItem] -> LstT -> Int -> MOO () + walk (item:items) args noptAvail = case item of + ScatRequired var -> do + storeVariable var (Lst.head args) + walk items (Lst.tail args) noptAvail + ScatOptional var opt + | noptAvail > 0 -> do + storeVariable var (Lst.head args) + walk items (Lst.tail args) (pred noptAvail) + | otherwise -> do + maybe (return zero) (storeVariable var <=< evaluate) opt walk items args noptAvail - ScatRest var -> do - let (s, r) = V.splitAt nrest args - storeVariable var (Lst s) - walk items r noptAvail + ScatRest var -> do + let (s, r) = Lst.splitAt nrest args :: (LstT, LstT) + storeVariable var (Lst s) + walk items r noptAvail walk [] _ _ = return () expand :: [Argument] -> MOO [Value] -expand (a:as) = case a of - ArgNormal expr -> do a' <- evaluate expr - (a' :) `liftM` expand as - ArgSplice expr -> do a' <- evaluate expr - case a' of - Lst v -> (V.toList v ++) `liftM` expand as - _ -> raise E_TYPE +expand (x:xs) = case x of + ArgNormal expr -> (:) <$> evaluate expr <*> expand xs + ArgSplice expr -> (++) <$> (evaluate expr >>= getList) <*> expand xs expand [] = return [] plus :: Value -> Value -> MOO Value -Int a `plus` Int b = return $ Int (a + b) -Flt a `plus` Flt b = checkFloat (a + b) -Str a `plus` Str b = return $ Str (a `Str.append` b) +Int x `plus` Int y = return $ Int (x + y) +Flt x `plus` Flt y = checkFloat (x + y) +Str x `plus` Str y = return $ Str (x <> y) _ `plus` _ = raise E_TYPE minus :: Value -> Value -> MOO Value -Int a `minus` Int b = return $ Int (a - b) -Flt a `minus` Flt b = checkFloat (a - b) +Int x `minus` Int y = return $ Int (x - y) +Flt x `minus` Flt y = checkFloat (x - y) _ `minus` _ = raise E_TYPE times :: Value -> Value -> MOO Value -Int a `times` Int b = return $ Int (a * b) -Flt a `times` Flt b = checkFloat (a * b) +Int x `times` Int y = return $ Int (x * y) +Flt x `times` Flt y = checkFloat (x * y) _ `times` _ = raise E_TYPE divide :: Value -> Value -> MOO Value -Int _ `divide` Int 0 = raise E_DIV -Int a `divide` Int (-1) -- avoid arithmetic overflow - | a == minBound = return $ Int a -Int a `divide` Int b = return $ Int (a `quot` b) -Flt _ `divide` Flt 0 = raise E_DIV -Flt a `divide` Flt b = checkFloat (a / b) -_ `divide` _ = raise E_TYPE +Int _ `divide` Int 0 = raise E_DIV +Int x `divide` Int (-1) + | x == minBound = return $ Int x -- avoid arithmetic overflow exception +Int x `divide` Int y = return $ Int (x `quot` y) +Flt _ `divide` Flt 0 = raise E_DIV +Flt x `divide` Flt y = checkFloat (x / y) +_ `divide` _ = raise E_TYPE remain :: Value -> Value -> MOO Value Int _ `remain` Int 0 = raise E_DIV -Int a `remain` Int b = return $ Int (a `rem` b) +Int x `remain` Int y = return $ Int (x `rem` y) Flt _ `remain` Flt 0 = raise E_DIV -Flt a `remain` Flt b = checkFloat (a `fmod` b) +Flt x `remain` Flt y = checkFloat (x `fmod` y) _ `remain` _ = raise E_TYPE fmod :: FltT -> FltT -> FltT -x `fmod` y = x - fromIntegral n * y - where n = roundZero (x / y) - roundZero :: FltT -> Integer - roundZero q | q > 0 = floor q - | q < 0 = ceiling q - | otherwise = round q +x `fmod` y = x - y * fromInteger (truncate $ x / y) power :: Value -> Value -> MOO Value -Int a `power` Int b - | b >= 0 = return $ Int (a ^ b) - | otherwise = case a of - -1 | even b -> return $ Int 1 - | otherwise -> return $ Int (-1) - 0 -> raise E_DIV - 1 -> return $ Int 1 - _ -> return $ Int 0 -Flt a `power` Int b = checkFloat (a ^^ b) -Flt a `power` Flt b = checkFloat (a ** b) -_ `power` _ = raise E_TYPE +Flt x `power` Flt y = checkFloat (x ** y) +Flt x `power` Int y = checkFloat (x ^^ y) +Int x `power` Int y | y >= 0 = return $ Int (x ^ y) +-- | y < 0 ... +Int 0 `power` Int _ = raise E_DIV +Int 1 `power` Int _ = return $ Int 1 +Int (-1) `power` Int y | even y = return $ Int 1 + | otherwise = return $ Int (-1) +Int _ `power` Int _ = return $ Int 0 +_ `power` _ = raise E_TYPE diff --git a/src/MOO/Compiler.hs-boot b/src/MOO/Compiler.hs-boot --- a/src/MOO/Compiler.hs-boot +++ b/src/MOO/Compiler.hs-boot @@ -3,7 +3,7 @@ module MOO.Compiler ( compile ) where import MOO.AST -import MOO.Task +import {-# SOURCE #-} MOO.Task import MOO.Types compile :: Program -> MOO Value diff --git a/src/MOO/Connection.hs b/src/MOO/Connection.hs --- a/src/MOO/Connection.hs +++ b/src/MOO/Connection.hs @@ -4,7 +4,10 @@ module MOO.Connection ( Connection , ConnectionHandler + , Disconnect(..) , connectionHandler + , connectionObject + , doDisconnected , firstConnectionId @@ -20,6 +23,8 @@ , sendToConnection , closeConnection + , readFromConnection + , notify , notify' @@ -34,9 +39,11 @@ , getConnectionOptions ) where +import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import Control.Concurrent.STM (STM, TVar, TMVar, atomically, newTVar, - newEmptyTMVar, tryPutTMVar, takeTMVar, + newEmptyTMVar, takeTMVar, + putTMVar, tryPutTMVar, tryTakeTMVar, readTVar, writeTVar, modifyTVar, swapTVar, readTVarIO) import Control.Concurrent.STM.TBMQueue (TBMQueue, newTBMQueue, closeTBMQueue, @@ -44,27 +51,31 @@ tryReadTBMQueue, tryWriteTBMQueue, unGetTBMQueue, isEmptyTBMQueue, freeSlotsTBMQueue) -import Control.Exception (SomeException, try, bracket) -import Control.Monad ((<=<), join, when, unless, foldM, forever, void, liftM) +import Control.Exception (SomeException, try, bracket, catch) +import Control.Monad ((<=<), join, when, unless, foldM, forever, void) +import Control.Monad.Cont (callCC) +import Control.Monad.Reader (asks) +import Control.Monad.State (get, modify) import Control.Monad.Trans (lift) import Data.ByteString (ByteString) import Data.Map (Map) -import Data.Maybe (fromMaybe, isNothing, fromJust) +import Data.Maybe (fromMaybe, isNothing) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Text.Encoding (Decoding(..), encodeUtf8, streamDecodeUtf8With) +import Data.Text.Encoding (Decoding(Some), encodeUtf8, streamDecodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Time (UTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Database.VCache (runVTx) import Pipes (Producer, Consumer, Pipe, await, yield, runEffect, for, cat, (>->)) -import Pipes.Concurrent (Buffer(..), Output(..), spawn, spawn', - fromInput, toOutput) +import Pipes.Concurrent (send, spawn, unbounded, fromInput, toOutput) import qualified Data.ByteString as BS import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import qualified Data.Vector as V +import qualified Database.VCache as DV import MOO.Command import MOO.Database @@ -72,13 +83,15 @@ import MOO.Task import MOO.Types +import qualified MOO.List as Lst import qualified MOO.String as Str data Connection = Connection { connectionObject :: ObjId , connectionPlayer :: TVar ObjId + , connectionPrintMessages :: Bool - , connectionInput :: TBMQueue ConnectionMessage + , connectionInput :: TBMQueue StrT , connectionOutput :: TBMQueue ConnectionMessage , connectionName :: ConnectionName @@ -157,13 +170,15 @@ where get = fromListBy (Str . Str.fromText) . M.keys . optionIntrinsicCommands set _ v options = do commands <- case v of - Lst vs -> foldM addCommand M.empty (V.toList vs) + Lst vs -> foldM addCommand M.empty (Lst.toList vs) Int 0 -> return M.empty Int _ -> return allIntrinsicCommands _ -> raise E_INVARG return options { optionIntrinsicCommands = commands } + addCommand :: Map Text IntrinsicCommand -> Value + -> MOO (Map Text IntrinsicCommand) addCommand cmds value = case value of Str cmd -> do ic <- maybe (raise E_INVARG) return $ @@ -216,15 +231,21 @@ , icProgram ] -outOfBandPrefix :: Text -outOfBandPrefix = "#$#" +maxQueueLength :: Int +maxQueueLength = 512 outOfBandQuotePrefix :: Text outOfBandQuotePrefix = "#$\"" -maxQueueLength :: Int -maxQueueLength = 512 +outOfBandPrefix :: Text +outOfBandPrefix = "#$#" +isOOBQuoted :: Text -> Bool +isOOBQuoted = (outOfBandQuotePrefix `T.isPrefixOf`) + +isOOB :: Text -> Bool +isOOB = (outOfBandPrefix `T.isPrefixOf`) + type ConnectionName = STM String type ConnectionHandler = ConnectionName -> (Producer ByteString IO (), Consumer ByteString IO ()) -> IO () @@ -234,7 +255,7 @@ connectionHandler :: TVar World -> ObjId -> Bool -> ConnectionHandler connectionHandler world' object printMessages connectionName (input, output) = bracket newConnection deleteConnection $ \conn -> do - forkIO $ runConnection world' printMessages conn + forkIO $ runConnection world' conn forkIO $ do try (runEffect $ input >-> connectionRead conn) >>= @@ -251,105 +272,133 @@ where newConnection :: IO Connection newConnection = do now <- getCurrentTime + vspace <- persistenceVSpace . persistence <$> readTVarIO world' - atomically $ do - world <- readTVar world' + runVTx vspace $ do + (world, connectionId, nextId, + connection, inputQueue) <- DV.liftSTM $ do + world <- readTVar world' - let connectionId = nextConnectionId world + let connectionId = nextConnectionId world - playerVar <- newTVar connectionId + name <- connectionName + writeLog world $ "ACCEPT: " <> toText (Obj connectionId) <> + " on " <> T.pack name - inputQueue <- newTBMQueue maxQueueLength - outputQueue <- newTBMQueue maxQueueLength + playerVar <- newTVar connectionId - cTimeVar <- newTVar Nothing - aTimeVar <- newTVar now + inputQueue <- newTBMQueue maxQueueLength + outputQueue <- newTBMQueue maxQueueLength - delimsVar <- newTVar (T.empty, T.empty) - optionsVar <- newTVar initConnectionOptions { - optionFlushCommand = defaultFlushCommand $ - serverOptions (database world) } + cTimeVar <- newTVar Nothing + aTimeVar <- newTVar now - readerVar <- newEmptyTMVar - disconnectVar <- newEmptyTMVar + delimsVar <- newTVar (T.empty, T.empty) + optionsVar <- newTVar initConnectionOptions { + optionFlushCommand = defaultFlushCommand $ + serverOptions (database world) } - let connection = Connection { - connectionObject = object - , connectionPlayer = playerVar + readerVar <- newEmptyTMVar + disconnectVar <- newEmptyTMVar - , connectionInput = inputQueue - , connectionOutput = outputQueue + let connection = Connection { + connectionObject = object + , connectionPlayer = playerVar + , connectionPrintMessages = printMessages - , connectionName = connectionName - , connectionConnectedTime = cTimeVar - , connectionActivityTime = aTimeVar + , connectionInput = inputQueue + , connectionOutput = outputQueue - , connectionOutputDelimiters = delimsVar - , connectionOptions = optionsVar + , connectionName = connectionName + , connectionConnectedTime = cTimeVar + , connectionActivityTime = aTimeVar - , connectionReader = readerVar - , connectionDisconnect = disconnectVar - } - nextId = succConnectionId - (`M.member` connections world) connectionId + , connectionOutputDelimiters = delimsVar + , connectionOptions = optionsVar - writeTVar world' world { - connections = M.insert connectionId connection - (connections world) - , nextConnectionId = nextId - } + , connectionReader = readerVar + , connectionDisconnect = disconnectVar + } + nextId = succConnectionId + (`M.member` connections world) connectionId - writeTBMQueue inputQueue (Line T.empty) + return (world, connectionId, nextId, connection, inputQueue) + DV.liftSTM $ writeTVar world' world { nextConnectionId = nextId } + updateConnections world' $ M.insert connectionId connection + + DV.liftSTM $ writeTBMQueue inputQueue Str.empty + return connection deleteConnection :: Connection -> IO () deleteConnection conn = do - atomically $ do - connectionId <- readTVar (connectionPlayer conn) - modifyTVar world' $ \world -> - world { connections = M.delete connectionId (connections world) } - how <- atomically $ takeTMVar (connectionDisconnect conn) player <- readTVarIO (connectionPlayer conn) - let systemVerb = case how of - Disconnected -> "user_disconnected" - ClientDisconnected -> "user_client_disconnected" - comp = fromMaybe zero `liftM` - callSystemVerb' object systemVerb [Obj player] Str.empty - void $ runTask =<< newTask world' player comp + doDisconnected world' object player how + case how of + ClientDisconnected -> do + let comp = do + world <- getWorld + connName <- liftSTM connectionName + objectName <- getObjectName player + liftSTM $ writeLog world $ "CLIENT DISCONNECTED: " <> + Str.toText objectName <> " on " <> T.pack connName + return zero + void $ runTask =<< newTask world' player + (resetLimits True >> comp) + _ -> return () -runConnection :: TVar World -> Bool -> Connection -> IO () -runConnection world' printMessages conn = loop +doDisconnected :: TVar World -> ObjId -> ObjId -> Disconnect -> IO () +doDisconnected world' object player how = do + let systemVerb = case how of + Disconnected -> "user_disconnected" + ClientDisconnected -> "user_client_disconnected" + comp = do + liftVTx $ updateConnections world' $ M.delete player + fromMaybe zero <$> + callSystemVerb' object systemVerb [Obj player] Str.empty + void $ runTask =<< newTask world' player (resetLimits True >> comp) + +runConnection :: TVar World -> Connection -> IO () +runConnection world' conn = loop where loop = do - input <- atomically $ readTBMQueue (connectionInput conn) + (line, reader) <- atomically $ do + line <- readTBMQueue (connectionInput conn) + reader <- tryTakeTMVar (connectionReader conn) + return (line, reader) + case (reader, line) of + (Nothing, Just line) -> processLine' line >> loop + (Just (Wake wake), Just line) -> wake (Str line) >> loop + (Just (Wake wake), Nothing) -> wake (Err E_INVARG) + (Nothing, Nothing) -> return () + + processLine' :: StrT -> IO () + processLine' line = do options <- readTVarIO (connectionOptions conn) - let processLine' - | optionDisableOOB options = processLine options - | otherwise = processLineWithOOB options - case input of - Just (Line line) -> processLine' line >> loop - Just (Binary bytes) -> processBinary bytes >> loop - Nothing -> return () + if optionDisableOOB options + then processLine options line + else processLineWithOOB options line - processLineWithOOB :: ConnectionOptions -> Text -> IO () + processLineWithOOB :: ConnectionOptions -> StrT -> IO () processLineWithOOB options line - | outOfBandQuotePrefix `T.isPrefixOf` line = processLine options line' - | outOfBandPrefix `T.isPrefixOf` line = processOOB line - | otherwise = processLine options line - where line' = T.drop (T.length outOfBandQuotePrefix) line + | isOOBQuoted line' = processLine options (unquote line) + | isOOB line' = processOOB line + | otherwise = processLine options line + where line' = Str.toText line + unquote = Str.drop (T.length outOfBandQuotePrefix) - processOOB :: Text -> IO () + processOOB :: StrT -> IO () processOOB line = void $ runServerVerb' "do_out_of_band_command" (cmdWords line) line - processLine :: ConnectionOptions -> Text -> IO () + processLine :: ConnectionOptions -> StrT -> IO () processLine options line = do player <- readTVarIO (connectionPlayer conn) if player < 0 then processUnLoggedIn line else do - let cmd = parseCommand line + let cmd = parseCommand (Str.toText line) case M.lookup (Str.toText $ commandVerb cmd) (optionIntrinsicCommands options) of Just Intrinsic { intrinsicFunction = runIntrinsic } -> @@ -369,18 +418,15 @@ Just value | truthOf value -> return zero _ -> runCommand cmd - processBinary :: ByteString -> IO () - processBinary bytes = return () - - processUnLoggedIn :: Text -> IO () + processUnLoggedIn :: StrT -> IO () processUnLoggedIn line = do result <- runServerTask $ do - maxObject <- maxObject `liftM` getDatabase - player <- fromMaybe zero `liftM` + maxObject <- maxObject <$> getDatabase + player <- fromMaybe zero <$> callSystemVerb "do_login_command" (cmdWords line) line return $ fromList [Obj maxObject, player] case result of - Just (Lst v) -> case V.toList v of + Just (Lst v) -> case Lst.toList v of [Obj maxObject, Obj player] -> connectPlayer player maxObject _ -> return () _ -> return () @@ -389,76 +435,69 @@ connectPlayer player maxObject = do now <- getCurrentTime - maybeOldConn <- atomically $ do - writeTVar (connectionConnectedTime conn) (Just now) + oldPlayer <- atomically $ swapTVar (connectionPlayer conn) player - oldPlayer <- swapTVar (connectionPlayer conn) player + void $ runServerTask $ do + liftSTM $ writeTVar (connectionConnectedTime conn) (Just now) - world <- readTVar world' + playerName <- getObjectName player + connName <- liftSTM $ connectionName conn + + world <- getWorld let maybeOldConn = M.lookup player (connections world) case maybeOldConn of Just oldConn -> do - writeTVar (connectionPlayer oldConn) oldPlayer + liftSTM $ writeTVar (connectionPlayer oldConn) oldPlayer + printMessage oldConn redirectFromMsg + liftSTM $ closeConnection oldConn - let oldObject = connectionObject oldConn - newObject = connectionObject conn - when (oldObject /= newObject) $ void $ - tryPutTMVar (connectionDisconnect oldConn) ClientDisconnected - -- print' oldConn redirectFromMsg - closeConnection oldConn - Nothing -> return () + oldConnName <- liftSTM $ connectionName oldConn + liftSTM $ writeLog world $ "REDIRECTED: " <> + Str.toText playerName <> ", was " <> T.pack oldConnName <> + ", now " <> T.pack connName - writeTVar world' world { - connections = M.insert player conn $ - M.delete oldPlayer (connections world) } - return maybeOldConn + Nothing -> liftSTM $ writeLog world $ "CONNECTED: " <> + Str.toText playerName <> " on " <> T.pack connName - let (systemVerb, msg) - | player > maxObject = ("user_created", createMsg) - | isNothing maybeOldConn || - connectionObject (fromJust maybeOldConn) /= - connectionObject conn = ("user_connected", connectMsg) - | otherwise = ("user_reconnected", redirectToMsg) - print msg - runServerVerb systemVerb [Obj player] + liftVTx $ updateConnections world' $ + M.insert player conn . M.delete oldPlayer - callSystemVerb :: StrT -> [Value] -> Text -> MOO (Maybe Value) - callSystemVerb vname args argstr = - callSystemVerb' object vname args (Str.fromText argstr) - where object = connectionObject conn + let (verb, msg) + | player > maxObject = ("user_created", createMsg) + | isNothing maybeOldConn = ("user_connected", connectMsg) + | otherwise = ("user_reconnected", redirectToMsg) - runServerVerb :: StrT -> [Value] -> IO () - runServerVerb vname args = void $ runServerVerb' vname args T.empty + printMessage conn msg + callSystemVerb verb [Obj player] Str.empty - runServerVerb' :: StrT -> [Value] -> Text -> IO (Maybe Value) + return zero + + callSystemVerb :: StrT -> [Value] -> StrT -> MOO (Maybe Value) + callSystemVerb = callSystemVerb' (connectionObject conn) + + runServerVerb' :: StrT -> [Value] -> StrT -> IO (Maybe Value) runServerVerb' vname args argstr = runServerTask $ - fromMaybe zero `liftM` - callSystemVerb' object vname args (Str.fromText argstr) + fromMaybe zero <$> callSystemVerb' object vname args argstr where object = connectionObject conn runServerTask :: MOO Value -> IO (Maybe Value) runServerTask comp = do player <- readTVarIO (connectionPlayer conn) - runTask =<< newTask world' player comp - - print' :: Connection -> (ObjId -> MOO [Text]) -> IO () - print' conn msg - | printMessages = void $ runServerTask $ - printMessage conn msg >> return zero - | otherwise = return () - - print :: (ObjId -> MOO [Text]) -> IO () - print = print' conn + let run = runTask =<< newTask world' player (resetLimits True >> comp) + run `catch` \except -> do + atomically $ sendToConnection conn $ + T.pack $ "*** Runtime error: " <> show (except :: SomeException) + return Nothing - cmdWords :: Text -> [Value] - cmdWords = map Str . parseWords + cmdWords :: StrT -> [Value] + cmdWords = map Str . parseWords . Str.toText -- | Connection reading thread: deliver messages from the network to our input -- 'TBMQueue' until EOF, handling binary mode and the flush command, if any. connectionRead :: Connection -> Consumer ByteString IO () connectionRead conn = do - (outputLines, inputLines) <- lift $ spawn Unbounded - (outputMessages, inputMessages) <- lift $ spawn Unbounded + (outputLines, inputLines) <- lift $ spawn unbounded + (outputMessages, inputMessages) <- lift $ spawn unbounded lift $ forkIO $ runEffect $ fromInput inputLines >-> @@ -489,19 +528,17 @@ readLines = readLines' TL.empty where readLines' prev = await >>= yieldLines prev >>= readLines' - yieldLines :: Monad m => TL.Text -> Text -> - Pipe Text Text m TL.Text - yieldLines prev text = - let concatenate = TL.append prev . TL.fromStrict - (end, rest) = T.break (== '\n') text - line = TL.toStrict (concatenate end) - line' = if not (T.null line) && T.last line == '\r' - then T.init line else line - in if T.null rest - then return $ concatenate text - else do - yield line' - yieldLines TL.empty (T.tail rest) + yieldLines :: Monad m => TL.Text -> Text + -> Pipe Text Text m TL.Text + yieldLines prev text + | T.null rest = return (concatenate text) + | otherwise = yield line' >> + yieldLines TL.empty (T.tail rest) + where (end, rest) = T.break (== '\n') text + concatenate = TL.append prev . TL.fromStrict + line = TL.toStrict (concatenate end) + line' = if not (T.null line) && T.last line == '\r' + then T.init line else line sanitize :: Monad m => Pipe Text Text m () sanitize = for cat (yield . T.filter Str.validChar) @@ -512,17 +549,22 @@ deliverMessages :: Consumer ConnectionMessage IO () deliverMessages = forever $ do message <- await - case message of + lift $ case message of Line line -> do - options <- lift $ readTVarIO (connectionOptions conn) + options <- readTVarIO (connectionOptions conn) let flushCmd = optionFlushCommand options - lift $ if not (T.null flushCmd) && line == flushCmd + if not (T.null flushCmd) && line == flushCmd then flushQueue else enqueue message - Binary _ -> lift $ enqueue message + Binary _ -> enqueue message enqueue :: ConnectionMessage -> IO () - enqueue = atomically . writeTBMQueue (connectionInput conn) + enqueue = atomically . writeTBMQueue (connectionInput conn) . stringize + stringize :: ConnectionMessage -> StrT + stringize message = case message of + Line text -> Str.fromText text + Binary bytes -> Str.fromBinary bytes + flushQueue :: IO () flushQueue = atomically $ flushInput True conn @@ -530,35 +572,16 @@ -- the network until the queue is closed, which is our signal to close the -- connection. connectionWrite :: Connection -> Producer ByteString IO () -connectionWrite conn = do - (outputBinary, inputBinary, sealBinary) <- lift $ spawn' Unbounded - (outputLines, inputLines, sealLines) <- lift $ spawn' Unbounded - - lift $ forkIO $ do - runEffect $ fromInput inputLines >-> writeLines >-> writeUtf8 >-> - toOutput outputBinary - atomically sealBinary - - lift $ forkIO $ processQueue outputLines outputBinary sealLines - - fromInput inputBinary - - where writeLines :: Monad m => Pipe Text Text m () - writeLines = forever $ await >>= yield >> yield "\r\n" - - writeUtf8 :: Monad m => Pipe Text ByteString m () - writeUtf8 = for cat (yield . encodeUtf8) +connectionWrite conn = loop + where loop = do + message <- lift $ atomically $ readTBMQueue (connectionOutput conn) + case message of + Just (Line text) -> yield (encodeUtf8 text) >> yield crlf >> loop + Just (Binary bytes) -> yield bytes >> loop + Nothing -> return () - processQueue :: Output Text -> Output ByteString -> STM () -> IO () - processQueue outputLines outputBinary sealLines = loop - where loop = do - message <- atomically $ readTBMQueue (connectionOutput conn) - case message of - Just (Line text) -> - atomically (send outputLines text) >> loop - Just (Binary bytes) -> - atomically (send outputBinary bytes) >> loop - Nothing -> atomically sealLines + crlf :: ByteString + crlf = encodeUtf8 "\r\n" -- | The first un-logged-in connection ID. Avoid conflicts with #-1 -- ($nothing), #-2 ($ambiguous_match), and #-3 ($failed_match). @@ -599,15 +622,58 @@ _ -> return True sendToConnection :: Connection -> Text -> STM () -sendToConnection conn line = void $ enqueueOutput False conn (Line line) +sendToConnection conn = void . enqueueOutput False conn . Line -printMessage :: Connection -> (ObjId -> MOO [Text]) -> MOO () -printMessage conn msg = serverMessage conn msg >>= liftSTM +printMessage :: Connection -> ServerMessage -> MOO () +printMessage conn msg + | connectionPrintMessages conn = liftSTM =<< serverMessage conn msg + | otherwise = return () -serverMessage :: Connection -> (ObjId -> MOO [Text]) -> MOO (STM ()) +serverMessage :: Connection -> ServerMessage -> MOO (STM ()) serverMessage conn msg = - mapM_ (sendToConnection conn) `liftM` msg (connectionObject conn) + mapM_ (sendToConnection conn) <$> msg (connectionObject conn) +readFromConnection :: ObjId -> Bool -> MOO Value +readFromConnection oid nonBlocking = withConnection oid $ \conn -> do + input <- liftSTM $ tryReadTBMQueue (connectionInput conn) + case input of + Just (Just line) -> return (Str line) + Just Nothing + | nonBlocking -> return zero + | otherwise -> suspend conn + Nothing -> raise E_INVARG + + where suspend :: Connection -> MOO Value + suspend conn = do + checkQueuedTaskLimit + + resumeTVar <- liftSTM newEmptyTMVar + let wake value = do + now <- getCurrentTime + atomically $ putTMVar resumeTVar (now, value) + + success <- liftSTM $ tryPutTMVar (connectionReader conn) (Wake wake) + unless success $ raise E_INVARG + + task <- asks task + state <- get + putTask task { taskStatus = Reading + , taskState = state { + startTime = posixSecondsToUTCTime (-1) } + } + + callCC $ interrupt . Suspend . Resume + (now, value) <- liftSTM $ takeTMVar resumeTVar + + putTask task + + resetLimits False + modify $ \state -> state { startTime = now } + + case value of + Err error -> raise error + _ -> return value + -- | Send data to a connection, flushing if necessary. notify :: ObjId -> StrT -> MOO Bool notify = notify' False @@ -618,7 +684,7 @@ withMaybeConnection who . maybe (return True) $ \conn -> do options <- liftSTM $ readTVar (connectionOptions conn) message <- if optionBinaryMode options - then Binary `fmap` binaryString what + then Binary <$> binaryString what else return (Line $ Str.toText what) liftSTM $ enqueueOutput noFlush conn message @@ -628,41 +694,35 @@ bufferedOutputLength :: Maybe Connection -> STM Int bufferedOutputLength Nothing = return maxQueueLength bufferedOutputLength (Just conn) = - (maxQueueLength -) `fmap` freeSlotsTBMQueue (connectionOutput conn) + (maxQueueLength -) <$> freeSlotsTBMQueue (connectionOutput conn) -- | Force a line of input for a connection. forceInput :: Bool -> ObjId -> StrT -> MOO () forceInput atFront oid line = withConnection oid $ \conn -> do - let queue = connectionInput conn - message = Line (Str.toText line) + let queue = connectionInput conn success <- liftSTM $ - if atFront then unGetTBMQueue queue message >> return True - else fromMaybe True `fmap` tryWriteTBMQueue queue message + if atFront then unGetTBMQueue queue line >> return True + else fromMaybe True <$> tryWriteTBMQueue queue line unless success $ raise E_QUOTA -- | Flush a connection's input queue, optionally showing what was flushed. flushInput :: Bool -> Connection -> STM () flushInput showMessages conn = do let queue = connectionInput conn - notify = when showMessages . void . enqueueOutput False conn . Line + notify = when showMessages . sendToConnection conn empty <- isEmptyTBMQueue queue if empty then notify ">> No pending input to flush..." else do notify ">> Flushing the following pending input:" flushQueue queue notify notify ">> (Done flushing)" - where flushQueue queue notify = loop - where loop = do - item <- join `fmap` tryReadTBMQueue queue - case item of - Just (Line line) -> do - notify $ ">> " <> line - loop - Just (Binary _) -> do - notify ">> * [binary data]" - loop - Nothing -> return () + where flushQueue queue notify = loop + where loop = do + item <- join <$> tryReadTBMQueue queue + case item of + Just line -> notify (">> " <> Str.toText line) >> loop + Nothing -> return () -- | Initiate the closing of a connection by closing its output queue. closeConnection :: Connection -> STM () @@ -677,12 +737,23 @@ bootPlayer' :: Bool -> ObjId -> MOO () bootPlayer' recycled oid = withMaybeConnection oid . maybe (return ()) $ \conn -> do - printMessage conn $ if recycled then recycleMsg else bootMsg + connName <- liftSTM $ connectionName conn + writeLog <- writeLog <$> getWorld + if recycled then do + liftSTM $ writeLog $ "RECYCLED: #" <> T.pack (show oid) <> + " on " <> T.pack connName + printMessage conn recycleMsg + else do + objectName <- getObjectName oid + liftSTM $ writeLog $ "DISCONNECTED: " <> Str.toText objectName <> + " on " <> T.pack connName + printMessage conn bootMsg + liftSTM $ closeConnection conn - modifyWorld $ \world -> world { connections = - M.delete oid (connections world) } - return () + world' <- getWorld' + liftVTx $ updateConnections world' $ M.delete oid + withConnectionOptions :: ObjId -> (ConnectionOptions -> MOO a) -> MOO a withConnectionOptions oid f = withConnection oid $ f <=< liftSTM . readTVar . connectionOptions @@ -710,7 +781,9 @@ let optionValue option = optionGet option options in return $ M.map optionValue allConnectionOptions -msgFor :: Id -> [Text] -> ObjId -> MOO [Text] +type ServerMessage = ObjId -> MOO [Text] + +msgFor :: Id -> [Text] -> ServerMessage msgFor msg def oid | oid == systemObject = systemMessage | otherwise = getServerMessage oid msg systemMessage diff --git a/src/MOO/Connection.hs-boot b/src/MOO/Connection.hs-boot --- a/src/MOO/Connection.hs-boot +++ b/src/MOO/Connection.hs-boot @@ -2,6 +2,7 @@ module MOO.Connection ( Connection + , connectionObject , firstConnectionId , sendToConnection , notify @@ -16,6 +17,7 @@ data Connection +connectionObject :: Connection -> ObjId firstConnectionId :: ObjId sendToConnection :: Connection -> Text -> STM () notify :: ObjId -> StrT -> MOO Bool diff --git a/src/MOO/Database.hs b/src/MOO/Database.hs --- a/src/MOO/Database.hs +++ b/src/MOO/Database.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module MOO.Database ( Database + , Connected , ServerOptions(..) + , Persistence(..) , serverOptions , initDatabase , dbObjectRef , dbObject , maxObject , resetMaxObject + , renumber , setObjects , addObject , deleteObject @@ -20,87 +23,143 @@ , getServerOption' , loadServerOptions , getServerMessage + , loadPersistence + , syncPersistence + , saveDatabase ) where -import Control.Concurrent.STM (STM, TVar, newTVarIO, newTVar, - readTVar, writeTVar) -import Control.Monad (forM, liftM) -import Data.Monoid ((<>)) -import Data.Vector (Vector) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (forM, forM_, when, (>=>)) import Data.IntSet (IntSet) -import Data.Set (Set) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Time (getCurrentTime) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import Data.Version (showVersion) +import Database.VCache (VCache, VSpace, VTx, VCacheable(put, get), vcache_space, + PVar, loadRootPVarIO, newPVarsIO, newPVarIO, newPVar, + readPVarIO, readPVar, writePVar, runVTx, markDurable) +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS import qualified Data.IntSet as IS -import qualified Data.Map as M -import qualified Data.Set as S import qualified Data.Vector as V import {-# SOURCE #-} MOO.Builtins (builtinFunctions) import MOO.Object import MOO.Task import MOO.Types +import MOO.Util +import MOO.Version +import qualified MOO.List as Lst import qualified MOO.String as Str data Database = Database { - objects :: Vector (TVar (Maybe Object)) + objects :: Vector (PVar (Maybe Object)) , players :: IntSet , serverOptions :: ServerOptions -} + } deriving Typeable +instance VCacheable Database where + put db = do + put $ VVector (objects db) + put $ VIntSet (players db) + + get = do + objects <- unVVector <$> get + players <- unVIntSet <$> get + return initDatabase { objects = objects, players = players } + initDatabase = Database { objects = V.empty , players = IS.empty , serverOptions = undefined -} + } -dbObjectRef :: ObjId -> Database -> Maybe (TVar (Maybe Object)) -dbObjectRef oid db - | oid < 0 || oid >= V.length objs = Nothing - | otherwise = Just (objs V.! oid) - where objs = objects db +dbObjectRef :: ObjId -> Database -> Maybe (PVar (Maybe Object)) +dbObjectRef oid = (V.!? oid) . objects -dbObject :: ObjId -> Database -> STM (Maybe Object) -dbObject oid db = maybe (return Nothing) readTVar $ dbObjectRef oid db +dbObject :: ObjId -> Database -> VTx (Maybe Object) +dbObject oid = maybe (return Nothing) readPVar . dbObjectRef oid maxObject :: Database -> ObjId -maxObject db = V.length (objects db) - 1 +maxObject = pred . V.length . objects -resetMaxObject :: Database -> STM Database +resetMaxObject :: Database -> VTx Database resetMaxObject db = do newMaxObject <- findLastValid (maxObject db) - return db { objects = V.take (newMaxObject + 1) $ objects db } - where findLastValid oid + return db { objects = V.take (succ newMaxObject) $ objects db } + + where findLastValid :: ObjId -> VTx ObjId + findLastValid oid | oid >= 0 = dbObject oid db >>= - maybe (findLastValid $ oid - 1) (return . const oid) + maybe (findLastValid $ pred oid) (return . const oid) | otherwise = return nothing -setObjects :: [Maybe Object] -> Database -> IO Database -setObjects objs db = do - tvarObjs <- mapM newTVarIO objs - return db { objects = V.fromList tvarObjs } +-- | Renumber an object in the database to be the least nonnegative object +-- number not currently in use pursuant to the renumber() built-in function. +renumber :: ObjId -> Database -> VTx (ObjId, Database) +renumber old db = do + maybeNew <- findLeastUnused 0 + case maybeNew of + Nothing -> return (old, db) + Just new -> do + -- renumber database slot references + let Just oldRef = dbObjectRef old db + Just newRef = dbObjectRef new db + Just obj <- readPVar oldRef + writePVar oldRef Nothing + writePVar newRef (Just obj) -addObject :: Object -> Database -> STM Database + -- ask the object to fix up parent/children and location/contents + renumberObject obj old new db + + -- fix up ownerships throughout entire database + forM_ [0..maxObject db] $ \oid -> case dbObjectRef oid db of + Just ref -> do + maybeObj <- readPVar ref + case maybeObj of + Just obj -> do + maybeNew <- renumberOwnership old new obj + when (isJust maybeNew) $ writePVar ref maybeNew + Nothing -> return () + Nothing -> return () + + -- renumber player references (if any) + let db' = setPlayer (objectIsPlayer obj) new $ setPlayer False old db + + return (new, db') + + where findLeastUnused :: ObjId -> VTx (Maybe ObjId) + findLeastUnused new + | new < old = dbObject new db >>= maybe (return $ Just new) + (const $ findLeastUnused $ succ new) + | otherwise = return Nothing + +setObjects :: VSpace -> [Maybe Object] -> Database -> IO Database +setObjects vspace objs db = do + refs <- newPVarsIO vspace objs + return db { objects = V.fromList refs } + +addObject :: Object -> Database -> VTx Database addObject obj db = do - objTVar <- newTVar (Just obj) - return db { objects = V.snoc (objects db) objTVar } + ref <- newPVar (Just obj) + return db { objects = V.snoc (objects db) ref } -deleteObject :: ObjId -> Database -> STM () +deleteObject :: ObjId -> Database -> VTx () deleteObject oid db = case dbObjectRef oid db of - Just objTVar -> writeTVar objTVar Nothing - Nothing -> return () + Just ref -> writePVar ref Nothing + Nothing -> return () -modifyObject :: ObjId -> Database -> (Object -> STM Object) -> STM () +modifyObject :: ObjId -> Database -> (Object -> VTx Object) -> VTx () modifyObject oid db f = case dbObjectRef oid db of - Nothing -> return () - Just objTVar -> do - maybeObject <- readTVar objTVar - case maybeObject of - Nothing -> return () - Just obj -> writeTVar objTVar . Just =<< f obj + Just ref -> readPVar ref >>= maybe (return ()) (f >=> writePVar ref . Just) + Nothing -> return () {- isPlayer :: ObjId -> Database -> Bool @@ -111,14 +170,15 @@ allPlayers = IS.toList . players setPlayer :: Bool -> ObjId -> Database -> Database -setPlayer yesno oid db = db { players = change oid (players db) } - where change = if yesno then IS.insert else IS.delete +setPlayer isPlayer oid db = db { players = change oid (players db) } + where change | isPlayer = IS.insert + | otherwise = IS.delete data ServerOptions = Options { - bgSeconds :: IntT + bgSeconds :: Int -- ^ The number of seconds allotted to background tasks - , bgTicks :: IntT + , bgTicks :: Int -- ^ The number of ticks allotted to background tasks , connectTimeout :: IntT @@ -128,16 +188,16 @@ , defaultFlushCommand :: Text -- ^ The initial setting of each new connection’s flush command - , fgSeconds :: IntT + , fgSeconds :: Int -- ^ The number of seconds allotted to foreground tasks - , fgTicks :: IntT + , fgTicks :: Int -- ^ The number of ticks allotted to foreground tasks - , maxStackDepth :: IntT + , maxStackDepth :: Int -- ^ The maximum number of levels of nested verb calls - , queuedTaskLimit :: Maybe IntT + , queuedTaskLimit :: Maybe Int -- ^ The default maximum number of tasks a player can have , nameLookupTimeout :: IntT @@ -148,10 +208,10 @@ -- ^ The maximum number of seconds to wait for an outbound network -- connection to successfully open - , protectProperty :: Set Id + , protectProperty :: Id -> Bool -- ^ Restrict reading of built-in property to wizards - , protectFunction :: Set Id + , protectFunction :: Id -> Bool -- ^ Restrict use of built-in function to wizards , supportNumericVerbnameStrings :: Bool @@ -171,10 +231,11 @@ Just (Obj oid) -> readProperty oid . fromId _ -> const (return Nothing) -getProtected :: (Id -> MOO (Maybe Value)) -> [Id] -> MOO (Set Id) +getProtected :: (Id -> MOO (Maybe Value)) -> [Id] -> MOO (Id -> Bool) getProtected getOption ids = do - maybes <- forM ids $ liftM (fmap truthOf) . getOption . ("protect_" <>) - return $ S.fromList [ id | (id, Just True) <- zip ids maybes ] + maybes <- forM ids $ fmap (fmap truthOf) . getOption . ("protect_" <>) + let protectedSet = HS.fromList [ id | (id, Just True) <- zip ids maybes ] + return (`HS.member` protectedSet) loadServerOptions :: MOO () loadServerOptions = do @@ -197,27 +258,27 @@ supportNumericVerbnameStrings <- option "support_numeric_verbname_strings" protectProperty <- getProtected option builtinProperties - protectFunction <- getProtected option (M.keys builtinFunctions) + protectFunction <- getProtected option (HM.keys builtinFunctions) let options = Options { bgSeconds = case bgSeconds of - Just (Int secs) | secs >= 1 -> secs - _ -> 3 + Just (Int secs) | secs >= 1 -> fromIntegral secs + _ -> defaultBgSeconds , bgTicks = case bgTicks of - Just (Int ticks) | ticks >= 100 -> ticks - _ -> 15000 + Just (Int ticks) | ticks >= 100 -> fromIntegral ticks + _ -> defaultBgTicks , fgSeconds = case fgSeconds of - Just (Int secs) | secs >= 1 -> secs - _ -> 5 + Just (Int secs) | secs >= 1 -> fromIntegral secs + _ -> defaultFgSeconds , fgTicks = case fgTicks of - Just (Int ticks) | ticks >= 100 -> ticks - _ -> 30000 + Just (Int ticks) | ticks >= 100 -> fromIntegral ticks + _ -> defaultFgTicks , maxStackDepth = case maxStackDepth of - Just (Int depth) | depth > 50 -> depth - _ -> 50 + Just (Int depth) | depth > 50 -> fromIntegral depth + _ -> defaultMaxStackDepth , queuedTaskLimit = case queuedTaskLimit of - Just (Int limit) | limit >= 0 -> Just limit + Just (Int limit) | limit >= 0 -> Just (fromIntegral limit) _ -> Nothing , connectTimeout = case connectTimeout of @@ -235,9 +296,8 @@ Just _ -> "" Nothing -> ".flush" - , supportNumericVerbnameStrings = case supportNumericVerbnameStrings of - Just v -> truthOf v - _ -> False + , supportNumericVerbnameStrings = + maybe False truthOf supportNumericVerbnameStrings , protectProperty = protectProperty , protectFunction = protectFunction @@ -251,11 +311,77 @@ maybeValue <- getServerOption' oid msg case maybeValue of Just (Str s) -> return [Str.toText s] - Just (Lst v) -> maybe (return []) return $ strings (V.toList v) + Just (Lst v) -> maybe (return []) return $ strings (Lst.toList v) Just _ -> return [] Nothing -> def + where strings :: [Value] -> Maybe [Text] strings (v:vs) = case v of - Str s -> (Str.toText s :) `fmap` strings vs + Str s -> (Str.toText s :) <$> strings vs _ -> Nothing strings [] = Just [] + +type Connected = [(ObjId, ObjId)] + +data Persistence = Persistence { + persistenceVSpace :: VSpace + , persistenceVersion :: PVar VVersion + , persistenceDatabase :: PVar Database + , persistenceConnected :: PVar Connected + , persistenceCheckpoint :: PVar VUTCTime + } deriving Typeable + +instance VCacheable Persistence where + put p = do + put $ persistenceVSpace p + put $ persistenceVersion p + put $ persistenceDatabase p + put $ persistenceConnected p + put $ persistenceCheckpoint p + + get = Persistence <$> get <*> get <*> get <*> get <*> get + +rootPVar :: VCache -> IO (PVar (Maybe Persistence)) +rootPVar vcache = loadRootPVarIO vcache "EtaMOO database" Nothing + +saveDatabase :: VCache -> (Database, Connected) -> IO () +saveDatabase vcache (db, connected) = do + let vspace = vcache_space vcache + + versionPVar <- newPVarIO vspace (VVersion version) + databasePVar <- newPVarIO vspace db + connectedPVar <- newPVarIO vspace connected + checkpointPVar <- newPVarIO vspace . VUTCTime =<< getCurrentTime + + let p = Persistence { + persistenceVSpace = vspace + , persistenceVersion = versionPVar + , persistenceDatabase = databasePVar + , persistenceConnected = connectedPVar + , persistenceCheckpoint = checkpointPVar + } + + root <- rootPVar vcache + runVTx vspace $ do + writePVar root (Just p) + markDurable + +loadPersistence :: VCache -> IO Persistence +loadPersistence vcache = rootPVar vcache >>= readPVarIO >>= + maybe (error "invalid database") checkVersion + + where checkVersion :: Persistence -> IO Persistence + checkVersion p = do + dbVersion <- unVVersion <$> readPVarIO (persistenceVersion p) + when (dbVersion /= version) $ error $ + "database version " ++ showVersion dbVersion ++ + " does not match current version " ++ showVersion version + return p + +syncPersistence :: Persistence -> IO () +syncPersistence p = do + now <- getCurrentTime + runVTx (persistenceVSpace p) $ do + writePVar (persistenceVersion p) (VVersion version) + writePVar (persistenceCheckpoint p) (VUTCTime now) + markDurable diff --git a/src/MOO/Database.hs-boot b/src/MOO/Database.hs-boot --- a/src/MOO/Database.hs-boot +++ b/src/MOO/Database.hs-boot @@ -1,15 +1,28 @@ -- -*- Haskell -*- module MOO.Database ( Database + , ServerOptions + , Persistence , serverOptions - , maxStackDepth , getServerOption' + , initDatabase , dbObject , modifyObject , loadServerOptions + , fgSeconds + , bgSeconds + , fgTicks + , bgTicks + , maxStackDepth + , queuedTaskLimit + , protectProperty + , supportNumericVerbnameStrings + , persistenceVSpace + , persistenceDatabase + , persistenceConnected ) where -import Control.Concurrent.STM (STM) +import Database.VCache (VSpace, PVar, VTx) import {-# SOURCE #-} MOO.Object (Object) import {-# SOURCE #-} MOO.Task (MOO) @@ -17,13 +30,33 @@ data Database data ServerOptions +data Persistence -serverOptions :: Database -> ServerOptions -maxStackDepth :: ServerOptions -> IntT +type Connected = [(ObjId, ObjId)] +serverOptions :: Database -> ServerOptions getServerOption' :: ObjId -> Id -> MOO (Maybe Value) -dbObject :: ObjId -> Database -> STM (Maybe Object) -modifyObject :: ObjId -> Database -> (Object -> STM Object) -> STM () +initDatabase :: Database +dbObject :: ObjId -> Database -> VTx (Maybe Object) +modifyObject :: ObjId -> Database -> (Object -> VTx Object) -> VTx () + loadServerOptions :: MOO () + +fgSeconds :: ServerOptions -> Int +bgSeconds :: ServerOptions -> Int + +fgTicks :: ServerOptions -> Int +bgTicks :: ServerOptions -> Int + +maxStackDepth :: ServerOptions -> Int +queuedTaskLimit :: ServerOptions -> Maybe Int + +protectProperty :: ServerOptions -> Id -> Bool + +supportNumericVerbnameStrings :: ServerOptions -> Bool + +persistenceVSpace :: Persistence -> VSpace +persistenceDatabase :: Persistence -> PVar Database +persistenceConnected :: Persistence -> PVar Connected diff --git a/src/MOO/Database/LambdaMOO.hs b/src/MOO/Database/LambdaMOO.hs --- a/src/MOO/Database/LambdaMOO.hs +++ b/src/MOO/Database/LambdaMOO.hs @@ -3,8 +3,8 @@ module MOO.Database.LambdaMOO ( loadLMDatabase, saveLMDatabase ) where -import Control.Concurrent.STM (STM, atomically, readTVar, writeTVar) -import Control.Monad (unless, when, forM, forM_, join, liftM) +import Control.Applicative ((<$>)) +import Control.Monad (unless, when, forM, forM_, join) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, runReaderT, local, asks, ask) import Control.Monad.Trans.Class (lift) @@ -14,35 +14,37 @@ import Data.IntSet (IntSet) import Data.List (sort, foldl', elemIndex) import Data.Maybe (catMaybes, listToMaybe) +import Data.Monoid ((<>)) import Data.Text.Lazy (Text) import Data.Text.Lazy.Builder (Builder, toLazyText, fromLazyText, fromString, singleton) import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) import Data.Word (Word) -import System.IO (Handle, hFlush, stdout, withFile, IOMode(..), - hSetBuffering, BufferMode(..), - hSetNewlineMode, NewlineMode(..), Newline(..), - hSetEncoding, utf8) +import Database.VCache (VSpace, VTx, runVTx, readPVar, writePVar) +import System.IO (Handle, withFile, IOMode(ReadMode, WriteMode), + hSetBuffering, BufferMode(BlockBuffering), + hSetNewlineMode, NewlineMode(NewlineMode, inputNL, outputNL), + Newline(CRLF, LF), hSetEncoding, utf8) import Text.Parsec (ParseError, ParsecT, runParserT, string, count, getState, putState, many1, oneOf, manyTill, anyToken, - digit, char, option, try, lookAhead, (<|>), ()) -import Text.Parsec.Text.Lazy () + between, eof, digit, char, option, try, lookAhead, + (<|>), ()) import qualified Data.HashMap.Strict as HM import qualified Data.IntSet as IS import qualified Data.Text as T import qualified Data.Text.Lazy.IO as TL -import qualified Data.Vector as V +import MOO.AST import MOO.Database import MOO.Object -import MOO.Verb -import MOO.Types import MOO.Parser +import MOO.Types import MOO.Unparser -import MOO.Compiler +import MOO.Verb +import qualified MOO.List as Lst import qualified MOO.String as Str {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} @@ -54,68 +56,79 @@ hSetEncoding handle utf8 io handle -loadLMDatabase :: FilePath -> IO (Either ParseError Database) -loadLMDatabase dbFile = withDBFile dbFile ReadMode $ \handle -> do - contents <- TL.hGetContents handle - runReaderT (runParserT lmDatabase initDatabase dbFile contents) initDBEnv +loadLMDatabase :: VSpace -> FilePath -> (T.Text -> IO ()) -> + IO (Either ParseError (Database, Connected)) +loadLMDatabase vspace dbFile writeLog = + withDBFile dbFile ReadMode $ \handle -> do + writeLog $ "IMPORTING: " <> T.pack dbFile + contents <- TL.hGetContents handle + runReaderT (runParserT lmDatabase initDatabase dbFile contents) + (initDBEnv writeLog vspace) type DBParser = ParsecT Text Database (ReaderT DBEnv IO) data DBEnv = DBEnv { - input_version :: Word + logger :: T.Text -> IO () + , input_version :: Word , users :: IntSet + , vspace :: VSpace } -initDBEnv = DBEnv { - input_version = undefined +initDBEnv logger vspace = DBEnv { + logger = logger + , input_version = undefined , users = IS.empty + , vspace = vspace } +writeLog :: String -> DBParser () +writeLog line = asks logger >>= \writeLog -> + liftIO (writeLog $ "LOADING: " <> T.pack line) + header_format_string = ("** LambdaMOO Database, Format Version ", " **") -lmDatabase :: DBParser Database +lmDatabase :: DBParser (Database, Connected) lmDatabase = do let (before, after) = header_format_string dbVersion <- line $ between (string before) (string after) unsignedInt - liftIO $ putStrLn $ "LambdaMOO database (version " ++ show dbVersion ++ ")" + writeLog $ "LambdaMOO database (version " ++ show dbVersion ++ ")" unless (dbVersion < num_db_versions) $ fail $ "Unsupported database format (version " ++ show dbVersion ++ ")" - local (\r -> r { input_version = dbVersion }) $ do + connected <- local (\r -> r { input_version = dbVersion }) $ do nobjs <- line signedInt nprogs <- line signedInt - dummy <- line signedInt + _dummy <- line signedInt nusers <- line signedInt - liftIO $ putStrLn $ show nobjs ++ " objects, " + writeLog $ show nobjs ++ " objects, " ++ show nprogs ++ " programs, " ++ show nusers ++ " users" users <- count nusers read_objid installUsers users - liftIO $ putStrLn $ "Players: " ++ + writeLog $ "Players: " ++ T.unpack (toLiteral $ objectList $ sort users) local (\r -> r { users = IS.fromList users }) $ do - liftIO $ putStrLn "Reading objects..." + writeLog $ "Reading " <> show nobjs <> " objects..." installObjects =<< count nobjs read_object - liftIO $ putStrLn "Reading verb programs..." + writeLog $ "Reading " <> show nprogs <> " MOO verb programs..." mapM_ installProgram =<< count nprogs dbProgram - liftIO $ putStrLn "Reading forked and suspended tasks..." + writeLog "Reading forked and suspended tasks..." read_task_queue - liftIO $ putStrLn "Reading list of formerly active connections..." + writeLog "Reading list of formerly active connections..." read_active_connections eof - liftIO $ putStrLn "Database loaded!" - getState + getState >>= \db -> return (db, connected) installUsers :: [ObjId] -> DBParser () installUsers users = do @@ -166,9 +179,11 @@ -- Check sequential object ordering mapM_ checkObjId (zip [0..] dbObjs) - objs <- liftIO (mapM installPropsAndVerbs preObjs) >>= setPlayerFlags - getState >>= liftIO . setObjects objs >>= putState + vspace <- asks vspace + objs <- liftIO (mapM (installPropsAndVerbs vspace) preObjs) >>= setPlayerFlags + getState >>= liftIO . setObjects vspace objs >>= putState + where dbArray = listArray (0, length dbObjs - 1) $ map valid dbObjs preObjs = map (objectForDBObject dbArray) dbObjs @@ -177,14 +192,16 @@ fail $ "Unexpected object #" ++ show (oid dbObj) ++ " (expecting #" ++ show objId ++ ")" - installPropsAndVerbs :: (ObjId, Maybe Object) -> IO (Maybe Object) - installPropsAndVerbs (_ , Nothing) = return Nothing - installPropsAndVerbs (oid, Just obj) = + installPropsAndVerbs :: VSpace -> (ObjId, Maybe Object) -> + IO (Maybe Object) + installPropsAndVerbs _ (_ , Nothing) = return Nothing + installPropsAndVerbs vspace (oid, Just obj) = let Just def = dbArray ! oid propvals = objPropvals def verbdefs = objVerbdefs def - in fmap Just $ setProperties (mkProperties False oid propvals) obj >>= - setVerbs (map mkVerb verbdefs) + in fmap Just $ + setProperties vspace (mkProperties False oid propvals) obj >>= + setVerbs vspace (map mkVerb verbdefs) mkProperties :: Bool -> ObjId -> [PropVal] -> [Property] mkProperties _ _ [] = [] @@ -227,9 +244,12 @@ (vbPerms def `shiftR` iobjShift) .&. objMask } + setPlayerFlags :: [Maybe Object] -> DBParser [Maybe Object] setPlayerFlags objs = do players <- asks users return $ map (setPlayerFlag players) $ zip [0..] objs + + setPlayerFlag :: IntSet -> (ObjId, Maybe Object) -> Maybe Object setPlayerFlag players (oid, Just obj) = Just $ obj { objectIsPlayer = oid `IS.member` players } setPlayerFlag _ _ = Nothing @@ -245,7 +265,7 @@ objectForDBObject :: Array ObjId (Maybe ObjectDef) -> DBObject -> (ObjId, Maybe Object) -objectForDBObject dbArray dbObj = (oid dbObj, fmap mkObject $ valid dbObj) +objectForDBObject dbArray dbObj = (oid dbObj, mkObject <$> valid dbObj) where mkObject def = initObject { objectParent = maybeObject (objParent def) , objectChildren = IS.fromList $ @@ -272,34 +292,32 @@ installProgram :: (Int, Int, Program) -> DBParser () installProgram (oid, vnum, program) = do + vspace <- asks vspace db <- getState - maybeObj <- liftIO $ atomically $ dbObject oid db + maybeObj <- liftIO $ runVTx vspace $ dbObject oid db case maybeObj of Nothing -> fail $ doesNotExist "Object" - Just obj -> case lookupVerbRef obj (Int $ 1 + fromIntegral vnum) of + Just obj -> case lookupVerbRef False obj (Int $ 1 + fromIntegral vnum) of Nothing -> fail $ doesNotExist "Verb" - Just (_, verbTVar) -> liftIO $ atomically $ do - verb <- readTVar verbTVar - writeTVar verbTVar verb { - verbProgram = program - , verbCode = compile program - } + Just (_, verbPVar) -> liftIO $ runVTx vspace $ do + verb <- readPVar verbPVar + writePVar verbPVar verb { verbProgram = program } where doesNotExist what = what ++ " for program " ++ desc ++ " does not exist" desc = "#" ++ show oid ++ ":" ++ show vnum integer :: DBParser Integer -integer = signed (read `fmap` many1 digit) +integer = signed (read <$> many1 digit) unsignedInt :: DBParser Word -unsignedInt = read `fmap` many1 digit +unsignedInt = read <$> many1 digit signedInt :: DBParser Int -signedInt = signed (read `fmap` many1 digit) +signedInt = signed (read <$> many1 digit) signed :: (Num a) => DBParser a -> DBParser a signed parser = negative <|> parser - where negative = char '-' >> negate `fmap` parser + where negative = char '-' >> negate <$> parser line :: DBParser a -> DBParser a line parser = do @@ -308,10 +326,10 @@ return x read_num :: DBParser IntT -read_num = line (fmap fromInteger integer) "num" +read_num = line (fromInteger <$> integer) "num" read_objid :: DBParser ObjId -read_objid = line (fmap fromInteger integer) "objid" +read_objid = line (fromInteger <$> integer) "objid" read_float :: DBParser FltT read_float = line (fmap read $ many1 $ oneOf "-0123456789.eE+") "float" @@ -328,7 +346,7 @@ objectDef <- if recycled then return Nothing else do name <- read_string - liftIO $ putStrLn $ " #" ++ show oid ++ " (" ++ name ++ ")" + -- liftIO $ putStrLn $ " #" ++ show oid ++ " (" ++ name ++ ")" read_string -- old handles string flags <- read_num @@ -401,19 +419,19 @@ data LMVar = LMClear | LMNone | LMStr String - | LMObj IntT - | LMErr IntT + | LMObj ObjT + | LMErr Int | LMInt IntT - | LMCatch IntT - | LMFinally IntT + | LMCatch Int + | LMFinally Int | LMFloat FltT | LMList [LMVar] valueFromVar :: LMVar -> Either LMVar (Maybe Value) valueFromVar LMClear = Right Nothing valueFromVar (LMStr str) = Right $ Just (Str $ Str.fromString str) -valueFromVar (LMObj obj) = Right $ Just (Obj $ fromIntegral obj) -valueFromVar (LMErr err) = Right $ Just (Err $ toEnum $ fromIntegral err) +valueFromVar (LMObj obj) = Right $ Just (Obj obj) +valueFromVar (LMErr err) = Right $ Just (Err $ toEnum err) valueFromVar (LMInt int) = Right $ Just (Int int) valueFromVar (LMFloat flt) = Right $ Just (Flt flt) valueFromVar (LMList list) = do @@ -436,16 +454,16 @@ cases l | l == type_clear = return LMClear | l == type_none = return LMNone - | l == _type_str = fmap LMStr read_string - | l == type_obj = fmap LMObj read_num - | l == type_err = fmap LMErr read_num - | l == type_int = fmap LMInt read_num - | l == type_catch = fmap LMCatch read_num - | l == type_finally = fmap LMFinally read_num - | l == _type_float = fmap LMFloat read_float - | l == _type_list = - do l <- read_num - fmap LMList $ count (fromIntegral l) read_var + | l == _type_str = LMStr <$> read_string + | l == type_obj = LMObj . fromIntegral <$> read_num + | l == type_err = LMErr . fromIntegral <$> read_num + | l == type_int = LMInt <$> read_num + | l == type_catch = LMCatch . fromIntegral <$> read_num + | l == type_finally = LMFinally . fromIntegral <$> read_num + | l == _type_float = LMFloat <$> read_float + | l == _type_list = do + l <- read_num + LMList <$> count (fromIntegral l) read_var cases l = fail $ "Unknown type (" ++ show l ++ ")" @@ -459,7 +477,7 @@ let verbdesc = "#" ++ show oid ++ ":" ++ show vnum - liftIO $ putStr (" " ++ verbdesc ++ " \r") >> hFlush stdout + -- liftIO $ putStr (" " ++ verbdesc ++ " \r") >> hFlush stdout program <- read_program case program of @@ -470,7 +488,7 @@ read_program = ( "program") $ do source <- try (string ".\n" >> return "") <|> manyTill anyToken (try $ string "\n.\n") - return $ parse (T.pack source) + return $ parseProgram (T.pack source) read_task_queue :: DBParser () read_task_queue = ( "task_queue") $ do @@ -483,26 +501,26 @@ string " queued tasks\n" count ntasks $ do signedInt >> char ' ' - first_lineno <- signedInt + _first_lineno <- signedInt char ' ' - st <- signedInt + _st <- signedInt char ' ' - id <- signedInt + _id <- signedInt char '\n' - a <- read_activ_as_pi + _a <- read_activ_as_pi read_rt_env - program <- read_program + _program <- read_program return () suspended_count <- signedInt string " suspended tasks\n" count suspended_count $ do - start_time <- signedInt + _start_time <- signedInt char ' ' - task_id <- signedInt - value <- (char ' ' >> read_var) <|> (char '\n' >> return (LMInt 0)) - the_vm <- read_vm + _task_id <- signedInt + _value <- (char ' ' >> read_var) <|> (char '\n' >> return (LMInt 0)) + _the_vm <- read_vm return () return () @@ -511,11 +529,11 @@ read_vm = ( "vm") $ do top <- unsignedInt char ' ' - vector <- signedInt + _vector <- signedInt char ' ' - func_id <- unsignedInt - max <- (char ' ' >> unsignedInt) <|> - (lookAhead (char '\n') >> return default_max_stack_depth) + _func_id <- unsignedInt + _max <- (char ' ' >> unsignedInt) <|> + (lookAhead (char '\n') >> return default_max_stack_depth) char '\n' count (fromIntegral top) read_activ return () @@ -530,7 +548,7 @@ unless (version < num_db_versions) $ fail $ "Unrecognized language version: " ++ show version - prog <- read_program + _prog <- read_program read_rt_env stack_in_use <- signedInt @@ -538,32 +556,32 @@ count stack_in_use read_var read_activ_as_pi - temp <- read_var + _temp <- read_var pc <- unsignedInt char ' ' i <- unsignedInt let bi_func_pc = i - error_pc <- (lookAhead (char '\n') >> return pc) <|> (char ' ' >> unsignedInt) + _error_pc <- (lookAhead (char '\n') >> return pc) <|> (char ' ' >> unsignedInt) char '\n' when (bi_func_pc /= 0) $ do - func_name <- read_string + _func_name <- read_string read_bi_func_data read_activ_as_pi :: DBParser () read_activ_as_pi = ( "activ_as_pi") $ do read_var - this <- signedInt + _this <- signedInt char ' ' >> signedInt char ' ' >> signedInt - player <- char ' ' >> signedInt + _player <- char ' ' >> signedInt char ' ' >> signedInt - progr <- char ' ' >> signedInt - vloc <- char ' ' >> signedInt + _progr <- char ' ' >> signedInt + _vloc <- char ' ' >> signedInt char ' ' >> signedInt - debug <- char ' ' >> signedInt + _debug <- char ' ' >> signedInt char '\n' read_string -- was argstr @@ -571,8 +589,8 @@ read_string -- was iobjstr read_string -- was prepstr - verb <- read_string - verbname <- read_string + _verb <- read_string + _verbname <- read_string return () @@ -589,7 +607,7 @@ read_bi_func_data :: DBParser () read_bi_func_data = return () -read_active_connections :: DBParser [(Int, Int)] +read_active_connections :: DBParser [(ObjId, ObjId)] read_active_connections = ( "active_connections") $ (eof >> return []) <|> do nconnections <- signedInt string " active connections" @@ -619,13 +637,13 @@ _type_float = 9 type_any = -1 -type_numeric = -2 +-- type_numeric = -2 dbv_prehistory = 0 -dbv_exceptions = 1 -dbv_breakcont = 2 +-- dbv_exceptions = 1 +-- dbv_breakcont = 2 dbv_float = 3 -dbv_bfbugfixed = 4 +-- dbv_bfbugfixed = 4 num_db_versions = 5 system_object = 0 @@ -633,10 +651,10 @@ flag_user = 0 flag_programmer = 1 flag_wizard = 2 -flag_obsolete_1 = 3 +-- flag_obsolete_1 = 3 flag_read = 4 flag_write = 5 -flag_obsolete_2 = 6 +-- flag_obsolete_2 = 6 flag_fertile = 7 pf_read = 0x01 @@ -651,26 +669,28 @@ dobjShift = 4 iobjShift = 6 objMask = 0x3 -permMask = 0xF +-- permMask = 0xF -- Database writing ... -type DBWriter = ReaderT Database (WriterT Builder STM) +type DBWriter = ReaderT Database (WriterT Builder VTx) -liftSTM :: STM a -> DBWriter a -liftSTM = lift . lift +liftVTx :: VTx a -> DBWriter a +liftVTx = lift . lift -saveLMDatabase :: FilePath -> Database -> IO () -saveLMDatabase dbFile database = withDBFile dbFile WriteMode $ \handle -> do - let writer = runReaderT writeDatabase database - stm = execWriterT writer - TL.hPutStr handle . toLazyText =<< atomically stm +saveLMDatabase :: VSpace -> FilePath -> (Database, Connected) -> IO () +saveLMDatabase vspace dbFile (database, connected) = do + putStrLn $ "EXPORTING: " ++ dbFile + withDBFile dbFile WriteMode $ \handle -> do + let writer = runReaderT (writeDatabase connected) database + vtx = execWriterT writer + TL.hPutStr handle . toLazyText =<< runVTx vspace vtx tellLn :: Builder -> DBWriter () tellLn line = tell line >> tell (singleton '\n') -writeDatabase :: DBWriter () -writeDatabase = do +writeDatabase :: Connected -> DBWriter () +writeDatabase connected = do let (before, after) = header_format_string tell (fromString before) tell (decimal $ num_db_versions - 1) @@ -680,8 +700,8 @@ let nobjs = maxObject db + 1 tellLn (decimal nobjs) - objects <- listArray (0, maxObject db) `liftM` - forM [0..maxObject db] (\oid -> liftSTM $ dbObject oid db) + objects <- listArray (0, maxObject db) <$> + forM [0..maxObject db] (\oid -> liftVTx $ dbObject oid db) let nprogs = foldl' numVerbs 0 (elems objects) where numVerbs acc Nothing = acc @@ -703,13 +723,18 @@ tellLn "0 queued tasks" tellLn "0 suspended tasks" + unless (null connected) $ do + tellLn $ decimal (length connected) <> " active connections with listeners" + forM_ connected $ \(who, listener) -> + tellLn $ decimal who <> " " <> decimal listener + tellObject :: Array ObjId (Maybe Object) -> (ObjId, Maybe Object) -> DBWriter (ObjId, [Verb]) tellObject objects (oid, Just obj) = do tell (singleton '#') tellLn (decimal oid) - tellLn (string2builder $ objectName obj) + tellLn (Str.toBuilder $ objectName obj) tellLn "" -- old handles string let flags = flag objectIsPlayer flag_user .|. @@ -737,10 +762,10 @@ tellLn (decimal $ objectForMaybe $ listToMaybe children) tellLn (decimal $ nextLink objects oid objectChildren parent) - verbs <- liftSTM $ mapM (readTVar . snd) $ objectVerbs obj + verbs <- liftVTx $ mapM (readPVar . snd) $ objectVerbs obj tellLn (decimal $ length verbs) forM_ verbs $ \verb -> do - tellLn (string2builder $ verbNames verb) + tellLn (Str.toBuilder $ verbNames verb) tellLn (decimal $ verbOwner verb) let flags = flag verbPermR vf_read .|. @@ -755,9 +780,9 @@ tellLn (decimal $ fromEnum (verbPreposition verb) - 2) - definedProperties <- liftSTM $ definedProperties obj + definedProperties <- liftVTx $ definedProperties obj tellLn (decimal $ length definedProperties) - forM_ definedProperties $ tellLn . string2builder + forM_ definedProperties $ tellLn . Str.toBuilder tellLn (decimal $ HM.size $ objectProperties obj) tellProperties objects obj (Just oid) @@ -775,7 +800,7 @@ (Object -> IntSet) -> Maybe ObjId -> ObjId nextLink objects oid projection superior = next where nexts = maybe [] (IS.toList . projection) $ - join $ (objects !) `fmap` superior + join $ (objects !) <$> superior myIndex = elemIndex oid nexts next = objectForMaybe $ listToMaybe $ maybe (const []) (drop . (+ 1)) myIndex nexts @@ -784,9 +809,9 @@ DBWriter () tellProperties objects obj (Just oid) = do let Just definer = objects ! oid - properties <- liftSTM $ definedProperties definer + properties <- liftVTx $ definedProperties definer forM_ properties $ \propertyName -> do - Just property <- liftSTM $ lookupProperty obj propertyName + Just property <- liftVTx $ lookupProperty obj propertyName case propertyValue property of Nothing -> tellLn (decimal type_clear) Just value -> tellValue value @@ -807,11 +832,11 @@ tellValue value = case value of Int x -> tellLn (decimal type_int) >> tellLn (decimal x) Flt x -> tellLn (decimal _type_float) >> tellLn (realFloat x) - Str x -> tellLn (decimal _type_str) >> tellLn (string2builder x) + Str x -> tellLn (decimal _type_str) >> tellLn (Str.toBuilder x) Obj x -> tellLn (decimal type_obj) >> tellLn (decimal x) Err x -> tellLn (decimal type_err) >> tellLn (decimal $ fromEnum x) - Lst x -> tellLn (decimal _type_list) >> tellLn (decimal $ V.length x) >> - V.forM_ x tellValue + Lst x -> tellLn (decimal _type_list) >> tellLn (decimal $ Lst.length x) >> + Lst.forM_ x tellValue tellVerbs :: (ObjId, [Verb]) -> DBWriter () tellVerbs (oid, verbs) = forM_ (zip [0..] verbs) $ \(vnum, verb) -> do diff --git a/src/MOO/List.hs b/src/MOO/List.hs new file mode 100644 --- /dev/null +++ b/src/MOO/List.hs @@ -0,0 +1,263 @@ + +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Abstract MOO list type +module MOO.List ( + MOOList + + -- * Accessors + -- ** Length information + , length + , null + + -- ** Indexing + , (!) + , head + + -- ** Extracting sublists (slicing) + , slice + , tail + , splitAt + + -- * Construction + -- ** Initialization + , empty + + -- ** Concatenation + , snoc + , concat + + -- * Elementwise operations + -- ** Monadic mapping + , forM_ + + -- * Working with predicates + -- ** Searching + , elem + , findIndex + , elemIndex + + -- * Folding + -- ** Monadic folds + , foldM + + -- * Conversions + -- ** Lists + , toList + , fromList + + -- * MOO primitives + , storageBytes + , equal + + -- * Association list interface + , assocLens + + -- * Convenience functions + , set + , insert + , delete + ) where + +import Control.Applicative ((<$>)) +import Data.Function (on) +import Data.HashMap.Lazy (HashMap) +import Data.Monoid (Monoid(mempty, mappend, mconcat), (<>)) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import Database.VCache (VCacheable(put, get)) +import Prelude hiding (concat, head, length, null, tail, elem, splitAt, (++)) + +import qualified Data.HashMap.Lazy as HM +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM + +import MOO.Types (Value(Lst, Str), StrT) +import MOO.Util (VVector(..)) + +import qualified MOO.Types as Value + +type AssocMap = HashMap StrT (Int, Value) + +data MOOList = MOOList { + toVector :: Vector Value + , toAssocMap :: Maybe AssocMap + } deriving Typeable + +instance Eq MOOList where + (==) = (==) `on` toVector + +instance Monoid MOOList where + mempty = empty + mappend = (++) + mconcat = concat + +instance Show MOOList where + show = show . toList + +instance VCacheable MOOList where + put = put . VVector . toVector + get = fromVector . unVVector <$> get + +fromVector :: Vector Value -> MOOList +fromVector vec = MOOList { + toVector = vec + , toAssocMap = vectorToAssocMap vec + } + +fromList :: [Value] -> MOOList +fromList = fromVector . V.fromList + +toList :: MOOList -> [Value] +toList = V.toList . toVector + +storageBytes :: MOOList -> Int +storageBytes = V.sum . V.map Value.storageBytes . toVector + +equal :: MOOList -> MOOList -> Bool +equal = vectorEqual `on` toVector + + where x `vectorEqual` y = V.length x == V.length y && + V.and (V.zipWith Value.equal x y) + +empty :: MOOList +empty = fromVector V.empty + +(!) :: MOOList -> Int -> Value +lst ! i = toVector lst V.! i + +head :: MOOList -> Value +head = V.head . toVector + +tail :: MOOList -> MOOList +tail = fromVector . V.tail . toVector + +slice :: Int -> Int -> MOOList -> MOOList +slice i n = fromVector . V.slice i n . toVector + +splitAt :: Int -> MOOList -> (MOOList, MOOList) +splitAt n lst = let (b, a) = V.splitAt n (toVector lst) + in (fromVector b, fromVector a) + +snoc :: MOOList -> Value -> MOOList +snoc lst = fromVector . V.snoc (toVector lst) + +(++) :: MOOList -> MOOList -> MOOList +x ++ y = fromVector $ toVector x <> toVector y + +concat :: [MOOList] -> MOOList +concat = fromVector . V.concat . map toVector + +length :: MOOList -> Int +length = V.length . toVector + +null :: MOOList -> Bool +null = V.null . toVector + +elem :: Value -> MOOList -> Bool +elem x = V.elem x . toVector + +elemIndex :: Value -> MOOList -> Maybe Int +elemIndex x = V.elemIndex x . toVector + +findIndex :: (Value -> Bool) -> MOOList -> Maybe Int +findIndex p = V.findIndex p . toVector + +foldM :: Monad m => (a -> Value -> m a) -> a -> MOOList -> m a +foldM f acc = V.foldM f acc . toVector + +forM_ :: Monad m => MOOList -> (Value -> m b) -> m () +forM_ = V.forM_ . toVector + +-- Association list interface + +vectorToAssocMap :: Vector Value -> Maybe AssocMap +vectorToAssocMap = fmap snd . V.foldM mkAssocMap (0, HM.empty) + + where mkAssocMap :: (Int, AssocMap) -> Value -> Maybe (Int, AssocMap) + mkAssocMap (i, map) (Lst lst) = case toList lst of + [Str k, value] -> let map' = assocMapInsert k (i, value) map + in Just (succ $! i, map') + [_ , _ ] -> Just (succ $! i, map) + _ -> Nothing + mkAssocMap _ _ = Nothing + + -- Preserve the first value associated with duplicate keys + assocMapInsert :: StrT -> (Int, Value) -> AssocMap -> AssocMap + assocMapInsert = HM.insertWith (flip const) + +-- | Return the current value (if any) associated with the given key, and a +-- function to associate the key with a new value (or remove it). Returns +-- 'Nothing' if the list is not a proper association list. +assocLens :: StrT -> MOOList -> Maybe (Maybe Value, Maybe Value -> MOOList) +assocLens key lst = mkLens <$> toAssocMap lst + + where mkLens :: AssocMap -> (Maybe Value, Maybe Value -> MOOList) + mkLens map = (snd <$> current, setValue) + + where current :: Maybe (Int, Value) + current = HM.lookup key map + + setValue :: Maybe Value -> MOOList + setValue (Just newValue) = + let vec = toVector lst + assoc = Lst $ fromList [Str key, newValue] + map' i = HM.insert key (i, newValue) map + in case current of + Nothing -> lst { + toVector = V.snoc vec assoc + , toAssocMap = Just $ map' (V.length vec) + } + Just (i, _) -> lst { + toVector = vectorSet vec assoc i + , toAssocMap = Just $ map' i + } + setValue Nothing = maybe lst (delete lst . fst) current + +-- Convenience functions + +-- | Return a modified list with the given 0-based index replaced with the +-- given value. +set :: MOOList -> Value -> Int -> MOOList +set lst value = fromVector . vectorSet (toVector lst) value + +vectorSet :: Vector Value -> Value -> Int -> Vector Value +vectorSet vec value i = V.modify (\vec' -> VM.write vec' i value) vec + +-- | Return a modified list with the given value inserted at the given 0-based +-- index. +insert :: MOOList -> Int -> Value -> MOOList +insert lst i = fromVector . vectorInsert (toVector lst) i + + where vectorInsert :: Vector Value -> Int -> Value -> Vector Value + vectorInsert vec index value + | index <= 0 = V.cons value vec + | index >= vecLen = V.snoc vec value + | otherwise = V.create $ do + vec' <- flip VM.grow 1 =<< V.thaw vec + let moveLen = vecLen - index + s = VM.slice index moveLen vec' + t = VM.slice (index + 1) moveLen vec' + VM.move t s + VM.write vec' index value + return vec' + where vecLen = V.length vec + +-- | Return a modified list with the value at the given 0-based index removed. +delete :: MOOList -> Int -> MOOList +delete lst i = fromVector $ vectorDelete (toVector lst) i + + where vectorDelete :: Vector Value -> Int -> Vector Value + vectorDelete vec index + | index == 0 = V.tail vec + | index == vecLen - 1 = V.init vec + | index * 2 < vecLen = V.tail $ (`V.modify` vec) $ \vec' -> + let s = VM.slice 0 index vec' + t = VM.slice 1 index vec' + in VM.move t s + | otherwise = V.init $ (`V.modify` vec) $ \vec' -> + let moveLen = vecLen - index - 1 + s = VM.slice (index + 1) moveLen vec' + t = VM.slice index moveLen vec' + in VM.move t s + where vecLen = V.length vec diff --git a/src/MOO/List.hs-boot b/src/MOO/List.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/List.hs-boot @@ -0,0 +1,24 @@ +-- -*- Haskell -*- + +module MOO.List ( MOOList, storageBytes + , empty, equal, null, toList, fromList ) where + +import Database.VCache (VCacheable) + +import {-# SOURCE #-} MOO.Types (Value) + +import Prelude hiding (null) + +data MOOList + +instance Eq MOOList +instance Show MOOList +instance VCacheable MOOList + +storageBytes :: MOOList -> Int + +empty :: MOOList +equal :: MOOList -> MOOList -> Bool +null :: MOOList -> Bool +toList :: MOOList -> [Value] +fromList :: [Value] -> MOOList diff --git a/src/MOO/Network.hs b/src/MOO/Network.hs --- a/src/MOO/Network.hs +++ b/src/MOO/Network.hs @@ -13,9 +13,12 @@ , unlisten ) where -import Control.Concurrent.STM (TVar, atomically, modifyTVar) -import Control.Exception (try) +import Control.Applicative ((<$>)) +import Control.Concurrent.STM (TVar, atomically, modifyTVar, readTVarIO) +import Control.Exception (try, finally) import Control.Monad (when) +import Data.Monoid ((<>)) +import Data.Text (Text) import System.IO.Error (isPermissionError) import MOO.Connection (connectionHandler) @@ -26,6 +29,7 @@ import MOO.Types import qualified Data.Map as M +import qualified Data.Text as T data Point = Console (TVar World) | TCP (Maybe HostName) PortNumber deriving (Eq) @@ -57,14 +61,19 @@ world <- getWorld case value of Int port -> return $ TCP (bindAddress world) (fromIntegral port) - Str "Console" -> Console `fmap` getWorld' + Str "Console" -> Console <$> getWorld' _ -> raise E_TYPE point2value :: Point -> Value point2value point = case point of - TCP _ port -> Int (fromIntegral port) - Console{} -> Str "Console" + TCP _ port -> Int (fromIntegral port) + Console{} -> Str "Console" +point2text :: Point -> Text +point2text point = case point of + TCP _ port -> "port " <> T.pack (show port) + Console{} -> "console" + createListener :: TVar World -> ObjId -> Point -> Bool -> IO Listener createListener world' object point printMessages = do let listener = initListener { @@ -78,11 +87,21 @@ TCP{} -> createTCPListener listener handler Console{} -> createConsoleListener listener handler + world <- readTVarIO world' let canon = listenerPoint listener - atomically $ modifyTVar world' $ \world -> world { - listeners = M.insert canon listener (listeners world) } + who = toText (Obj object) + what = " listening on " <> point2text canon + listening = "LISTEN: " <> who <> " now" <> what + notListening = "UNLISTEN: " <> who <> " no longer" <> what + logUnlisten = atomically $ writeLog world notListening + listener' = listener { listenerCancel = listenerCancel listener + `finally` logUnlisten } + atomically $ do + writeLog world listening + modifyTVar world' $ \world -> world { + listeners = M.insert canon listener' (listeners world) } - return listener + return listener' listen :: ObjId -> Point -> Bool -> MOO Point listen object point printMessages = do diff --git a/src/MOO/Network/Console.hs b/src/MOO/Network/Console.hs --- a/src/MOO/Network/Console.hs +++ b/src/MOO/Network/Console.hs @@ -14,8 +14,8 @@ import Data.Text.Encoding (encodeUtf8) import Pipes (Producer, Pipe, runEffect, await, yield, for, cat, (>->)) import Pipes.ByteString (stdout) -import Pipes.Concurrent (Buffer(..), Output, spawn, send, fromInput, toOutput) -import System.Console.Haskeline (InputT, CompletionFunc, Completion(..), +import Pipes.Concurrent (spawn, unbounded, send, fromInput, toOutput) +import System.Console.Haskeline (InputT, CompletionFunc, Completion(), runInputT, getInputLine, setComplete, defaultSettings, completeWordWithPrev, simpleCompletion) @@ -27,7 +27,8 @@ import qualified Data.Vector as V import MOO.Connection (ConnectionHandler) -import {-# SOURCE #-} MOO.Network (Point(..), Listener(..)) +import {-# SOURCE #-} MOO.Network (Point(Console), + Listener(listenerPoint, listenerCancel)) import MOO.Object import MOO.Task import MOO.Types @@ -48,7 +49,7 @@ let connectionName :: STM String connectionName = return "console" - (output, input) <- spawn Unbounded + (output, input) <- spawn unbounded thread <- forkIO $ runInputT defaultSettings $ runEffect $ consoleInput >-> writeLines >-> writeUtf8 >-> toOutput output diff --git a/src/MOO/Network/TCP.hs b/src/MOO/Network/TCP.hs --- a/src/MOO/Network/TCP.hs +++ b/src/MOO/Network/TCP.hs @@ -5,15 +5,23 @@ , createTCPListener ) where +import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, killThread) import Control.Concurrent.STM (STM, TMVar, newEmptyTMVarIO, atomically, putTMVar, readTMVar) -import Control.Exception (SomeException, mask, try, finally, bracketOnError) -import Control.Monad (liftM, forever) +import Control.Exception (SomeException, IOException, mask, try, finally, + bracketOnError) +import Control.Monad (forever) import Data.Maybe (fromMaybe) -import Network.Socket (PortNumber, Socket, SockAddr, SocketOption(..), - Family(AF_INET6), SocketType(Stream), - AddrInfo(..), AddrInfoFlag(..), NameInfoFlag(..), +import Network.Socket (PortNumber, Socket, SockAddr, + SocketOption(ReuseAddr, KeepAlive), + Family(AF_INET, AF_INET6), SocketType(Stream), + AddrInfo(addrFlags, addrFamily, addrSocketType, + addrProtocol, addrAddress), + AddrInfoFlag(AI_PASSIVE, AI_NUMERICSERV, + AI_ADDRCONFIG, AI_V4MAPPED), + NameInfoFlag(NI_NAMEREQD, + NI_NUMERICHOST, NI_NUMERICSERV), HostName, ServiceName, maxListenQueue, defaultHints, getAddrInfo, setSocketOption, socket, bind, listen, accept, close, @@ -21,21 +29,29 @@ import Pipes.Network.TCP (fromSocket, toSocket) import MOO.Connection (ConnectionHandler) -import {-# SOURCE #-} MOO.Network (Point(..), Listener(..)) +import {-# SOURCE #-} MOO.Network (Point(TCP), + Listener(listenerPoint, listenerCancel)) maxBufferSize :: Int maxBufferSize = 1024 serverAddrInfo :: Maybe HostName -> PortNumber -> IO [AddrInfo] serverAddrInfo host port = - let hints = defaultHints { + let hints6, hints4 :: AddrInfo + hints6 = defaultHints { addrFlags = [AI_PASSIVE, AI_NUMERICSERV, AI_ADDRCONFIG, AI_V4MAPPED] , addrFamily = AF_INET6 , addrSocketType = Stream } - in getAddrInfo (Just hints) host (Just $ show port) + hints4 = hints6 { addrFamily = AF_INET } + gai :: AddrInfo -> IO [AddrInfo] + gai hints = getAddrInfo (Just hints) host (Just $ show port) + + in try (gai hints6) >>= + either (\e -> let _ = e :: IOException in gai hints4) return + createTCPListener :: Listener -> ConnectionHandler -> IO Listener createTCPListener listener handler = do let TCP host port = listenerPoint listener @@ -53,7 +69,7 @@ acceptThread <- forkIO $ acceptConnections sock handler - return $ listener { + return listener { listenerPoint = TCP host boundPort , listenerCancel = killThread acceptThread >> close sock } @@ -94,7 +110,7 @@ nameVar <- newEmptyTMVarIO forkIO $ do - maybeHost <- try (fst `liftM` getNameInfo [NI_NAMEREQD] True False addr) >>= + maybeHost <- try (fst <$> getNameInfo [NI_NAMEREQD] True False addr) >>= either (\except -> let _ = except :: SomeException in return Nothing) return atomically $ putTMVar nameVar maybeHost @@ -105,5 +121,4 @@ return $ AddrName nameVar numericHost port hostName :: AddrName -> STM HostName -hostName addr = - return . fromMaybe (addrNumeric addr) =<< readTMVar (addrHostName addr) +hostName addr = fromMaybe (addrNumeric addr) <$> readTMVar (addrHostName addr) diff --git a/src/MOO/Object.hs b/src/MOO/Object.hs --- a/src/MOO/Object.hs +++ b/src/MOO/Object.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module MOO.Object ( Object (..) , Property (..) @@ -10,6 +10,8 @@ , addChild , deleteChild , getContents + , addContent + , deleteContent , builtinProperties , builtinProperty , isBuiltinProperty @@ -28,6 +30,8 @@ , deleteVerb , definedProperties , definedVerbs + , renumberObject + , renumberOwnership -- * Special Object Numbers , systemObject @@ -36,23 +40,30 @@ , failedMatch ) where +import Control.Applicative ((<$>), (<*>)) import Control.Arrow (second) -import Control.Concurrent.STM (STM, TVar, newTVarIO, newTVar, readTVar) -import Control.Monad (liftM) +import Control.Monad ((>=>), forM_) import Data.HashMap.Strict (HashMap) import Data.IntSet (IntSet) -import Data.Maybe (isJust) import Data.List (find) +import Data.Maybe (isJust) +import Data.Typeable (Typeable) +import Database.VCache (VCacheable(put, get), VSpace, VTx, + PVar, newPVarIO, newPVar, readPVar, writePVar) import Prelude hiding (getContents) import qualified Data.HashMap.Strict as HM import qualified Data.IntSet as IS +import {-# SOURCE #-} MOO.Database import MOO.Types +import MOO.Util import MOO.Verb import qualified MOO.String as Str +type VerbDef = ([StrT], PVar Verb) + data Object = Object { -- Attributes objectIsPlayer :: Bool @@ -71,10 +82,32 @@ , objectPermF :: Bool -- Definitions - , objectProperties :: HashMap StrT (TVar Property) - , objectVerbs :: [([StrT], TVar Verb)] -} + , objectProperties :: HashMap StrT (PVar Property) + , objectVerbs :: [VerbDef] +} deriving Typeable +instance VCacheable Object where + put obj = do + put $ objectIsPlayer obj + put $ objectParent obj + put $ VIntSet (objectChildren obj) + put $ objectName obj + put $ objectOwner obj + put $ objectLocation obj + put $ VIntSet (objectContents obj) + put $ objectProgrammer obj + put $ objectWizard obj + put $ objectPermR obj + put $ objectPermW obj + put $ objectPermF obj + put $ VHashMap (objectProperties obj) + put $ objectVerbs obj + + get = Object <$> get <*> get <*> (unVIntSet <$> get) + <*> get <*> get <*> get <*> (unVIntSet <$> get) + <*> get <*> get <*> get <*> get <*> get + <*> (unVHashMap <$> get) <*> get + instance Sizeable Object where -- this does not capture the size of defined properties or verbs, as these -- are tucked behind TVars and cannot be read outside the STM monad @@ -122,11 +155,11 @@ getChildren :: Object -> [ObjId] getChildren = IS.elems . objectChildren -addChild :: ObjId -> Object -> STM Object +addChild :: ObjId -> Object -> VTx Object addChild childOid obj = return obj { objectChildren = IS.insert childOid (objectChildren obj) } -deleteChild :: ObjId -> Object -> STM Object +deleteChild :: ObjId -> Object -> VTx Object deleteChild childOid obj = return obj { objectChildren = IS.delete childOid (objectChildren obj) } @@ -136,6 +169,14 @@ getContents :: Object -> [ObjId] getContents = IS.elems . objectContents +addContent :: ObjId -> Object -> VTx Object +addContent oid obj = + return obj { objectContents = IS.insert oid (objectContents obj) } + +deleteContent :: ObjId -> Object -> VTx Object +deleteContent oid obj = + return obj { objectContents = IS.delete oid (objectContents obj) } + data Property = Property { propertyName :: StrT , propertyValue :: Maybe Value @@ -145,8 +186,21 @@ , propertyPermR :: Bool , propertyPermW :: Bool , propertyPermC :: Bool -} deriving Show +} deriving Typeable +instance VCacheable Property where + put prop = do + put $ propertyName prop + put $ propertyValue prop + put $ propertyInherited prop + put $ propertyOwner prop + put $ propertyPermR prop + put $ propertyPermW prop + put $ propertyPermC prop + + get = Property <$> get <*> get <*> get + <*> get <*> get <*> get <*> get + instance Sizeable Property where storageBytes prop = storageBytes (propertyName prop) + @@ -194,97 +248,150 @@ objectForMaybe (Just oid) = oid objectForMaybe Nothing = nothing -setProperties :: [Property] -> Object -> IO Object -setProperties props obj = do +setProperties :: VSpace -> [Property] -> Object -> IO Object +setProperties vspace props obj = do propHash <- mkHash props return obj { objectProperties = propHash } - where mkHash = liftM HM.fromList . mapM mkAssoc + + where mkHash :: [Property] -> IO (HashMap StrT (PVar Property)) + mkHash = fmap HM.fromList . mapM mkAssoc + + mkAssoc :: Property -> IO (StrT, PVar Property) mkAssoc prop = do - tvarProp <- newTVarIO prop + tvarProp <- newPVarIO vspace prop return (propertyKey prop, tvarProp) propertyKey :: Property -> StrT propertyKey = propertyName -setVerbs :: [Verb] -> Object -> IO Object -setVerbs verbs obj = do +setVerbs :: VSpace -> [Verb] -> Object -> IO Object +setVerbs vspace verbs obj = do verbList <- mkList verbs return obj { objectVerbs = verbList } - where mkList = mapM mkVerb + + where mkList :: [Verb] -> IO [VerbDef] + mkList = mapM mkVerb + + mkVerb :: Verb -> IO VerbDef mkVerb verb = do - tvarVerb <- newTVarIO verb - return (verbKey verb, tvarVerb) + verbRef <- newPVarIO vspace verb + return (verbKey verb, verbRef) verbKey :: Verb -> [StrT] verbKey = Str.words . verbNames -lookupPropertyRef :: Object -> StrT -> Maybe (TVar Property) +lookupPropertyRef :: Object -> StrT -> Maybe (PVar Property) lookupPropertyRef obj name = HM.lookup name (objectProperties obj) -lookupProperty :: Object -> StrT -> STM (Maybe Property) -lookupProperty obj name = maybe (return Nothing) (fmap Just . readTVar) $ +lookupProperty :: Object -> StrT -> VTx (Maybe Property) +lookupProperty obj name = maybe (return Nothing) (fmap Just . readPVar) $ lookupPropertyRef obj name -addProperty :: Property -> Object -> STM Object +addProperty :: Property -> Object -> VTx Object addProperty prop obj = do - propTVar <- newTVar prop + propPVar <- newPVar prop return obj { objectProperties = - HM.insert (propertyKey prop) propTVar $ objectProperties obj } + HM.insert (propertyKey prop) propPVar $ objectProperties obj } -addInheritedProperty :: Property -> Object -> STM Object +addInheritedProperty :: Property -> Object -> VTx Object addInheritedProperty prop obj = flip addProperty obj $ if propertyPermC prop then prop' { propertyOwner = objectOwner obj } else prop' where prop' = prop { propertyInherited = True, propertyValue = Nothing } -deleteProperty :: StrT -> Object -> STM Object +deleteProperty :: StrT -> Object -> VTx Object deleteProperty name obj = return obj { objectProperties = HM.delete name (objectProperties obj) } -lookupVerbRef :: Object -> Value -> Maybe (Int, TVar Verb) -lookupVerbRef obj (Str name) = - fmap (second snd) $ find matchVerb (zip [0..] $ objectVerbs obj) - where matchVerb (_, (names, _)) = verbNameMatch name names -lookupVerbRef obj (Int index) +lookupVerbRef :: Bool -> Object -> Value -> Maybe (Int, PVar Verb) +lookupVerbRef numericStrings obj (Str name) = + second snd <$> find matchVerb (zip [0..] $ objectVerbs obj) + where matchVerb :: (Int, VerbDef) -> Bool + matchVerb (i, (names, _)) = verbNameMatch name names || + (numericStrings && nameString == show i) + nameString = Str.toString name :: String +lookupVerbRef _ obj (Int index) | index' < 1 = Nothing | index' > numVerbs = Nothing | otherwise = Just (index'', snd $ verbs !! index'') - where index' = fromIntegral index - index'' = index' - 1 - verbs = objectVerbs obj - numVerbs = length verbs -lookupVerbRef _ _ = Nothing + where index' = fromIntegral index :: Int + index'' = index' - 1 :: Int + verbs = objectVerbs obj :: [VerbDef] + numVerbs = length verbs :: Int +lookupVerbRef _ _ _ = Nothing -lookupVerb :: Object -> Value -> STM (Maybe Verb) -lookupVerb obj desc = maybe (return Nothing) (fmap Just . readTVar . snd) $ - lookupVerbRef obj desc +lookupVerb :: Bool -> Object -> Value -> VTx (Maybe Verb) +lookupVerb numericStrings obj desc = + maybe (return Nothing) (fmap Just . readPVar . snd) $ + lookupVerbRef numericStrings obj desc -replaceVerb :: Int -> Verb -> Object -> STM Object +replaceVerb :: Int -> Verb -> Object -> VTx Object replaceVerb index verb obj = - return obj { objectVerbs = pre ++ [(verbKey verb, tvarVerb)] ++ tail post } - where (pre, post) = splitAt index (objectVerbs obj) - tvarVerb = snd $ head post + return obj { objectVerbs = pre ++ [(verbKey verb, verbRef)] ++ tail post } + where (pre, post) = splitAt index (objectVerbs obj) :: ([VerbDef], [VerbDef]) + verbRef = snd (head post) :: PVar Verb -addVerb :: Verb -> Object -> STM Object +addVerb :: Verb -> Object -> VTx Object addVerb verb obj = do - verbTVar <- newTVar verb - return obj { objectVerbs = objectVerbs obj ++ [(verbKey verb, verbTVar)] } + verbPVar <- newPVar verb + return obj { objectVerbs = objectVerbs obj ++ [(verbKey verb, verbPVar)] } -deleteVerb :: Int -> Object -> STM Object -deleteVerb index obj = return obj { objectVerbs = verbs } - where verbs = before ++ tail after - (before, after) = splitAt index (objectVerbs obj) +deleteVerb :: Int -> Object -> VTx Object +deleteVerb index obj = return obj { objectVerbs = pre ++ tail post } + where (pre, post) = splitAt index (objectVerbs obj) :: ([VerbDef], [VerbDef]) -definedProperties :: Object -> STM [StrT] +definedProperties :: Object -> VTx [StrT] definedProperties obj = do - props <- mapM readTVar $ HM.elems (objectProperties obj) + props <- mapM readPVar $ HM.elems (objectProperties obj) return $ map propertyName $ filter (not . propertyInherited) props -definedVerbs :: Object -> STM [StrT] +definedVerbs :: Object -> VTx [StrT] definedVerbs obj = do - verbs <- mapM (readTVar . snd) $ objectVerbs obj + verbs <- mapM (readPVar . snd) $ objectVerbs obj return $ map verbNames verbs + +renumberObject :: Object -> ObjId -> ObjId -> Database -> VTx () +renumberObject obj old new db = do + -- renumber parent/children + case objectParent obj of + Nothing -> return () + Just parent -> modifyObject parent db $ deleteChild old >=> addChild new + + forM_ (getChildren obj) $ \child -> modifyObject child db $ \obj -> + return obj { objectParent = Just new } + + -- renumber location/contents + case objectLocation obj of + Nothing -> return () + Just place -> modifyObject place db $ deleteContent old >=> addContent new + + forM_ (getContents obj) $ \thing -> modifyObject thing db $ \obj -> + return obj { objectLocation = Just new } + +renumberOwnership :: ObjId -> ObjId -> Object -> VTx (Maybe Object) +renumberOwnership old new obj = do + -- renumber property ownerships + forM_ (HM.elems $ objectProperties obj) $ \propRef -> do + prop <- readPVar propRef + case propertyOwner prop of + owner | owner == new -> writePVar propRef prop { propertyOwner = nothing } + | owner == old -> writePVar propRef prop { propertyOwner = new } + _ -> return () + + -- renumber verb ownerships + forM_ (map snd $ objectVerbs obj) $ \verbRef -> do + verb <- readPVar verbRef + case verbOwner verb of + owner | owner == new -> writePVar verbRef verb { verbOwner = nothing } + | owner == old -> writePVar verbRef verb { verbOwner = new } + _ -> return () + + -- renumber object ownership + return $ case objectOwner obj of + owner | owner == new -> Just obj { objectOwner = nothing } + | owner == old -> Just obj { objectOwner = new } + _ -> Nothing -- | The system object (@#0@) systemObject :: ObjId diff --git a/src/MOO/Parser.hs b/src/MOO/Parser.hs --- a/src/MOO/Parser.hs +++ b/src/MOO/Parser.hs @@ -1,8 +1,8 @@ -module MOO.Parser ( Program, parse, runParser, initParserState - , expression, between, whiteSpace, eof, program - , parseInt, parseFlt, parseNum, parseObj, keywords ) where +module MOO.Parser ( parseProgram, parseNum, parseObj, keywords ) where +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((&&&)) import Control.Monad (when, unless, mplus) import Control.Monad.Identity (Identity) import Data.List (find) @@ -10,19 +10,24 @@ import Data.Ratio ((%)) import Data.String (fromString) import Data.Text (Text) -import Text.Parsec (try, many, many1, digit, letter, char, anyChar, alphaNum, - oneOf, noneOf, lookAhead, notFollowedBy, chainl1, chainr1, +import Text.Parsec (try, many, many1, digit, letter, char, satisfy, alphaNum, + oneOf, lookAhead, notFollowedBy, chainl1, chainr1, option, optionMaybe, choice, between, getState, modifyState, - eof, runParser, sourceLine, errorPos, (<|>), ()) -import Text.Parsec.Error (Message(Message), errorMessages, messageString) + eof, runParser, errorPos, sourceLine, sourceColumn, + (<|>), ()) +import Text.Parsec.Error (ParseError, Message(Message), + errorMessages, messageString) import Text.Parsec.Text (GenParser) import Text.Parsec.Token (GenLanguageDef(LanguageDef)) +import qualified Data.Text as Text import qualified Text.Parsec.Token as T import MOO.AST import MOO.Types +import qualified MOO.String as Str + data ParserState = ParserState { dollarContext :: Int , loopStack :: [[Maybe Id]] @@ -100,18 +105,18 @@ signed :: (Num a) => MOOParser a -> MOOParser a signed parser = negative <|> parser - where negative = char '-' >> fmap negate parser + where negative = char '-' >> negate <$> parser plusMinus :: (Num a) => MOOParser a -> MOOParser a plusMinus parser = positive <|> signed parser where positive = char '+' >> parser integerLiteral :: MOOParser Value -integerLiteral = try (lexeme $ signed decimal) >>= return . Int . fromIntegral +integerLiteral = Int . fromIntegral <$> try (lexeme $ signed decimal) "integer literal" floatLiteral :: MOOParser Value -floatLiteral = try (lexeme $ signed real) >>= checkRange >>= return . Flt +floatLiteral = try (lexeme $ signed real) >>= checkRange "floating-point literal" where real = try withDot <|> withoutDot withDot = do @@ -125,8 +130,10 @@ exp <- exponent mkFloat pre "" (Just exp) + exponent :: MOOParser Integer exponent = oneOf "eE" >> plusMinus decimal "exponent" + mkFloat :: String -> String -> Maybe Integer -> MOOParser FltT mkFloat pre post exp = let whole = if null pre then 0 else read pre % 1 frac = if null post then 0 else read post % (10 ^ length post) @@ -138,24 +145,25 @@ | e < 0 -> fromRational $ mantissa * (1 % (10 ^ (-e))) | otherwise -> fromRational $ mantissa * (10 ^ e) - checkRange flt = - if isInfinite flt - then fail "Floating-point literal out of range" - else return flt + checkRange :: FltT -> MOOParser Value + checkRange flt + | isInfinite flt = fail "Floating-point literal out of range" + | otherwise = return (Flt flt) stringLiteral :: MOOParser Value stringLiteral = lexeme mooString "string literal" where mooString = between (char '"') (char '"' "terminating quote") $ - fmap (Str . fromString) $ many stringChar - stringChar = noneOf "\"\\" <|> (char '\\' >> anyChar "") + Str . fromString <$> many stringChar + stringChar = escapedChar <|> unescapedChar + escapedChar = char '\\' >> satisfy Str.validChar + unescapedChar = satisfy $ (&&) <$> (/= '"') <*> Str.validChar objectLiteral :: MOOParser Value -objectLiteral = lexeme (char '#' >> signed decimal) >>= - return . Obj . fromIntegral +objectLiteral = Obj . fromIntegral <$> lexeme (char '#' >> signed decimal) "object number" errorLiteral :: MOOParser Value -errorLiteral = checkPrefix >> fmap Err errorValue "error value" +errorLiteral = checkPrefix >> Err <$> errorValue "error value" where checkPrefix = try $ lookAhead $ (char 'E' <|> char 'e') >> char '_' errorValue = choice $ map literal [minBound..maxBound] literal err = reserved (show err) >> return err @@ -236,10 +244,10 @@ base :: MOOParser Expr base = bangThing <|> minusThing <|> unary - where bangThing = symbol "!" >> fmap Not base + where bangThing = symbol "!" >> Not <$> base minusThing = do try $ lexeme $ char '-' >> notFollowedBy (digit <|> char '.') - fmap Negate base + Negate <$> base unary :: MOOParser Expr unary = primary >>= modifiers @@ -249,25 +257,23 @@ list <|> catchExpr <|> literal where subexpression = parens expression - dollarThing = do - symbol "$" - dollarRef <|> justDollar + dollarThing = symbol "$" >> (dollarRef <|> justDollar) dollarRef = do - name <- fmap (Literal . Str . fromId) identifier + name <- Literal . Str . fromId <$> identifier dollarVerb name <|> return (PropertyRef objectZero name) - dollarVerb name = fmap (VerbCall objectZero name) $ parens argList - objectZero = Literal $ Obj 0 + dollarVerb name = VerbCall objectZero name <$> parens argList + objectZero = Literal (Obj 0) justDollar = do - dc <- fmap dollarContext getState + dc <- dollarContext <$> getState unless (dc > 0) $ fail "Illegal context for `$' expression." return Length identThing = do ident <- identifier - let builtin = fmap (BuiltinFunc ident) $ parens argList + let builtin = BuiltinFunc ident <$> parens argList builtin <|> return (Variable ident) - list = fmap List $ braces argList + list = List <$> braces argList catchExpr = do symbol "`" @@ -320,19 +326,16 @@ | allowEmpty = commaSep arg | otherwise = commaSep1 arg where arg = splice <|> normal - splice = symbol "@" >> fmap ArgSplice expression - normal = fmap ArgNormal expression + splice = symbol "@" >> ArgSplice <$> expression + normal = ArgNormal <$> expression scatList :: MOOParser [ScatterItem] scatList = commaSep1 scat where scat = optional <|> rest <|> required - optional = do - symbol "?" - ident <- identifier - dv <- optionMaybe $ symbol "=" >> expression - return $ ScatOptional ident dv - rest = symbol "@" >> fmap ScatRest identifier - required = fmap ScatRequired identifier + optional = symbol "?" >> ScatOptional <$> identifier <*> + optionMaybe (symbol "=" >> expression) + rest = symbol "@" >> ScatRest <$> identifier + required = ScatRequired <$> identifier scatFromArgList :: [Argument] -> MOOParser [ScatterItem] scatFromArgList [] = fail "Empty list in scattering assignment." @@ -361,10 +364,10 @@ incLineNumber = modifyState $ \st -> st { lineNumber = succ (lineNumber st) } getLineNumber :: MOOParser Int -getLineNumber = fmap lineNumber getState +getLineNumber = lineNumber <$> getState statements :: MOOParser [Statement] -statements = fmap catMaybes (many statement) "statements" +statements = catMaybes <$> many statement "statements" statement :: MOOParser (Maybe Statement) statement = fmap Just someStatement <|> nullStatement "statement" @@ -456,7 +459,7 @@ checkLoopName :: String -> Maybe Id -> MOOParser () checkLoopName kind ident = do - stack <- fmap (head . loopStack) getState + stack <- head . loopStack <$> getState case ident of Nothing -> when (null stack) $ fail $ "No enclosing loop for `" ++ kind ++ "' statement" @@ -527,26 +530,51 @@ -- Main parser interface program :: MOOParser Program -program = between whiteSpace eof $ fmap Program statements +program = between whiteSpace eof $ Program <$> statements type Errors = [String] -parse :: Text -> Either Errors Program -parse input = case runParser program initParserState "MOO code" input of - Right prog -> Right prog - Left err -> Left $ let line = sourceLine $ errorPos err - msg = find message $ errorMessages err - message Message{} = True - message _ = False - in ["Line " ++ show line ++ ": " ++ - maybe "syntax error" messageString msg] +parseProgram :: Text -> Either Errors Program +parseProgram input = either (Left . errors) Right $ + runParser program initParserState "" input + where errors :: ParseError -> Errors + errors err = + let (line, column) = (sourceLine &&& sourceColumn) $ errorPos err + (source, point) = illustrate column $ + Text.unpack $ Text.lines input !! (line - 1) + message = find isMessage $ errorMessages err + in [ "Line " ++ show line ++ ": " ++ + maybe "syntax error" messageString message + , indent source + , indent point + ] + + illustrate :: Int -> String -> (String, String) + illustrate col str + | overflowLeft = illustrate colMid $ ellipsis ++ + drop (length ellipsis + col - colMid) str + | overflowRight = (take colMax str ++ ellipsis, point) + | otherwise = (str, point) + where overflowLeft = col > colMax || (col > colMid && overflowRight) + overflowRight = length str > colMax + colMax = 70 + colMid = 50 + ellipsis = "..." + point = replicate (col - 1) ' ' ++ "^" + + isMessage :: Message -> Bool + isMessage Message{} = True + isMessage _ = False + + indent :: String -> String + indent = (" " ++) + -- Auxiliary parser interface standalone :: MOOParser Value -> Text -> Maybe Value -standalone parser input = case runParser parser' initParserState "" input of - Right v -> Just v - Left _ -> Nothing +standalone parser input = either (const Nothing) Just $ + runParser parser' initParserState "" input where parser' = between whiteSpace eof parser parseInt :: Text -> Maybe Value diff --git a/src/MOO/Server.hs b/src/MOO/Server.hs --- a/src/MOO/Server.hs +++ b/src/MOO/Server.hs @@ -1,56 +1,216 @@ {-# LANGUAGE OverloadedStrings #-} -module MOO.Server ( startServer ) where +module MOO.Server (startServer, importDatabase, exportDatabase) where -import Control.Concurrent (takeMVar) -import Control.Concurrent.STM (TVar, atomically, readTVarIO, readTVar) -import Control.Monad (forM_) +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) +import Control.Concurrent (takeMVar, getNumCapabilities, threadDelay) +import Control.Concurrent.Async (async, withAsync, waitEither, wait) +import Control.Concurrent.STM (STM, TVar, atomically, retry, newEmptyTMVarIO, + tryPutTMVar, putTMVar, tryTakeTMVar, takeTMVar, + readTVarIO, readTVar, modifyTVar) +import Control.Exception (SomeException, try) +import Control.Monad (forM_, void, unless) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Text.IO (hPutStrLn) +import Data.Time (getCurrentTime, utcToLocalZonedTime, formatTime, + defaultTimeLocale) +import Database.VCache (openVCache, vcache_space, readPVarIO) import Network (withSocketsDo) -import System.Posix (installHandler, sigPIPE, Handler(..)) +import Pipes (Pipe, runEffect, (>->), for, cat, lift, yield) +import Pipes.Concurrent (spawn', unbounded, send, fromInput) +import System.IO (IOMode(ReadMode, AppendMode), BufferMode(LineBuffering), + openFile, stderr, hSetBuffering, hClose) +import System.Posix (installHandler, sigPIPE, Handler(Ignore)) import qualified Data.Map as M import qualified Data.Text as T import MOO.Builtins +import MOO.Builtins.Match (verifyPCRE) import MOO.Connection +import MOO.Database import MOO.Database.LambdaMOO -import MOO.Task -import MOO.Types import MOO.Network import MOO.Object +import MOO.Task +import MOO.Types +import MOO.Util +import MOO.Version +-- | Maximum database size, in megabytes +maxVCacheSize :: Int +maxVCacheSize = 2000 + -- | Start the main server and create the first listening point. -startServer :: Maybe FilePath -> FilePath -> FilePath -> +startServer :: Maybe FilePath -> FilePath -> Bool -> (TVar World -> Point) -> IO () -startServer logFile inputDB outputDB outboundNet pf = withSocketsDo $ do +startServer logFile dbFile outboundNet pf = withSocketsDo $ do + verifyPCRE either error return verifyBuiltins + installHandler sigPIPE Ignore Nothing - db <- loadLMDatabase inputDB >>= either (error . show) return + openFile dbFile ReadMode >>= hClose -- ensure file exists + vcache <- openVCache maxVCacheSize dbFile - world' <- newWorld db outboundNet + (stmLogger, stopLogger) <- startLogger logFile + let writeLog = atomically . stmLogger + numCapabilities <- getNumCapabilities + + writeLog $ "CMDLINE: Outbound network connections " <> + if outboundNet then "enabled." else "disabled." + + mapM_ writeLog [ + "STARTING: Server version " <> serverVersion + , " (Using TCP/IP with IPv6 support)" + , " (Task timeouts not measured)" + , " (Multithreading over " <> + pluralize numCapabilities "processor core" <> ")" + ] + + p <- loadPersistence vcache + + checkpoint <- ctime . unVUTCTime =<< readPVarIO (persistenceCheckpoint p) + writeLog $ "LOADING: Database checkpoint from " <> T.pack checkpoint + + world' <- newWorld stmLogger p outboundNet + + connected <- readPVarIO (persistenceConnected p) + unless (null connected) $ do + writeLog $ "Disconnecting formerly active connections: " <> + toLiteral (objectList $ map fst connected) + forM_ connected $ \(player, listener) -> + doDisconnected world' listener player Disconnected + runTask =<< newTask world' nothing - (callSystemVerb "server_started" [] >> return zero) + (resetLimits True >> callSystemVerb "server_started" [] >> return zero) + (checkpoint, stopCheckpointer) <- startCheckpointer world' + atomically $ modifyTVar world' $ \world -> world { checkpoint = checkpoint } + createListener world' systemObject (pf world') True - putStrLn "Listening for connections..." - world <- readTVarIO world' - takeMVar (shutdownMessage world) >>= shutdownServer world' + message <- takeMVar . shutdownMessage =<< readTVarIO world' + stopCheckpointer + shutdownServer world' message + + writeLog "Synchronizing database..." + syncPersistence p + writeLog "Finished" + + stopLogger + + where pluralize :: Int -> Text -> Text + pluralize n what = T.concat $ + [ T.pack (show n), " ", what ] ++ [ "s" | n /= 1 ] + shutdownServer :: TVar World -> Text -> IO () shutdownServer world' message = do atomically $ do world <- readTVar world' + writeLog world $ "SHUTDOWN: " <> message + forM_ (M.elems $ connections world) $ \conn -> do - sendToConnection conn $ T.concat ["*** Shutting down: ", message, " ***"] + -- XXX probably not good to send to ALL connections + sendToConnection conn $ "*** Shutting down: " <> message <> " ***" closeConnection conn - -- Give connections time to close - delay 5000000 + -- Wait for all connections to close + atomically $ do + world <- readTVar world' + unless (M.null $ connections world) retry return () + +startLogger :: Maybe FilePath -> IO (Text -> STM (), IO ()) +startLogger dest = do + handle <- maybe (return stderr) (`openFile` AppendMode) dest + hSetBuffering handle LineBuffering + + (output, input, seal) <- spawn' unbounded + + logger <- async $ do + runEffect $ + fromInput input >-> timestamp >-> for cat (lift . hPutStrLn handle) + hClose handle + + let writeLog = void . send output + stopLogger = atomically seal >> wait logger + + return (writeLog, stopLogger) + + where timestamp :: Pipe Text Text IO () + timestamp = for cat $ \line -> do + zonedTime <- lift $ utcToLocalZonedTime =<< getCurrentTime + let timestamp = formatTime defaultTimeLocale "%b %_d %T: " zonedTime + yield $ T.pack timestamp <> line + +startCheckpointer :: TVar World -> IO (STM (), IO ()) +startCheckpointer world' = do + (writeLog, p) <- atomically $ (writeLog &&& persistence) <$> readTVar world' + signal <- newEmptyTMVarIO + + let verbCall :: StrT -> [Value] -> IO () + verbCall name args = + void $ runTask =<< newTask world' nothing + (resetLimits False >> callSystemVerb name args >> return zero) + + checkpointerLoop :: IO () + checkpointerLoop = do + dumpInterval <- runTask =<< newTask world' nothing + (fromMaybe zero <$> + readProperty systemObject "dump_interval") + let interval = case dumpInterval >>= toMicroseconds of + Just usecs | usecs >= 60 * 1000000 -> fromIntegral usecs + _ -> 3600 * 1000000 + + shouldExit <- withAsync (threadDelay interval) $ \delayAsync -> + withAsync (atomically $ takeTMVar signal) $ \signalAsync -> + waitEither delayAsync signalAsync + case shouldExit of + Right True -> return () + _ -> do + atomically $ writeLog "CHECKPOINTING database..." + verbCall "checkpoint_started" [] + success <- either (\e -> let _ = e :: SomeException in False) + (const True) <$> try (syncPersistence p) + atomically $ writeLog "CHECKPOINTING finished" + verbCall "checkpoint_finished" [truthValue success] + + checkpointerLoop + + checkpointer <- async checkpointerLoop + + let checkpoint = void $ tryPutTMVar signal False + stopCheckpointer = do + atomically $ tryTakeTMVar signal >> putTMVar signal True + wait checkpointer + + return (checkpoint, stopCheckpointer) + +importDatabase :: FilePath -> FilePath -> IO () +importDatabase lambdaDB etaDB = do + vcache <- openVCache maxVCacheSize etaDB + let vspace = vcache_space vcache + + let writeLog = putStrLn . T.unpack + loadLMDatabase vspace lambdaDB writeLog >>= + either (error . show) (saveDatabase vcache) + +exportDatabase :: FilePath -> FilePath -> IO () +exportDatabase etaDB lambdaDB = do + openFile etaDB ReadMode >>= hClose -- ensure file exists + + p <- loadPersistence =<< openVCache maxVCacheSize etaDB + + db <- readPVarIO (persistenceDatabase p) + connected <- readPVarIO (persistenceConnected p) + + saveLMDatabase (persistenceVSpace p) lambdaDB (db, connected) diff --git a/src/MOO/String.hs b/src/MOO/String.hs --- a/src/MOO/String.hs +++ b/src/MOO/String.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveDataTypeable #-} + -- | Abstract MOO string type module MOO.String ( MOOString @@ -11,6 +13,7 @@ , toCaseFold , toBinary , toString + , toBuilder , toRegexp , singleton , empty @@ -27,7 +30,9 @@ -- * Transformations , intercalate - -- * Special folds + -- * Folds + , foldr + -- ** Special folds , concat , concatMap @@ -53,35 +58,52 @@ , index ) where +import Control.Applicative ((<$>)) import Data.ByteString (ByteString) import Data.Char (isAscii, isPrint, isHexDigit, digitToInt, intToDigit) import Data.Function (on) -import Data.Hashable (Hashable(..)) -import Data.Monoid (Monoid(..)) -import Data.String (IsString(..)) +import Data.Hashable (Hashable(hashWithSalt)) +import Data.Monoid (Monoid(mempty, mappend, mconcat)) +import Data.String (IsString(fromString)) import Data.Text (Text) -import Data.Word (Word8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Foreign (lengthWord16) +import Data.Text.Lazy.Builder (Builder) +import Data.Typeable (Typeable) +import Data.Word (Word8, Word16) +import Database.VCache (VCacheable(put, get)) import Foreign.Storable (sizeOf) -import Prelude hiding (tail, null, length, concat, concatMap, take, drop, +import Prelude hiding (tail, null, length, foldr, concat, concatMap, take, drop, splitAt, break, words, unwords) import qualified Data.ByteString as BS import qualified Data.Text as T -import qualified Prelude +import qualified Data.Text.Lazy.Builder as TLB import MOO.Builtins.Match (Regexp, newRegexp) -type CompiledRegexp = Either (String, Int) Regexp +type CompiledRegexp = Either String Regexp -data MOOString = MOOString { - toText :: Text - , toCaseFold :: Text - , toBinary :: Maybe ByteString - , length :: Int - , regexp :: CompiledRegexp - , regexpCaseless :: CompiledRegexp +data CachedReps = CachedReps { + binaryData :: Maybe ByteString + , caseInsensitiveRegexp :: CompiledRegexp + , caseSensitiveRegexp :: CompiledRegexp } +mkCachedReps :: Text -> CachedReps +mkCachedReps text = CachedReps { + binaryData = decodeBinary text + , caseInsensitiveRegexp = newRegexp text False + , caseSensitiveRegexp = newRegexp text True + } + +data MOOString = MOOString { + toText :: Text + , toCaseFold :: Text + , length :: Int + , cachedReps :: CachedReps + } deriving Typeable + instance IsString MOOString where fromString = fromText . T.pack @@ -102,26 +124,37 @@ instance Show MOOString where show = show . toText +instance VCacheable MOOString where + put = let left = Left :: a -> Either a ByteString + in put . left . encodeUtf8 . toText + get = either (fromText . decodeUtf8) fromBinary <$> get + fromText :: Text -> MOOString fromText text = MOOString { - toText = text - , toCaseFold = caseFold text - , toBinary = decodeBinary text - , length = T.length text - , regexp = newRegexp text True - , regexpCaseless = newRegexp text False + toText = text + , toCaseFold = caseFold text + , length = T.length text + , cachedReps = mkCachedReps text } fromBinary :: ByteString -> MOOString -fromBinary bytes = (fromText $ encodeBinary bytes) { toBinary = Just bytes } +fromBinary bytes = + let str = fromText (encodeBinary bytes) + in str { cachedReps = (cachedReps str) { binaryData = Just bytes } } toString :: MOOString -> String toString = T.unpack . toText +toBuilder :: MOOString -> Builder +toBuilder = TLB.fromText . toText + +toBinary :: MOOString -> Maybe ByteString +toBinary = binaryData . cachedReps + toRegexp :: Bool -- ^ case-matters -> MOOString -> CompiledRegexp -toRegexp True = regexp -toRegexp False = regexpCaseless +toRegexp False = caseInsensitiveRegexp . cachedReps +toRegexp True = caseSensitiveRegexp . cachedReps -- | Case-fold the argument, returning the same argument if the result is -- unchanged to avoid wasting memory. @@ -133,15 +166,15 @@ -- | Encode a MOO /binary string/. encodeBinary :: ByteString -> Text -encodeBinary = T.pack . Prelude.concatMap encode . BS.unpack - where encode :: Word8 -> String +encodeBinary = T.pack . BS.foldr encode [] + where encode :: Word8 -> String -> String encode b - | isAscii c && isPrint c && c /= '~' = [c] - | otherwise = ['~', hex q, hex r] - where n = fromIntegral b - c = toEnum n - (q, r) = n `divMod` 16 - hex = intToDigit + | isAscii c && isPrint c && c /= '~' = (c :) + | otherwise = ('~' :) . (hex q :) . (hex r :) + where n = fromIntegral b :: Int + c = toEnum n :: Char + (q, r) = n `divMod` 16 :: (Int, Int) + hex = intToDigit :: Int -> Char -- | Decode a MOO /binary string/ or return 'Nothing' if the string is -- improperly formatted. @@ -152,13 +185,13 @@ q' <- fromHex q r' <- fromHex r let b = 16 * q' + r' - (b :) `fmap` decode rest + (b :) <$> decode rest decode ('~':_) = Nothing decode (c:rest) - | isAscii c && isPrint c = (b :) `fmap` decode rest + | isAscii c && isPrint c = (b :) <$> decode rest | otherwise = Nothing where b = fromIntegral (fromEnum c) - decode [] = return [] + decode [] = Just [] fromHex :: Char -> Maybe Word8 fromHex c @@ -174,7 +207,7 @@ singleton = fromText . T.singleton storageBytes :: MOOString -> Int -storageBytes str = sizeOf 'x' * (length str + 1) + +storageBytes str = sizeOf (undefined :: Word16) * lengthWord16 (toText str) + sizeOf (undefined :: Int) * 4 -- | Test two strings for indistinguishable (case-sensitive) equality. @@ -188,7 +221,7 @@ tail = fromText . T.tail . toText append :: MOOString -> MOOString -> MOOString -append str1 str2 = fromText $ T.append (toText str1) (toText str2) +append str1 str2 = fromText $ toText str1 `T.append` toText str2 null :: MOOString -> Bool null = T.null . toText @@ -198,6 +231,9 @@ intercalate :: MOOString -> [MOOString] -> MOOString intercalate sep = fromText . T.intercalate (toText sep) . map toText + +foldr :: (Char -> a -> a) -> a -> MOOString -> a +foldr f z = T.foldr f z . toText concat :: [MOOString] -> MOOString concat = fromText . T.concat . map toText diff --git a/src/MOO/Task.hs b/src/MOO/Task.hs --- a/src/MOO/Task.hs +++ b/src/MOO/Task.hs @@ -6,6 +6,7 @@ MOO , Environment(..) , initEnvironment + , liftVTx , liftSTM -- * World Interface @@ -15,8 +16,11 @@ , getWorld' , putWorld , modifyWorld + , updateConnections , getDatabase , putDatabase + , getVSpace + , serverOption -- * Task Interface , Task(..) @@ -33,6 +37,13 @@ , initTask , newTaskId , newTask + , defaultMaxStackDepth + , defaultFgTicks + , defaultBgTicks + , defaultFgSeconds + , defaultBgSeconds + , getDelay + , resetLimits , taskOwner , isQueued , queuedTasks @@ -43,6 +54,7 @@ , requestIO , delayIO , unsafeIOtoMOO + , catchUnsafeIOtoMOO , getTask , putTask , purgeTask @@ -75,15 +87,12 @@ , Continuation(..) , initFrame , formatFrames - , pushFrame - , popFrame , activeFrame , frame , caller , modifyFrame , setLineNumber , mkVariables - , formatTraceback -- * Loop and Try/Finally Control Functions , pushTryFinallyContext @@ -112,7 +121,9 @@ , checkPermission , checkValid , checkFertile + , checkProtectedProperty , checkRecurrence + , checkQueuedTaskLimit -- * Miscellaneous , binaryString @@ -124,40 +135,51 @@ , notyet ) where +import Control.Applicative ((<$>)) import Control.Arrow ((&&&)) import Control.Concurrent (MVar, ThreadId, myThreadId, forkIO, threadDelay, newEmptyMVar, putMVar, tryPutMVar, takeMVar) import Control.Concurrent.STM (STM, TVar, atomically, retry, throwSTM, newEmptyTMVar, putTMVar, takeTMVar, - newTVarIO, readTVar, writeTVar, modifyTVar) -import Control.Exception (SomeException, catch) -import Control.Monad (when, unless, join, liftM, void, (>=>)) + newTVarIO, readTVar, readTVarIO, writeTVar, + modifyTVar) +import Control.Exception (SomeException, try) +import Control.Monad (when, unless, void, (>=>), forM_) import Control.Monad.Cont (ContT, runContT, callCC) import Control.Monad.Reader (ReaderT, runReaderT, local, asks) import Control.Monad.State.Strict (StateT, runStateT, get, gets, modify) import Control.Monad.Trans.Class (lift) -import Control.Monad.Writer (execWriter, tell) +import Control.Monad.Writer (Writer, execWriter, tell) import Data.ByteString (ByteString) +import Data.Function (on) +import Data.HashMap.Lazy (HashMap) import Data.Int (Int32) import Data.List (find) import Data.Map (Map) import Data.Maybe (isNothing, fromMaybe, fromJust) import Data.Monoid (Monoid(mempty, mappend), (<>)) import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) import Data.Time (UTCTime, getCurrentTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Database.VCache (VSpace, VTx, runVTx, getVTxSpace, + PVar, readPVarIO, readPVar, writePVar, modifyPVar) import System.IO.Unsafe (unsafePerformIO) import System.Posix (nanosleep) import System.Random (Random, StdGen, newStdGen, mkStdGen, split, randomR, randomRs) +import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder.Int as TLB +import qualified Database.VCache as DV import MOO.Command +import {-# SOURCE #-} MOO.Compiler +import {-# SOURCE #-} MOO.Connection import {-# SOURCE #-} MOO.Database import {-# SOURCE #-} MOO.Network -import {-# SOURCE #-} MOO.Connection import MOO.Object import MOO.Types import MOO.Verb @@ -165,19 +187,29 @@ import qualified MOO.String as Str -- | This is the basic MOO monad transformer stack. A computation of type --- @'MOO' a@ is an 'STM' transaction that returns a value of type @a@ within --- an environment that supports state, continuations, and local modification. +-- @'MOO' a@ is a 'VTx' transaction (layered on 'STM') that returns a value of +-- type @a@ within an environment that supports state, continuations, and +-- local modification. type MOO = ReaderT Environment (ContT TaskDisposition - (StateT TaskState STM)) + (StateT TaskState VTx)) +-- | Lift a 'VTx' transaction into the 'MOO' monad. +liftVTx :: VTx a -> MOO a +liftVTx = lift . lift . lift + -- | Lift an 'STM' transaction into the 'MOO' monad. liftSTM :: STM a -> MOO a -liftSTM = lift . lift . lift +liftSTM = liftVTx . DV.liftSTM -- | The known universe, as far as the MOO server is concerned data World = World { - database :: Database -- ^ The database of objects + writeLog :: Text -> STM () -- ^ Logging function + + , persistence :: Persistence -- ^ Persistent storage + , checkpoint :: STM () -- ^ Database checkpoint signal + + , database :: Database -- ^ The database of objects , tasks :: Map TaskId Task -- ^ Queued and running tasks , listeners :: Map Point Listener -- ^ Network listening points @@ -196,8 +228,14 @@ -- ^ Shutdown signal } +initWorld :: World initWorld = World { - database = undefined + writeLog = const $ return () + + , persistence = undefined + , checkpoint = return () + + , database = initDatabase , tasks = M.empty , listeners = M.empty @@ -211,12 +249,15 @@ , shutdownMessage = undefined } -newWorld :: Database -> Bool -> IO (TVar World) -newWorld db outboundNetworkEnabled = do +newWorld :: (Text -> STM ()) -> Persistence -> Bool -> IO (TVar World) +newWorld writeLog persist outboundNetworkEnabled = do shutdownVar <- newEmptyMVar + db <- readPVarIO (persistenceDatabase persist) world' <- newTVarIO initWorld { - database = db + writeLog = writeLog + , persistence = persist + , database = db , outboundNetwork = outboundNetworkEnabled , shutdownMessage = shutdownVar } @@ -238,10 +279,7 @@ , taskComputation :: MOO Value } -instance Show Task where - show task = "" - +initTask :: Task initTask = Task { taskId = 0 , taskStatus = Pending @@ -265,12 +303,10 @@ -- storageBytes (taskComputation task) instance Eq Task where - Task { taskId = taskId1 } == Task { taskId = taskId2 } = - taskId1 == taskId2 + (==) = (==) `on` taskId instance Ord Task where - Task { taskState = state1 } `compare` Task { taskState = state2 } = - startTime state1 `compare` startTime state2 + compare = compare `on` (startTime . taskState) type TaskId = Int32 @@ -309,7 +345,6 @@ -- | The running state of a task data TaskStatus = Pending | Running | Forked | Suspended Wake | Reading - deriving Show isQueued :: TaskStatus -> Bool isQueued Pending = False @@ -321,8 +356,7 @@ isRunning _ = False queuedTasks :: MOO [Task] -queuedTasks = - (filter (isQueued . taskStatus) . M.elems . tasks) `liftM` getWorld +queuedTasks = filter (isQueued . taskStatus) . M.elems . tasks <$> getWorld instance Sizeable TaskStatus where storageBytes (Suspended _) = 2 * storageBytes () @@ -331,13 +365,9 @@ -- | A function to call in order to wake a suspended task newtype Wake = Wake (Value -> IO ()) -instance Show Wake where - show _ = "Wake{..}" - -- | The intermediate or final result of a running task data TaskDisposition = Complete Value - | Suspend (Maybe Integer) (Resume ()) - | Read ObjId (Resume Value) + | Suspend (Resume ()) | forall a. RequestIO (IO a) (Resume a) | Uncaught Exception | Timeout Resource CallStack @@ -363,12 +393,13 @@ let env = initEnvironment task comp = taskComputation task comp' = callCC $ \k -> - Complete `liftM` local (\r -> r { interruptHandler = Interrupt k }) comp + Complete <$> local (\r -> r { interruptHandler = Interrupt k }) comp state = taskState task contM = runReaderT comp' env stateM = runContT contM return - stmM = runStateT stateM state - (result, state') <- atomically stmM + vtxM = runStateT stateM state + vspace <- persistenceVSpace . persistence <$> readTVarIO (taskWorld task) + (result, state') <- runVTx vspace vtxM runDelayed $ delayedIO state' return (result, task { taskState = state' { delayedIO = mempty }}) @@ -412,7 +443,7 @@ case disposition of Complete value -> putResult (Just value) - Suspend _ (Resume resume) -> do + Suspend (Resume resume) -> do putResult Nothing -- restart this task only when there are none other running @@ -423,8 +454,6 @@ runTask' task' { taskComputation = resume () } noOp - Read _ _ -> error "read() not yet implemented" - Uncaught exception@Exception { exceptionCode = code , exceptionMessage = message @@ -432,43 +461,44 @@ , exceptionCallStack = Stack frames } -> handleAbortedTask task' formatted putResult $ callSystemVerb "handle_uncaught_error" - [code, Str message, value, traceback, stringList formatted] + [ code, Str message, value, traceback + , fromListBy (Str . Str.fromText) formatted ] where traceback = formatFrames True frames formatted = formatTraceback exception Timeout resource stack@(Stack frames) -> handleAbortedTask task' formatted putResult $ callSystemVerb "handle_task_timeout" - [Str $ showResource resource, traceback, stringList formatted] + [ Str $ showResource resource, traceback + , fromListBy (Str . Str.fromText) formatted ] where traceback = formatFrames True frames formatted = formatTraceback $ timeoutException resource stack Suicide -> putResult Nothing - handleAbortedTask :: Task -> [StrT] -> (Maybe Value -> IO ()) -> + handleAbortedTask :: Task -> [Text] -> (Maybe Value -> IO ()) -> MOO (Maybe Value) -> IO () handleAbortedTask task traceback putResult call = do state <- newState handleAbortedTask' traceback task { taskState = state - , taskComputation = fromMaybe zero `fmap` call + , taskComputation = fromMaybe zero <$> call } - where handleAbortedTask' :: [StrT] -> Task -> IO () + where handleAbortedTask' :: [Text] -> Task -> IO () handleAbortedTask' traceback task = do (disposition, task') <- stepTaskWithIO task case disposition of Complete value -> do unless (truthOf value) $ informPlayer traceback putResult Nothing - Suspend _ (Resume resume) -> do + Suspend (Resume resume) -> do -- The aborted task is considered "handled" but continue -- running the suspended handler (which might abort -- again!) putResult Nothing runTask' task' { taskComputation = resume () } noOp - Read _ _ -> error "read() not yet implemented" Uncaught exception -> do informPlayer traceback informPlayer $ formatTraceback exception @@ -480,14 +510,36 @@ putResult Nothing Suicide -> putResult Nothing - informPlayer :: [StrT] -> IO () + informPlayer :: [Text] -> IO () informPlayer lines = atomically $ do world <- readTVar (taskWorld task) - let maybeConnection = M.lookup (taskPlayer task) (connections world) - case maybeConnection of - Just conn -> mapM_ (sendToConnection conn . Str.toText) lines - Nothing -> return () -- XXX write to server log? + forM_ lines $ writeLog world + case M.lookup (taskPlayer task) (connections world) of + Just conn -> forM_ lines $ sendToConnection conn + Nothing -> return () + +defaultMaxStackDepth :: Num a => a +defaultMaxStackDepth = 50 + +defaultFgTicks :: Num a => a +defaultFgTicks = 30000 + +defaultBgTicks :: Num a => a +defaultBgTicks = 15000 + +defaultFgSeconds :: Num a => a +defaultFgSeconds = 5 + +defaultBgSeconds :: Num a => a +defaultBgSeconds = 3 + +getDelay :: Value -> MOO Integer +getDelay v = case toMicroseconds v of + Just usecs | usecs >= 0 -> return usecs + | otherwise -> raise E_INVARG + Nothing -> raise E_TYPE + -- | Create and queue a task to run the given computation after the given -- microsecond delay. 'E_INVARG' may be raised if the delay is out of -- acceptable range. (The given 'TaskId' should have been reserved by a call @@ -504,16 +556,17 @@ task <- asks task gen <- newRandomGen + maxDepth <- serverOption maxStackDepth let frame = currentFrame (stack state) frame' = frame { - depthLeft = depthLeft initFrame + depthLeft = maxDepth , contextStack = contextStack initFrame , lineNumber = lineNumber frame + 1 } state' = initState { - ticksLeft = 15000 -- XXX + ticksLeft = defaultBgTicks , stack = Stack [frame'] , startTime = estimatedWakeup , randomGen = gen @@ -523,7 +576,7 @@ taskId = taskId , taskStatus = Forked , taskState = state' - , taskComputation = code + , taskComputation = resetLimits False >> code } -- make sure the forked task doesn't start before the current task commits @@ -542,10 +595,10 @@ -- | Wait for the given number of microseconds to elapse. delay :: Integer -> IO () -delay usecs = - if usecs <= fromIntegral (maxBound :: Int) - then threadDelay (fromIntegral usecs) - else nanosleep (usecs * 1000) +delay usecs + | usecs <= maxInt = threadDelay (fromIntegral usecs) + | otherwise = nanosleep (usecs * 1000) + where maxInt = fromIntegral (maxBound :: Int) -- | A continuation for returning to the task dispatcher to handle an -- interrupt request. Note that calling this continuation implies a commit to @@ -583,25 +636,30 @@ -- alternative when the value returned by the IO isn't needed. delayIO :: IO () -> MOO () delayIO io = modify $ \state -> - state { delayedIO = delayedIO state `mappend` DelayedIO io } + state { delayedIO = delayedIO state <> DelayedIO io } --- | Unsafely perform the given IO computation within the current 'STM' --- transaction. +-- | Unsafely perform the given IO action within the current 'STM' +-- transaction, using the supplied exception handler in case the IO throws an +-- exception. -- -- Since 'STM' transactions may be aborted at any time, the IO is performed in -- a separate thread in order to guarantee consistency with any finalizers, -- brackets, and so forth. The IO must be idempotent as it may be run more -- than once. +-- +-- Note that all the hazards of 'unsafePerformIO' apply; in particular, it is +-- incumbent upon the caller to ensure the IO action is executed at least as +-- many times as desired (and not, say, optimized to a single execution). +catchUnsafeIOtoMOO :: IO a -> (SomeException -> MOO a) -> MOO a +catchUnsafeIOtoMOO io catchFunc = either catchFunc return $ unsafePerformIO $ do + r <- newEmptyMVar + forkIO $ try io >>= putMVar r + takeMVar r + +-- | A version of 'catchUnsafeIOtoMOO' that simply propagates any thrown +-- exception into the calling thread, most likely aborting its execution. unsafeIOtoMOO :: IO a -> MOO a -unsafeIOtoMOO io = liftSTM $ do - let result = unsafePerformIO $ do - r <- newEmptyMVar - forkIO $ (io >>= putMVar r . Right) `catch` \e -> - putMVar r $ Left (e :: SomeException) - takeMVar r - case result of - Right x -> return x - Left e -> throwSTM e +unsafeIOtoMOO io = catchUnsafeIOtoMOO io $ liftSTM . throwSTM -- | A 'Reader' environment for state that either doesn't change, or can be -- locally modified for subcomputations @@ -609,7 +667,7 @@ task :: Task , interruptHandler :: InterruptHandler , exceptionHandler :: ExceptionHandler - , indexLength :: MOO Int + , indexLength :: MOO Value } initEnvironment :: Task -> Environment @@ -622,19 +680,22 @@ -- | A 'State' structure for data that may normally change during computation data TaskState = State { - ticksLeft :: Int - , stack :: CallStack - , startTime :: UTCTime - , randomGen :: StdGen - , delayedIO :: DelayedIO + ticksLeft :: Int + , secondsLimit :: Int + , stack :: CallStack + , startTime :: UTCTime + , randomGen :: StdGen + , delayedIO :: DelayedIO } +initState :: TaskState initState = State { - ticksLeft = 30000 - , stack = Stack [] - , startTime = posixSecondsToUTCTime 0 - , randomGen = mkStdGen 0 - , delayedIO = mempty + ticksLeft = defaultFgTicks + , secondsLimit = defaultFgSeconds + , stack = Stack [] + , startTime = posixSecondsToUTCTime 0 + , randomGen = mkStdGen 0 + , delayedIO = mempty } instance Sizeable TaskState where @@ -654,24 +715,46 @@ , randomGen = gen } -getWorld :: MOO World -getWorld = liftSTM . readTVar . taskWorld =<< asks task +-- | Reset the number of ticks and seconds available for the current task +-- based on the latest values obtained from @$server_options@. +resetLimits :: Bool -> MOO () +resetLimits foreground = getServerOptions >>= \options -> modify $ \state -> + state { ticksLeft = (if foreground then fgTicks else bgTicks ) options + , secondsLimit = (if foreground then fgSeconds else bgSeconds) options + } +getServerOptions :: MOO ServerOptions +getServerOptions = serverOptions <$> getDatabase + +-- | Fetch the current setting of a server option obtained from +-- @$server_options@. +serverOption :: (ServerOptions -> a) -> MOO a +serverOption = (<$> getServerOptions) + getWorld' :: MOO (TVar World) getWorld' = asks (taskWorld . task) +getWorld :: MOO World +getWorld = liftSTM . readTVar =<< getWorld' + putWorld :: World -> MOO () -putWorld world = do - world' <- getWorld' - liftSTM $ writeTVar world' world +putWorld world = liftSTM . flip writeTVar world =<< getWorld' modifyWorld :: (World -> World) -> MOO () -modifyWorld f = do - world' <- getWorld' - liftSTM $ modifyTVar world' f +modifyWorld f = liftSTM . flip modifyTVar f =<< getWorld' +updateConnections :: TVar World -> + (Map ObjId Connection -> Map ObjId Connection) -> VTx () +updateConnections world' f = do + world <- DV.liftSTM $ readTVar world' + let connections' = f (connections world) + DV.liftSTM $ writeTVar world' world { connections = connections' } + + writePVar (persistenceConnected $ persistence world) $ M.foldMapWithKey + (\player conn -> [(player, connectionObject conn)]) connections' + getTask :: TaskId -> MOO (Maybe Task) -getTask taskId = (M.lookup taskId . tasks) `liftM` getWorld +getTask taskId = M.lookup taskId . tasks <$> getWorld putTask :: Task -> MOO () putTask task = modifyWorld $ \world -> @@ -682,39 +765,41 @@ world { tasks = M.delete (taskId task) $ tasks world } getDatabase :: MOO Database -getDatabase = database `liftM` getWorld +getDatabase = database <$> getWorld putDatabase :: Database -> MOO () -putDatabase db = modifyWorld $ \world -> world { database = db } +putDatabase db = do + modifyWorld $ \world -> world { database = db } + p <- persistence <$> getWorld + liftVTx $ writePVar (persistenceDatabase p) db + +getVSpace :: MOO VSpace +getVSpace = liftVTx getVTxSpace + getPlayer :: MOO ObjId getPlayer = asks (taskPlayer . task) getObject :: ObjId -> MOO (Maybe Object) -getObject oid = liftSTM . dbObject oid =<< getDatabase +getObject oid = liftVTx . dbObject oid =<< getDatabase getObjectName :: ObjId -> MOO StrT -getObjectName oid = do - obj <- getObject oid - let objNum = Str.fromText (toText $ Obj oid) - - return $ maybe objNum (\obj -> Str.concat [objectName obj, - " (", objNum, ")"]) obj +getObjectName oid = maybe objNum objNameNum <$> getObject oid + where objNum = Str.fromText (toText $ Obj oid) + objNameNum obj = Str.concat [objectName obj, " (", objNum, ")"] getProperty :: Object -> StrT -> MOO Property -getProperty obj name = do - maybeProp <- liftSTM $ lookupProperty obj name - maybe (raise E_PROPNF) return maybeProp +getProperty obj name = liftVTx (lookupProperty obj name) >>= + maybe (raise E_PROPNF) return getVerb :: Object -> Value -> MOO Verb getVerb obj desc@Str{} = do - maybeVerb <- liftSTM $ lookupVerb obj desc - maybe (raise E_VERBNF) return maybeVerb + numericStrings <- serverOption supportNumericVerbnameStrings + liftVTx (lookupVerb numericStrings obj desc) >>= maybe (raise E_VERBNF) return getVerb obj desc@(Int index) | index < 1 = raise E_INVARG - | otherwise = do - maybeVerb <- liftSTM $ lookupVerb obj desc - maybe (raise E_VERBNF) return maybeVerb + | otherwise = liftVTx (lookupVerb False obj desc) >>= + maybe (raise E_VERBNF) return getVerb _ _ = raise E_TYPE findVerb :: (Verb -> Bool) -> StrT -> ObjId -> MOO (Maybe ObjId, Maybe Verb) @@ -722,33 +807,28 @@ where findVerb' oid = do maybeObj <- getObject oid case maybeObj of - Nothing -> return (Nothing, Nothing) Just obj -> do - maybeVerb <- searchVerbs (objectVerbs obj) + maybeVerb <- liftVTx $ searchVerbs (objectVerbs obj) case maybeVerb of Just verb -> return (Just oid, Just verb) Nothing -> maybe (return (Just oid, Nothing)) findVerb' (objectParent obj) + Nothing -> return (Nothing, Nothing) - searchVerbs ((names,verbTVar):rest) = - if verbNameMatch name names - then do - verb <- liftSTM $ readTVar verbTVar - if acceptable verb - then return (Just verb) - else searchVerbs rest - else searchVerbs rest + searchVerbs :: [([StrT], PVar Verb)] -> VTx (Maybe Verb) + searchVerbs ((names,verbPVar):rest) + | verbNameMatch name names = readPVar verbPVar >>= \verb -> + if acceptable verb then return (Just verb) else searchVerbs rest + | otherwise = searchVerbs rest searchVerbs [] = return Nothing callSystemVerb :: StrT -> [Value] -> MOO (Maybe Value) callSystemVerb name args = callSystemVerb' systemObject name args Str.empty callSystemVerb' :: ObjId -> StrT -> [Value] -> StrT -> MOO (Maybe Value) -callSystemVerb' object name args argstr = do - player <- asks (taskPlayer . task) - maybeVerb <- findVerb verbPermX name object - case maybeVerb of - (Just verbOid, Just verb) -> do +callSystemVerb' object name args argstr = getPlayer >>= \player -> + findVerb verbPermX name object >>= \found -> case found of + (Just verbLoc, Just verb) -> let vars = mkVariables [ ("player", Obj player) , ("this" , Obj object) @@ -756,23 +836,24 @@ , ("args" , fromList args) , ("argstr", Str argstr) ] - Just `liftM` runVerb verb initFrame { + in Just <$> runVerb verb initFrame { variables = vars , verbName = name - , verbLocation = verbOid + , verbLocation = verbLoc , initialThis = object , initialPlayer = player } _ -> return Nothing callCommandVerb :: ObjId -> (ObjId, Verb) -> ObjId -> - Command -> (ObjId, ObjId) -> MOO Value -callCommandVerb player (verbOid, verb) this command (dobj, iobj) = do - let vars = mkVariables [ + Command -> ObjId -> ObjId -> MOO Value +callCommandVerb player (verbLoc, verb) this command dobj iobj = + let name = commandVerb command + vars = mkVariables [ ("player" , Obj player) , ("this" , Obj this) , ("caller" , Obj player) - , ("verb" , Str $ commandVerb command) + , ("verb" , Str name) , ("argstr" , Str $ commandArgStr command) , ("args" , stringList $ commandArgs command) , ("dobjstr", Str $ commandDObjStr command) @@ -781,98 +862,86 @@ , ("iobjstr", Str $ commandIObjStr command) , ("iobj" , Obj iobj) ] - - runVerb verb initFrame { + in runVerb verb initFrame { variables = vars - , verbName = commandVerb command - , verbLocation = verbOid + , verbName = name + , verbLocation = verbLoc , initialThis = this , initialPlayer = player } -callVerb' :: (ObjId, Verb) -> ObjId -> StrT -> [Value] -> MOO Value -callVerb' (verbOid, verb) this name args = do +callVerb' :: ObjId -> ObjId -> Verb -> StrT -> [Value] -> MOO Value +callVerb' this verbLoc verb name args = do thisFrame <- frame id wizard <- isWizard (permissions thisFrame) - let player = case (wizard, vars M.! "player") of + let var = (vars HM.!) + player = case (wizard, var "player") of (True, Obj oid) -> oid _ -> initialPlayer thisFrame - vars = variables thisFrame - vars' = mkVariables [ - ("this" , Obj this) - , ("verb" , Str name) - , ("args" , fromList args) - , ("caller" , Obj $ initialThis thisFrame) - , ("player" , Obj player) - , ("argstr" , vars M.! "argstr") - , ("dobjstr", vars M.! "dobjstr") - , ("dobj" , vars M.! "dobj") - , ("prepstr", vars M.! "prepstr") - , ("iobjstr", vars M.! "iobjstr") - , ("iobj" , vars M.! "iobj") + vars = variables thisFrame + vars' = mkVariables [ + ("this" , Obj this) + , ("verb" , Str name) + , ("args" , fromList args) + , ("caller", Obj $ initialThis thisFrame) + , ("player", Obj player) + , retain "argstr" + , retain "dobjstr" + , retain "dobj" + , retain "prepstr" + , retain "iobjstr" + , retain "iobj" ] + retain x = (x, var x) runVerb verb initFrame { variables = vars' , verbName = name - , verbLocation = verbOid + , verbLocation = verbLoc , initialThis = this , initialPlayer = player } callVerb :: ObjId -> ObjId -> StrT -> [Value] -> MOO Value -callVerb verbLoc this name args = do - maybeVerb <- findVerb verbPermX name verbLoc - case maybeVerb of - (Just verbOid, Just verb) -> callVerb' (verbOid, verb) this name args - (Nothing , _) -> raise E_INVIND - (_ , Nothing) -> raise E_VERBNF +callVerb this oid name args = + findVerb verbPermX name oid >>= \found -> case found of + (Just verbLoc, Just verb) -> callVerb' this verbLoc verb name args + (Nothing , _ ) -> raise E_INVIND + (_ , Nothing ) -> raise E_VERBNF -callFromFunc :: StrT -> IntT -> (ObjId, StrT) -> [Value] -> MOO (Maybe Value) -callFromFunc func index (oid, name) args = do - maybeVerb <- findVerb verbPermX name oid - case maybeVerb of - (Just verbOid, Just verb) -> liftM Just $ evalFromFunc func index $ - callVerb' (verbOid, verb) oid name args +callFromFunc :: StrT -> LineNo -> (ObjId, StrT) -> [Value] -> MOO (Maybe Value) +callFromFunc func index (oid, name) args = + findVerb verbPermX name oid >>= \found -> case found of + (Just verbLoc, Just verb) -> fmap Just $ evalFromFunc func index $ + callVerb' oid verbLoc verb name args _ -> return Nothing -evalFromFunc :: StrT -> IntT -> MOO Value -> MOO Value +evalFromFunc :: StrT -> LineNo -> MOO Value -> MOO Value evalFromFunc func index code = do (depthLeft, player) <- frame (depthLeft &&& initialPlayer) - pushFrame initFrame { + code `runInFrame` initFrame { depthLeft = depthLeft , verbName = func , initialPlayer = player , builtinFunc = True , lineNumber = index } - value <- code `catchException` \except -> do - popFrame - passException except - popFrame - return value runVerb :: Verb -> StackFrame -> MOO Value runVerb verb verbFrame = do Stack frames <- gets stack - let depthLeft' = depthLeft $ case frames of - frame:_ -> frame - [] -> initFrame + depthLeft' <- case frames of + frame:_ -> return (depthLeft frame) + [] -> serverOption maxStackDepth unless (depthLeft' > 0) $ raise E_MAXREC - pushFrame verbFrame { + compile (verbProgram verb) `runInFrame` verbFrame { depthLeft = depthLeft' - 1 , debugBit = verbPermD verb , permissions = verbOwner verb , verbFullName = verbNames verb } - value <- verbCode verb `catchException` \except -> do - popFrame - passException except - popFrame - return value - runTick :: MOO () runTick = do ticksLeft <- gets ticksLeft @@ -880,101 +949,100 @@ modify $ \state -> state { ticksLeft = ticksLeft - 1 } modifyProperty :: Object -> StrT -> (Property -> MOO Property) -> MOO () -modifyProperty obj name f = - case lookupPropertyRef obj name of - Nothing -> raise E_PROPNF - Just propTVar -> do - prop <- liftSTM $ readTVar propTVar - prop' <- f prop - liftSTM $ writeTVar propTVar prop' +modifyProperty obj name f = case lookupPropertyRef obj name of + Just propPVar -> do + prop <- liftVTx $ readPVar propPVar + prop' <- f prop + liftVTx $ writePVar propPVar prop' + Nothing -> raise E_PROPNF modifyVerb :: (ObjId, Object) -> Value -> (Verb -> MOO Verb) -> MOO () -modifyVerb (oid, obj) desc f = - case lookupVerbRef obj desc of - Nothing -> raise E_VERBNF - Just (index, verbTVar) -> do - verb <- liftSTM $ readTVar verbTVar +modifyVerb (oid, obj) desc f = do + numericStrings <- serverOption supportNumericVerbnameStrings + case lookupVerbRef numericStrings obj desc of + Just (index, verbPVar) -> do + verb <- liftVTx $ readPVar verbPVar verb' <- f verb - liftSTM $ writeTVar verbTVar verb' + liftVTx $ writePVar verbPVar verb' unless (verbNames verb `Str.equal` verbNames verb') $ do db <- getDatabase - liftSTM $ modifyObject oid db $ replaceVerb index verb' + liftVTx $ modifyObject oid db $ replaceVerb index verb' + Nothing -> raise E_VERBNF readProperty :: ObjId -> StrT -> MOO (Maybe Value) -readProperty oid name = do - maybeObj <- getObject oid +readProperty oid name = getObject oid >>= \maybeObj -> case maybeObj of - Nothing -> return Nothing Just obj -> maybe (search obj) (return . Just . ($ obj)) $ builtinProperty name - where search obj = do - maybeProp <- liftSTM $ lookupProperty obj name + Nothing -> return Nothing + + where search :: Object -> MOO (Maybe Value) + search obj = do + maybeProp <- liftVTx $ lookupProperty obj name case maybeProp of - Nothing -> return Nothing Just prop -> case propertyValue prop of Nothing -> do parentObj <- maybe (return Nothing) getObject (objectParent obj) maybe (error $ "No inherited value for property " ++ Str.toString name) search parentObj just -> return just + Nothing -> return Nothing writeProperty :: ObjId -> StrT -> Value -> MOO () -writeProperty oid name value = do - maybeObj <- getObject oid +writeProperty oid name value = getObject oid >>= \maybeObj -> case maybeObj of - Nothing -> return () - Just obj -> - if isBuiltinProperty name - then setBuiltinProperty (oid, obj) name value - else case lookupPropertyRef obj name of - Nothing -> return () - Just propTVar -> liftSTM $ do - prop <- readTVar propTVar - writeTVar propTVar prop { propertyValue = Just value } + Just obj + | isBuiltinProperty name -> setBuiltinProperty (oid, obj) name value + | otherwise -> case lookupPropertyRef obj name of + Just propPVar -> liftVTx $ modifyPVar propPVar $ + \prop -> prop { propertyValue = Just value } + Nothing -> return () + Nothing -> return () +modifyObject' :: ObjId -> (Object -> Object) -> MOO () +modifyObject' oid f = getDatabase >>= \db -> + liftVTx $ modifyObject oid db $ return . f + setBuiltinProperty :: (ObjId, Object) -> StrT -> Value -> MOO () setBuiltinProperty (oid, obj) "name" (Str name) = do if objectIsPlayer obj then checkWizard else checkPermission (objectOwner obj) - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> return obj { objectName = name } + modifyObject' oid $ \obj -> obj { objectName = name } setBuiltinProperty (oid, _) "owner" (Obj owner) = do checkWizard - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> return obj { objectOwner = owner } + modifyObject' oid $ \obj -> obj { objectOwner = owner } setBuiltinProperty _ "location" (Obj _) = raise E_PERM setBuiltinProperty _ "contents" (Lst _) = raise E_PERM setBuiltinProperty (oid, _) "programmer" bit = do checkWizard - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> - return obj { objectProgrammer = truthOf bit } -setBuiltinProperty (oid, _) "wizard" bit = do + modifyObject' oid $ \obj -> obj { objectProgrammer = truthOf bit } +setBuiltinProperty (oid, obj) "wizard" bit = do checkWizard - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> - return obj { objectWizard = truthOf bit } + when (objectWizard obj /= bit') $ do + writeLog' <- writeLog <$> getWorld + programmer <- frame permissions + liftSTM $ writeLog' $ (if bit' then "" else "DE") <> "WIZARDED: " <> + toText (Obj oid) <> " by programmer " <> toText (Obj programmer) + setWizardBit `catchException` (liftSTM . mapM_ writeLog' . formatTraceback) + where bit' = truthOf bit + setWizardBit = do + modifyObject' oid $ \obj -> obj { objectWizard = bit' } + let message = "Wizard bit " <> if bit' then "set." else "unset." + raiseException (Err E_NONE) message bit setBuiltinProperty (oid, obj) "r" bit = do checkPermission (objectOwner obj) - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> - return obj { objectPermR = truthOf bit } + modifyObject' oid $ \obj -> obj { objectPermR = truthOf bit } setBuiltinProperty (oid, obj) "w" bit = do checkPermission (objectOwner obj) - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> - return obj { objectPermW = truthOf bit } + modifyObject' oid $ \obj -> obj { objectPermW = truthOf bit } setBuiltinProperty (oid, obj) "f" bit = do checkPermission (objectOwner obj) - db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> - return obj { objectPermF = truthOf bit } + modifyObject' oid $ \obj -> obj { objectPermF = truthOf bit } setBuiltinProperty _ _ _ = raise E_TYPE -- | The stack of verb and/or built-in function frames newtype CallStack = Stack [StackFrame] - deriving Show instance Sizeable CallStack where storageBytes (Stack stack) = storageBytes stack @@ -1005,18 +1073,12 @@ storageBytes TryFinally{} = storageBytes () -- storageBytes (finally context) -instance Show Context where - show Loop { loopName = Nothing } = "" - show Loop { loopName = Just name } = "" - - show TryFinally{} = "" - -- | The data tracked for each verb and/or built-in function call data StackFrame = Frame { depthLeft :: Int , contextStack :: [Context] - , variables :: Map Id Value + , variables :: HashMap Id Value , debugBit :: Bool , permissions :: ObjId @@ -1027,11 +1089,12 @@ , initialPlayer :: ObjId , builtinFunc :: Bool - , lineNumber :: IntT - } deriving Show + , lineNumber :: LineNo + } +initFrame :: StackFrame initFrame = Frame { - depthLeft = 50 + depthLeft = defaultMaxStackDepth , contextStack = [] , variables = initVariables @@ -1065,24 +1128,33 @@ formatFrames :: Bool -> [StackFrame] -> Value formatFrames includeLineNumbers = fromListBy formatFrame - where formatFrame frame = fromList $ - Obj (initialThis frame) - : Str (verbName frame) - : Obj (permissions frame) - : Obj (verbLocation frame) - : Obj (initialPlayer frame) - : [Int $ lineNumber frame | includeLineNumbers] -pushFrame :: StackFrame -> MOO () -pushFrame frame = modify $ \state@State { stack = Stack frames } -> - state { stack = Stack (frame : frames) } + where formatFrame :: StackFrame -> Value + formatFrame frame = fromList $ + Obj (initialThis frame) + : Str (verbName frame) + : Obj (permissions frame) + : Obj (verbLocation frame) + : Obj (initialPlayer frame) + : [Int $ fromIntegral $ lineNumber frame | includeLineNumbers] -popFrame :: MOO () -popFrame = do - unwindContexts (const False) - modify $ \state@State { stack = Stack (_:frames) } -> - state { stack = Stack frames } +runInFrame :: MOO a -> StackFrame -> MOO a +runInFrame code frame = do + pushFrame frame + result <- code `catchException` \except -> popFrame >> passException except + popFrame + return result + where pushFrame :: StackFrame -> MOO () + pushFrame frame = modify $ \state@State { stack = Stack frames } -> + state { stack = Stack (frame : frames) } + + popFrame :: MOO () + popFrame = do + unwindContexts (const False) + modify $ \state@State { stack = Stack (_:frames) } -> + state { stack = Stack frames } + currentFrame :: CallStack -> StackFrame currentFrame (Stack (frame:_)) = frame currentFrame (Stack []) = error "currentFrame: Empty call stack" @@ -1105,12 +1177,11 @@ caller f = gets (fmap f . previousFrame . stack) modifyFrame :: (StackFrame -> StackFrame) -> MOO () -modifyFrame f = modify $ \state@State { stack = Stack (frame:stack) } -> - state { stack = Stack (f frame : stack) } +modifyFrame f = modify $ \state@State { stack = Stack (frame:frames) } -> + state { stack = Stack (f frame : frames) } -setLineNumber :: Int -> MOO () -setLineNumber lineNumber = modifyFrame $ \frame -> - frame { lineNumber = fromIntegral lineNumber } +setLineNumber :: LineNo -> MOO () +setLineNumber lineNo = modifyFrame $ \frame -> frame { lineNumber = lineNo } pushContext :: Context -> MOO () pushContext context = modifyFrame $ \frame -> @@ -1142,23 +1213,26 @@ stack <- unwind =<< frame contextStack modifyFrame $ \frame -> frame { contextStack = stack } return stack - where unwind stack@(this:next) = - if p this - then return stack - else do - case this of - TryFinally { finally = finally } -> do - modifyFrame $ \frame -> frame { contextStack = next } - void finally - _ -> return () - unwind next + + where unwind :: [Context] -> MOO [Context] + unwind stack@(this:next) + | p this = return stack + | otherwise = do + case this of + TryFinally { finally = finally } -> do + modifyFrame $ \frame -> frame { contextStack = next } + void finally + _ -> return () + unwind next unwind [] = return [] unwindLoopContext :: Maybe Id -> MOO Context unwindLoopContext maybeName = do loop:_ <- unwindContexts testContext return loop - where testContext Loop { loopName = name } = + + where testContext :: Context -> Bool + testContext Loop { loopName = name } = isNothing maybeName || maybeName == name testContext _ = False @@ -1173,42 +1247,42 @@ continue () -- | The default collection of verb variables -initVariables :: Map Id Value -initVariables = M.fromList $ [ - ("player" , Obj nothing) - , ("this" , Obj nothing) - , ("caller" , Obj nothing) +initVariables :: HashMap Id Value +initVariables = HM.fromList $ [ + ("player" , noObject) + , ("this" , noObject) + , ("caller" , noObject) , ("args" , emptyList) , ("argstr" , emptyString) , ("verb" , emptyString) , ("dobjstr", emptyString) - , ("dobj" , Obj nothing) + , ("dobj" , noObject) , ("prepstr", emptyString) , ("iobjstr", emptyString) - , ("iobj" , Obj nothing) + , ("iobj" , noObject) ] ++ typeVariables - where typeVariables = [ - ("INT" , Int $ typeCode TInt) - , ("NUM" , Int $ typeCode TInt) - , ("FLOAT", Int $ typeCode TFlt) - , ("LIST" , Int $ typeCode TLst) - , ("STR" , Int $ typeCode TStr) - , ("OBJ" , Int $ typeCode TObj) - , ("ERR" , Int $ typeCode TErr) + where noObject = Obj nothing :: Value + + typeVariables :: [(Id, Value)] + typeVariables = map (fmap $ Int . typeCode) [ + ("INT" , TInt) + , ("NUM" , TInt) + , ("FLOAT", TFlt) + , ("LIST" , TLst) + , ("STR" , TStr) + , ("OBJ" , TObj) + , ("ERR" , TErr) ] -- | Create a variable block for a verb by overriding the default. -mkVariables :: [(Id, Value)] -> Map Id Value -mkVariables = foldr (uncurry M.insert) initVariables +mkVariables :: [(Id, Value)] -> HashMap Id Value +mkVariables = foldr (uncurry HM.insert) initVariables newtype ExceptionHandler = Handler (Exception -> MOO Value) -instance Show ExceptionHandler where - show _ = "" - -- | A MOO exception data Exception = Exception { exceptionCode :: Code @@ -1224,6 +1298,7 @@ type Code = Value type Message = StrT +initException :: Exception initException = Exception { exceptionCode = Err E_NONE , exceptionMessage = Str.fromText (error2text E_NONE) @@ -1298,7 +1373,7 @@ -- not. checkProgrammer' :: ObjId -> MOO () checkProgrammer' perm = do - programmer <- maybe False objectProgrammer `liftM` getObject perm + programmer <- maybe False objectProgrammer <$> getObject perm unless programmer $ raise E_PERM -- | Verify that the current task permissions have programmer privileges, @@ -1308,7 +1383,7 @@ -- | Determine whether the given object has its wizard bit set. isWizard :: ObjId -> MOO Bool -isWizard = liftM (maybe False objectWizard) . getObject +isWizard = fmap (maybe False objectWizard) . getObject -- | Verify that the given object is a wizard, raising 'E_PERM' if not. checkWizard' :: ObjId -> MOO () @@ -1336,12 +1411,18 @@ -- | Verify that the given object is fertile for the current task permissions, -- raising 'E_PERM' if not. checkFertile :: ObjId -> MOO () -checkFertile oid = do - maybeObj <- getObject oid - case maybeObj of - Nothing -> raise E_PERM - Just obj -> unless (objectPermF obj) $ checkPermission (objectOwner obj) +checkFertile = getObject >=> maybe (raise E_PERM) checkFertile' + where checkFertile' obj = unless (objectPermF obj) $ + checkPermission (objectOwner obj) +-- | Verify that the named built-in property is not protected by +-- @$server_options.protect_/prop/@, or that the current task permissions have +-- wizard privileges if it is, raising 'E_PERM' otherwise. +checkProtectedProperty :: Id -> MOO () +checkProtectedProperty name = do + protected <- ($ name) <$> serverOption protectProperty + when protected checkWizard + -- | Verify that the given /object/ does not have a recursive relationship -- with the given /subject/, raising 'E_RECMOVE' if so. checkRecurrence :: (Object -> Maybe ObjId) -- ^ relationship projection @@ -1352,57 +1433,72 @@ where checkRecurrence' object = do when (object == subject) $ raise E_RECMOVE maybeObject <- getObject object - case join $ relation `fmap` maybeObject of - Just oid -> checkRecurrence' oid - Nothing -> return () + maybe (return ()) checkRecurrence' $ maybeObject >>= relation +-- | Verify that the programmer has not reached their queued task limit +-- (before creating a new forked, suspended, or reading task). +checkQueuedTaskLimit :: MOO () +checkQueuedTaskLimit = do + programmer <- frame permissions + programmerLimit <- readProperty programmer "queued_task_limit" + limit <- case programmerLimit of + Just (Int n) | n >= 0 -> return (Just $ fromIntegral n) + _ -> serverOption queuedTaskLimit + + case limit of + Just limit -> do + tasks <- filter ((== programmer) . taskOwner) <$> queuedTasks + when (length tasks >= limit) $ raise E_QUOTA + Nothing -> return () + -- | Translate a MOO /binary string/ into a Haskell 'ByteString', raising -- 'E_INVARG' if the MOO string is improperly formatted. binaryString :: StrT -> MOO ByteString binaryString = maybe (raise E_INVARG) return . Str.toBinary --- | Generate and return a pseudorandom number in the given range, modifying +-- | Generate and return a pseudorandom value in the given range, modifying -- the local generator state. -random :: (Random a) => (a, a) -> MOO a -random range = do - (r, gen) <- randomR range `liftM` gets randomGen - modify $ \state -> state { randomGen = gen } - return r +random :: Random a => (a, a) -> MOO a +random = getRandom . randomR -- | Split the local random number generator state in two, updating the local -- state with one of them and returning the other. newRandomGen :: MOO StdGen -newRandomGen = do - (gen, gen') <- split `liftM` gets randomGen +newRandomGen = getRandom split + +getRandom :: (StdGen -> (a, StdGen)) -> MOO a +getRandom f = do + (r, gen) <- f <$> gets randomGen modify $ \state -> state { randomGen = gen } - return gen' + return r -- | Generate traceback lines for an exception, suitable for displaying to a -- user. -formatTraceback :: Exception -> [StrT] +formatTraceback :: Exception -> [Text] formatTraceback except@Exception { exceptionCallStack = Stack frames } = - map Str.fromText $ T.splitOn "\n" $ execWriter (traceback frames) + T.splitOn "\n" $ builder2text $ execWriter (traceback frames) - where traceback (frame:frames) = do - describeVerb frame - tell $ ": " <> Str.toText (exceptionMessage except) - traceback' frames + where traceback :: [StackFrame] -> Writer Builder () + traceback (frame:frames) = + describeVerb frame >> tell ": " >> traceback' frames traceback [] = traceback' [] - traceback' (frame:frames) = do - tell "\n... called from " - describeVerb frame - traceback' frames - traceback' [] = tell "\n(End of traceback)" + traceback' :: [StackFrame] -> Writer Builder () + traceback' frames = do + tell $ Str.toBuilder (exceptionMessage except) + forM_ frames $ \frame -> + tell "\n... called from " >> describeVerb frame + tell "\n(End of traceback)" + describeVerb :: StackFrame -> Writer Builder () describeVerb Frame { builtinFunc = False , verbLocation = loc, verbFullName = name , initialThis = this, lineNumber = line } = do - tell $ "#" <> T.pack (show loc) <> ":" <> Str.toText name - when (loc /= this) $ tell $ " (this == #" <> T.pack (show this) <> ")" - when (line > 0) $ tell $ ", line " <> T.pack (show line) + tell $ "#" <> TLB.decimal loc <> ":" <> Str.toBuilder name + when (this /= loc) $ tell $ " (this == #" <> TLB.decimal this <> ")" + when (line > 0) $ tell $ ", line " <> TLB.decimal line describeVerb Frame { builtinFunc = True, verbName = name } = - tell $ "built-in function " <> Str.toText name <> "()" + tell $ "built-in function " <> Str.toBuilder name <> "()" -- | Begin the server shutdown process. shutdown :: StrT -> MOO () diff --git a/src/MOO/Task.hs-boot b/src/MOO/Task.hs-boot --- a/src/MOO/Task.hs-boot +++ b/src/MOO/Task.hs-boot @@ -16,10 +16,11 @@ , notyet ) where -import Control.Concurrent.STM (STM, TVar) +import Control.Concurrent.STM (TVar) import Control.Monad.Reader (ReaderT) import Control.Monad.Cont (ContT) import Control.Monad.State.Strict (StateT) +import Database.VCache (VTx) import {-# SOURCE #-} MOO.Command import {-# SOURCE #-} MOO.Object @@ -33,7 +34,7 @@ type MOO = ReaderT Environment (ContT TaskDisposition - (StateT TaskState STM)) + (StateT TaskState VTx)) requestIO :: IO a -> MOO a delayIO :: IO () -> MOO () @@ -46,7 +47,7 @@ readProperty :: ObjId -> StrT -> MOO (Maybe Value) findVerb :: (Verb -> Bool) -> StrT -> ObjId -> MOO (Maybe ObjId, Maybe Verb) callCommandVerb :: ObjId -> (ObjId, Verb) -> ObjId -> - Command -> (ObjId, ObjId) -> MOO Value + Command -> ObjId -> ObjId -> MOO Value raise :: Error -> MOO a notyet :: StrT -> MOO a diff --git a/src/MOO/Types.hs b/src/MOO/Types.hs --- a/src/MOO/Types.hs +++ b/src/MOO/Types.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE CPP, OverloadedStrings, FlexibleInstances, + GeneralizedNewtypeDeriving, DeriveDataTypeable #-} -- | Basic data types used throughout the MOO server code module MOO.Types ( @@ -15,6 +16,8 @@ , ObjId , Id + , LineNo + -- * MOO Type and Value Reification , Type(..) , Value(..) @@ -27,24 +30,30 @@ -- * Type and Value Functions , fromId , toId - , string2builder - - , fromInt - , fromFlt - , fromStr - , fromObj - , fromErr - , fromLst + , builder2text , equal + , comparable + , truthOf , truthValue - , typeOf + , typeOf , typeCode + , intValue + , fltValue + , strValue + , objValue + , errValue + , lstValue + , toText + , toBuilder + , toBuilder' , toLiteral + , toMicroseconds + , error2text -- * List Convenience Functions @@ -53,10 +62,6 @@ , stringList , objectList - , listSet - , listInsert - , listDelete - -- * Miscellaneous , endOfTime @@ -65,19 +70,25 @@ ) where +import Control.Applicative ((<$>)) import Control.Concurrent (ThreadId) import Control.Concurrent.STM (TVar) -import Control.Monad (liftM) import Data.CaseInsensitive (CI) +import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.Int (Int32, Int64) import Data.IntSet (IntSet) +import Data.List (intersperse) import Data.Map (Map) +import Data.Monoid (Monoid, (<>), mappend, mconcat) +import Data.String (IsString) import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Lazy.Builder (Builder) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Vector (Vector) +import Data.Typeable (Typeable) +import Database.VCache (VCacheable(put, get), PVar) import Foreign.Storable (sizeOf) import System.Random (StdGen) @@ -86,11 +97,15 @@ import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as VM +import qualified Data.Text.Lazy.Builder.Int as TLB +import qualified Data.Text.Lazy.Builder.RealFloat as TLB +import {-# SOURCE #-} MOO.List (MOOList) import MOO.String (MOOString) + +import {-# SOURCE #-} qualified MOO.List as Lst import qualified MOO.String as Str -- | The 'Sizeable' class is used to estimate the storage requirements of @@ -131,8 +146,8 @@ instance Sizeable s => Sizeable (CI s) where storageBytes = (* 2) . storageBytes . CI.original -instance Sizeable a => Sizeable (Vector a) where - storageBytes v = V.sum (V.map storageBytes v) +instance Sizeable MOOList where + storageBytes = Lst.storageBytes instance Sizeable a => Sizeable [a] where storageBytes = foldr bytes (storageBytes ()) @@ -168,6 +183,20 @@ instance Sizeable (TVar a) where storageBytes _ = storageBytes () +instance Sizeable (PVar a) where + storageBytes _ = storageBytes () + +{- +-- Unfortunately these can cause vcache deadlock + +instance VCacheable a => Sizeable (PVar a) where + storageBytes var = unsafePerformIO $ + storageBytes . vref (pvar_space var) <$> readPVarIO var + +instance Sizeable (VRef a) where + storageBytes ref = unsafePerformIO $ unsafeVRefEncoding ref $ const return +-} + # ifdef MOO_64BIT_INTEGER type IntT = Int64 # else @@ -178,44 +207,72 @@ type StrT = MOOString -- ^ MOO string type ObjT = ObjId -- ^ MOO object number type ErrT = Error -- ^ MOO error -type LstT = Vector Value -- ^ MOO list +type LstT = MOOList -- ^ MOO list type ObjId = Int -- ^ MOO object number -type Id = CI Text -- ^ MOO identifier (string lite) +type LineNo = Int -- ^ MOO code line number + +-- | MOO identifier (string lite) +newtype Id = Id { unId :: CI Text } + deriving (Eq, Ord, Show, Monoid, IsString, + Hashable, Sizeable, Typeable) + +instance VCacheable Id where + put = put . encodeUtf8 . fromId + get = toId . decodeUtf8 <$> get + -- | Convert an identifier to and from another type. class Ident a where fromId :: Id -> a toId :: a -> Id -instance Ident String where - fromId = T.unpack . CI.original - toId = CI.mk . T.pack +instance Ident [Char] where + fromId = T.unpack . CI.original . unId + toId = Id . CI.mk . T.pack instance Ident Text where - fromId = CI.original - toId = CI.mk + fromId = CI.original . unId + toId = Id . CI.mk instance Ident MOOString where - fromId = Str.fromText . CI.original - toId = CI.mk . Str.toText + fromId = Str.fromText . CI.original . unId + toId = Id . CI.mk . Str.toText instance Ident Builder where - fromId = TLB.fromText . CI.original - toId = error "Unsupported conversion from Builder to Id" + fromId = TLB.fromText . CI.original . unId + toId = Id . CI.mk . builder2text -string2builder :: StrT -> Builder -string2builder = TLB.fromText . Str.toText +builder2text :: Builder -> Text +builder2text = TL.toStrict . TLB.toLazyText -- | A 'Value' represents any MOO value. -data Value = Int !IntT -- ^ integer - | Flt !FltT -- ^ floating-point number - | Str !StrT -- ^ string - | Obj !ObjT -- ^ object number - | Err !ErrT -- ^ error - | Lst !LstT -- ^ list - deriving (Eq, Show) +data Value = Int IntT -- ^ integer + | Flt FltT -- ^ floating-point number + | Str StrT -- ^ string + | Obj ObjT -- ^ object number + | Err ErrT -- ^ error + | Lst LstT -- ^ list + deriving (Eq, Show, Typeable) +instance VCacheable Value where + put v = put (typeOf v) >> case v of + Int x -> put (toInteger x) + Flt x -> put $ if isNegativeZero x then Nothing else Just (decodeFloat x) + Str x -> put x + Obj x -> put (toInteger x) + Err x -> put (fromEnum x) + Lst x -> put x + + get = get >>= \t -> case t of + TInt -> Int . fromInteger <$> get + TFlt -> Flt . maybe (-0.0) (uncurry encodeFloat) <$> get + TStr -> Str <$> get + TObj -> Obj . fromInteger <$> get + TErr -> Err . toEnum <$> get + TLst -> Lst <$> get + _ -> fail $ "get: unknown Value type (" ++ show (fromEnum t) ++ ")" + instance Sizeable Value where storageBytes value = case value of Int x -> box + storageBytes x @@ -226,9 +283,9 @@ Lst x -> box + storageBytes x where box = storageBytes () --- | A default (false) MOO value +-- | A default MOO value zero :: Value -zero = truthValue False +zero = Int 0 -- | An empty MOO string emptyString :: Value @@ -236,42 +293,29 @@ -- | An empty MOO list emptyList :: Value -emptyList = Lst V.empty - -fromInt :: Value -> IntT -fromInt (Int x) = x - -fromFlt :: Value -> FltT -fromFlt (Flt x) = x - -fromStr :: Value -> StrT -fromStr (Str x) = x - -fromObj :: Value -> ObjT -fromObj (Obj x) = x - -fromErr :: Value -> ErrT -fromErr (Err x) = x - -fromLst :: Value -> LstT -fromLst (Lst x) = x +emptyList = Lst Lst.empty -- | Test two MOO values for indistinguishable (case-sensitive) equality. equal :: Value -> Value -> Bool -(Str a) `equal` (Str b) = a `Str.equal` b -(Lst a) `equal` (Lst b) = V.length a == V.length b && - V.and (V.zipWith equal a b) +(Str x) `equal` (Str y) = x `Str.equal` y +(Lst x) `equal` (Lst y) = x `Lst.equal` y x `equal` y = x == y -- Case-insensitive ordering instance Ord Value where - (Int a) `compare` (Int b) = a `compare` b - (Flt a) `compare` (Flt b) = a `compare` b - (Str a) `compare` (Str b) = a `compare` b - (Obj a) `compare` (Obj b) = a `compare` b - (Err a) `compare` (Err b) = a `compare` b + (Int x) `compare` (Int y) = x `compare` y + (Flt x) `compare` (Flt y) = x `compare` y + (Str x) `compare` (Str y) = x `compare` y + (Obj x) `compare` (Obj y) = x `compare` y + (Err x) `compare` (Err y) = x `compare` y _ `compare` _ = error "Illegal comparison" +-- | Can the provided values be compared for relative ordering? +comparable :: Value -> Value -> Bool +comparable x y = case (typeOf x, typeOf y) of + (TLst, _ ) -> False + (tx , ty) -> tx == ty + -- | A 'Type' represents one or more MOO value types. data Type = TAny -- ^ any type | TNum -- ^ integer or floating-point number @@ -281,8 +325,12 @@ | TObj -- ^ object number | TErr -- ^ error | TLst -- ^ list - deriving (Eq, Show) + deriving (Eq, Enum, Typeable) +instance VCacheable Type where + put = put . fromEnum + get = toEnum <$> get + -- | A MOO error data Error = E_NONE -- ^ No error | E_TYPE -- ^ Type mismatch @@ -310,15 +358,15 @@ truthOf (Int x) = x /= 0 truthOf (Flt x) = x /= 0.0 truthOf (Str t) = not (Str.null t) -truthOf (Lst v) = not (V.null v) +truthOf (Lst v) = not (Lst.null v) truthOf _ = False -- | Return a default MOO value (integer) having the given boolean value. truthValue :: Bool -> Value -truthValue False = Int 0 +truthValue False = zero truthValue True = Int 1 --- | Return a 'Type' indicating the type of the given value. +-- | Return a 'Type' indicating the type of the given MOO value. typeOf :: Value -> Type typeOf Int{} = TInt typeOf Flt{} = TFlt @@ -340,30 +388,82 @@ typeCode TLst = 4 typeCode TFlt = 9 --- | Return a string representation of the given MOO value, using the same +-- | Extract an 'IntT' from a MOO value. +intValue :: Value -> Maybe IntT +intValue (Int x) = Just x +intValue _ = Nothing + +-- | Extract a 'FltT' from a MOO value. +fltValue :: Value -> Maybe FltT +fltValue (Flt x) = Just x +fltValue _ = Nothing + +-- | Extract a 'StrT' from a MOO value. +strValue :: Value -> Maybe StrT +strValue (Str x) = Just x +strValue _ = Nothing + +-- | Extract an 'ObjT' from a MOO value. +objValue :: Value -> Maybe ObjT +objValue (Obj x) = Just x +objValue _ = Nothing + +-- | Extract an 'ErrT' from a MOO value. +errValue :: Value -> Maybe ErrT +errValue (Err x) = Just x +errValue _ = Nothing + +-- | Extract a 'LstT' from a MOO value. +lstValue :: Value -> Maybe LstT +lstValue (Lst x) = Just x +lstValue _ = Nothing + +-- | Return a 'Text' representation of the given MOO value, using the same -- rules as the @tostr()@ built-in function. toText :: Value -> Text -toText (Int x) = T.pack (show x) -toText (Flt x) = T.pack (show x) toText (Str x) = Str.toText x -toText (Obj x) = T.pack ('#' : show x) toText (Err x) = error2text x toText (Lst _) = "{list}" +toText v = builder2text (toBuilder v) --- | Return a literal representation of the given MOO value, using the same +-- | Return a 'Builder' representation of the given MOO value, using the same +-- rules as the @tostr()@ built-in function. +toBuilder :: Value -> Builder +toBuilder (Int x) = TLB.decimal x +toBuilder (Obj x) = TLB.singleton '#' <> TLB.decimal x +toBuilder (Flt x) = TLB.realFloat x +toBuilder v = TLB.fromText (toText v) + +-- | Return a 'Builder' representation of the given MOO value, using the same -- rules as the @toliteral()@ built-in function. +toBuilder' :: Value -> Builder +toBuilder' (Lst x) = TLB.singleton '{' <> mconcat + (intersperse ", " $ map toBuilder' $ Lst.toList x) <> + TLB.singleton '}' +toBuilder' (Str x) = quote <> Str.foldr escape quote x + where quote, backslash :: Builder + quote = TLB.singleton '"' + backslash = TLB.singleton '\\' + + escape :: Char -> Builder -> Builder + escape '"' = mappend backslash . mappend quote + escape '\\' = mappend backslash . mappend backslash + escape c = mappend (TLB.singleton c) + +toBuilder' (Err x) = TLB.fromString (show x) +toBuilder' v = toBuilder v + +-- | Return a 'Text' representation of the given MOO value, using the same +-- rules as the @toliteral()@ built-in function. toLiteral :: Value -> Text -toLiteral (Lst vs) = T.concat - [ "{" - , T.intercalate ", " $ map toLiteral (V.toList vs) - , "}"] -toLiteral (Str x) = T.concat ["\"", T.concatMap escape $ Str.toText x, "\""] - where escape '"' = "\\\"" - escape '\\' = "\\\\" - escape c = T.singleton c -toLiteral (Err x) = T.pack (show x) -toLiteral v = toText v +toLiteral = builder2text . toBuilder' +-- | Interpret a MOO value as a number of microseconds. +toMicroseconds :: Value -> Maybe Integer +toMicroseconds (Int secs) = Just $ fromIntegral secs * 1000000 +toMicroseconds (Flt secs) = Just $ ceiling $ secs * 1000000 +toMicroseconds _ = Nothing + -- | Return a string description of the given error value. error2text :: Error -> Text error2text E_NONE = "No error" @@ -385,7 +485,7 @@ -- | Turn a Haskell list into a MOO list. fromList :: [Value] -> Value -fromList = Lst . V.fromList +fromList = Lst . Lst.fromList -- | Turn a Haskell list into a MOO list, using a function to map Haskell -- values to MOO values. @@ -399,41 +499,6 @@ -- | Turn a list of object numbers into a MOO list. objectList :: [ObjT] -> Value objectList = fromListBy Obj - --- | Return a modified list with the given 0-based index replaced with the --- given value. -listSet :: LstT -> Int -> Value -> LstT -listSet v i value = V.modify (\m -> VM.write m i value) v - --- | Return a modified list with the given value inserted at the given 0-based --- index. -listInsert :: LstT -> Int -> Value -> LstT -listInsert list index value - | index <= 0 = V.cons value list - | index > listLen = V.snoc list value - | otherwise = V.create $ do - list' <- V.thaw list >>= flip VM.grow 1 - let moveLen = listLen - index - s = VM.slice index moveLen list' - t = VM.slice (index + 1) moveLen list' - VM.move t s - VM.write list' index value - return list' - where listLen = V.length list - --- | Return a modified list with the value at the given 0-based index removed. -listDelete :: LstT -> Int -> LstT -listDelete list index - | index == 0 = V.create $ VM.tail `liftM` V.thaw list - | index == listLen - 1 = V.create $ VM.init `liftM` V.thaw list - | otherwise = V.create $ do - list' <- V.thaw list - let moveLen = listLen - index - 1 - s = VM.slice index moveLen list' - t = VM.slice (index + 1) moveLen list' - VM.move s t - return $ VM.init list' - where listLen = V.length list -- | This is the last UTC time value representable as a signed 32-bit -- seconds-since-1970 value. Unfortunately it is used as a sentinel value in diff --git a/src/MOO/Types.hs-boot b/src/MOO/Types.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Types.hs-boot @@ -0,0 +1,5 @@ +-- -*- Haskell -*- + +module MOO.Types ( Value ) where + +data Value diff --git a/src/MOO/Unparser.hs b/src/MOO/Unparser.hs --- a/src/MOO/Unparser.hs +++ b/src/MOO/Unparser.hs @@ -5,17 +5,18 @@ -- built-in function module MOO.Unparser ( unparse ) where -import Control.Monad (when, unless, liftM, (<=<)) +import Control.Applicative ((<$>)) +import Control.Monad (unless, (<=<)) import Control.Monad.Reader (ReaderT, runReaderT, asks, local) import Control.Monad.Writer (Writer, execWriter, tell) import Data.Char (isAlpha, isAlphaNum) +import Data.HashSet (HashSet) import Data.List (intersperse) import Data.Monoid ((<>), mconcat) -import Data.Set (Set) import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder, toLazyText, fromText) +import Data.Text.Lazy.Builder (Builder, toLazyText) -import qualified Data.Set as S +import qualified Data.HashSet as HS import MOO.AST import MOO.Parser (keywords) @@ -27,14 +28,7 @@ data UnparserEnv = UnparserEnv { fullyParenthesizing :: Bool - , indenting :: Bool - , indentation :: Builder -} - -initUnparserEnv = UnparserEnv { - fullyParenthesizing = False - , indenting = False - , indentation = "" + , indentation :: Maybe Builder } -- | Synthesize the MOO code corresponding to the given abstract syntax @@ -43,26 +37,24 @@ -- true, the resulting MOO code will be indented with spaces as appropriate to -- show the nesting structure of statements. -- --- The MOO code is returned as a single 'Text' value containing embedded +-- The MOO code is returned as a single lazy 'Text' value containing embedded -- newline characters. unparse :: Bool -- ^ /fully-paren/ -> Bool -- ^ /indent/ -> Program -> Text unparse fullyParen indent (Program stmts) = - toLazyText $ execWriter $ runReaderT (tellStatements stmts) $ - initUnparserEnv { - fullyParenthesizing = fullyParen - , indenting = indent + toLazyText $ execWriter $ runReaderT (tellStatements stmts) UnparserEnv { + fullyParenthesizing = fullyParen + , indentation = if indent then Just "" else Nothing } indent :: Unparser () -indent = do - indenting <- asks indenting - when indenting $ tell =<< asks indentation +indent = maybe (return ()) tell =<< asks indentation moreIndented :: Unparser a -> Unparser a -moreIndented = local $ \env -> env { indentation = " " <> indentation env } +moreIndented = local $ \env -> + env { indentation = (" " <>) <$> indentation env } tellStatements :: [Statement] -> Unparser () tellStatements = mapM_ tellStatement @@ -140,7 +132,7 @@ unparseExpr :: Expr -> Unparser Builder unparseExpr expr = case expr of - Literal value -> return (fromText $ toLiteral value) + Literal value -> return (toBuilder' value) List args -> do args' <- unparseArgs args @@ -149,7 +141,7 @@ Variable var -> return (fromId var) PropertyRef (Literal (Obj 0)) (Literal (Str name)) - | isIdentifier name -> return $ "$" <> string2builder name + | isIdentifier name -> return $ "$" <> Str.toBuilder name PropertyRef obj name -> do obj' <- case obj of Literal Int{} -> paren obj -- avoid digits followed by dot (-> float) @@ -169,7 +161,7 @@ VerbCall (Literal (Obj 0)) (Literal (Str name)) args | isIdentifier name -> do args' <- unparseArgs args - return $ "$" <> string2builder name <> + return $ "$" <> Str.toBuilder name <> "(" <> args' <> ")" VerbCall obj name args -> do obj' <- parenL expr obj @@ -218,9 +210,9 @@ Negate lhs@(Literal x `Range` _) | numeric x -> negateParen lhs Negate lhs@(Literal Flt{} `PropertyRef` _) -> negateParen lhs Negate lhs@(VerbCall (Literal x) _ _) | numeric x -> negateParen lhs - Negate lhs -> ("-" <>) `liftM` parenL expr lhs + Negate lhs -> ("-" <>) <$> parenL expr lhs - Not lhs -> ("!" <>) `liftM` parenL expr lhs + Not lhs -> ("!" <>) <$> parenL expr lhs Conditional cond lhs rhs -> do cond' <- parenR expr cond @@ -239,11 +231,13 @@ expr' <- unparseExpr expr return $ "`" <> lhs' <> " ! " <> codes' <> " => " <> expr' <> "'" - where binaryL lhs op rhs = do + where binaryL :: Expr -> Builder -> Expr -> Unparser Builder + binaryL lhs op rhs = do lhs' <- parenL expr lhs rhs' <- parenR expr rhs return $ lhs' <> op <> rhs' + binaryR :: Expr -> Builder -> Expr -> Unparser Builder binaryR lhs op rhs = do lhs' <- parenR expr lhs rhs' <- parenL expr rhs @@ -254,15 +248,16 @@ numeric Flt{} = True numeric _ = False - negateParen = liftM ("-" <>) . paren + negateParen :: Expr -> Unparser Builder + negateParen = fmap ("-" <>) . paren unparseArgs :: [Argument] -> Unparser Builder -unparseArgs = liftM (mconcat . intersperse ", ") . mapM unparseArg - where unparseArg (ArgNormal expr) = unparseExpr expr - unparseArg (ArgSplice expr) = ("@" <>) `liftM` unparseExpr expr +unparseArgs = fmap (mconcat . intersperse ", ") . mapM unparseArg + where unparseArg (ArgNormal expr) = unparseExpr expr + unparseArg (ArgSplice expr) = ("@" <>) <$> unparseExpr expr unparseScatter :: [ScatterItem] -> Unparser Builder -unparseScatter = liftM (mconcat . intersperse ", ") . mapM unparseScat +unparseScatter = fmap (mconcat . intersperse ", ") . mapM unparseScat where unparseScat (ScatRequired var) = return $ fromId var unparseScat (ScatRest var) = return $ "@" <> fromId var unparseScat (ScatOptional var Nothing) = return $ "?" <> fromId var @@ -272,7 +267,7 @@ unparseNameExpr :: Expr -> Unparser Builder unparseNameExpr (Literal (Str name)) - | isIdentifier name = return (string2builder name) + | isIdentifier name = return (Str.toBuilder name) unparseNameExpr expr = paren expr paren :: Expr -> Unparser Builder @@ -296,12 +291,16 @@ isIdentifier :: StrT -> Bool isIdentifier name = isIdentifier' (Str.toString name) && not (isKeyword name) - where isIdentifier' (c:cs) = isIdentStart c && all isIdentChar cs - isIdentStart c = isAlpha c || c == '_' - isIdentChar c = isAlphaNum c || c == '_' + where isIdentifier' :: String -> Bool + isIdentifier' (c:cs) = isIdentStart c && all isIdentChar cs + isIdentifier' [] = False + isIdentStart, isIdentChar :: Char -> Bool + isIdentStart c = isAlpha c || c == '_' + isIdentChar c = isAlphaNum c || c == '_' + isKeyword :: StrT -> Bool -isKeyword = (`S.member` keywordsSet) . toId +isKeyword = (`HS.member` keywordsSet) . toId -keywordsSet :: Set Id -keywordsSet = S.fromList $ map toId keywords +keywordsSet :: HashSet Id +keywordsSet = HS.fromList (map toId keywords) diff --git a/src/MOO/Util.hs b/src/MOO/Util.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Util.hs @@ -0,0 +1,86 @@ + +{-# LANGUAGE DeriveDataTypeable #-} + +module MOO.Util ( + ctime + , VIntSet(..) + , VHashMap(..) + , VUTCTime(..) + , VVector(..) + , VVersion(..) + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import Data.IntSet (IntSet) +import Data.Ratio (numerator, denominator, (%)) +import Data.Time (UTCTime(..), Day(..), DiffTime, utcToLocalZonedTime, + formatTime, defaultTimeLocale) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import Data.Version (Version(..)) +import Database.VCache (VCacheable(put, get), putVarNat, getVarNat) + +import qualified Data.HashMap.Strict as HM +import qualified Data.IntSet as IS +import qualified Data.Vector as V + +ctime :: UTCTime -> IO String +ctime time = formatTime defaultTimeLocale "%a %b %_d %T %Y %Z" <$> + utcToLocalZonedTime time + +newtype VIntSet = VIntSet { unVIntSet :: IntSet } deriving Typeable + +instance VCacheable VIntSet where + put = put . IS.toList . unVIntSet + get = VIntSet . IS.fromList <$> get + +newtype VHashMap k v = VHashMap { unVHashMap :: HashMap k v } deriving Typeable + +instance (Eq k, Hashable k, + VCacheable k, VCacheable v) => VCacheable (VHashMap k v) where + put = put . HM.toList . unVHashMap + get = VHashMap . HM.fromList <$> get + +newtype VUTCTime = VUTCTime { unVUTCTime :: UTCTime } deriving Typeable + +instance VCacheable VUTCTime where + put (VUTCTime time) = do + put $ VDay (utctDay time) + put $ VDiffTime (utctDayTime time) + + get = VUTCTime <$> (UTCTime <$> (unVDay <$> get) <*> (unVDiffTime <$> get)) + +newtype VDay = VDay { unVDay :: Day } deriving Typeable + +instance VCacheable VDay where + put = put . toModifiedJulianDay . unVDay + get = VDay . ModifiedJulianDay <$> get + +newtype VDiffTime = VDiffTime { unVDiffTime :: DiffTime } deriving Typeable + +instance VCacheable VDiffTime where + put = put . VRational . toRational . unVDiffTime + get = VDiffTime . fromRational . unVRational <$> get + +newtype VRational = VRational { unVRational :: Rational } deriving Typeable + +instance VCacheable VRational where + put (VRational x) = do + put $ numerator x + put $ denominator x + + get = VRational <$> ((%) <$> get <*> get) + +newtype VVector a = VVector { unVVector :: Vector a } deriving Typeable + +instance VCacheable a => VCacheable (VVector a) where + put (VVector x) = putVarNat (fromIntegral $ V.length x) >> V.forM_ x put + get = getVarNat >>= \len -> VVector <$> V.replicateM (fromIntegral len) get + +newtype VVersion = VVersion { unVVersion :: Version } deriving Typeable + +instance VCacheable VVersion where + put = put . versionBranch . unVVersion + get = VVersion . flip Version [] <$> get diff --git a/src/MOO/Verb.hs b/src/MOO/Verb.hs --- a/src/MOO/Verb.hs +++ b/src/MOO/Verb.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module MOO.Verb ( Verb(..) , ObjSpec(..) @@ -15,9 +15,12 @@ , verbNameMatch ) where +import Control.Applicative ((<$>), (<*>)) +import Data.Typeable (Typeable) +import Database.VCache (VCacheable(put, get)) + import MOO.AST import {-# SOURCE #-} MOO.Object (nothing) -import {-# SOURCE #-} MOO.Task import MOO.Types import qualified MOO.String as Str @@ -25,7 +28,6 @@ data Verb = Verb { verbNames :: StrT , verbProgram :: Program - , verbCode :: MOO Value , verbOwner :: ObjId , verbPermR :: Bool @@ -36,13 +38,29 @@ , verbDirectObject :: ObjSpec , verbPreposition :: PrepSpec , verbIndirectObject :: ObjSpec -} +} deriving Typeable +instance VCacheable Verb where + put verb = do + put $ verbNames verb + put $ verbProgram verb + put $ verbOwner verb + put $ verbPermR verb + put $ verbPermW verb + put $ verbPermX verb + put $ verbPermD verb + put $ verbDirectObject verb + put $ verbPreposition verb + put $ verbIndirectObject verb + + get = Verb <$> get <*> get + <*> get <*> get <*> get <*> get <*> get + <*> get <*> get <*> get + instance Sizeable Verb where storageBytes verb = storageBytes (verbNames verb) + storageBytes (verbProgram verb) * 2 + - -- storageBytes (verbCode verb) + storageBytes (verbOwner verb) + storageBytes (verbPermR verb) + storageBytes (verbPermW verb) + @@ -55,7 +73,6 @@ initVerb = Verb { verbNames = "" , verbProgram = Program [] - , verbCode = return zero , verbOwner = nothing , verbPermR = False @@ -72,8 +89,12 @@ data ObjSpec = ObjNone -- ^ none | ObjAny -- ^ any | ObjThis -- ^ this - deriving (Enum, Bounded, Eq, Show) + deriving (Enum, Bounded, Typeable) +instance VCacheable ObjSpec where + put = put . fromEnum + get = toEnum <$> get + instance Sizeable ObjSpec where storageBytes _ = storageBytes () @@ -84,7 +105,8 @@ string2obj :: StrT -> Maybe ObjSpec string2obj = flip lookup $ map mkAssoc [minBound ..] - where mkAssoc objSpec = (obj2string objSpec, objSpec) + where mkAssoc :: ObjSpec -> (StrT, ObjSpec) + mkAssoc objSpec = (obj2string objSpec, objSpec) objMatch :: ObjId -> ObjSpec -> ObjId -> Bool objMatch _ ObjNone oid = oid == nothing @@ -108,9 +130,13 @@ | PrepForAbout -- ^ for\/about | PrepIs -- ^ is | PrepAs -- ^ as - | PrepOffOffof -- ^ off\/off of - deriving (Enum, Bounded, Eq, Show) + | PrepOffofOff -- ^ off of\/off + deriving (Enum, Bounded, Eq, Typeable) +instance VCacheable PrepSpec where + put = put . fromEnum + get = toEnum <$> get + instance Sizeable PrepSpec where storageBytes _ = storageBytes () @@ -131,11 +157,12 @@ prep2string PrepForAbout = "for/about" prep2string PrepIs = "is" prep2string PrepAs = "as" -prep2string PrepOffOffof = "off/off of" +prep2string PrepOffofOff = "off of/off" string2prep :: StrT -> Maybe PrepSpec string2prep = flip lookup $ concatMap mkAssoc [minBound ..] - where mkAssoc prepSpec = + where mkAssoc :: PrepSpec -> [(StrT, PrepSpec)] + mkAssoc prepSpec = [ (prep, prepSpec) | prep <- Str.splitOn "/" $ prep2string prepSpec ] ++ [ (Str.fromString $ show index, prepSpec) @@ -157,7 +184,8 @@ -- use @*@ to separate required and optional text to match. verbNameMatch :: StrT -> [StrT] -> Bool verbNameMatch name = any matchName - where matchName vname + where matchName :: StrT -> Bool + matchName vname | post == "" = name == vname | post == "*" = preName == pre | otherwise = preName == pre && diff --git a/src/MOO/Version.hs b/src/MOO/Version.hs --- a/src/MOO/Version.hs +++ b/src/MOO/Version.hs @@ -1,12 +1,34 @@ -module MOO.Version ( serverVersion ) where +{-# LANGUAGE ForeignFunctionInterface #-} +module MOO.Version (version, serverVersion, lmdbVersion, pcreVersion, + runtimeVersion) where + +import Data.Char (toUpper) import Data.Text (Text, pack) import Data.Version (showVersion) +import Foreign (Ptr, nullPtr) +import Foreign.C (CString, CInt, peekCString) +import System.Info (compilerName, compilerVersion) +import System.IO.Unsafe (unsafePerformIO) import Paths_EtaMOO (version) +import MOO.Builtins.Match (pcreVersion) + +foreign import ccall unsafe "static lmdb.h" + mdb_version :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CString + -- | The current version of the server code, as a displayable 'Text' value -- (for use by the @server_version()@ built-in function) serverVersion :: Text serverVersion = pack $ "EtaMOO/" ++ showVersion version + +lmdbVersion :: String +{-# NOINLINE lmdbVersion #-} +lmdbVersion = unsafePerformIO + (peekCString =<< mdb_version nullPtr nullPtr nullPtr) + +runtimeVersion :: String +runtimeVersion = map toUpper compilerName ++ " runtime " ++ + showVersion compilerVersion diff --git a/src/cbits/crypt.c b/src/cbits/crypt.c deleted file mode 100644 --- a/src/cbits/crypt.c +++ /dev/null @@ -1,34 +0,0 @@ - -# define _XOPEN_SOURCE -# include -# include - -# include "crypt.h" - -/* - * Call the POSIX crypt() function - * - * The crypt() function is not reentrant, so this helper allows us to copy the - * results out while the Haskell runtime has blocked all other threads. - * - * To simplify memory management, we perform allocation for the results on the - * Haskell side. However, if the provided buffer is too small, we return an - * indication of the required size. - */ -int crypt_helper(const char *key, const char *salt, char *encrypted, int len) -{ - char *result; - int req; - - result = crypt(key, salt); - if (result == 0) - return -1; - - req = strlen(result) + 1; - if (req > len) - return req; - - strcpy(encrypted, result); - - return 0; -} diff --git a/src/cbits/crypt.h b/src/cbits/crypt.h deleted file mode 100644 --- a/src/cbits/crypt.h +++ /dev/null @@ -1,2 +0,0 @@ - -int crypt_helper(const char *, const char *, char *, int); diff --git a/src/cbits/match.c b/src/cbits/match.c --- a/src/cbits/match.c +++ b/src/cbits/match.c @@ -2,7 +2,7 @@ # include # include "match.h" -# define MAX_CAPTURES 10 +# define MAX_CAPTURES 10 /* * Structure for capturing rmatch results @@ -15,17 +15,23 @@ /* * PCRE callout function used to capture rmatch results * - * This function may be called by PCRE each time the (?C) pattern is + * This function will be called by PCRE each time the (?C) pattern is * encountered, which we have arranged to occur at the end of each successful - * pattern match. To find the rightmost match, we record the match found so - * far if it is further right and/or longer than the last found match, then - * tell PCRE to continue matching as if the match had failed. + * pattern match. To find the rightmost match for rmatch, we record the match + * found so far if it is further right and/or longer than the last found + * match, then tell PCRE to continue matching as if the match had failed. + * + * This function is a no-op unless passed rmatch callout_data, allowing it to + * be kept as the global PCRE callout function even for normal matches. */ static -int rmatch_callout(pcre_callout_block *block) +int global_callout(pcre_callout_block *block) { rmatch_data_t *rmatch = block->callout_data; + if (!rmatch) + return 0; /* proceed as normal; not using rmatch */ + if (!rmatch->valid || block->start_match > rmatch->ovec[0] || (block->start_match == rmatch->ovec[0] && block->current_position > rmatch->ovec[1])) { @@ -45,17 +51,17 @@ /* * match() helper function * - * This function exists so that it can be called by the Haskell runtime - * without any other threads running. This is necessary because it needs to - * convey callout information to PCRE via global variable. + * Arrange to call pcre_exec() with a callout that does nothing. We use the + * same callout function as rmatch_helper() so that we can run simultaneously + * with it, as pcre_callout is a global variable. */ -int match_helper(const pcre *code, pcre_extra *extra, +int match_helper(const pcre *code, const pcre_extra *extra, const char *subject, int length, int options, int ovector[MAX_CAPTURES * 3]) { - extra->flags &= ~PCRE_EXTRA_CALLOUT_DATA; + /* we rely on the fact that *extra has no callout_data by default */ - pcre_callout = 0; + pcre_callout = global_callout; return pcre_exec(code, extra, subject, length, 0, options, ovector, MAX_CAPTURES * 3); @@ -64,26 +70,32 @@ /* * rmatch() helper function * - * This function exists so that it can be called by the Haskell runtime - * without any other threads running. This is necessary because it needs to - * convey callout information to PCRE via global variable. + * Arrange to call pcre_exec() with a callout that records the rightmost + * match. We use the same callout function as match_helper() so that we can + * run simultaneously with it, as pcre_callout is a global variable. + * + * We also use an option to disable PCRE optimizations that can interfere with + * rmatch semantics. This has a side-effect of disabling JIT unless the + * pattern has been compiled using the same option. */ -int rmatch_helper(const pcre *code, pcre_extra *extra, +int rmatch_helper(const pcre *code, const pcre_extra *extra, const char *subject, int length, int options, int ovector[MAX_CAPTURES * 3]) { + pcre_extra local_extra = *extra; rmatch_data_t rmatch; int rc; rmatch.valid = 0; - extra->callout_data = &rmatch; - extra->flags |= PCRE_EXTRA_CALLOUT_DATA; + /* modify a local copy to avoid interfering with any other threads */ + local_extra.callout_data = &rmatch; + local_extra.flags |= PCRE_EXTRA_CALLOUT_DATA; - pcre_callout = rmatch_callout; + pcre_callout = global_callout; - rc = pcre_exec(code, extra, subject, length, 0, - options, ovector, MAX_CAPTURES * 3); + rc = pcre_exec(code, &local_extra, subject, length, 0, + options | PCRE_NO_START_OPTIMIZE, ovector, MAX_CAPTURES * 3); if (rc == PCRE_ERROR_NOMATCH && rmatch.valid) { rc = rmatch.valid; memcpy(ovector, &rmatch.ovec[0], sizeof(ovector[0]) * 2 * rc); diff --git a/src/cbits/match.h b/src/cbits/match.h --- a/src/cbits/match.h +++ b/src/cbits/match.h @@ -1,5 +1,7 @@ # include -int match_helper(const pcre *, pcre_extra *, const char *, int, int, int *); -int rmatch_helper(const pcre *, pcre_extra *, const char *, int, int, int *); +int match_helper(const pcre *, const pcre_extra *, + const char *, int, int, int *); +int rmatch_helper(const pcre *, const pcre_extra *, + const char *, int, int, int *); diff --git a/src/etamoo.hs b/src/etamoo.hs --- a/src/etamoo.hs +++ b/src/etamoo.hs @@ -3,31 +3,61 @@ module Main (main) where -import Control.Monad (foldM, unless) +import Control.Monad (foldM, unless, when) +import Data.Char (isDigit) import Data.List (isInfixOf, isPrefixOf) import Data.Maybe (isJust, isNothing, fromJust) -import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), - getOpt, usageInfo) +import Data.Version (showVersion) +import System.Console.GetOpt (OptDescr(Option), ArgDescr(NoArg, ReqArg), + ArgOrder(Permute), getOpt, usageInfo) import System.Environment (getArgs, getProgName) import MOO.Network import MOO.Server +import MOO.Version main :: IO () main = parseArgs >>= run run :: Options -> IO () run opts - | optHelp opts = putStrLn =<< usage + | optHelp opts = putStr =<< usage + | optVersion opts = putStr versionDetails + | optImport opts = importDatabase (fromJust $ optInputDB opts) + (fromJust $ optOutputDB opts) + | optExport opts = exportDatabase (fromJust $ optInputDB opts) + (fromJust $ optOutputDB opts) | optEmergency opts = error "Emergency Wizard Mode not yet implemented" | otherwise = startServer (optLogFile opts) (fromJust $ optInputDB opts) - (fromJust $ optOutputDB opts) (optOutboundNetwork opts) (const $ TCP (optBindAddress opts) (optPort opts)) +versionDetails :: String +versionDetails = unlines [ + "EtaMOO " ++ showVersion version ++ ", using:" + , " " ++ lmdbVersion + , " " ++ pcreVersion + , " " ++ runtimeVersion + , "" + , "Build options:" +# ifdef MOO_64BIT_INTEGER + , " 64-bit MOO integers" +# else + , " 32-bit MOO integers" +# endif +# ifdef MOO_OUTBOUND_NETWORK + , " open_network_connection() enabled by default" +# else + , " open_network_connection() disabled by default" +# endif + ] + data Options = Options { - optHelp :: Bool + optImport :: Bool + , optExport :: Bool + , optHelp :: Bool + , optVersion :: Bool , optEmergency :: Bool , optLogFile :: Maybe FilePath , optInputDB :: Maybe FilePath @@ -39,7 +69,10 @@ } defaultOptions = Options { - optHelp = False + optImport = False + , optExport = False + , optHelp = False + , optVersion = False , optEmergency = False , optLogFile = Nothing , optInputDB = Nothing @@ -74,9 +107,18 @@ (ReqArg (\ip opts -> opts { optBindAddress = Just ip }) "IP-ADDR") "Bind address for connections" , Option "p" ["port"] - (ReqArg (\port opts -> opts { optPort = fromInteger $ read port, - optPortSpecified = True }) "PORT") + (ReqArg (\port opts -> opts { optPort = fromInteger $ read port + , optPortSpecified = True }) "PORT") $ "Listening port (default: " ++ show (optPort defaultOptions) ++ ")" + , Option "" ["import"] + (NoArg (\opts -> opts { optImport = True })) + "Import LambdaMOO-format database" + , Option "" ["export"] + (NoArg (\opts -> opts { optExport = True })) + "Export LambdaMOO-format database" + , Option "V" ["version"] + (NoArg (\opts -> opts { optVersion = True })) + "Show server version and build details" , Option "h?" ["help"] (NoArg (\opts -> opts { optHelp = True })) "Show this usage" @@ -86,10 +128,14 @@ usage :: IO String usage = do argv0 <- getProgName - let header = "Usage: " ++ argv0 ++ " [-e] [-l FILE] " ++ - "INPUT-DB OUTPUT-DB [+O|-O] [-a IP-ADDR] [[-p] PORT]" + let header = init $ unlines [ + "Usage: " ++ argv0 ++ " [-e] [-l FILE] " ++ + "ETAMOO-DB [+O|-O] [-a IP-ADDR] [[-p] PORT]" + , " " ++ argv0 ++ " --import LAMBDAMOO-DB ETAMOO-DB" + , " " ++ argv0 ++ " --export ETAMOO-DB LAMBDAMOO-DB" + ] return $ patchUsage (usageInfo header options) ++ - "* Default outbound network option" + unlines ((replicate 68 ' ' ++ "(* default)") : "" : rtsOptions) where patchUsage :: String -> String patchUsage = unlines . map patch . lines @@ -98,8 +144,16 @@ " " `isPrefixOf` str = take 2 str ++ "+O" ++ drop 4 str | otherwise = str + rtsOptions :: [String] + rtsOptions = [ + "Run time system options (use between +RTS and -RTS):" + , " -N Use processors for multithreading (default: all)" + , " -T Enable statistics for memory_usage() built-in function" + , " -? Show other run time system options" + ] + usageError :: String -> IO a -usageError msg = usage >>= error . ((msg ++ "\n") ++) +usageError msg = error . (msg ++) . ("\n\n" ++) . init =<< usage serverOpts :: IO (Options, [String]) serverOpts = do @@ -113,9 +167,11 @@ (opts, nonOpts) <- serverOpts opts <- foldM handleArg opts nonOpts - unless (optHelp opts) $ do - unless (isJust $ optInputDB opts) $ usageError "missing INPUT-DB" - unless (isJust $ optOutputDB opts) $ usageError "missing OUTPUT-DB" + unless (optHelp opts || optVersion opts) $ do + when (optImport opts && optExport opts) $ usageError "usage error" + when (isNothing $ optInputDB opts) $ usageError "missing input DB" + when (optImport opts || optExport opts) $ + when (isNothing $ optOutputDB opts) $ usageError "missing output DB" return opts @@ -125,9 +181,10 @@ '+':_ -> usageError $ "unrecognized option `" ++ arg ++ "'" _ | isNothing (optInputDB opts) -> return opts { optInputDB = Just arg } - | isNothing (optOutputDB opts) -> + | isNothing (optOutputDB opts) && + (optImport opts || optExport opts) -> return opts { optOutputDB = Just arg } - | not (optPortSpecified opts) -> - return opts { optPort = fromInteger $ read arg, - optPortSpecified = True } + | not (optPortSpecified opts) && all isDigit arg -> + return opts { optPort = fromInteger $ read arg + , optPortSpecified = True } | otherwise -> usageError $ "unknown argument `" ++ arg ++ "'"