EtaMOO 0.2.0.0 → 0.3.0.0
raw patch · 49 files changed
+4138/−2101 lines, 49 filesdep +asyncdep +cryptonitedep +memorydep −old-localedep −pureMD5dep ~basedep ~pipes-concurrencydep ~text
Dependencies added: async, cryptonite, memory, vcache
Dependencies removed: old-locale, pureMD5
Dependency ranges changed: base, pipes-concurrency, text, time, vector
Files
- ACKNOWLEDGMENTS.md +37/−0
- DIFFERENCES.md +110/−0
- EtaMOO.cabal +40/−29
- LICENSE +1/−1
- README.md +106/−21
- TODO +72/−0
- src/MOO/AST.hs +206/−23
- src/MOO/Builtins.hs +49/−176
- src/MOO/Builtins.hs-boot +2/−2
- src/MOO/Builtins/Common.hs +2/−3
- src/MOO/Builtins/Crypt.hs +20/−21
- src/MOO/Builtins/Extra.hs +9/−0
- src/MOO/Builtins/Hash.hs +102/−0
- src/MOO/Builtins/Match.hsc +185/−75
- src/MOO/Builtins/Misc.hs +197/−0
- src/MOO/Builtins/Network.hs +15/−12
- src/MOO/Builtins/Objects.hs +77/−80
- src/MOO/Builtins/Tasks.hs +42/−39
- src/MOO/Builtins/Values.hs +142/−140
- src/MOO/Command.hs +33/−32
- src/MOO/Compiler.hs +257/−262
- src/MOO/Compiler.hs-boot +1/−1
- src/MOO/Connection.hs +280/−207
- src/MOO/Connection.hs-boot +2/−0
- src/MOO/Database.hs +197/−71
- src/MOO/Database.hs-boot +39/−6
- src/MOO/Database/LambdaMOO.hs +152/−127
- src/MOO/List.hs +263/−0
- src/MOO/List.hs-boot +24/−0
- src/MOO/Network.hs +27/−8
- src/MOO/Network/Console.hs +5/−4
- src/MOO/Network/TCP.hs +27/−12
- src/MOO/Object.hs +162/−55
- src/MOO/Parser.hs +83/−55
- src/MOO/Server.hs +178/−18
- src/MOO/String.hs +73/−37
- src/MOO/Task.hs +421/−325
- src/MOO/Task.hs-boot +4/−3
- src/MOO/Types.hs +189/−124
- src/MOO/Types.hs-boot +5/−0
- src/MOO/Unparser.hs +38/−39
- src/MOO/Util.hs +86/−0
- src/MOO/Verb.hs +41/−13
- src/MOO/Version.hs +23/−1
- src/cbits/crypt.c +0/−34
- src/cbits/crypt.h +0/−2
- src/cbits/match.c +33/−21
- src/cbits/match.h +4/−2
- src/etamoo.hs +77/−20
+ ACKNOWLEDGMENTS.md view
@@ -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.
+ DIFFERENCES.md view
@@ -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.
EtaMOO.cabal view
@@ -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 <rob@mars.org> maintainer: Rob Leslie <rob@mars.org> @@ -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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2015, Robert Leslie+Copyright (c) 2014-2016, Robert Leslie All rights reserved.
README.md view
@@ -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 -------
+ TODO view
@@ -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
src/MOO/AST.hs view
@@ -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 ++ ")"
src/MOO/Builtins.hs view
@@ -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"
src/MOO/Builtins.hs-boot view
@@ -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
src/MOO/Builtins/Common.hs view
@@ -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/.
src/MOO/Builtins/Crypt.hs view
@@ -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 ()
+ src/MOO/Builtins/Extra.hs view
@@ -0,0 +1,9 @@++{-# LANGUAGE CPP #-}++module MOO.Builtins.Extra ( builtins ) where++import MOO.Builtins.Common++builtins :: [Builtin]+builtins = []
+ src/MOO/Builtins/Hash.hs view
@@ -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
src/MOO/Builtins/Match.hsc view
@@ -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 <pcre.h>+{-# ANN module ("HLint: ignore Redundant lambda" :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} -data PCRE-data PCREExtra-data CharacterTables+# include <pcre.h> -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
+ src/MOO/Builtins/Misc.hs view
@@ -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"
src/MOO/Builtins/Network.hs view
@@ -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
src/MOO/Builtins/Objects.hs view
@@ -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
src/MOO/Builtins/Tasks.hs view
@@ -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
src/MOO/Builtins/Values.hs view
@@ -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
src/MOO/Command.hs view
@@ -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
src/MOO/Compiler.hs view
@@ -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
src/MOO/Compiler.hs-boot view
@@ -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
src/MOO/Connection.hs view
@@ -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
src/MOO/Connection.hs-boot view
@@ -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
src/MOO/Database.hs view
@@ -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
src/MOO/Database.hs-boot view
@@ -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
src/MOO/Database/LambdaMOO.hs view
@@ -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
+ src/MOO/List.hs view
@@ -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
+ src/MOO/List.hs-boot view
@@ -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
src/MOO/Network.hs view
@@ -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
src/MOO/Network/Console.hs view
@@ -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
src/MOO/Network/TCP.hs view
@@ -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)
src/MOO/Object.hs view
@@ -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
src/MOO/Parser.hs view
@@ -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
src/MOO/Server.hs view
@@ -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)
src/MOO/String.hs view
@@ -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
src/MOO/Task.hs view
@@ -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 = "<Task " ++ show (taskId task) ++- ": " ++ show (taskStatus 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 } = "<Loop>"- show Loop { loopName = Just name } = "<Loop " ++ show name ++ ">"-- show TryFinally{} = "<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 _ = "<ExceptionHandler>"- -- | 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 ()
src/MOO/Task.hs-boot view
@@ -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
src/MOO/Types.hs view
@@ -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
+ src/MOO/Types.hs-boot view
@@ -0,0 +1,5 @@+-- -*- Haskell -*-++module MOO.Types ( Value ) where++data Value
src/MOO/Unparser.hs view
@@ -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)
+ src/MOO/Util.hs view
@@ -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
src/MOO/Verb.hs view
@@ -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 &&
src/MOO/Version.hs view
@@ -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
− src/cbits/crypt.c
@@ -1,34 +0,0 @@--# define _XOPEN_SOURCE-# include <unistd.h>-# include <string.h>--# 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;-}
− src/cbits/crypt.h
@@ -1,2 +0,0 @@--int crypt_helper(const char *, const char *, char *, int);
src/cbits/match.c view
@@ -2,7 +2,7 @@ # include <string.h> # 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);
src/cbits/match.h view
@@ -1,5 +1,7 @@ # include <pcre.h> -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 *);
src/etamoo.hs view
@@ -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<n> Use <n> 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 ++ "'"