EtaMOO (empty) → 0.1.0.0
raw patch · 35 files changed
+7752/−0 lines, 35 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, containers, haskeline, mtl, network, old-locale, parsec, pureMD5, random, stm, text, time, transformers, unix, unordered-containers, vector
Files
- EtaMOO.cabal +111/−0
- LICENSE +30/−0
- Makefile +56/−0
- README.md +80/−0
- Setup.hs +2/−0
- configure +17/−0
- src/MOO/AST.hs +250/−0
- src/MOO/Builtins.hs +193/−0
- src/MOO/Builtins.hs-boot +12/−0
- src/MOO/Builtins/Common.hs +43/−0
- src/MOO/Builtins/Match.hsc +330/−0
- src/MOO/Builtins/Network.hs +124/−0
- src/MOO/Builtins/Objects.hs +589/−0
- src/MOO/Builtins/Tasks.hs +247/−0
- src/MOO/Builtins/Values.hs +475/−0
- src/MOO/Command.hs +220/−0
- src/MOO/Command.hs-boot +5/−0
- src/MOO/Compiler.hs +574/−0
- src/MOO/Compiler.hs-boot +9/−0
- src/MOO/Database.hs +237/−0
- src/MOO/Database.hs-boot +29/−0
- src/MOO/Database/LambdaMOO.hs +624/−0
- src/MOO/Network.hs +329/−0
- src/MOO/Network.hs-boot +18/−0
- src/MOO/Object.hs +257/−0
- src/MOO/Object.hs-boot +5/−0
- src/MOO/Parser.hs +556/−0
- src/MOO/Task.hs +1248/−0
- src/MOO/Task.hs-boot +53/−0
- src/MOO/Types.hs +375/−0
- src/MOO/Unparser.hs +300/−0
- src/MOO/Verb.hs +163/−0
- src/MOO/Verb.hs-boot +5/−0
- src/MOO/Version.hs +18/−0
- src/etamoo.hs +168/−0
+ EtaMOO.cabal view
@@ -0,0 +1,111 @@++name: EtaMOO+version: 0.1.0.0++synopsis: A new implementation of the LambdaMOO server++description:++ LambdaMOO is a network-accessible, multi-user, programmable, interactive+ system well-suited to the construction of text-based adventure games,+ 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.+ .+ /N.B./ This is (currently) incomplete software. It is not yet usable,+ although with further development it is hoped that it soon will be.++license: BSD3+license-file: LICENSE++copyright: © 2014 Rob Leslie+author: Rob Leslie <rob@mars.org>+maintainer: Rob Leslie <rob@mars.org>++stability: alpha+category: Network++build-type: Simple+cabal-version: >=1.8++homepage: https://github.com/verement/etamoo+bug-reports: https://github.com/verement/etamoo/issues++extra-source-files: README.md configure Makefile++source-repository head+ type: git+ location: https://github.com/verement/etamoo.git++-- source-repository this+-- type: git+-- location: git://...++flag llvm+ description: Use GHC's LLVM backend to compile the code+ default: False++executable etamoo+ hs-source-dirs: src+ main-is: etamoo.hs++ other-modules: MOO.AST+ MOO.Builtins+ MOO.Builtins.Common+ MOO.Builtins.Match+ MOO.Builtins.Network+ MOO.Builtins.Objects+ MOO.Builtins.Tasks+ MOO.Builtins.Values+ MOO.Command+ MOO.Compiler+ MOO.Database+ MOO.Database.LambdaMOO+ MOO.Network+ MOO.Object+ MOO.Parser+ MOO.Task+ MOO.Types+ MOO.Unparser+ MOO.Verb+ MOO.Version+ Paths_EtaMOO++ ghc-options: -threaded -rtsopts+ if flag(llvm)+ ghc-options: -fllvm++ extensions: OverloadedStrings, ForeignFunctionInterface,+ EmptyDataDecls, ExistentialQuantification++ if !os(darwin)+ extra-libraries: crypt+ extra-libraries: pcre++ includes: unistd.h pcre.h++ build-depends: array+ , base ==4.*+ , bytestring+ , containers >= 0.4+ , haskeline+ , mtl+ , network+ , old-locale+ , parsec+ , random+ , stm+ , text+ , time+ , unix+ , unordered-containers+ , pureMD5+ , transformers+ , vector++ build-tools: hsc2hs+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Rob Leslie++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Rob Leslie nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,56 @@++all: FORCE etamoo++test: FORCE etamoo-test++CABAL = EtaMOO.cabal++HS_SOURCES = $(shell find src -name \*.hs \! -name .\*)+HSC_SOURCES = $(shell find src -name \*.hsc \! -name .\*)+SOURCES = $(HS_SOURCES) $(HSC_SOURCES)++BUILT_SOURCES = $(foreach file,$(HSC_SOURCES),$(patsubst \+ src/%.hsc,dist/.test/build/etamoo/etamoo-tmp/%.hs,$(file)))++DOCS = dist/doc/html/EtaMOO/etamoo/index.html++etamoo: FORCE+ @cabal build --builddir=dist+ ln -sf dist/build/etamoo/etamoo $@++etamoo-test: FORCE+ @cabal build --builddir=dist/.test+ ln -sf dist/.test/build/etamoo/etamoo $@++etamoo-prof: FORCE+ @cabal build --builddir=dist/.prof+ ln -sf dist/.prof/build/etamoo/etamoo $@++etamoo-llvm: FORCE+ @cabal build --builddir=dist/.llvm+ ln -sf dist/.llvm/build/etamoo/etamoo $@++$(BUILT_SOURCES): $(HSC_SOURCES)+ $(MAKE) etamoo-test++hlint.html: $(HS_SOURCES) $(BUILT_SOURCES)+ -hlint --report=$@ $^ >/dev/null++$(DOCS): $(CABAL) $(SOURCES) Makefile+ @cabal haddock --builddir=dist \+ --haddock-options="--title=EtaMOO --no-warnings" \+ --executables --hyperlink-source++docs: FORCE $(DOCS)++%.ps: %.hp+ hp2ps $^++install: FORCE+ @cabal install --builddir=dist++clean: FORCE+ -@cabal clean --builddir=dist+ rm -f etamoo etamoo-* *.prof hlint.html++FORCE:
+ README.md view
@@ -0,0 +1,80 @@++Important!+==========++**This is experimental and (currently) incomplete software. It is not yet+usable, although with further development it is hoped that it soon will be.**++_At present, all the code will do is (optionally) load a database file and+present a REPL interface for running commands and evaluating MOO code from the+console as if you had connected as a wizard. While most MOO code will run+correctly, there are still some built-in functions that are not yet+implemented. Also, notably, there is almost no network functionality, and no+way to save any changes made to the database. Finally, there has been no+effort to optimize any performance bottlenecks, of which loading a database is+at least one._++_Once the code is in at least a minimally useful state, this message will be+updated or removed._++EtaMOO+======++EtaMOO is a new implementation of the LambdaMOO server written in Haskell.++[LambdaMOO][] is a network-accessible, multi-user, programmable, interactive+system well-suited to the construction of text-based adventure games,+conferencing systems, and other collaborative software.++ [LambdaMOO]: http://www.ipomoea.org/moo/++EtaMOO differs from LambdaMOO in a few significant ways:++ * EtaMOO is multi-threaded. MOO tasks run concurrently, producing network+ output and changes to the database in isolated transactions that are+ committed only when not in conflict with any other transaction. (In cases+ of conflict, transactions are automatically retried.) Separate threads are+ also used for network connection management, so for example name lookups+ do not block the entire server.++ * In some cases, MOO values may be computed in a "lazy" manner, meaning the+ evaluation could be skipped if MOO code never fully inspects the result.+ This could be beneficial when large list structures are returned from+ built-in functions, for example.++ * It is anticipated that EtaMOO will easily support 64-bit MOO integers+ and/or Unicode MOO strings via independent build options.++ * 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.++ [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:++ 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.++ [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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ configure view
@@ -0,0 +1,17 @@+#! /bin/sh -e++cabal configure "$@" --builddir=dist++case "$1" in+ -h|--help|-\?)+ exit ;;+esac++cabal configure "$@" --builddir=dist/.test --verbose=0 \+ --disable-optimization++cabal configure "$@" --builddir=dist/.prof --verbose=0 \+ --enable-executable-profiling++cabal configure "$@" --builddir=dist/.llvm --verbose=0 \+ --flags=llvm
+ src/MOO/AST.hs view
@@ -0,0 +1,250 @@++-- | Data structures representing an abstract syntax tree for MOO code+module MOO.AST (++ -- * Data Structures+ Program(..)+ , Statement(..)+ , Then(..)+ , ElseIf(..)+ , Else(..)+ , Except(..)+ , Finally(..)+ , Expr(..)+ , Codes(..)+ , Default(..)+ , Arg(..)+ , ScatItem(..)++ -- * Utility Functions+ , isLValue+ , precedence++ ) where++import MOO.Types++newtype Program = Program [Statement]+ deriving Show++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++newtype Then = Then [Statement] deriving Show+data ElseIf = ElseIf !Int Expr [Statement] deriving Show+newtype Else = Else [Statement] deriving Show++data Except = Except !Int (Maybe Id) Codes [Statement] deriving Show+newtype Finally = Finally [Statement] deriving Show++instance Sizeable Statement where+ storageBytes (Expression line expr) =+ storageBytes () + storageBytes line + storageBytes expr+ storageBytes (If line expr (Then thens) elseIfs (Else elses)) =+ storageBytes () + storageBytes line + storageBytes expr ++ storageBytes thens + storageBytes elseIfs + storageBytes elses+ storageBytes (ForList line var expr body) =+ storageBytes () + storageBytes line + storageBytes var ++ storageBytes expr + storageBytes body+ storageBytes (ForRange line var range body) =+ storageBytes () + storageBytes line + storageBytes var ++ storageBytes range + storageBytes body+ storageBytes (While line var expr body) =+ storageBytes () + storageBytes line + storageBytes var ++ storageBytes expr + storageBytes body+ storageBytes (Fork line var expr body) =+ storageBytes () + storageBytes line + storageBytes var ++ storageBytes expr + storageBytes body+ storageBytes (Break var) = storageBytes () + storageBytes var+ storageBytes (Continue var) = storageBytes () + storageBytes var+ storageBytes (Return line expr) =+ storageBytes () + storageBytes line + storageBytes expr+ storageBytes (TryExcept body excepts) =+ storageBytes () + storageBytes body + storageBytes excepts+ storageBytes (TryFinally body (Finally finally)) =+ storageBytes () + storageBytes body + storageBytes finally++instance Sizeable ElseIf where+ storageBytes (ElseIf line expr body) =+ storageBytes () + storageBytes line + storageBytes expr + storageBytes body++instance Sizeable Except where+ storageBytes (Except line var codes body) =+ storageBytes () + storageBytes line + storageBytes var ++ storageBytes codes + storageBytes body++data Expr = Literal Value+ | List [Arg]++ | Variable Id+ | PropRef Expr Expr++ | Assign Expr Expr+ | ScatterAssign [ScatItem] Expr++ | VerbCall Expr Expr [Arg]+ | BuiltinFunc Id [Arg]++ | Expr `Index` Expr+ | Expr `Range` (Expr, Expr)+ | Length++ | Expr `In` Expr++ | Expr `Plus` Expr+ | Expr `Minus` Expr+ | Expr `Times` Expr+ | Expr `Divide` Expr+ | Expr `Remain` Expr+ | Expr `Power` Expr+ | Negate Expr++ | Conditional Expr Expr Expr+ | Expr `And` Expr+ | Expr `Or` Expr+ | Not Expr++ | Expr `Equal` Expr+ | Expr `NotEqual` Expr+ | Expr `LessThan` Expr+ | Expr `LessEqual` Expr+ | Expr `GreaterThan` Expr+ | Expr `GreaterEqual` Expr++ | Catch Expr Codes Default++ deriving Show++instance Sizeable Expr where+ storageBytes (Literal value) = storageBytes () + storageBytes value+ storageBytes (List args) = storageBytes () + storageBytes args+ storageBytes (Variable var) = storageBytes () + storageBytes var+ storageBytes (PropRef obj name) =+ storageBytes () + storageBytes obj + storageBytes name+ storageBytes (Assign lhs rhs) =+ storageBytes () + storageBytes lhs + storageBytes rhs+ storageBytes (ScatterAssign scats expr) =+ storageBytes () + storageBytes scats + storageBytes expr+ storageBytes (VerbCall obj name args) =+ storageBytes () + storageBytes obj + storageBytes name + storageBytes args+ storageBytes (BuiltinFunc name args) =+ storageBytes () + storageBytes name + storageBytes args+ storageBytes (Index x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Range x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes Length = storageBytes ()+ storageBytes (In x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Plus x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Minus x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Times x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Divide x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Remain x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Power x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Negate x) = storageBytes () + storageBytes x+ storageBytes (Conditional x y z) =+ storageBytes () + storageBytes x + storageBytes y + storageBytes z+ storageBytes (And x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Or x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (Not x) = storageBytes () + storageBytes x+ storageBytes (Equal x y) = storageBytes () + storageBytes x + storageBytes y+ storageBytes (NotEqual x y) =+ storageBytes () + storageBytes x + storageBytes y+ storageBytes (LessThan x y) =+ storageBytes () + storageBytes x + storageBytes y+ storageBytes (LessEqual x y) =+ storageBytes () + storageBytes x + storageBytes y+ storageBytes (GreaterThan x y) =+ storageBytes () + storageBytes x + storageBytes y+ storageBytes (GreaterEqual x y) =+ storageBytes () + storageBytes x + storageBytes y+ storageBytes (Catch expr codes (Default dv)) =+ storageBytes () + storageBytes expr + storageBytes codes + storageBytes dv++data Codes = ANY | Codes [Arg] deriving Show+newtype Default = Default (Maybe Expr) deriving Show++instance Sizeable Codes where+ storageBytes ANY = storageBytes ()+ storageBytes (Codes args) = storageBytes () + storageBytes args++data Arg = ArgNormal Expr+ | ArgSplice Expr+ deriving Show++instance Sizeable Arg where+ storageBytes (ArgNormal expr) = storageBytes () + storageBytes expr+ storageBytes (ArgSplice expr) = storageBytes () + storageBytes expr++data ScatItem = ScatRequired Id+ | ScatOptional Id (Maybe Expr)+ | ScatRest Id+ deriving Show++instance Sizeable ScatItem where+ storageBytes (ScatRequired var) = storageBytes () + storageBytes var+ storageBytes (ScatOptional var expr) =+ storageBytes () + storageBytes var + storageBytes expr+ storageBytes (ScatRest var) = storageBytes () + storageBytes var++-- | Can the given expression be used on the left-hand side of an assignment?+isLValue :: Expr -> Bool+isLValue (Range e _) = isLValue' e+isLValue e = isLValue' e++isLValue' :: Expr -> Bool+isLValue' Variable{} = True+isLValue' PropRef{} = True+isLValue' (Index e _) = isLValue' e+isLValue' _ = False++-- | Return a precedence value for the given expression, needed by+-- "MOO.Unparser" to determine whether parentheses are necessary to isolate an+-- expression from its surrounding context.+precedence :: Expr -> Int+precedence expr = case expr of+ Assign{} -> 1+ ScatterAssign{} -> 1++ Conditional{} -> 2++ And{} -> 3+ Or{} -> 3++ Equal{} -> 4+ NotEqual{} -> 4+ LessThan{} -> 4+ LessEqual{} -> 4+ GreaterThan{} -> 4+ GreaterEqual{} -> 4+ In{} -> 4++ Plus{} -> 5+ Minus{} -> 5++ Times{} -> 6+ Divide{} -> 6+ Remain{} -> 6++ Power{} -> 7++ Not{} -> 8+ Negate{} -> 8++ PropRef{} -> 9+ VerbCall{} -> 9+ Index{} -> 9+ Range{} -> 9++ _ -> 10
+ src/MOO/Builtins.hs view
@@ -0,0 +1,193 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Builtins ( builtinFunctions, callBuiltin, verifyBuiltins ) where++import Control.Monad (when, foldM, liftM, join)+import Control.Monad.State (gets)+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.IO.Unsafe (unsafePerformIO)+import System.Locale (defaultTimeLocale)++import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Vector as V++import MOO.Builtins.Common+import MOO.Types+import MOO.Task+import MOO.Database+import MOO.Object+import MOO.Version++import MOO.Builtins.Values as Values+import MOO.Builtins.Objects as Objects+import MOO.Builtins.Network as Network+import MOO.Builtins.Tasks as Tasks++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}++-- | A 'Map' of all built-in functions, keyed by name+builtinFunctions :: Map Id (Builtin, Info)+builtinFunctions =+ M.fromList $ miscBuiltins +++ Values.builtins ++ Objects.builtins ++ Network.builtins ++ Tasks.builtins++-- | Call the named built-in function with the given arguments, checking first+-- 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 (bf, info) -> checkArgs info args >> bf args+ Nothing -> raiseException $+ Exception (Err E_INVARG) "Unknown built-in function" (Str func)++ where checkArgs (Info min max types _) args = do+ let nargs = length args+ in when (nargs < min || nargs > fromMaybe nargs max) $ raise E_ARGS+ checkTypes types args++ checkTypes (t:ts) (a:as) = do+ when (typeMismatch t $ typeOf a) $ raise E_TYPE+ checkTypes ts as+ checkTypes _ _ = return ()++ typeMismatch x y | x == y = False+ typeMismatch TAny _ = False+ typeMismatch TNum TInt = False+ typeMismatch TNum TFlt = False+ typeMismatch _ _ = True++-- | Perform internal consistency verification of all the built-in functions,+-- checking that each implementation actually accepts the claimed argument+-- types. Note that an inconsistency may cause the program to abort.+--+-- Assuming the program doesn't abort, this generates either a string+-- describing an inconsistency, or an integer giving the total number of+-- (verified) built-in functions.+verifyBuiltins :: Either String Int+verifyBuiltins = foldM accum 0 $ M.assocs builtinFunctions+ where accum a b = valid b >>= Right . (+ a)+ valid (name, (func, Info min max types _))+ | name /= T.toCaseFold name = invalid "name not case-folded"+ | min < 0 = invalid "arg min < 0"+ | 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 $ T.unpack name ++ ": " ++ msg+ ok = Right 1++ testArgs func min max types = all test argSpecs+ where argSpecs = drop min $ inits $ map mkArgs augmentedTypes+ augmentedTypes = maybe (types ++ [TAny]) (const types) max+ test argSpec = all (\args -> func args `seq` True) $+ enumerateArgs argSpec++ enumerateArgs :: [[Value]] -> [[Value]]+ enumerateArgs (a:[]) = transpose [a]+ enumerateArgs (a:as) = concatMap (combine a) (enumerateArgs as)+ where combine ps rs = map (: rs) ps+ enumerateArgs [] = [[]]++ mkArgs :: Type -> [Value]+ mkArgs TAny = mkArgs TNum ++ mkArgs TStr ++ mkArgs TObj +++ mkArgs TErr ++ mkArgs TLst+ mkArgs TNum = mkArgs TInt ++ mkArgs TFlt+ mkArgs TInt = [Int 0]+ mkArgs TFlt = [Flt 0]+ mkArgs TStr = [Str T.empty]+ mkArgs TObj = [Obj 0]+ mkArgs TErr = [Err E_NONE]+ mkArgs TLst = [Lst V.empty]++-- 4.4 Built-in Functions++miscBuiltins :: [BuiltinSpec]+miscBuiltins = [+ -- 4.4.1 Object-Oriented Programming+ ("pass" , (bf_pass , Info 0 Nothing [] TAny))++ -- 4.4.5 Operations Involving Times and Dates+ , ("time" , (bf_time , Info 0 (Just 0) [] TInt))+ , ("ctime" , (bf_ctime , Info 0 (Just 1) [TInt] TStr))++ -- 4.4.7 Administrative Operations+ , ("dump_database" , (bf_dump_database , Info 0 (Just 0) [] TAny))+ , ("shutdown" , (bf_shutdown , Info 0 (Just 1) [TStr] TAny))+ , ("load_server_options",+ (bf_load_server_options, Info 0 (Just 0) [] TAny))+ , ("server_log" , (bf_server_log , Info 1 (Just 2) [TStr, TAny] TAny))+ , ("renumber" , (bf_renumber , Info 1 (Just 1) [TObj] TObj))+ , ("reset_max_object",+ (bf_reset_max_object, Info 0 (Just 0) [] TAny))++ -- 4.4.8 Server Statistics and Miscellaneous Information+ , ("server_version", (bf_server_version, Info 0 (Just 0) [] TStr))+ , ("memory_usage" , (bf_memory_usage , Info 0 (Just 0) [] TLst))+ , ("db_disk_size" , (bf_db_disk_size , Info 0 (Just 0) [] TInt))+ , ("verb_cache_stats",+ (bf_verb_cache_stats, Info 0 (Just 0) [] TLst))+ , ("log_cache_stats",+ (bf_log_cache_stats , Info 0 (Just 0) [] TAny))+ ]++-- 4.4.1 Object-Oriented Programming++bf_pass 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 [] = Int `liftM` currentTime++bf_ctime [] = ctime =<< currentTime+bf_ctime [Int time] = ctime time++ctime :: IntT -> MOO Value+ctime time =+ return $ Str $ T.pack $ formatTime defaultTimeLocale format zonedTime+ where format = "%a %b %_d %T %Y %Z"+ zonedTime = unsafePerformIO $ utcToLocalZonedTime utcTime+ utcTime = posixSecondsToUTCTime (fromIntegral time)++-- 4.4.7 Administrative Operations++bf_dump_database [] = notyet "dump_database"++bf_shutdown optional = notyet "shutdown"+ where (message : _) = maybeDefaults optional++bf_load_server_options [] = checkWizard >> loadServerOptions >> return nothing++bf_server_log (Str message : optional) = notyet "server_log"+ where [is_error] = booleanDefaults optional [False]++bf_renumber [Obj object] = notyet "renumber"++bf_reset_max_object [] = do+ checkWizard+ getDatabase >>= liftSTM . resetMaxObject >>= putDatabase+ return nothing++-- 4.4.8 Server Statistics and Miscellaneous Information++bf_server_version [] = return (Str serverVersionText)++bf_memory_usage [] = return $ Lst V.empty -- ... nothing to see here++bf_db_disk_size [] = raise E_QUOTA -- not yet?++bf_verb_cache_stats [] = notyet "verb_cache_stats"+bf_log_cache_stats [] = notyet "log_cache_stats"
+ src/MOO/Builtins.hs-boot view
@@ -0,0 +1,12 @@+-- -*- Haskell -*-++module MOO.Builtins ( builtinFunctions, callBuiltin ) where++import Data.Map (Map)++import MOO.Types+import MOO.Task+import MOO.Builtins.Common++builtinFunctions :: Map Id (Builtin, Info)+callBuiltin :: Id -> [Value] -> MOO Value
+ src/MOO/Builtins/Common.hs view
@@ -0,0 +1,43 @@++module MOO.Builtins.Common ( BuiltinSpec, Builtin, Info(..)+ , defaults, booleanDefaults, maybeDefaults ) where++import MOO.Types+import MOO.Task++-- | A pair associating a named built-in function with its implementation and+-- a description of the required arguments+type BuiltinSpec = (Id, (Builtin, Info))++-- | The type of each built-in function implementation+type Builtin = [Value] -> MOO Value++-- | A description of the number and types of required and optional arguments+--+-- @Info@ /min/ /max/ @[@/types/@]@ /return-type/ describes a function+-- requiring at least /min/ and at most /max/ arguments (or no maximum if+-- /max/ is 'Nothing'), with each argument having the specified 'Type'. The+-- /return-type/ is for documentation purposes and is not otherwise currently+-- used.+data Info = Info Int (Maybe Int) [Type] Type++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"++-- | @defaults@ /optional/ @[@/default-values/@]@ generates an argument list+-- by supplying /default-values/ for any missing from /optional/.+defaults :: [Value] -> [Value] -> [Value]+defaults = defaultOptions id++-- | Generate a list of boolean arguments with the given defaults.+booleanDefaults :: [Value] -> [Bool] -> [Bool]+booleanDefaults = defaultOptions truthOf++-- | Generate an infinite list of arguments where each missing argument is+-- 'Nothing'.+maybeDefaults :: [Value] -> [Maybe Value]+maybeDefaults = flip (defaultOptions Just) (repeat Nothing)
+ src/MOO/Builtins/Match.hsc view
@@ -0,0 +1,330 @@++{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}++-- | Regular expression matching via PCRE through the FFI+module MOO.Builtins.Match (+ Regexp+ , MatchResult(..)++ -- ** Compiling+ , newRegexp++ -- ** Matching+ , match+ , rmatch+ ) where++import Foreign hiding (unsafePerformIO)+import Foreign.C+import Control.Monad+import Control.Exception+import Control.Concurrent.MVar+import Data.Text (Text)+import Data.Text.Encoding+import Data.ByteString (ByteString, useAsCString, useAsCStringLen)+import Data.IORef+import System.IO.Unsafe (unsafePerformIO)++import qualified Data.Text as T+import qualified Data.ByteString as BS++{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-}++#include <pcre.h>++data PCRE+data PCREExtra+data PCRECalloutBlock+data CharacterTables++type Callout = Ptr PCRECalloutBlock -> IO CInt++foreign import ccall unsafe "static pcre.h"+ pcre_compile :: CString -> CInt -> 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 unsafe "static pcre.h &"+ pcre_free_study :: FunPtr (Ptr PCREExtra -> IO ())++foreign import ccall safe "static pcre.h"+ pcre_exec :: Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> CInt ->+ CInt -> Ptr CInt -> CInt -> IO CInt++foreign import ccall unsafe "static pcre.h &"+ pcre_free :: Ptr (FunPtr (Ptr a -> IO ()))++foreign import ccall "static pcre.h &"+ pcre_callout :: Ptr (FunPtr Callout)++foreign import ccall "wrapper"+ mkCallout :: Callout -> IO (FunPtr Callout)++data Regexp = Regexp {+ pattern :: Text+ , caseMatters :: Bool++ , code :: ForeignPtr PCRE+ , extra :: ForeignPtr PCREExtra+ }+ deriving Show++instance Eq Regexp where+ Regexp { pattern = p1, caseMatters = cm1 } ==+ Regexp { pattern = p2, caseMatters = cm2 } =+ cm1 == cm2 && p1 == p2++data RewriteState = StateBase+ | StateEsc+ | StateCsetInit+ | StateCsetInit2+ | StateCset++{-# ANN translate ("HLint: ignore Use list literal" :: String) #-}++-- | Translate MOO regular expression syntax into PCRE syntax.+--+-- Aside from changing % to \ and sundry tweaks we also address an+-- incompatibility between MOO %b, %B, %w, %W and PCRE \b, \B, \w, \W --+-- namely, the inclusion of _ in \w and its absence in %w.+translate :: Text -> Text+translate = T.pack . concat . rewrite . T.unpack+ where+ -- wrap entire expression so we can add a callout at the end+ rewrite s = "(?:" : rewrite' StateBase s++ rewrite' StateBase ('%':cs) = rewrite' StateEsc cs+ rewrite' StateBase ('[':cs) = "[" : rewrite' StateCsetInit cs+ rewrite' StateBase ( c :cs)+ | c `elem` "\\|(){" = "\\" : [c] : rewrite' StateBase cs+ | otherwise = [c] : rewrite' StateBase cs++ rewrite' StateCsetInit ('^':cs) = "^" : rewrite' StateCsetInit2 cs+ rewrite' StateCsetInit ( c :cs)+ | c `elem` "\\[" = "\\" : [c] : rewrite' StateCset cs+ | otherwise = [c] : rewrite' StateCset cs++ rewrite' StateCsetInit2 (c:cs)+ | c `elem` "\\[" = "\\" : [c] : rewrite' StateCset cs+ | otherwise = [c] : rewrite' StateCset cs++ rewrite' StateCset (']':cs) = "]" : rewrite' StateBase cs+ rewrite' StateCset ( c :cs)+ | c `elem` "\\[" = "\\" : [c] : rewrite' StateCset cs+ | otherwise = [c] : rewrite' StateCset cs++ -- insert a null-op (comment) to prevent special sequences+ rewrite' StateEsc ('(':cs) = "((?#)" : rewrite' StateBase cs+ rewrite' StateEsc ('b':cs) = alt wordBegin wordEnd+ : rewrite' StateBase cs+ rewrite' StateEsc ('B':cs) = alt (lookba word word)+ (lookba nonword nonword)+ : rewrite' StateBase cs+ rewrite' StateEsc ('<':cs) = wordBegin : rewrite' StateBase cs+ rewrite' StateEsc ('>':cs) = wordEnd : rewrite' StateBase cs+ rewrite' StateEsc ('w':cs) = word : rewrite' StateBase cs+ rewrite' StateEsc ('W':cs) = nonword : rewrite' StateBase cs+ rewrite' StateEsc ( c :cs)+ | c `elem` ['1'..'9'] = "\\" : [c] : "(?#)"+ : rewrite' StateBase cs+ | c `elem` "\\^$.[?*+{" = "\\" : [c] : rewrite' StateBase cs+ | otherwise = [c] : rewrite' StateBase cs++ -- add callout at end of pattern for rmatch+ rewrite' state [] = ")(?C)" : rewriteFinal state++ -- don't let a trailing % get away without a syntax error+ rewriteFinal StateEsc = "\\" : []+ rewriteFinal _ = []++ word = "[^\\W_]"+ nonword = "[\\W_]"+ alt a b = "(?:" ++ a ++ "|" ++ b ++ ")"+ lbehind p = "(?<=" ++ p ++ ")"+ lahead p = "(?=" ++ p ++ ")"+ lookba b a = lbehind b ++ lahead a+ wordBegin = alt "^" (lbehind nonword) ++ lahead word+ wordEnd = lbehind word ++ alt "$" (lahead nonword)++-- | @newRegexp@ /regexp/ /case-matters/ compiles a regular expression pattern+-- /regexp/ into a 'Regexp' value, or returns an error description if the+-- pattern is malformed. The returned 'CInt' is a byte offset into an+-- internally translated pattern, and thus is probably not very useful.+newRegexp :: Text -> Bool -> IO (Either (String, CInt) Regexp)+newRegexp regexp caseMatters =+ useAsCString (encodeUtf8 $ translate regexp) $ \pattern ->+ alloca $ \errorPtr ->+ alloca $ \errorOffsetPtr -> do+ code <- pcre_compile pattern options errorPtr errorOffsetPtr nullPtr+ if code == nullPtr+ then do error <- peek errorPtr >>= peekCString+ errorOffset <- peek errorOffsetPtr+ return $ Left (patchError error, errorOffset)+ else do extraFP <- mkExtra code+ setExtraFlags extraFP+ codeFP <- peek pcre_free >>= flip newForeignPtr code+ return $ Right Regexp { pattern = regexp+ , caseMatters = caseMatters+ , code = codeFP+ , extra = extraFP+ }+ where+ mkExtra code = alloca $ \errorPtr -> do+ extra <- pcre_study code 0 errorPtr+ if extra == nullPtr+ then do extraFP <- mallocForeignPtrBytes #{const sizeof(pcre_extra)}+ withForeignPtr extraFP $ \extra ->+ #{poke pcre_extra, flags} extra (0 :: CULong)+ return extraFP+ else newForeignPtr pcre_free_study extra++ 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++ 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 = 10+ovecLen = maxCaptures * 3++data MatchResult = MatchFailed+ | MatchAborted+ | MatchSucceeded [(Int, Int)]+ deriving Show++-- We need a lock to protect pcre_callout which is shared by all threads+matchLock :: MVar ()+matchLock = unsafePerformIO $ newMVar ()+{-# NOINLINE matchLock #-}++match :: Regexp -> Text -> IO MatchResult+match Regexp { code = codeFP, extra = extraFP } text =+ bracket (takeMVar matchLock) (putMVar matchLock) $ \_ ->+ withForeignPtr codeFP $ \code ->+ withForeignPtr extraFP $ \extra ->+ useAsCStringLen string $ \(cstring, len) ->+ allocaArray ovecLen $ \ovec -> do++ flags <- #{peek pcre_extra, flags} extra+ #{poke pcre_extra, flags} extra $ flags .&. complement (0 :: CULong)+ .&. complement #{const PCRE_EXTRA_CALLOUT_DATA}+ poke pcre_callout nullFunPtr++ rc <- pcre_exec code extra cstring (fromIntegral len) 0 options+ ovec (fromIntegral ovecLen)+ if rc < 0+ then case rc of+ #{const PCRE_ERROR_NOMATCH} -> return MatchFailed+ _ -> return MatchAborted+ else mkMatchResult rc ovec subject++ where string = encodeUtf8 text+ subject = (string, T.length text)+ options = #{const PCRE_NO_UTF8_CHECK}++rmatch :: Regexp -> Text -> IO MatchResult+rmatch Regexp {code = codeFP, extra = extraFP } text =+ bracket (takeMVar matchLock) (putMVar matchLock) $ \_ ->+ withForeignPtr codeFP $ \code ->+ withForeignPtr extraFP $ \extra ->+ useAsCStringLen string $ \(cstring, len) ->+ allocaArray ovecLen $ \ovec ->+ allocaArray ovecLen $ \rOvec -> do++ rdRef <- newIORef RmatchData { rmatchResult = 0, rmatchOvec = rOvec }+ bracket (newStablePtr rdRef) freeStablePtr $ \sp -> do+ #{poke pcre_extra, callout_data} extra sp++ flags <- #{peek pcre_extra, flags} extra+ #{poke pcre_extra, flags} extra $ flags .|. (0 :: CULong)+ .|. #{const PCRE_EXTRA_CALLOUT_DATA}++ bracket (mkCallout rmatchCallout) freeHaskellFunPtr $ \callout -> do+ poke pcre_callout callout++ rc <- pcre_exec code extra cstring (fromIntegral len) 0 options+ ovec (fromIntegral ovecLen)+ if rc < 0+ then case rc of+ #{const PCRE_ERROR_NOMATCH} -> do+ rd <- readIORef rdRef+ if valid rd+ then mkMatchResult (rmatchResult rd) (rmatchOvec rd) subject+ else return MatchFailed+ _ -> return MatchAborted+ else mkMatchResult rc ovec subject++ where string = encodeUtf8 text+ subject = (string, T.length text)+ options = #{const PCRE_NO_UTF8_CHECK}++mkMatchResult :: CInt -> Ptr CInt -> (ByteString, Int) -> IO MatchResult+mkMatchResult rc ovec (subject, subjectCharLen) =+ (MatchSucceeded . pairs . map (rebase . fromIntegral)) `liftM`+ peekArray (n * 2) ovec++ where rc' = fromIntegral rc+ n = if rc' == 0 || rc' > maxCaptures then maxCaptures else rc'++ pairs (s:e:rs) = (s, e) : pairs rs+ pairs [] = []++ -- translate UTF-8 byte offset to character offset+ rebase 0 = 0+ rebase i = subjectCharLen - T.length (decodeUtf8 $ BS.drop i subject)++data RmatchData = RmatchData {+ rmatchResult :: CInt+ , rmatchOvec :: Ptr CInt+ }++valid :: RmatchData -> Bool+valid RmatchData { rmatchResult = rc } = rc /= 0++rmatchCallout :: Callout+rmatchCallout block = do+ rdRef <- deRefStablePtr =<< #{peek pcre_callout_block, callout_data} block+ rd <- readIORef rdRef++ currentPos <- #{peek pcre_callout_block, current_position} block+ startMatch <- #{peek pcre_callout_block, start_match} block++ let ovec = rmatchOvec rd+ ovec0 <- peekElemOff ovec 0+ ovec1 <- peekElemOff ovec 1++ when (not (valid rd) || startMatch > ovec0 ||+ (startMatch == ovec0 && currentPos > ovec1)) $ do+ -- make a copy of the offsets vector so the last such vector found can+ -- be returned as the rightmost match+ pokeElemOff ovec 0 startMatch+ pokeElemOff ovec 1 currentPos++ offsetVector <- #{peek pcre_callout_block, offset_vector} block+ captureTop <- #{peek pcre_callout_block, capture_top} block++ copyArray (ovec `advancePtr` 2)+ (offsetVector `advancePtr` 2)+ (sizeOf ovec0 * 2 * (fromIntegral captureTop - 1))++ writeIORef rdRef rd { rmatchResult = captureTop }++ return 1 -- cause match failure at current point, but continue trying
+ src/MOO/Builtins/Network.hs view
@@ -0,0 +1,124 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Builtins.Network ( builtins ) where++import Control.Monad (liftM)+import Control.Monad.State (gets)+import Data.Time++import MOO.Types+import MOO.Task+import MOO.Network+import MOO.Database (systemObject)+import MOO.Builtins.Common++import qualified Data.Map as M+import qualified Data.Text as T++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}++-- | § 4.4.4 Operations on Network Connections+builtins :: [BuiltinSpec]+builtins = [+ ("connected_players",+ (bf_connected_players, Info 0 (Just 1) [TAny] TLst))+ , ("connected_seconds",+ (bf_connected_seconds, Info 1 (Just 1) [TObj] TInt))+ , ("idle_seconds" , (bf_idle_seconds , Info 1 (Just 1) [TObj] TInt))+ , ("notify" , (bf_notify , Info 2 (Just 3) [TObj, TStr,+ TAny] TAny))+ , ("buffered_output_length",+ (bf_buffered_output_length, Info 0 (Just 1) [TObj] TInt))+ , ("read" , (bf_read , Info 0 (Just 2) [TObj, TAny] TStr))+ , ("force_input" , (bf_force_input , Info 2 (Just 3) [TObj, TStr,+ TAny] TAny))+ , ("flush_input" , (bf_flush_input , Info 1 (Just 2) [TObj, TAny] TAny))+ , ("output_delimiters",+ (bf_output_delimiters, Info 1 (Just 1) [TObj] TLst))+ , ("boot_player" , (bf_boot_player , Info 1 (Just 1) [TObj] TAny))+ , ("connection_name",+ (bf_connection_name, Info 1 (Just 1) [TObj] TStr))+ , ("set_connection_option",+ (bf_set_connection_option, Info 3 (Just 3) [TObj, TStr,+ TAny] TAny))+ , ("connection_options",+ (bf_connection_options, Info 1 (Just 1) [TObj] TLst))+ , ("connection_option",+ (bf_connection_option, Info 2 (Just 2) [TObj, TStr] TAny))+ , ("open_network_connection",+ (bf_open_network_connection, Info 2 (Just 3) [TStr, TInt,+ TObj] TObj))+ , ("listen" , (bf_listen , Info 2 (Just 3) [TObj, TInt,+ TAny] TAny))+ , ("unlisten" , (bf_unlisten , Info 1 (Just 1) [TInt] TAny))+ , ("listeners" , (bf_listeners , Info 0 (Just 0) [] TLst))+ ]++bf_connected_players optional = do+ world <- getWorld+ let objects = M.keys $ connections world+ return $ objectList $ if include_all then objects else filter (>= 0) objects+ where [include_all] = booleanDefaults optional [False]++connectionSeconds :: ObjId -> (Maybe Connection -> Maybe UTCTime) -> MOO Value+connectionSeconds oid f = do+ world <- getWorld+ case f $ M.lookup oid (connections world) of+ Just utcTime -> secondsSince utcTime+ Nothing -> raise E_INVARG++ where secondsSince :: UTCTime -> MOO Value+ secondsSince utcTime = do+ now <- gets startTime+ return (Int $ floor $ now `diffUTCTime` utcTime)++bf_connected_seconds [Obj player] =+ connectionSeconds player (connectionEstablishedTime =<<)++bf_idle_seconds [Obj player] =+ connectionSeconds player (connectionActivityTime `fmap`)++bf_notify (Obj conn : Str string : optional) = do+ notify conn string+ return $ truthValue True+ where [no_flush] = booleanDefaults optional [False]++bf_buffered_output_length optional = notyet "buffered_output_length"+bf_read optional = notyet "read"+bf_force_input (Obj conn : Str line : optional) = notyet "force_input"+bf_flush_input (Obj conn : optional) = notyet "flush_input"+bf_output_delimiters [Obj player] = notyet "output_delimiters"+bf_boot_player [Obj player] = notyet "boot_player"++bf_connection_name [Obj player] = do+ checkPermission player+ Str `liftM` getConnectionName player++bf_set_connection_option [Obj conn, Str option, value] =+ notyet "set_connection_option"+bf_connection_options [Obj conn] = notyet "connection_options"+bf_connection_option [Obj conn, Str name] = notyet "connection_option"++bf_open_network_connection (Str host : Int port : optional) = do+ checkWizard+ connId <- openNetworkConnection (T.unpack host) (fromIntegral port) listener+ return (Obj connId)++ where [Obj listener] = defaults optional [Obj systemObject]++bf_listen (Obj object : Int point : optional) = do+ checkWizard+ checkValid object++ canon <- listen (fromIntegral point) object print_messages+ return (Int $ fromIntegral canon)++ where [print_messages] = booleanDefaults optional [False]++bf_unlisten [Int canon] =+ checkWizard >> unlisten (fromIntegral canon) >> return nothing++bf_listeners [] = do+ world <- getWorld+ return $ fromListBy formatListener $ M.elems (listeners world)
+ src/MOO/Builtins/Objects.hs view
@@ -0,0 +1,589 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Builtins.Objects ( builtins ) where++import Control.Concurrent.STM+import Control.Monad (when, unless, liftM, void, join)+import Data.Maybe+import Data.Set (Set)++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.Vector as V++import MOO.Builtins.Common+import MOO.Database+import MOO.Types+import MOO.Task+import MOO.Object+import MOO.Verb+import MOO.Network+import MOO.Unparser+import MOO.Parser+import {-# SOURCE #-} MOO.Compiler+import MOO.AST++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}++-- | § 4.4.3 Manipulating Objects+builtins :: [BuiltinSpec]+builtins = [+ ("create" , (bf_create , Info 1 (Just 2) [TObj, TObj] TObj))+ , ("chparent" , (bf_chparent , Info 2 (Just 2) [TObj, TObj] TAny))+ , ("valid" , (bf_valid , Info 1 (Just 1) [TObj] TInt))+ , ("parent" , (bf_parent , Info 1 (Just 1) [TObj] TObj))+ , ("children" , (bf_children , Info 1 (Just 1) [TObj] TLst))+ , ("recycle" , (bf_recycle , Info 1 (Just 1) [TObj] TAny))+ , ("object_bytes" , (bf_object_bytes , Info 1 (Just 1) [TObj] TInt))+ , ("max_object" , (bf_max_object , Info 0 (Just 0) [] TObj))++ , ("move" , (bf_move , Info 2 (Just 2) [TObj, TObj] TAny))+ , ("properties" , (bf_properties , Info 1 (Just 1) [TObj] TLst))+ , ("property_info" , (bf_property_info , Info 2 (Just 2) [TObj, TStr] TLst))+ , ("set_property_info",+ (bf_set_property_info, Info 3 (Just 3) [TObj, TStr,+ TLst] TAny))+ , ("add_property" , (bf_add_property , Info 4 (Just 4) [TObj, TStr,+ TAny, TLst] TAny))+ , ("delete_property",+ (bf_delete_property, Info 2 (Just 2) [TObj, TStr] TAny))+ , ("is_clear_property",+ (bf_is_clear_property, Info 2 (Just 2) [TObj, TStr] TInt))+ , ("clear_property", (bf_clear_property, Info 2 (Just 2) [TObj, TStr] TAny))++ , ("verbs" , (bf_verbs , Info 1 (Just 1) [TObj] TLst))+ , ("verb_info" , (bf_verb_info , Info 2 (Just 2) [TObj, TAny] TLst))+ , ("set_verb_info" , (bf_set_verb_info , Info 3 (Just 3) [TObj, TAny,+ TLst] TAny))+ , ("verb_args" , (bf_verb_args , Info 2 (Just 2) [TObj, TAny] TLst))+ , ("set_verb_args" , (bf_set_verb_args , Info 3 (Just 3) [TObj, TAny,+ TLst] TAny))+ , ("add_verb" , (bf_add_verb , Info 3 (Just 3) [TObj, TLst,+ TLst] TInt))+ , ("delete_verb" , (bf_delete_verb , Info 2 (Just 2) [TObj, TAny] TAny))+ , ("verb_code" , (bf_verb_code , Info 2 (Just 4) [TObj, TAny,+ TAny, TAny] TLst))+ , ("set_verb_code" , (bf_set_verb_code , Info 3 (Just 3) [TObj, TAny,+ TLst] TLst))+ , ("disassemble" , (bf_disassemble , Info 2 (Just 2) [TObj, TAny] TLst))++ , ("players" , (bf_players , Info 0 (Just 0) [] TLst))+ , ("is_player" , (bf_is_player , Info 1 (Just 1) [TObj] TInt))+ , ("set_player_flag",+ (bf_set_player_flag, Info 2 (Just 2) [TObj, TAny] TAny))+ ]++-- § 4.4.3.1 Fundamental Operations on Objects++bf_create (Obj parent : optional) = do+ maybeParent <- case parent of+ -1 -> return Nothing+ oid -> checkFertile oid >> return (Just oid)++ db <- getDatabase+ let newOid = maxObject db + 1++ ownerOid <- case maybeOwner of+ Nothing -> frame permissions+ Just (Obj (-1)) -> checkWizard >> return newOid+ Just (Obj oid) -> checkPermission oid >> return oid++ maybeQuota <- readProperty ownerOid "ownership_quota"+ case maybeQuota of+ Just (Int quota)+ | quota <= 0 -> raise E_QUOTA+ | otherwise -> writeProperty ownerOid "ownership_quota" (Int $ quota - 1)+ _ -> return ()++ properties <- case maybeParent of+ Nothing -> return $ objectProperties initObject+ Just oid -> do+ -- add to parent's set of children+ liftSTM $ modifyObject oid db $ \obj -> return $ addChild obj newOid++ -- properties inherited from parent+ Just parent <- getObject oid+ HM.fromList `liftM` mapM mkProperty (HM.toList $ objectProperties parent)++ where mkProperty (name, propTVar) = liftSTM $ do+ prop <- readTVar propTVar+ let prop' = prop {+ propertyValue = Nothing+ , propertyInherited = True+ , propertyOwner = if propertyPermC prop+ then ownerOid+ else propertyOwner prop+ }+ propTVar' <- newTVar prop'+ return (name, propTVar')++ let newObj = initObject {+ objectParent = maybeParent+ , objectOwner = ownerOid+ , objectProperties = properties+ }++ putDatabase =<< liftSTM (addObject newObj db)++ callFromFunc "create" 0 (newOid, "initialize") []+ return (Obj newOid)++ where (maybeOwner : _) = maybeDefaults optional++bf_chparent [Obj object, Obj new_parent] = notyet "chparent"++bf_valid [Obj object] = (truthValue . isJust) `liftM` getObject object++bf_parent [Obj object] = (Obj . getParent) `liftM` checkValid object++bf_children [Obj object] = (objectList . getChildren) `liftM` checkValid object++bf_recycle [Obj object] = notyet "recycle"++bf_object_bytes [Obj object] = do+ checkWizard+ obj <- checkValid object++ propertyBytes <- liftM storageBytes $ liftSTM $+ mapM readTVar $ HM.elems (objectProperties obj)+ verbBytes <- liftM storageBytes $ liftSTM $+ mapM (readTVar . snd) $ objectVerbs obj++ return $ Int $ fromIntegral $ storageBytes obj + propertyBytes + verbBytes++bf_max_object [] = (Obj . maxObject) `liftM` getDatabase++-- § 4.4.3.2 Object Movement++bf_move [Obj what, Obj where_] = do+ what' <- checkValid what+ where' <- case where_ of+ -1 -> return Nothing+ oid -> Just `liftM` checkValid oid+ checkPermission (objectOwner what')++ when (isJust where') $ do+ accepted <- maybe False truthOf `liftM`+ callFromFunc "move" 0 (where_, "accept") [Obj what]+ unless accepted $ do+ wizard <- isWizard =<< frame permissions+ unless wizard $ raise E_NACC++ let newWhere = case where_ of+ -1 -> Nothing+ oid -> Just oid++ maybeWhat <- getObject what+ case maybeWhat of+ Nothing -> return ()+ Just whatObj -> unless (objectLocation whatObj == newWhere) $ do+ maybeWhere <- getObject where_+ when (isNothing newWhere || isJust maybeWhere) $ do+ checkRecurse what where_++ let oldWhere = objectLocation whatObj+ db <- getDatabase++ liftSTM $ 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) }+ case newWhere of+ Nothing -> return ()+ Just newWhere' -> liftSTM $ modifyObject newWhere' db $ \obj ->+ return obj { objectContents = IS.insert what (objectContents obj) }++ case oldWhere of+ Nothing -> return ()+ Just oldWhere' ->+ void $ callFromFunc "move" 1 (oldWhere', "exitfunc") [Obj what]++ maybeWhat <- getObject what+ case maybeWhat of+ Nothing -> return ()+ Just whatObj ->+ when (objectLocation whatObj == newWhere) $+ void $ callFromFunc "move" 2 (where_, "enterfunc") [Obj what]++ return nothing++ where checkRecurse what loc = do+ when (loc == what) $ raise E_RECMOVE+ maybeLoc <- getObject loc+ case join $ objectLocation `fmap` maybeLoc of+ Just oid -> checkRecurse what oid+ Nothing -> return ()++-- § 4.4.3.3 Operations on Properties++bf_properties [Obj object] = do+ obj <- checkValid object+ unless (objectPermR obj) $ checkPermission (objectOwner obj)++ stringList `liftM` liftSTM (definedProperties obj)++bf_property_info [Obj object, Str prop_name] = do+ obj <- checkValid object+ prop <- getProperty obj prop_name+ unless (propertyPermR prop) $ checkPermission (propertyOwner prop)++ return $ fromList [Obj $ propertyOwner prop, Str $ perms prop]++ where perms prop = T.pack $ concat [['r' | propertyPermR prop],+ ['w' | propertyPermW prop],+ ['c' | propertyPermC prop]]++traverseDescendants :: (Object -> MOO a) -> ObjId -> MOO ()+traverseDescendants f oid = do+ Just obj <- getObject oid+ f obj+ mapM_ (traverseDescendants f) $ getChildren obj++modifyDescendants :: Database -> (Object -> STM Object) -> ObjId -> MOO ()+modifyDescendants db f oid = do+ liftSTM $ modifyObject oid db f+ Just obj <- getObject oid+ mapM_ (modifyDescendants db f) $ getChildren obj++{-# ANN module ("HLint: ignore Use String" :: String) #-}++checkPerms :: [Char] -> StrT -> MOO (Set Char)+checkPerms valid perms = do+ let permSet = S.fromList (T.unpack $ T.toCaseFold perms)+ unless (S.null $ permSet `S.difference` S.fromList valid) $ raise E_INVARG+ return permSet++bf_set_property_info [Obj object, Str prop_name, Lst info] = do+ (owner, perms, new_name) <- case V.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)+ [_ , _ , _ ] -> raise E_TYPE+ _ -> raise E_INVARG+ permSet <- checkPerms "rwc" perms+ checkValid owner++ obj <- checkValid object+ prop <- getProperty obj prop_name+ unless (propertyPermW prop) $ checkPermission (propertyOwner prop)+ checkPermission owner++ let setInfo = modifyProperty obj prop_name $ \prop ->+ return prop {+ propertyOwner = owner+ , propertyPermR = 'r' `S.member` permSet+ , propertyPermW = 'w' `S.member` permSet+ , propertyPermC = 'c' `S.member` permSet+ }++ case new_name of+ Nothing -> setInfo+ Just newName -> do+ let newName' = T.toCaseFold newName+ oldName' = T.toCaseFold prop_name++ unless (objectPermW obj) $ checkPermission (objectOwner obj)++ when (propertyInherited prop) $ raise E_INVARG+ unless (newName' == oldName') $ flip traverseDescendants object $ \obj ->+ when (isJust $ lookupPropertyRef obj newName') $ raise E_INVARG++ setInfo++ db <- getDatabase+ flip (modifyDescendants db) object $ \obj -> do+ let Just propTVar = lookupPropertyRef obj oldName'+ prop <- readTVar propTVar+ writeTVar propTVar $ prop { propertyName = newName }++ return obj { objectProperties =+ HM.insert newName' propTVar $+ HM.delete oldName' (objectProperties obj) }++ return nothing++bf_add_property [Obj object, Str prop_name, value, Lst info] = do+ (owner, perms) <- case V.toList info of+ [Obj owner, Str perms] -> return (owner, perms)+ [_ , _ ] -> raise E_TYPE+ _ -> raise E_INVARG+ permSet <- checkPerms "rwc" perms+ checkValid owner++ obj <- checkValid object+ unless (objectPermW obj) $ checkPermission (objectOwner obj)+ checkPermission owner++ when (isBuiltinProperty name) $ raise E_INVARG+ flip traverseDescendants object $ \obj ->+ when (isJust $ lookupPropertyRef obj name) $ raise E_INVARG++ let definedProp = initProperty {+ propertyName = prop_name+ , propertyValue = Just value+ , propertyInherited = False+ , propertyOwner = owner+ , propertyPermR = 'r' `S.member` permSet+ , propertyPermW = 'w' `S.member` permSet+ , propertyPermC = 'c' `S.member` permSet+ }+ inheritedProp = definedProp {+ propertyInherited = True+ , propertyValue = Nothing+ }+ addProperty prop obj = do+ propTVar <- newTVar prop+ return obj { objectProperties =+ HM.insert name propTVar $ objectProperties obj }+ addInheritedProperty prop obj =+ flip addProperty obj $ if propertyPermC prop+ then prop { propertyOwner = objectOwner obj }+ else prop+ db <- getDatabase+ liftSTM $ modifyObject object db (addProperty definedProp)+ mapM_ (modifyDescendants db $+ addInheritedProperty inheritedProp) $ getChildren obj++ return nothing++ where name = T.toCaseFold prop_name++bf_delete_property [Obj object, Str prop_name] = do+ obj <- checkValid object+ unless (objectPermW obj) $ checkPermission (objectOwner obj)+ prop <- getProperty obj prop_name+ when (propertyInherited prop) $ raise E_PROPNF++ db <- getDatabase+ flip (modifyDescendants db) object $ \obj ->+ return obj { objectProperties = HM.delete name (objectProperties obj) }++ return nothing++ where name = T.toCaseFold prop_name++bf_is_clear_property [Obj object, Str prop_name] = do+ obj <- checkValid object+ if isBuiltinProperty prop_name+ then return $ truthValue False+ else do+ prop <- getProperty obj prop_name+ unless (propertyPermR prop) $ checkPermission (propertyOwner prop)++ return (truthValue $ isNothing $ propertyValue prop)++bf_clear_property [Obj object, Str prop_name] = do+ obj <- checkValid object+ if isBuiltinProperty prop_name+ then raise E_PERM+ else do+ modifyProperty obj prop_name $ \prop -> do+ unless (propertyPermW prop) $ checkPermission (propertyOwner prop)+ unless (propertyInherited prop) $ raise E_INVARG+ return prop { propertyValue = Nothing }++ return nothing++-- § 4.4.3.4 Operations on Verbs++bf_verbs [Obj object] = do+ obj <- checkValid object+ unless (objectPermR obj) $ checkPermission (objectOwner obj)++ stringList `liftM` liftSTM (definedVerbs obj)++bf_verb_info [Obj object, verb_desc] = do+ obj <- checkValid object+ verb <- getVerb obj verb_desc+ unless (verbPermR verb) $ checkPermission (verbOwner verb)++ return $ fromList+ [Obj $ verbOwner verb, Str $ perms verb, Str $ verbNames verb]++ where perms verb = T.pack $ concat [['r' | verbPermR verb],+ ['w' | verbPermW verb],+ ['x' | verbPermX verb],+ ['d' | verbPermD verb]]++verbInfo :: LstT -> MOO (ObjId, Set Char, StrT)+verbInfo info = do+ (owner, perms, names) <- case V.toList info of+ [Obj owner, Str perms, Str names] -> return (owner, perms, names)+ [_ , _ , _ ] -> raise E_TYPE+ _ -> raise E_INVARG+ permSet <- checkPerms "rwxd" perms+ checkValid owner+ when (null $ T.words names) $ raise E_INVARG++ return (owner, permSet, names)++bf_set_verb_info [Obj object, verb_desc, Lst info] = do+ (owner, permSet, names) <- verbInfo info++ obj <- checkValid object+ verb <- getVerb obj verb_desc+ unless (verbPermW verb) $ checkPermission (verbOwner verb)+ checkPermission owner++ let newNames = T.toCaseFold names+ oldNames = T.toCaseFold (verbNames verb)+ unless (newNames == oldNames || objectPermW obj) $+ checkPermission (objectOwner obj)++ modifyVerb (object, obj) verb_desc $ \verb ->+ return verb {+ verbNames = names+ , verbOwner = owner+ , verbPermR = 'r' `S.member` permSet+ , verbPermW = 'w' `S.member` permSet+ , verbPermX = 'x' `S.member` permSet+ , verbPermD = 'd' `S.member` permSet+ }++ return nothing++bf_verb_args [Obj object, verb_desc] = do+ obj <- checkValid object+ verb <- getVerb obj verb_desc+ unless (verbPermR verb) $ checkPermission (verbOwner verb)++ return $ stringList [dobj verb, prep verb, iobj verb]++ where dobj = obj2text . verbDirectObject+ iobj = obj2text . verbIndirectObject+ prep = prep2text . verbPreposition++verbArgs :: LstT -> MOO (ObjSpec, PrepSpec, ObjSpec)+verbArgs args = do+ (dobj, prep, iobj) <- case V.toList args of+ [Str dobj, Str prep, Str iobj] -> return (dobj, breakSlash prep, iobj)+ where breakSlash = fst . T.breakOn "/"+ [_ , _ , _ ] -> raise E_TYPE+ _ -> raise E_INVARG+ dobj' <- maybe (raise E_INVARG) return $ text2obj (T.toCaseFold dobj)+ prep' <- maybe (raise E_INVARG) return $ text2prep (T.toCaseFold prep)+ iobj' <- maybe (raise E_INVARG) return $ text2obj (T.toCaseFold iobj)++ return (dobj', prep', iobj')++bf_set_verb_args [Obj object, verb_desc, Lst args] = do+ (dobj, prep, iobj) <- verbArgs args++ obj <- checkValid object+ verb <- getVerb obj verb_desc+ unless (verbPermW verb) $ checkPermission (verbOwner verb)++ modifyVerb (object, obj) verb_desc $ \verb ->+ return verb {+ verbDirectObject = dobj+ , verbPreposition = prep+ , verbIndirectObject = iobj+ }++ return nothing++bf_add_verb [Obj object, Lst info, Lst args] = do+ (owner, permSet, names) <- verbInfo info+ (dobj, prep, iobj) <- verbArgs args++ obj <- checkValid object+ unless (objectPermW obj) $ checkPermission (objectOwner obj)+ checkPermission owner++ let definedVerb = initVerb {+ verbNames = names+ , verbOwner = owner+ , verbPermR = 'r' `S.member` permSet+ , verbPermW = 'w' `S.member` permSet+ , verbPermX = 'x' `S.member` permSet+ , verbPermD = 'd' `S.member` permSet+ , verbDirectObject = dobj+ , verbPreposition = prep+ , verbIndirectObject = iobj+ }++ db <- getDatabase+ liftSTM $ modifyObject object db $ addVerb definedVerb++ return $ Int $ fromIntegral $ length (objectVerbs obj) + 1++bf_delete_verb [Obj object, verb_desc] = do+ obj <- checkValid object+ getVerb obj verb_desc+ unless (objectPermW obj) $ checkPermission (objectOwner obj)++ case lookupVerbRef obj verb_desc of+ Nothing -> raise E_VERBNF+ Just (index, _) -> do+ db <- getDatabase+ liftSTM $ modifyObject object db $ deleteVerb index++ return nothing++bf_verb_code (Obj object : verb_desc : optional) = do+ obj <- checkValid object+ verb <- getVerb obj verb_desc+ unless (verbPermR verb) $ checkPermission (verbOwner verb)+ checkProgrammer++ let code = init $ T.splitOn "\n" $+ unparse fully_paren indent (verbProgram verb)+ return (stringList code)++ where [fully_paren, indent] = booleanDefaults optional [False, True]++bf_set_verb_code [Obj object, verb_desc, Lst code] = do+ obj <- checkValid object+ verb <- getVerb obj verb_desc+ text <- (T.concat . ($ [])) `liftM` V.foldM addLine id code+ unless (verbPermW verb) $ checkPermission (verbOwner verb)+ checkProgrammer++ case parse text of+ Left errors -> return $ fromListBy (Str . T.pack) errors+ Right program -> do+ modifyVerb (object, obj) verb_desc $ \verb ->+ return verb {+ verbProgram = program+ , verbCode = compile program+ }+ return $ Lst V.empty++ where addLine :: ([StrT] -> [StrT]) -> Value -> MOO ([StrT] -> [StrT])+ addLine add (Str line) = return (add [line, "\n"] ++)+ addLine _ _ = raise E_INVARG++bf_disassemble [Obj object, verb_desc] = do+ obj <- checkValid object+ verb <- getVerb obj verb_desc+ unless (verbPermR verb) $ checkPermission (verbOwner verb)++ let Program statements = verbProgram verb+ return $ fromListBy (Str . T.pack . show) statements++-- § 4.4.3.5 Operations on Player Objects++bf_players [] = (objectList . allPlayers) `liftM` getDatabase++bf_is_player [Obj object] =+ (truthValue . objectIsPlayer) `liftM` checkValid object++bf_set_player_flag [Obj object, value] = do+ checkValid object+ checkWizard++ db <- getDatabase+ liftSTM $ modifyObject object db $+ \obj -> return obj { objectIsPlayer = isPlayer }+ putDatabase $ setPlayer isPlayer object db++ unless isPlayer $ bootPlayer object++ return nothing++ where isPlayer = truthOf value
+ src/MOO/Builtins/Tasks.hs view
@@ -0,0 +1,247 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Builtins.Tasks ( builtins ) where++import Control.Concurrent (forkIO, threadDelay, killThread)+import Control.Concurrent.STM+import Control.Monad (liftM, 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.Clock.POSIX (utcTimeToPOSIXSeconds)+import System.Posix (nanosleep)++import MOO.Types+import MOO.Task+import MOO.Object+import MOO.Verb+import MOO.Parser+import {-# SOURCE #-} MOO.Compiler+import {-# SOURCE #-} MOO.Builtins+import MOO.Builtins.Common++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}++-- | § 4.4.6 MOO-Code Evaluation and Task Manipulation+builtins :: [BuiltinSpec]+builtins = [+ ("raise" , (bf_raise , Info 1 (Just 3) [TAny, TStr,+ TAny] TAny))+ , ("call_function" , (bf_call_function , Info 1 Nothing [TStr] TAny))+ , ("function_info" , (bf_function_info , Info 0 (Just 1) [TStr] TLst))+ , ("eval" , (bf_eval , Info 1 (Just 1) [TStr] TLst))+ , ("set_task_perms", (bf_set_task_perms, Info 1 (Just 1) [TObj] TAny))+ , ("caller_perms" , (bf_caller_perms , Info 0 (Just 0) [] TObj))+ , ("ticks_left" , (bf_ticks_left , Info 0 (Just 0) [] TInt))+ , ("seconds_left" , (bf_seconds_left , Info 0 (Just 0) [] TInt))+ , ("task_id" , (bf_task_id , Info 0 (Just 0) [] TInt))+ , ("suspend" , (bf_suspend , Info 0 (Just 1) [TNum] TAny))+ , ("resume" , (bf_resume , Info 1 (Just 2) [TInt, TAny] TAny))+ , ("queue_info" , (bf_queue_info , Info 0 (Just 1) [TObj] TLst))+ , ("queued_tasks" , (bf_queued_tasks , Info 0 (Just 0) [] TLst))+ , ("kill_task" , (bf_kill_task , Info 1 (Just 1) [TInt] TAny))+ , ("callers" , (bf_callers , Info 0 (Just 1) [TAny] TLst))+ , ("task_stack" , (bf_task_stack , Info 1 (Just 2) [TInt, TAny] TLst))+ ]++bf_raise (code : optional) = raiseException $ Exception code message value+ where [Str message, value] = defaults optional [Str $ toText code, nothing]++bf_call_function (Str func_name : args) =+ callBuiltin (T.toCaseFold func_name) args++formatInfo :: (Id, (Builtin, Info)) -> Value+formatInfo (name, (_, Info min max types _)) =+ fromList [ Str name+ , Int $ fromIntegral min+ , Int $ maybe (-1) fromIntegral max+ , fromListBy (Int . typeCode) types+ ]++bf_function_info [] = return $ fromListBy formatInfo $ M.assocs builtinFunctions+bf_function_info [Str name] =+ case M.lookup name' builtinFunctions of+ Just detail -> return $ formatInfo (name', detail)+ Nothing -> raise E_INVARG+ where name' = T.toCaseFold name++bf_eval [Str string] = do+ checkProgrammer+ case parse string of+ Left errors -> return $ fromList [truthValue False,+ fromListBy (Str . T.pack) errors]+ 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+ }+ vars = mkVariables [+ ("player", Obj player)+ , ("caller", Obj this)+ ]+ value <- evalFromFunc "eval" 0 $+ runVerb verb initFrame {+ variables = vars+ , initialPlayer = player+ }+ return $ fromList [truthValue True, value]++bf_set_task_perms [Obj who] = do+ checkPermission who+ modifyFrame $ \frame -> frame { permissions = who }+ return nothing++bf_caller_perms [] = (Obj . objectForMaybe) `liftM` caller permissions++bf_ticks_left [] = (Int . fromIntegral) `liftM` gets ticksLeft++bf_seconds_left [] = return (Int 5) -- XXX can this be measured?++bf_task_id [] = (Int . fromIntegral) `liftM` asks (taskId . task)++bf_suspend optional = do+ 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++ state <- get++ estimatedWakeup <- case maybeMicroseconds of+ Just usecs+ | time < now || time > endOfTime -> raise E_INVARG+ | otherwise -> return time+ where now = startTime state+ time = (fromIntegral usecs / 1000000) `addUTCTime` now++ Nothing -> return endOfTime -- XXX this is a sad wart in need of remedy++ resumeTMVar <- liftSTM newEmptyTMVar+ task <- asks task++ let wake value = do+ now <- getCurrentTime+ atomically $ putTMVar resumeTMVar (now, value)++ task' = task {+ taskStatus = Suspended (Wake wake)+ , taskState = state { startTime = estimatedWakeup }+ }++ case maybeMicroseconds of+ Just usecs -> delayIO $ void $ forkIO $ do+ if usecs <= fromIntegral (maxBound :: Int)+ then threadDelay (fromIntegral usecs)+ else nanosleep (usecs * 1000)+ wake nothing+ Nothing -> return ()++ putTask task'++ callCC $ interrupt . Suspend maybeMicroseconds . Resume+ (now, value) <- liftSTM $ takeTMVar resumeTMVar++ putTask task' { taskStatus = Running }++ modify $ \state -> state { ticksLeft = 15000, startTime = now } -- XXX ticks++ case value of+ Err error -> raise error+ _ -> return value++ where (maybeSeconds : _) = maybeDefaults optional++bf_resume (Int task_id : optional) = do+ maybeTask <- getTask task_id'+ case maybeTask of+ Just task@Task { taskStatus = Suspended (Wake wake) } -> do+ checkPermission (taskOwner task)+ putTask task { taskStatus = Running }+ delayIO (wake value)+ _ -> raise E_INVARG++ return nothing++ where [value] = defaults optional [nothing]+ task_id' = fromIntegral task_id++bf_queue_info [] =+ (objectList . S.toList . foldr (S.insert . taskOwner) S.empty) `liftM`+ queuedTasks++bf_queue_info [Obj player] =+ (Int . fromIntegral . length . filter ((== player) . taskOwner)) `liftM`+ queuedTasks++bf_queued_tasks [] = do+ tasks <- queuedTasks+ programmer <- frame permissions+ wizard <- isWizard programmer+ let ownedTasks = if wizard then tasks+ else filter ((== programmer) . taskOwner) tasks++ return $ fromListBy formatTask $ sort ownedTasks++ where 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+ , Obj . taskOwner -- programmer+ , Obj . verbLocation . activeFrame -- verb-loc+ , Str . verbFullName . activeFrame -- verb-name+ , Int . lineNumber . activeFrame -- line+ , Obj . initialThis . activeFrame -- this+ , Int . fromIntegral . storageBytes -- task-size+ ]++bf_kill_task [Int task_id] = do+ maybeTask <- getTask task_id'+ case maybeTask of+ Just task@Task { taskStatus = status } | isQueued status -> do+ checkPermission (taskOwner task)+ purgeTask task+ delayIO $ killThread (taskThread task)+ return nothing+ _ -> do+ thisTaskId <- taskId `liftM` asks task+ if task_id' == thisTaskId+ then interrupt Suicide+ else raise E_INVARG++ where task_id' = fromIntegral task_id++bf_callers optional = do+ Stack frames <- gets stack+ return $ formatFrames include_line_numbers (tail frames)++ where [include_line_numbers] = booleanDefaults optional [False]++bf_task_stack (Int task_id : optional) = do+ maybeTask <- getTask task_id'+ case maybeTask of+ Just task@Task { taskStatus = Suspended{} } -> do+ checkPermission (taskOwner task)+ let Stack frames = stack $ taskState task+ return $ formatFrames include_line_numbers frames+ _ -> raise E_INVARG++ where [include_line_numbers] = booleanDefaults optional [False]+ task_id' = fromIntegral task_id
+ src/MOO/Builtins/Values.hs view
@@ -0,0 +1,475 @@++{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface #-}++module MOO.Builtins.Values ( builtins ) where++import Control.Monad (mplus, unless, liftM)+import Control.Exception (bracket)+import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf (printf)+import Foreign.C (CString, withCString, peekCString)+import Data.Maybe (fromJust)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.ByteString (ByteString)+import Data.Char (intToDigit, isDigit)++import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM++import Data.Digest.Pure.MD5 (MD5Digest)+import qualified Data.Digest.Pure.MD5 as MD5++import MOO.Types+import MOO.Task+import MOO.Parser (parseNum, parseObj)+import MOO.Builtins.Common+import MOO.Builtins.Match++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}++-- | § 4.4.2 Manipulating MOO Values+builtins :: [BuiltinSpec]+builtins = [+ ("typeof" , (bf_typeof , Info 1 (Just 1) [TAny] TInt))+ , ("tostr" , (bf_tostr , Info 0 Nothing [] TStr))+ , ("toliteral" , (bf_toliteral , Info 1 (Just 1) [TAny] TStr))+ , ("toint" , (bf_toint , Info 1 (Just 1) [TAny] TInt))+ , ("tonum" , fromJust $ lookup "toint" builtins)+ , ("toobj" , (bf_toobj , Info 1 (Just 1) [TAny] TObj))+ , ("tofloat" , (bf_tofloat , Info 1 (Just 1) [TAny] TFlt))+ , ("equal" , (bf_equal , Info 2 (Just 2) [TAny, TAny] TInt))+ , ("value_bytes" , (bf_value_bytes , Info 1 (Just 1) [TAny] TInt))+ , ("value_hash" , (bf_value_hash , Info 1 (Just 1) [TAny] TStr))++ , ("random" , (bf_random , Info 0 (Just 1) [TInt] TInt))+ , ("min" , (bf_min , Info 1 Nothing [TNum] TNum))+ , ("max" , (bf_max , Info 1 Nothing [TNum] TNum))+ , ("abs" , (bf_abs , Info 1 (Just 1) [TNum] TNum))+ , ("floatstr" , (bf_floatstr , Info 2 (Just 3) [TFlt, TInt,+ TAny] TStr))+ , ("sqrt" , (bf_sqrt , Info 1 (Just 1) [TFlt] TFlt))+ , ("sin" , (bf_sin , Info 1 (Just 1) [TFlt] TFlt))+ , ("cos" , (bf_cos , Info 1 (Just 1) [TFlt] TFlt))+ , ("tan" , (bf_tan , Info 1 (Just 1) [TFlt] TFlt))+ , ("asin" , (bf_asin , Info 1 (Just 1) [TFlt] TFlt))+ , ("acos" , (bf_acos , Info 1 (Just 1) [TFlt] TFlt))+ , ("atan" , (bf_atan , Info 1 (Just 2) [TFlt, TFlt] TFlt))+ , ("sinh" , (bf_sinh , Info 1 (Just 1) [TFlt] TFlt))+ , ("cosh" , (bf_cosh , Info 1 (Just 1) [TFlt] TFlt))+ , ("tanh" , (bf_tanh , Info 1 (Just 1) [TFlt] TFlt))+ , ("exp" , (bf_exp , Info 1 (Just 1) [TFlt] TFlt))+ , ("log" , (bf_log , Info 1 (Just 1) [TFlt] TFlt))+ , ("log10" , (bf_log10 , Info 1 (Just 1) [TFlt] TFlt))+ , ("ceil" , (bf_ceil , Info 1 (Just 1) [TFlt] TFlt))+ , ("floor" , (bf_floor , Info 1 (Just 1) [TFlt] TFlt))+ , ("trunc" , (bf_trunc , Info 1 (Just 1) [TFlt] TFlt))++ , ("length" , (bf_length , Info 1 (Just 1) [TAny] TInt))+ , ("strsub" , (bf_strsub , Info 3 (Just 4) [TStr, TStr,+ TStr, TAny] TStr))+ , ("index" , (bf_index , Info 2 (Just 3) [TStr, TStr,+ TAny] TInt))+ , ("rindex" , (bf_rindex , Info 2 (Just 3) [TStr, TStr,+ TAny] TInt))+ , ("strcmp" , (bf_strcmp , Info 2 (Just 2) [TStr, TStr] TInt))+ , ("decode_binary" , (bf_decode_binary , Info 1 (Just 2) [TStr, TAny] TLst))+ , ("encode_binary" , (bf_encode_binary , Info 0 Nothing [] TStr))+ , ("match" , (bf_match , Info 2 (Just 3) [TStr, TStr,+ TAny] TLst))+ , ("rmatch" , (bf_rmatch , Info 2 (Just 3) [TStr, TStr,+ TAny] TLst))+ , ("substitute" , (bf_substitute , Info 2 (Just 2) [TStr, TLst] TStr))+ , ("crypt" , (bf_crypt , Info 1 (Just 2) [TStr, TStr] TStr))+ , ("string_hash" , (bf_string_hash , Info 1 (Just 1) [TStr] TStr))+ , ("binary_hash" , (bf_binary_hash , Info 1 (Just 1) [TStr] TStr))++ , ("is_member" , (bf_is_member , Info 2 (Just 2) [TAny, TLst] TInt))+ , ("listinsert" , (bf_listinsert , Info 2 (Just 3) [TLst, TAny,+ TInt] TLst))+ , ("listappend" , (bf_listappend , Info 2 (Just 3) [TLst, TAny,+ TInt] TLst))+ , ("listdelete" , (bf_listdelete , Info 2 (Just 2) [TLst, TInt] TLst))+ , ("listset" , (bf_listset , Info 3 (Just 3) [TLst, TAny,+ TInt] TLst))+ , ("setadd" , (bf_setadd , Info 2 (Just 2) [TLst, TAny] TLst))+ , ("setremove" , (bf_setremove , Info 2 (Just 2) [TLst, TAny] TLst))+ ]++-- § 4.4.2.1 General Operations Applicable to all Values++bf_typeof [value] = return $ Int $ typeCode $ typeOf value++bf_tostr values = return $ Str $ T.concat $ map toText values++bf_toliteral [value] = return $ Str $ toLiteral value++-- XXX toint(" - 34 ") does not parse as -34+bf_toint [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)+ Obj x -> return (Int $ fromIntegral x)+ Str x -> maybe (return $ Int 0) toint (parseNum x)+ Err x -> return (Int $ fromIntegral $ fromEnum x)+ Lst _ -> raise E_TYPE++bf_toobj [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)+ Obj _ -> return value+ Str x -> maybe (return $ Obj 0) toobj $ parseNum x `mplus` parseObj x+ Err x -> return (Obj $ fromIntegral $ fromEnum x)+ Lst _ -> raise E_TYPE++bf_tofloat [value] = tofloat value+ where tofloat value = case value of+ Int x -> return (Flt $ fromIntegral x)+ Flt _ -> return value+ Obj x -> return (Flt $ fromIntegral x)+ Str x -> maybe (return $ Flt 0) tofloat (parseNum x)+ Err x -> return (Flt $ fromIntegral $ fromEnum x)+ Lst _ -> raise E_TYPE++bf_equal [value1, value2] = return $ truthValue (value1 `equal` value2)++bf_value_bytes [value] = return $ Int $ fromIntegral $ storageBytes value++bf_value_hash [value] = do+ literal <- bf_toliteral [value]+ bf_string_hash [literal]++-- § 4.4.2.2 Operations on Numbers++bf_random optional+ | mod <= 0 = raise E_INVARG+ | otherwise = Int `liftM` random (1, mod)+ where [Int mod] = defaults optional [Int maxBound]++bf_min (Int x:xs) = minMaxInt min x xs+bf_min (Flt x:xs) = minMaxFlt min x xs++bf_max (Int x:xs) = minMaxInt max x xs+bf_max (Flt x:xs) = minMaxFlt max x xs++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++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_abs [Int x] = return $ Int $ abs x+bf_abs [Flt x] = return $ Flt $ abs x++bf_floatstr (Flt x : Int precision : optional)+ | precision < 0 = raise E_INVARG+ | otherwise = return $ Str $ T.pack $ printf format x+ where [scientific] = booleanDefaults optional [False]+ prec = min precision 19+ format = printf "%%.%d%c" prec $ if scientific then 'e' else 'f'++bf_sqrt [Flt x] = checkFloat $ sqrt x++bf_sin [Flt x] = checkFloat $ sin x+bf_cos [Flt x] = checkFloat $ cos x+bf_tan [Flt x] = checkFloat $ tan x++bf_asin [Flt x] = checkFloat $ asin x+bf_acos [Flt x] = checkFloat $ acos x+bf_atan [Flt y] = checkFloat $ atan y+bf_atan [Flt y,+ Flt x] = checkFloat $ atan2 y x++bf_sinh [Flt x] = checkFloat $ sinh x+bf_cosh [Flt x] = checkFloat $ cosh x+bf_tanh [Flt x] = checkFloat $ tanh x++bf_exp [Flt x] = checkFloat $ exp x+bf_log [Flt x] = checkFloat $ log x+bf_log10 [Flt x] = checkFloat $ logBase 10 x++bf_ceil [Flt x] = checkFloat $ fromIntegral (ceiling x :: Integer)+bf_floor [Flt x] = checkFloat $ fromIntegral (floor x :: Integer)+bf_trunc [Flt x]+ | x < 0 = checkFloat $ fromIntegral (ceiling x :: Integer)+ | otherwise = checkFloat $ fromIntegral (floor x :: Integer)++-- § 4.4.2.3 Operations on Strings++bf_length [Str string] = return $ Int $ fromIntegral $ T.length string+bf_length [Lst list] = return $ Int $ fromIntegral $ V.length list+bf_length _ = raise E_TYPE++bf_strsub (Str subject : Str what : Str with : optional)+ | T.null what = raise E_INVARG+ | otherwise = return $ Str $ T.concat $ subs subject+ where [case_matters] = booleanDefaults optional [False]+ caseFold str = if case_matters then str else T.toCaseFold str+ -- this won't work for Unicode in general+ subs "" = []+ subs subject = case T.breakOn what' (caseFold subject) of+ (_, "") -> [subject]+ (prefix, _) -> let (s, r) = T.splitAt (T.length prefix) subject+ in s : with : subs (T.drop whatLen r)+ what' = caseFold what+ whatLen = T.length what++bf_index (Str str1 : Str str2 : optional)+ | T.null str2 = return (Int 1)+ | otherwise =+ return $ Int $ case T.breakOn (caseFold str2) (caseFold str1) of+ (_, "") -> 0+ (prefix, _) -> fromIntegral $ 1 + T.length prefix+ where [case_matters] = booleanDefaults optional [False]+ caseFold str = if case_matters then str else T.toCaseFold str+ -- this won't work for Unicode in general++bf_rindex (Str str1 : Str str2 : optional)+ | T.null str2 = return (Int $ fromIntegral $ T.length str1 + 1)+ | otherwise =+ return $ Int $ case T.breakOnEnd needle haystack of+ ("", _) -> 0+ (prefix, _) -> fromIntegral $ 1 + T.length prefix - T.length needle+ where [case_matters] = booleanDefaults optional [False]+ needle = caseFold str2+ haystack = caseFold str1+ caseFold str = if case_matters then str else T.toCaseFold str+ -- this won't work for Unicode in general++bf_strcmp [Str str1, Str str2] =+ return $ Int $ case compare str1 str2 of+ LT -> -1+ EQ -> 0+ GT -> 1++bf_decode_binary (Str bin_string : optional) =+ maybe (raise E_INVARG) (return . mkResult) $ text2binary bin_string+ where [fully] = booleanDefaults optional [False]+ mkResult | fully = fromListBy (Int . fromIntegral)+ | otherwise = fromList . groupPrinting ("" ++)+ groupPrinting g (w:ws)+ | validStrChar c = groupPrinting (g [c] ++) ws+ | null group = Int (fromIntegral w) : groupPrinting g ws+ | otherwise = Str (T.pack group) : Int (fromIntegral w) :+ groupPrinting ("" ++) ws+ where c = toEnum (fromIntegral w)+ group = g ""+ groupPrinting g []+ | null group = []+ | otherwise = [Str $ T.pack group]+ where group = g ""++bf_encode_binary = liftM (Str . T.pack) . encodeBinary++encodeBinary :: [Value] -> MOO String+encodeBinary (Int n : args)+ | n >= 0 && n <= 255 = prepend `liftM` encodeBinary args+ | otherwise = raise E_INVARG+ where c = toEnum n'+ n' = fromIntegral n+ prepend | validStrChar c &&+ c /= '\t' = (c :)+ | otherwise = \r -> '~' : hex (n' `div` 16)+ : hex (n' `mod` 16) : r+ hex = intToDigit -- N.B. not uppercase+encodeBinary (Str str : args) = (encodeStr (T.unpack str) ++) `liftM`+ encodeBinary args+ where encodeStr ('~' :cs) = "~7e" ++ encodeStr cs+ encodeStr ('\t':cs) = "~09" ++ encodeStr cs+ encodeStr (c :cs) = c : encodeStr cs+ encodeStr "" = ""+encodeBinary (Lst list : args) = do+ listEncoding <- encodeBinary (V.toList list)+ (listEncoding ++) `liftM` encodeBinary args+encodeBinary (_:_) = raise E_INVARG+encodeBinary [] = return ""++bf_match (Str subject : Str pattern : optional) =+ runMatch match subject pattern case_matters+ where [case_matters] = booleanDefaults optional [False]++bf_rmatch (Str subject : Str pattern : optional) =+ runMatch rmatch subject pattern case_matters+ where [case_matters] = booleanDefaults optional [False]++runMatch :: (Regexp -> Text -> IO MatchResult) ->+ StrT -> StrT -> Bool -> MOO Value+runMatch match subject pattern case_matters = do+ let compiled = unsafePerformIO $ newRegexp pattern case_matters+ case compiled of+ Left (err, at) -> raiseException $ Exception (Err E_INVARG)+ (T.pack $ "Invalid pattern: " ++ err)+ (Int $ fromIntegral at)+ Right regexp -> do+ let result = unsafePerformIO $ match regexp subject+ case result of+ MatchFailed -> return (Lst V.empty)+ MatchAborted -> raise E_QUOTA+ 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]++ where -- convert from 0-based open interval to 1-based closed one+ convert (s,e) = (1 + fromIntegral s, fromIntegral e)++ 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 = []++bf_substitute [Str template, Lst subs] =+ case V.toList subs of+ [Int start', Int end', Lst replacements', Str subject'] -> do+ let start = fromIntegral start'+ end = fromIntegral end'+ subject = T.unpack subject'+ subjectLen = T.length subject'++ valid s e = (s == 0 && e == -1) ||+ (s > 0 && e >= s - 1 && e <= subjectLen)++ substr start end =+ let len = end - start + 1+ in take len $ drop (start - 1) subject++ substitution (Lst sub) = case V.toList sub of+ [Int start', Int end'] -> do+ let start = fromIntegral start'+ end = fromIntegral end'+ unless (valid start end) $ raise E_INVARG+ return $ substr start end+ _ -> 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')++ let walk ('%':c:cs)+ | isDigit c = let i = fromEnum c - fromEnum '0'+ in (replacements !! i ++) `liftM` walk cs+ | c == '%' = ("%" ++) `liftM` walk cs+ | otherwise = raise E_INVARG+ walk (c:cs) = ([c] ++) `liftM` walk cs+ walk [] = return []++ (Str . T.pack) `liftM` walk (T.unpack template)+ _ -> raise E_INVARG++foreign import ccall unsafe "static unistd.h crypt"+ c_crypt :: CString -> CString -> IO CString++{-# ANN crypt ("HLint: ignore Use >=>" :: String) #-}++crypt :: String -> String -> String+crypt key salt =+ unsafePerformIO $ bracket (takeMVar cryptLock) (putMVar cryptLock) $ \_ ->+ withCString key $ \c_key ->+ withCString salt $ \c_salt ->+ c_crypt c_key c_salt >>= peekCString++cryptLock :: MVar ()+cryptLock = unsafePerformIO $ newMVar ()+{-# NOINLINE cryptLock #-}++bf_crypt (Str text : optional)+ | maybe True invalidSalt saltArg = generateSalt >>= go+ | otherwise = go $ fromStr $ fromJust saltArg+ where (saltArg : _) = maybeDefaults optional+ invalidSalt (Str salt) = salt `T.compareLength` 2 == LT+ generateSalt = do+ c1 <- randSaltChar+ c2 <- randSaltChar+ return $ T.pack [c1, c2]+ randSaltChar = (saltStuff !!) `liftM` random (0, length saltStuff - 1)+ saltStuff = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "./"+ go salt = return $ Str $ T.pack $ crypt (T.unpack text) (T.unpack salt)++hash :: ByteString -> Value+hash bs = Str $ T.pack $ show md5hash+ where md5hash = MD5.hash' bs :: MD5Digest++bf_string_hash [Str text] = return $ hash $ encodeUtf8 text++bf_binary_hash [Str bin_string] = hash `liftM` binaryString bin_string++-- § 4.4.2.4 Operations on Lists++-- bf_length already defined above++bf_is_member [value, Lst list] =+ return $ Int $ maybe 0 (fromIntegral . succ) $+ V.findIndex (`equal` value) list++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++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++bf_listinsert (Lst list : value : optional) =+ return $ Lst $ listInsert list (fromIntegral index - 1) value+ where [Int index] = defaults optional [Int 1]++bf_listappend (Lst list : value : optional) =+ return $ Lst $ listInsert list (fromIntegral index) value+ where [Int index] = defaults optional [Int $ fromIntegral $ V.length list]++bf_listdelete [Lst list, Int index]+ | index' < 1 || index' > V.length list = raise E_RANGE+ | otherwise = return $ Lst $ listDelete list (index' - 1)+ where index' = fromIntegral index++bf_listset [Lst list, value, Int index]+ | index' < 1 || index' > V.length list = raise E_RANGE+ | otherwise = return $ Lst $ listSet list index' value+ where index' = fromIntegral index++bf_setadd [Lst list, value] =+ return $ Lst $ if value `V.elem` list then list else V.snoc list value++bf_setremove [Lst list, value] =+ return $ Lst $ case V.elemIndex value list of+ Nothing -> list+ Just index -> listDelete list (fromIntegral index)
+ src/MOO/Command.hs view
@@ -0,0 +1,220 @@++{-# LANGUAGE OverloadedStrings #-}++-- | MOO command parsing and execution+module MOO.Command (++ -- * Data Structures+ Command(..)++ -- * Parsing Typed Commands+ , parseWords+ , parseCommand++ -- * Executing MOO Code+ , runCommand++ ) where++import Control.Monad (liftM, void, foldM, join)+import Data.Char (isSpace, isDigit)+import Data.Monoid+import Data.Text (Text)+import Text.Parsec+import Text.Parsec.Text (Parser)++import qualified Data.IntSet as IS+import qualified Data.Text as T+import qualified Data.Vector as V++import MOO.Types+import {-# SOURCE #-} MOO.Task+import MOO.Object+import MOO.Verb+import {-# SOURCE #-} MOO.Network++commandWord :: Parser Text+commandWord = do+ word <- many1 wordChar+ spaces+ return (T.concat word)++ where wordChar = T.singleton `liftM` satisfy nonspecial <|>+ T.pack `liftM` quotedChars <|>+ T.singleton `liftM` backslashChar <|>+ trailingBackslash++ nonspecial '\"' = False+ nonspecial '\\' = False+ nonspecial c = not $ isSpace c++ quotedChars = between (char '"') quoteEnd $+ many (noneOf "\"\\" <|> backslashChar)+ quoteEnd = void (char '"') <|> eof <|> void trailingBackslash++ backslashChar = try (char '\\' >> anyChar)++ trailingBackslash = try (char '\\' >> eof) >> return ""++commandWords :: Parser [Text]+commandWords = between spaces eof $ many commandWord++builtinCommand :: Parser Text+builtinCommand = say <|> emote <|> eval+ where say = char '\"' >> return "say"+ emote = char ':' >> return "emote"+ eval = char ';' >> return "eval"++command :: Parser (Text, Text)+command = between spaces eof $ do+ verb <- builtinCommand <|> commandWord <|> return ""+ argstr <- T.pack `liftM` many anyChar+ return (verb, argstr)++matchPrep :: [Text] -> (Text, (PrepSpec, Text), Text)+matchPrep = matchPrep' id prepPhrases+ where matchPrep' dobj _ [] = (T.unwords $ dobj [], (PrepNone, ""), "")+ matchPrep' dobj ((spec,phrase):phrases) args+ | phrase == map T.toCaseFold argsPhrase =+ (T.unwords $ dobj [], (spec, T.unwords argsPhrase), T.unwords iobj)+ | otherwise = matchPrep' dobj phrases args+ where (argsPhrase, iobj) = splitAt (length phrase) args+ matchPrep' dobj [] (arg:args) =+ matchPrep' (dobj . (arg :)) prepPhrases args++-- | A structure describing a player's parsed command+data Command = Command {+ commandVerb :: Text+ , commandArgs :: [Text]+ , commandArgStr :: Text+ , commandDObjStr :: Text+ , commandPrepSpec :: PrepSpec+ , commandPrepStr :: Text+ , commandIObjStr :: Text+ } deriving Show++-- | Split a typed command into words according to the MOO rules for quoting+-- and escaping.+parseWords :: Text -> [Text]+parseWords argstr = args+ where Right args = parse commandWords "" argstr++-- | Return a 'Command' value describing the arguments of a typed command as+-- parsed into verb, preposition, direct and indirect object, etc.+parseCommand :: Text -> Command+parseCommand cmd = Command verb args argstr dobjstr prepSpec prepstr iobjstr+ where Right (verb, argstr) = parse command "" cmd+ args = parseWords argstr+ (dobjstr, (prepSpec, prepstr), iobjstr) = matchPrep args++objectNumber :: Parser ObjId+objectNumber = liftM read $ between (char '#') eof $ many1 (satisfy isDigit)++matchObject :: ObjId -> StrT -> MOO ObjId+matchObject player str+ | T.null str = return nothing+ | otherwise = case parse objectNumber "" str of+ Right oid -> do+ obj <- getObject oid+ case obj of+ Just _ -> return oid+ Nothing -> matchObject' player str+ Left _ -> matchObject' player str++ where matchObject' :: ObjId -> StrT -> MOO ObjId+ matchObject' player str = case str' of+ "me" -> return player+ "here" -> maybe nothing (objectForMaybe . objectLocation) `liftM`+ getObject player+ _ -> do+ maybePlayer <- getObject player+ case maybePlayer of+ Nothing -> return failedMatch+ Just player' -> do+ let holding = objectContents player'+ maybeRoom = objectLocation player'+ roomContents <-+ maybe (return IS.empty)+ (liftM (maybe IS.empty objectContents) . getObject)+ maybeRoom+ matchName str' $ IS.toList (holding `IS.union` roomContents)+ where str' = T.toCaseFold str++ matchName :: StrT -> [ObjId] -> MOO ObjId+ matchName str = liftM (uncurry matchResult) .+ foldM (matchName' str) ([], [])+ 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+ _ -> []+ names = maybe id ((:) . Str . objectName) maybeObj aliases+ return $ case searchNames str names of+ ExactMatch -> (oid : exact, prefix)+ PrefixMatch -> (exact, oid : prefix)+ NoMatch -> matches++ matchResult :: [ObjId] -> [ObjId] -> ObjId+ matchResult [oid] _ = oid+ matchResult [] [oid] = oid+ matchResult [] [] = failedMatch+ matchResult _ _ = ambiguousMatch++ searchNames :: StrT -> [Value] -> Match+ searchNames str = mconcat . map (nameMatch str)++ nameMatch :: StrT -> Value -> Match+ nameMatch str (Str name)+ | name' == str = ExactMatch+ | T.take strLen name' == str = PrefixMatch+ | otherwise = NoMatch+ where name' = T.toCaseFold name+ strLen = T.length str+ nameMatch _ _ = NoMatch++ nothing = -1+ ambiguousMatch = -2+ failedMatch = -3++data Match = NoMatch | PrefixMatch | ExactMatch++instance Monoid Match where+ mempty = NoMatch++ NoMatch `mappend` match = match+ _ `mappend` ExactMatch = ExactMatch+ match `mappend` _ = match++-- | Execute a typed command by locating and calling an appropriate MOO verb+-- for the current player, matching @dobj@ and @iobj@ objects against the+-- strings in the typed command.+runCommand :: Command -> MOO Value+runCommand command = do+ player <- getPlayer+ dobj <- matchObject player (commandDObjStr command)+ iobj <- matchObject player (commandIObjStr command)++ room <- (objectForMaybe . join . fmap objectLocation) `liftM` getObject player+ maybeVerb <- (getFirst . mconcat . map First) `liftM`+ 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 nothing++ 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)
+ src/MOO/Command.hs-boot view
@@ -0,0 +1,5 @@+-- -*- Haskell -*-++module MOO.Command ( Command ) where++data Command
+ src/MOO/Compiler.hs view
@@ -0,0 +1,574 @@++{-# LANGUAGE OverloadedStrings #-}++-- | Compiling abstract syntax trees into 'MOO' computations+module MOO.Compiler ( compile, evaluate ) where++import Control.Monad (when, unless, void, liftM)+import Control.Monad.Cont (callCC)+import Control.Monad.Reader (asks, local)+import Control.Monad.State (gets)++import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Vector as V++import MOO.Types+import MOO.AST+import MOO.Task+import MOO.Builtins+import MOO.Object++-- | Compile a complete MOO program into a computation in the 'MOO' monad that+-- returns whatever the MOO program returns.+compile :: Program -> MOO Value+compile (Program stmts) = callCC $ compileStatements stmts++compileStatements :: [Statement] -> (Value -> MOO Value) -> MOO Value+compileStatements (statement:rest) yield = catchDebug $ case statement of+ Expression lineNumber expr -> do+ setLineNumber lineNumber+ evaluate expr+ compile' rest++ If lineNumber cond (Then thens) elseIfs (Else elses) -> runTick >> do+ compileIf ((lineNumber, cond, thens) : map elseIf elseIfs) elses+ compile' rest++ where elseIf (ElseIf lineNumber cond thens) = (lineNumber, cond, thens)++ compileIf ((lineNumber,cond,thens):conds) elses = do+ setLineNumber lineNumber+ cond' <- truthOf `liftM` evaluate cond+ if cond' then compile' thens+ else compileIf conds elses+ compileIf [] elses = compile' elses++ ForList lineNumber var expr body -> do+ setLineNumber lineNumber+ expr' <- evaluate expr+ elts <- case expr' of+ Lst elts -> return $ V.toList elts+ _ -> raise E_TYPE++ callCC $ \break -> do+ pushLoopContext (Just var') (Continuation break)+ loop var' elts (compile' body)+ popContext++ compile' rest++ where var' = T.toCaseFold var+ loop var (elt:elts) body = runTick >> do+ storeVariable var elt+ callCC $ \continue -> do+ setLoopContinue (Continuation continue)+ body+ loop var elts body+ loop _ [] _ = return nothing++ ForRange lineNumber var (start, end) body -> do+ setLineNumber lineNumber+ 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)+ (_ , _ ) -> raise E_TYPE++ callCC $ \break -> do+ pushLoopContext (Just var') (Continuation break)+ loop var' ty s e (compile' body)+ popContext++ compile' rest++ where var' = T.toCaseFold var+ loop var ty i end body+ | i > end = return nothing+ | otherwise = runTick >> do+ storeVariable var (ty i)+ callCC $ \continue -> do+ setLoopContinue (Continuation continue)+ body+ loop var ty (succ i) end body++ While lineNumber var expr body -> do+ callCC $ \break -> do+ pushLoopContext var' (Continuation break)+ loop lineNumber var' (evaluate expr) (compile' body)+ return nothing+ popContext++ compile' rest++ where var' = fmap T.toCaseFold var+ loop lineNumber var expr body = runTick >> do+ setLineNumber lineNumber+ expr' <- expr+ maybe return storeVariable var expr'+ when (truthOf expr') $ do+ callCC $ \continue -> do+ setLoopContinue (Continuation continue)+ body+ loop lineNumber var expr body++ Fork lineNumber var delay body -> runTick >> 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++ world <- getWorld+ gen <- newRandomGen+ taskId <- liftSTM $ newTaskId world gen+ case var of+ Just ident -> void $ storeVariable ident (Int $ fromIntegral taskId)+ Nothing -> return ()++ forkTask taskId usecs (compileStatements body return)++ compile' rest++ Break name -> breakLoop (fmap T.toCaseFold name)+ Continue name -> continueLoop (fmap T.toCaseFold name)++ Return _ Nothing -> runTick >> yield nothing+ Return lineNumber (Just expr) -> runTick >> do+ setLineNumber lineNumber+ yield =<< evaluate expr++ TryExcept body excepts -> runTick >> do+ excepts' <- mapM compileExcepts excepts++ compile' body `catchException` dispatch excepts'+ compile' rest++ where compileExcepts (Except lineNumber var codes handler) = do+ codes' <- case codes of+ ANY -> return Nothing+ Codes args -> setLineNumber lineNumber >> Just `liftM` expand args+ return (codes', var, compile' handler)++ dispatch ((codes, var, handler):next)+ except@(Exception code message value)+ | maybe True (code `elem`) codes = \(Stack errorFrames) -> 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+ | otherwise = dispatch next except+ dispatch [] except = passException except++ TryFinally body (Finally finally) -> runTick >> do+ let finally' = compile' finally+ pushTryFinallyContext finally'++ compile' body `catchException` \except callStack -> do+ popContext+ finally'+ passException except callStack++ popContext+ finally'++ compile' rest++ where compile' ss = compileStatements ss yield++compileStatements [] _ = return nothing++catchDebug :: MOO Value -> MOO Value+catchDebug action =+ action `catchException` \except@(Exception code _ _) callStack -> do+ debug <- frame debugBit+ if debug then passException except callStack else return code++-- | Compile a MOO expression into a computation in the 'MOO' monad. If a MOO+-- exception is raised and the current verb frame's debug bit is not set,+-- return the error code as a MOO value rather than propagating the exception.+evaluate :: Expr -> MOO Value+evaluate (Literal value) = return value+evaluate expr@Variable{} = catchDebug $ fetch (lValue expr)+evaluate expr = runTick >>= \_ -> catchDebug $ case expr of+ List args -> fromList `liftM` expand args++ PropRef{} -> fetch (lValue expr)++ Assign what expr -> store (lValue what) =<< evaluate expr++ ScatterAssign items expr -> do+ expr' <- evaluate expr+ case expr' of+ Lst v -> scatterAssign items v+ _ -> raise E_TYPE++ VerbCall target vname args -> do+ target' <- evaluate target+ oid <- case target' of+ Obj oid -> return oid+ _ -> raise E_TYPE++ vname' <- evaluate vname+ name <- case vname' of+ Str name -> return name+ _ -> raise E_TYPE++ callVerb oid oid name =<< expand args++ BuiltinFunc func args -> callBuiltin (T.toCaseFold func) =<< expand args++ 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++ Negate a -> do a' <- evaluate a+ case a' of+ Int x -> return (Int $ negate x)+ Flt x -> return (Flt $ negate x)+ _ -> raise E_TYPE++ Conditional c x y -> do c' <- evaluate c+ evaluate $ if truthOf c' 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++ Not x -> (truthValue . not . truthOf) `liftM` evaluate x++ x `Equal` y -> equality (==) x y+ x `NotEqual` y -> equality (/=) x y+ x `LessThan` y -> comparison (<) x y+ x `LessEqual` y -> comparison (<=) x y+ x `GreaterThan` y -> comparison (>) x y+ x `GreaterEqual` y -> comparison (>=) x y++ Index{} -> fetch (lValue expr)+ Range{} -> fetch (lValue expr)++ Length -> liftM (Int . fromIntegral) =<< 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++ Catch expr codes (Default dv) -> do+ codes' <- case codes of+ ANY -> return Nothing+ Codes args -> Just `liftM` expand args+ evaluate expr `catchException` \except@(Exception code _ _) callStack ->+ if maybe True (code `elem`) codes'+ then maybe (return code) evaluate dv+ else passException except callStack++ where binary op a b = do+ a' <- evaluate a+ b' <- evaluate b+ a' `op` b'+ equality op = binary test+ where test a b = return $ truthValue (a `op` b)+ 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)++fetchVariable :: Id -> MOO Value+fetchVariable var =+ maybe (raise E_VARNF) return . M.lookup var =<< frame variables++storeVariable :: Id -> Value -> MOO Value+storeVariable var value = do+ modifyFrame $ \frame ->+ frame { variables = M.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'+ where name' = T.toCaseFold name++ search skipPermCheck obj = do+ prop <- getProperty obj name'+ unless (skipPermCheck || propertyPermR prop) $+ checkPermission (propertyOwner prop)+ case propertyValue prop of+ Just value -> return value+ Nothing -> do+ parentObj <- maybe (return Nothing) getObject (objectParent obj)+ maybe (error $ "No inherited value for property " +++ T.unpack name) (search True) parentObj++storeProperty :: (ObjT, StrT) -> Value -> MOO Value+storeProperty (oid, name) value = do+ obj <- getObject oid >>= maybe (raise E_INVIND) return+ if isBuiltinProperty name'+ then setBuiltinProperty (oid, obj) name' value+ else modifyProperty obj name' $ \prop -> do+ unless (propertyPermW prop) $ checkPermission (propertyOwner prop)+ return prop { propertyValue = Just value }+ return value+ where name' = T.toCaseFold name++withIndexLength :: Value -> MOO a -> MOO a+withIndexLength expr =+ local $ \env -> env { indexLength = case expr of+ Lst v -> return (V.length v)+ Str t -> return (T.length t)+ _ -> raise E_TYPE+ }++checkLstRange :: LstT -> Int -> MOO ()+checkLstRange v i = when (i < 1 || i > V.length v) $ raise E_RANGE++checkStrRange :: StrT -> Int -> MOO ()+checkStrRange t i = when (i < 1 || t `T.compareLength` i == LT) $ raise E_RANGE++checkIndex :: Value -> MOO Int+checkIndex (Int i) = return (fromIntegral i)+checkIndex _ = raise E_TYPE++data LValue = LValue {+ fetch :: MOO Value+ , store :: Value -> MOO Value+ , change :: MOO (Value, Value -> MOO Value)+ }++lValue :: Expr -> LValue++lValue (Variable var) = LValue fetch store change+ where var' = T.toCaseFold var+ fetch = fetchVariable var'+ store = storeVariable var'++ change = do+ value <- fetch+ return (value, store)++lValue (PropRef objExpr nameExpr) = LValue fetch store change+ where fetch = getRefs >>= fetchProperty+ store value = getRefs >>= flip storeProperty value++ change = do+ value <- fetch+ return (value, store)+ -- XXX improve this to avoid redundant checks?++ getRefs = do+ objRef <- evaluate objExpr+ nameRef <- evaluate nameExpr+ case (objRef, nameRef) of+ (Obj oid, Str name) -> return (oid, name)+ _ -> raise E_TYPE++lValue (expr `Index` index) = LValue fetchIndex storeIndex changeIndex+ where fetchIndex = do+ (value, _) <- changeIndex+ return value++ storeIndex newValue = do+ (_, change) <- changeIndex+ change newValue+ return newValue++ changeIndex = 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 $ T.singleton $ t `T.index` (index' - 1))+ _ -> raise E_TYPE+ return (value', changeValue value index' changeExpr)++ changeValue (Lst v) index changeExpr newValue =+ changeExpr $ Lst $ listSet v index newValue++ changeValue (Str t) index changeExpr (Str c) = do+ when (c `T.compareLength` 1 /= EQ) $ raise E_INVARG+ let (s, r) = T.splitAt (index - 1) t+ changeExpr $ Str $ T.concat [s, c, T.tail r]++ changeValue _ _ _ _ = raise E_TYPE++lValue (expr `Range` (start, end)) = LValue fetchRange storeRange changeRange+ where fetchRange = do+ value <- fetch (lValue expr)+ (start', end') <- getIndices value+ if start' > end'+ then case value of+ Lst{} -> return $ Lst V.empty+ Str{} -> return $ Str T.empty+ _ -> 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+ Str t -> do checkStrRange t start' >> checkStrRange t end'+ return $ Str $ T.take len $ T.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+ return newValue++ changeValue (Lst v) start end changeExpr (Lst r) = do+ let len = V.length v+ when (end < 0 || start > len + 1) $ raise E_RANGE+ let pre = sublist v 1 (start - 1)+ post = sublist v (end + 1) len+ 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 `T.compareLength` (start - 1) == LT) $ raise E_RANGE+ let pre = substr t 1 (start - 1)+ post = substr t (end + 1) (T.length t)+ substr t s e+ | e < s = T.empty+ | otherwise = T.take (e - s + 1) $ T.drop (s - 1) t+ changeExpr $ Str $ T.concat [pre, r, post]++ changeValue _ _ _ _ _ = raise E_TYPE++ changeRange = error "Illegal Range as lvalue subexpression"++lValue expr = LValue fetch store change+ where fetch = evaluate expr+ store _ = error "Unmodifiable LValue"++ change = do+ value <- fetch+ return (value, store)++scatterAssign :: [ScatItem] -> LstT -> MOO Value+scatterAssign items args = do+ when (nargs < nreqs || (not haveRest && nargs > ntarg)) $ raise E_ARGS+ 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++ haveRest = any rest items+ count p = length . filter p++ required ScatRequired{} = True+ required _ = False+ optional ScatOptional{} = True+ optional _ = False+ rest ScatRest{} = True+ rest _ = False++ walk (item:items) args noptAvail =+ case item of+ ScatRequired var -> do+ assign var (V.head args)+ walk items (V.tail args) noptAvail+ ScatOptional var opt+ | noptAvail > 0 -> do assign var (V.head args)+ walk items (V.tail args) (noptAvail - 1)+ | otherwise -> do+ case opt of Nothing -> return ()+ Just expr -> void $ assign var =<< evaluate expr+ walk items args noptAvail+ ScatRest var -> do+ let (s, r) = V.splitAt nrest args+ assign var (Lst s)+ walk items r noptAvail+ walk [] _ _ = return ()++ assign var = storeVariable (T.toCaseFold var)++expand :: [Arg] -> 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 [] = 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 (T.append a b)+_ `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)+_ `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)+_ `times` _ = raise E_TYPE++divide :: Value -> Value -> MOO Value+(Int a) `divide` (Int b) | b == 0 = raise E_DIV+ | otherwise = return $ Int (a `quot` b)+(Flt a) `divide` (Flt b) | b == 0 = raise E_DIV+ | otherwise = checkFloat (a / b)+_ `divide` _ = raise E_TYPE++remain :: Value -> Value -> MOO Value+(Int a) `remain` (Int b) | b == 0 = raise E_DIV+ | otherwise = return $ Int (a `rem` b)+(Flt a) `remain` (Flt b) | b == 0 = raise E_DIV+ | otherwise = checkFloat (a `fmod` b)+_ `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++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) | b >= 0 = checkFloat (a ^ b)+ | otherwise = checkFloat (a ** fromIntegral b)+(Flt a) `power` (Flt b) = checkFloat (a ** b)+_ `power` _ = raise E_TYPE
+ src/MOO/Compiler.hs-boot view
@@ -0,0 +1,9 @@+-- -*- Haskell -*-++module MOO.Compiler ( compile ) where++import MOO.AST+import MOO.Task+import MOO.Types++compile :: Program -> MOO Value
+ src/MOO/Database.hs view
@@ -0,0 +1,237 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Database ( Database+ , ServerOptions(..)+ , serverOptions+ , initDatabase+ , systemObject+ , dbObjectRef+ , dbObject+ , maxObject+ , resetMaxObject+ , setObjects+ , addObject+ , modifyObject+ , allPlayers+ , setPlayer+ , getServerOption+ , getServerOption'+ , loadServerOptions+ ) where++import Control.Concurrent.STM+import Control.Monad (forM, liftM)+import Data.Monoid ((<>))+import Data.Vector (Vector)+import Data.IntSet (IntSet)+import Data.Set (Set)++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 MOO.Types+import MOO.Object+import MOO.Task+import {-# SOURCE #-} MOO.Builtins (builtinFunctions)++data Database = Database {+ objects :: Vector (TVar (Maybe Object))+ , players :: IntSet+ , serverOptions :: ServerOptions+}++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++dbObject :: ObjId -> Database -> STM (Maybe Object)+dbObject oid db = maybe (return Nothing) readTVar $ dbObjectRef oid db++maxObject :: Database -> ObjId+maxObject db = V.length (objects db) - 1++resetMaxObject :: Database -> STM Database+resetMaxObject db = do+ newMaxObject <- findLastValid (maxObject db)+ return db { objects = V.take (newMaxObject + 1) $ objects db }+ where findLastValid oid+ | oid >= 0 = dbObject oid db >>=+ maybe (findLastValid $ oid - 1) (return . const oid)+ | otherwise = return (-1)++setObjects :: [Maybe Object] -> Database -> IO Database+setObjects objs db = do+ tvarObjs <- mapM newTVarIO objs+ return db { objects = V.fromList tvarObjs }++addObject :: Object -> Database -> STM Database+addObject obj db = do+ objTVar <- newTVar (Just obj)+ return db { objects = V.snoc (objects db) objTVar }++modifyObject :: ObjId -> Database -> (Object -> STM Object) -> STM ()+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++{-+isPlayer :: ObjId -> Database -> Bool+isPlayer oid db = oid `IS.member` players db+-}++allPlayers :: Database -> [ObjId]+allPlayers = IS.toList . players++setPlayer :: Bool -> ObjId -> Database -> Database+setPlayer yesno oid db = db { players = change (players db) }+ where change = (if yesno then IS.insert else IS.delete) oid++data ServerOptions = Options {+ bgSeconds :: IntT+ -- The number of seconds allotted to background tasks.++ , bgTicks :: IntT+ -- The number of ticks allotted to background tasks.++ , connectTimeout :: IntT+ -- The maximum number of seconds to allow an un-logged-in in-bound+ -- connection to remain open.++ , defaultFlushCommand :: StrT+ -- The initial setting of each new connection’s flush command.++ , fgSeconds :: IntT+ -- The number of seconds allotted to foreground tasks.++ , fgTicks :: IntT+ -- The number of ticks allotted to foreground tasks.++ , maxStackDepth :: IntT+ -- The maximum number of levels of nested verb calls.++ , queuedTaskLimit :: Maybe IntT+ -- The default maximum number of tasks a player can have.++ , nameLookupTimeout :: IntT+ -- The maximum number of seconds to wait for a network hostname/address+ -- lookup.++ , outboundConnectTimeout :: IntT+ -- The maximum number of seconds to wait for an outbound network+ -- connection to successfully open.++ , protectProperty :: Set Id+ -- Restrict reading of built-in property to wizards.++ , protectFunction :: Set Id+ -- Restrict use of built-in function to wizards.++ , supportNumericVerbnameStrings :: Bool+ -- Enables use of an obsolete verb-naming mechanism.+}++systemObject :: ObjId+systemObject = 0++getServerOptions :: ObjId -> MOO (Id -> MOO (Maybe Value))+getServerOptions oid = do+ serverOptions <- readProperty oid "server_options"+ return $ case serverOptions of+ Just (Obj oid) -> readProperty oid+ _ -> const (return Nothing)++getServerOption :: Id -> MOO (Maybe Value)+getServerOption = getServerOption' systemObject++getServerOption' :: ObjId -> Id -> MOO (Maybe Value)+getServerOption' oid option = getServerOptions oid >>= ($ option)++getProtected :: (Id -> MOO (Maybe Value)) -> [Id] -> MOO (Set Id)+getProtected getOption ids = do+ maybes <- forM ids $ liftM (fmap truthOf) . getOption . ("protect_" <>)+ return $ S.fromList [ id | (id, Just True) <- zip ids maybes ]++loadServerOptions :: MOO ()+loadServerOptions = do+ option <- getServerOptions systemObject++ bgSeconds <- option "bg_seconds"+ bgTicks <- option "bg_ticks"+ fgSeconds <- option "fg_seconds"+ fgTicks <- option "fg_ticks"++ maxStackDepth <- option "max_stack_depth"+ queuedTaskLimit <- option "queued_task_limit"++ connectTimeout <- option "connect_timeout"+ outboundConnectTimeout <- option "outbound_connect_timeout"+ nameLookupTimeout <- option "name_lookup_timeout"++ defaultFlushCommand <- option "default_flush_command"++ supportNumericVerbnameStrings <- option "support_numeric_verbname_strings"++ protectProperty <- getProtected option builtinProperties+ protectFunction <- getProtected option (M.keys builtinFunctions)++ let options = Options {+ bgSeconds = case bgSeconds of+ Just (Int secs) | secs >= 1 -> secs+ _ -> 3+ , bgTicks = case bgTicks of+ Just (Int ticks) | ticks >= 100 -> ticks+ _ -> 15000+ , fgSeconds = case fgSeconds of+ Just (Int secs) | secs >= 1 -> secs+ _ -> 5+ , fgTicks = case fgTicks of+ Just (Int ticks) | ticks >= 100 -> ticks+ _ -> 30000++ , maxStackDepth = case maxStackDepth of+ Just (Int depth) | depth > 50 -> depth+ _ -> 50+ , queuedTaskLimit = case queuedTaskLimit of+ Just (Int limit) | limit >= 0 -> Just limit+ _ -> Nothing++ , connectTimeout = case connectTimeout of+ Just (Int secs) | secs > 0 -> secs+ _ -> 300+ , outboundConnectTimeout = case outboundConnectTimeout of+ Just (Int secs) | secs > 0 -> secs+ _ -> 5+ , nameLookupTimeout = case nameLookupTimeout of+ Just (Int secs) | secs >= 0 -> secs+ _ -> 5++ , defaultFlushCommand = case defaultFlushCommand of+ Just (Str cmd) -> cmd+ _ -> ".flush"++ , supportNumericVerbnameStrings = case supportNumericVerbnameStrings of+ Just v -> truthOf v+ _ -> False++ , protectProperty = protectProperty+ , protectFunction = protectFunction+ }++ db <- getDatabase+ putDatabase db { serverOptions = options }
+ src/MOO/Database.hs-boot view
@@ -0,0 +1,29 @@+-- -*- Haskell -*-++module MOO.Database ( Database+ , systemObject+ , serverOptions+ , maxStackDepth+ , getServerOption'+ , dbObject+ , modifyObject+ ) where++import Control.Concurrent.STM (STM)++import MOO.Types+import {-# SOURCE #-} MOO.Object (Object)+import {-# SOURCE #-} MOO.Task (MOO)++data Database+data ServerOptions++systemObject :: ObjId++serverOptions :: Database -> ServerOptions+maxStackDepth :: ServerOptions -> IntT++getServerOption' :: ObjId -> Id -> MOO (Maybe Value)++dbObject :: ObjId -> Database -> STM (Maybe Object)+modifyObject :: ObjId -> Database -> (Object -> STM Object) -> STM ()
+ src/MOO/Database/LambdaMOO.hs view
@@ -0,0 +1,624 @@++module MOO.Database.LambdaMOO ( loadLMDatabase ) where++import Control.Concurrent.STM+import Control.Monad.Reader+import Text.Parsec+import Data.Word (Word)+import Data.List (sort)+import Data.Maybe (catMaybes)+import Data.Array+import Data.Bits+import Data.IntSet (IntSet)+import System.IO (hFlush, stdout)++import qualified Data.Text as T+import qualified Data.IntSet as IS++import MOO.Database+import MOO.Object+import MOO.Verb+import MOO.Types+import MOO.Parser+import MOO.Compiler++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}++loadLMDatabase :: FilePath -> IO (Either ParseError Database)+loadLMDatabase dbFile = do+ contents <- readFile dbFile+ runReaderT (runParserT lmDatabase initDatabase dbFile contents) initDBEnv++type DBParser = ParsecT String Database (ReaderT DBEnv IO)++data DBEnv = DBEnv {+ input_version :: Word+ , users :: IntSet+}++initDBEnv = DBEnv {+ input_version = undefined+ , users = IS.empty+}++header_format_string = ("** LambdaMOO Database, Format Version ", " **")++lmDatabase :: DBParser Database+lmDatabase = do+ let (before, after) = header_format_string+ dbVersion <- line $ between (string before) (string after) unsignedInt++ liftIO $ putStrLn $ "LambdaMOO database (version " ++ show dbVersion ++ ")"++ unless (dbVersion < num_db_versions) $+ fail $ "Unsupported database format (version " ++ show dbVersion ++ ")"++ local (\r -> r { input_version = dbVersion }) $ do+ nobjs <- line signedInt+ nprogs <- line signedInt+ dummy <- line signedInt+ nusers <- line signedInt++ liftIO $ putStrLn $ show nobjs ++ " objects, "+ ++ show nprogs ++ " programs, "+ ++ show nusers ++ " users"++ users <- count nusers read_objid+ installUsers users++ liftIO $ putStrLn $ "Players: " +++ T.unpack (toLiteral $ objectList $ sort users)++ local (\r -> r { users = IS.fromList users }) $ do+ liftIO $ putStrLn "Reading objects..."+ installObjects =<< count nobjs read_object++ liftIO $ putStrLn "Reading verb programs..."+ mapM_ installProgram =<< count nprogs dbProgram++ liftIO $ putStrLn "Reading forked and suspended tasks..."+ read_task_queue++ liftIO $ putStrLn "Reading list of formerly active connections..."+ read_active_connections++ eof+ liftIO $ putStrLn "Database loaded!"++ getState++installUsers :: [ObjId] -> DBParser ()+installUsers users = do+ db <- getState+ putState $ foldr (setPlayer True) db users++data DBObject = DBObject {+ oid :: ObjId+ , valid :: Maybe ObjectDef+}++data ObjectDef = ObjectDef {+ objName :: String+ , objFlags :: Int+ , objOwner :: ObjId++ , objLocation :: ObjId+ , objContents :: ObjId+ , objNext :: ObjId++ , objParent :: ObjId+ , objChild :: ObjId+ , objSibling :: ObjId++ , objVerbdefs :: [VerbDef]++ , objPropdefs :: [PropDef]+ , objPropvals :: [PropVal]+}++data VerbDef = VerbDef {+ vbName :: String+ , vbOwner :: ObjId+ , vbPerms :: IntT+ , vbPrep :: IntT+}++type PropDef = String++data PropVal = PropVal {+ propVar :: LMVar+ , propOwner :: ObjId+ , propPerms :: IntT+}++installObjects :: [DBObject] -> DBParser ()+installObjects dbObjs = do+ -- Check sequential object ordering+ mapM_ checkObjId (zip [0..] dbObjs)++ objs <- liftIO (mapM installPropsAndVerbs preObjs) >>= setPlayerFlags+ getState >>= liftIO . setObjects objs >>= putState++ where dbArray = listArray (0, length dbObjs - 1) $ map valid dbObjs+ preObjs = map (objectForDBObject dbArray) dbObjs++ checkObjId (objId, dbObj) =+ unless (objId == oid dbObj) $+ fail $ "Unexpected object #" ++ show (oid dbObj) +++ " (expecting #" ++ show objId ++ ")"++ installPropsAndVerbs :: (ObjId, Maybe Object) -> IO (Maybe Object)+ installPropsAndVerbs (_ , Nothing) = return Nothing+ installPropsAndVerbs (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)++ mkProperties :: Bool -> ObjId -> [PropVal] -> [Property]+ mkProperties _ _ [] = []+ mkProperties inherited oid propvals+ | inRange (bounds dbArray) oid =+ case maybeDef of+ Nothing -> []+ Just def ->+ let propdefs = objPropdefs def+ (mine, others) = splitAt (length propdefs) propvals+ properties = zipWith (mkProperty inherited) propdefs mine+ in properties ++ mkProperties True (objParent def) others+ | otherwise = []+ where maybeDef = dbArray ! oid++ mkProperty :: Bool -> PropDef -> PropVal -> Property+ mkProperty inherited propdef propval = initProperty {+ propertyName = T.pack propdef+ , propertyValue = either (const Nothing) id $+ valueFromVar (propVar propval)+ , propertyInherited = inherited+ , propertyOwner = propOwner propval+ , propertyPermR = propPerms propval .&. pf_read /= 0+ , propertyPermW = propPerms propval .&. pf_write /= 0+ , propertyPermC = propPerms propval .&. pf_chown /= 0+ }++ mkVerb :: VerbDef -> Verb+ mkVerb def = initVerb {+ verbNames = T.pack $ vbName def+ , verbOwner = vbOwner def+ , verbPermR = vbPerms def .&. vf_read /= 0+ , verbPermW = vbPerms def .&. vf_write /= 0+ , verbPermX = vbPerms def .&. vf_exec /= 0+ , verbPermD = vbPerms def .&. vf_debug /= 0+ , verbDirectObject = toEnum $ fromIntegral $+ (vbPerms def `shiftR` dobjShift) .&. objMask+ , verbPreposition = toEnum $ fromIntegral $ 2 + vbPrep def+ , verbIndirectObject = toEnum $ fromIntegral $+ (vbPerms def `shiftR` iobjShift) .&. objMask+ }++ setPlayerFlags objs = do+ players <- asks users+ return $ map (setPlayerFlag players) $ zip [0..] objs+ setPlayerFlag players (oid, Just obj) = Just $+ obj { objectIsPlayer = oid `IS.member` players }+ setPlayerFlag _ _ = Nothing++objectTrail :: Array ObjId (Maybe ObjectDef) -> ObjectDef ->+ (ObjectDef -> ObjId) -> (ObjectDef -> ObjId) -> [ObjId]+objectTrail arr def first rest = follow first rest (Just def)+ where follow _ _ Nothing = []+ follow f1 f2 (Just def)+ | inRange (bounds arr) idx = idx : follow f2 f2 (arr ! idx)+ | otherwise = []+ where idx = f1 def++objectForDBObject :: Array ObjId (Maybe ObjectDef) ->+ DBObject -> (ObjId, Maybe Object)+objectForDBObject dbArray dbObj = (oid dbObj, fmap mkObject $ valid dbObj)+ where mkObject def = initObject {+ objectParent = maybeObject (objParent def)+ , objectChildren = IS.fromList $+ objectTrail dbArray def objChild objSibling+ , objectName = T.pack $ objName def+ , objectOwner = objOwner def+ , objectLocation = maybeObject (objLocation def)+ , objectContents = IS.fromList $+ objectTrail dbArray def objContents objNext+ , objectProgrammer = flag def flag_programmer+ , objectWizard = flag def flag_wizard+ , objectPermR = flag def flag_read+ , objectPermW = flag def flag_write+ , objectPermF = flag def flag_fertile+ }++ flag def fl = let mask = 1 `shiftL` fl+ in (objFlags def .&. mask) /= 0++ maybeObject :: ObjId -> Maybe ObjId+ maybeObject oid+ | oid >= 0 = Just oid+ | otherwise = Nothing++installProgram :: (Int, Int, Program) -> DBParser ()+installProgram (oid, vnum, program) = do+ db <- getState+ maybeObj <- liftIO $ atomically $ dbObject oid db+ case maybeObj of+ Nothing -> fail $ doesNotExist "Object"+ Just obj -> case lookupVerbRef 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+ }++ where doesNotExist what = what ++ " for program " ++ desc ++ " does not exist"+ desc = "#" ++ show oid ++ ":" ++ show vnum++unsignedInt :: DBParser Word+unsignedInt = fmap read $ many1 digit++signedInt :: DBParser Int+signedInt = fmap fromIntegral $ signed unsignedInt++signed :: (Num a) => DBParser a -> DBParser a+signed parser = negative <|> parser+ where negative = char '-' >> fmap negate parser++line :: DBParser a -> DBParser a+line parser = do+ x <- parser+ char '\n'+ return x++read_num :: DBParser IntT+read_num = line (signed (fmap read $ many1 digit)) <?> "num"++read_objid :: DBParser ObjId+read_objid = fmap fromIntegral read_num <?> "objid"++read_float :: DBParser FltT+read_float = line (fmap read $ many1 $ oneOf "-0123456789.eE+") <?> "float"++read_string :: DBParser String+read_string = manyTill anyToken (char '\n') <?> "string"++read_object :: DBParser DBObject+read_object = (<?> "object") $ do+ oid <- fmap fromIntegral $ char '#' >> signedInt+ recycled <- option False (string " recycled" >> return True)+ char '\n'++ objectDef <- if recycled then return Nothing else do+ name <- read_string++ liftIO $ putStrLn $ " #" ++ show oid ++ " (" ++ name ++ ")"++ read_string -- old handles string+ flags <- read_num++ owner <- read_objid++ location <- read_objid+ contents <- read_objid+ next <- read_objid++ parent <- read_objid+ child <- read_objid+ sibling <- read_objid++ numVerbdefs <- read_num+ verbdefs <- count (fromIntegral numVerbdefs) read_verbdef++ numPropdefs <- read_num+ propdefs <- count (fromIntegral numPropdefs) read_propdef++ nprops <- read_num+ propvals <- count (fromIntegral nprops) read_propval++ return $ Just ObjectDef {+ objName = name+ , objFlags = fromIntegral flags+ , objOwner = owner+ , objLocation = location+ , objContents = contents+ , objNext = next+ , objParent = parent+ , objChild = child+ , objSibling = sibling+ , objVerbdefs = verbdefs+ , objPropdefs = propdefs+ , objPropvals = propvals+ }++ return DBObject { oid = oid, valid = objectDef }++read_verbdef :: DBParser VerbDef+read_verbdef = (<?> "verbdef") $ do+ name <- read_string+ owner <- read_objid+ perms <- read_num+ prep <- read_num++ return VerbDef {+ vbName = name+ , vbOwner = owner+ , vbPerms = perms+ , vbPrep = prep+ }++read_propdef :: DBParser PropDef+read_propdef = read_string <?> "propdef"++read_propval :: DBParser PropVal+read_propval = (<?> "propval") $ do+ var <- read_var+ owner <- read_objid+ perms <- read_num++ return PropVal {+ propVar = var+ , propOwner = owner+ , propPerms = perms+ }++data LMVar = LMClear+ | LMNone+ | LMStr String+ | LMObj IntT+ | LMErr IntT+ | LMInt IntT+ | LMCatch IntT+ | LMFinally IntT+ | LMFloat FltT+ | LMList [LMVar]++valueFromVar :: LMVar -> Either LMVar (Maybe Value)+valueFromVar LMClear = Right Nothing+valueFromVar (LMStr str) = Right $ Just (Str $ T.pack str)+valueFromVar (LMObj obj) = Right $ Just (Obj $ fromIntegral obj)+valueFromVar (LMErr err) = Right $ Just (Err $ toEnum $ fromIntegral err)+valueFromVar (LMInt int) = Right $ Just (Int int)+valueFromVar (LMFloat flt) = Right $ Just (Flt flt)+valueFromVar (LMList list) = do+ elems <- mapM valueFromVar list+ return $ Just (fromList $ catMaybes elems)+valueFromVar var = Left var++read_var :: DBParser LMVar+read_var = (<?> "var") $ do+ l <- read_num+ l <- if l == type_any+ then do input_version <- reader input_version+ return $ if input_version == dbv_prehistory+ then type_none else l+ else return l++ cases l++ where+ 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++ cases l = fail $ "Unknown type (" ++ show l ++ ")"++dbProgram :: DBParser (Int, Int, Program)+dbProgram = do+ char '#'+ oid <- signedInt+ char ':'+ vnum <- signedInt+ char '\n'++ let verbdesc = "#" ++ show oid ++ ":" ++ show vnum++ liftIO $ putStr (" " ++ verbdesc ++ " \r") >> hFlush stdout++ program <- read_program+ case program of+ Left err -> fail $ "Parse error in " ++ verbdesc ++ ": " ++ head err+ Right prog -> return (oid, vnum, prog)++read_program :: DBParser (Either [String] Program)+read_program = (<?> "program") $ do+ source <- try (string ".\n" >> return "") <|>+ manyTill anyToken (try $ string "\n.\n")+ return $ MOO.Parser.parse (T.pack source)++read_task_queue :: DBParser ()+read_task_queue = (<?> "task_queue") $ do+ nclocks <- signedInt+ string " clocks\n"+ count nclocks $+ signedInt >> char ' ' >> signedInt >> char ' ' >> signedInt >> char '\n'++ ntasks <- signedInt+ string " queued tasks\n"+ count ntasks $ do+ signedInt >> char ' '+ first_lineno <- signedInt+ char ' '+ st <- signedInt+ char ' '+ id <- signedInt+ char '\n'++ a <- read_activ_as_pi+ read_rt_env+ program <- read_program+ return ()++ suspended_count <- signedInt+ string " suspended tasks\n"+ count suspended_count $ do+ start_time <- signedInt+ char ' '+ task_id <- signedInt+ value <- (char ' ' >> read_var) <|> (char '\n' >> return (LMInt 0))+ the_vm <- read_vm+ return ()++ return ()++read_vm :: DBParser ()+read_vm = (<?> "vm") $ do+ top <- unsignedInt+ char ' '+ vector <- signedInt+ char ' '+ func_id <- unsignedInt+ max <- (char ' ' >> unsignedInt) <|>+ (lookAhead (char '\n') >> return default_max_stack_depth)+ char '\n'+ count (fromIntegral top) read_activ+ return ()++default_max_stack_depth = 50++read_activ :: DBParser ()+read_activ = (<?> "activ") $ do+ input_version <- reader input_version+ version <- if input_version < dbv_float then return input_version+ else string "language version " >> unsignedInt+ unless (version < num_db_versions) $+ fail $ "Unrecognized language version: " ++ show version++ prog <- read_program+ read_rt_env++ stack_in_use <- signedInt+ string " rt_stack slots in use\n"+ count stack_in_use read_var++ read_activ_as_pi+ temp <- read_var++ pc <- unsignedInt+ char ' '+ i <- unsignedInt+ let bi_func_pc = i+ error_pc <- (lookAhead (char '\n') >> return pc) <|> (char ' ' >> unsignedInt)+ char '\n'++ when (bi_func_pc /= 0) $ do+ 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+ char ' ' >> signedInt+ char ' ' >> signedInt+ player <- char ' ' >> signedInt+ char ' ' >> signedInt+ progr <- char ' ' >> signedInt+ vloc <- char ' ' >> signedInt+ char ' ' >> signedInt+ debug <- char ' ' >> signedInt+ char '\n'++ read_string -- was argstr+ read_string -- was dobjstr+ read_string -- was iobjstr+ read_string -- was prepstr++ verb <- read_string+ verbname <- read_string++ return ()++read_rt_env :: DBParser ()+read_rt_env = (<?> "rt_env") $ do+ old_size <- signedInt+ string " variables\n"+ count old_size $ do+ old_names <- read_string+ rt_env <- read_var+ return (old_names, rt_env)+ return ()++read_bi_func_data :: DBParser ()+read_bi_func_data = return ()++read_active_connections :: DBParser ()+read_active_connections = (<?> "active_connections") $ eof <|> do+ nconnections <- signedInt+ string " active connections"+ have_listeners <- (string " with listeners\n" >> return True) <|>+ (char '\n' >> return False)++ count nconnections $ do+ (who, listener) <- if have_listeners+ then do who <- signedInt+ char ' '+ listener <- signedInt+ char '\n'+ return (who, listener)+ else do who <- read_num+ return (fromIntegral who, system_object)+ return ()++ return ()++-- Enumeration constants from LambdaMOO+type_int = 0+type_obj = 1+_type_str = 2+type_err = 3+_type_list = 4+type_clear = 5+type_none = 6+type_catch = 7+type_finally = 8+_type_float = 9++type_any = -1+type_numeric = -2++dbv_prehistory = 0+dbv_exceptions = 1+dbv_breakcont = 2+dbv_float = 3+dbv_bfbugfixed = 4+num_db_versions = 5++system_object = 0++flag_user = 0+flag_programmer = 1+flag_wizard = 2+flag_obsolete_1 = 3+flag_read = 4+flag_write = 5+flag_obsolete_2 = 6+flag_fertile = 7++pf_read = 0x01+pf_write = 0x02+pf_chown = 0x04++vf_read = 0x01+vf_write = 0x02+vf_exec = 0x04+vf_debug = 0x08++dobjShift = 4+iobjShift = 6+objMask = 0x3+permMask = 0xF
+ src/MOO/Network.hs view
@@ -0,0 +1,329 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Network ( Listener+ , Connection+ , PortNumber+ , connectionEstablishedTime+ , connectionActivityTime+ , formatListener+ , connectionOption+ , setConnectionOption+ , bootPlayer+ , notify+ , getConnectionName+ , listen+ , unlisten+ , openNetworkConnection+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Network+import Data.Set (Set)+import Data.Text (Text)+import Data.Time+import System.IO+import System.IO.Error hiding (try)++import MOO.Types+import MOO.Task+import {-# SOURCE #-} MOO.Database (systemObject, getServerOption')++import qualified Data.ByteString as BS+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector as V++data Listener = Listener {+ listenerSocket :: Socket+ , listenerThread :: ThreadId++ , listenerPort :: PortID+ , listenerObject :: ObjId+ , listenerPrintMessages :: Bool+ }++initListener = Listener {+ listenerSocket = undefined+ , listenerThread = undefined++ , listenerPort = PortNumber 0+ , listenerObject = systemObject+ , listenerPrintMessages = True+ }++formatListener :: Listener -> Value+formatListener listener =+ fromList [ Obj $ listenerObject listener+ , formatPoint $ listenerPort listener+ , truthValue $ listenerPrintMessages listener+ ]++ where formatPoint (PortNumber port) = Int $ fromIntegral port+ formatPoint (UnixSocket path) = Str $ T.pack path++data Connection = Connection {+ connectionHandle :: Handle+ , connectionName :: Text++ , connectionEstablishedTime :: Maybe UTCTime+ , connectionActivityTime :: UTCTime++ , connectionOutputPrefix :: Text+ , connectionOutputSuffix :: Text++ , connectionOptionBinary :: Bool+ , connectionOptionHoldInput :: Bool+ , connectionOptionDisableOob :: Bool+ , connectionOptionClientEcho :: Bool+ , connectionOptionFlushCommand :: Text+ , connectionOptionIntrinsicCommands :: Set IntrinsicCommand+ }++initConnection = Connection {+ connectionHandle = undefined+ , connectionName = T.empty++ , connectionEstablishedTime = Nothing+ , connectionActivityTime = undefined++ , connectionOutputPrefix = T.empty+ , connectionOutputSuffix = T.empty++ , connectionOptionBinary = False+ , connectionOptionHoldInput = False+ , connectionOptionDisableOob = False+ , connectionOptionClientEcho = True+ , connectionOptionFlushCommand = ".flush"+ , connectionOptionIntrinsicCommands = allIntrinsicCommands+ }++data IntrinsicCommand = IntrinsicProgram+ | IntrinsicPrefix+ | IntrinsicSuffix+ | IntrinsicOutputPrefix+ | IntrinsicOutputSuffix+ deriving (Enum, Bounded, Eq, Ord, Show)++ic2text :: IntrinsicCommand -> Text+ic2text IntrinsicProgram = ".program"+ic2text IntrinsicPrefix = "PREFIX"+ic2text IntrinsicSuffix = "SUFFIX"+ic2text IntrinsicOutputPrefix = "OUTPUTPREFIX"+ic2text IntrinsicOutputSuffix = "OUTPUTSUFFIX"++text2ic :: Text -> Maybe IntrinsicCommand+text2ic str | T.toCaseFold str == ".program" = Just IntrinsicProgram+text2ic "PREFIX" = Just IntrinsicPrefix+text2ic "SUFFIX" = Just IntrinsicSuffix+text2ic "OUTPUTPREFIX" = Just IntrinsicOutputPrefix+text2ic "OUTPUTSUFFIX" = Just IntrinsicOutputSuffix+text2ic _ = Nothing++allIntrinsicCommands :: Set IntrinsicCommand+allIntrinsicCommands = S.fromList [minBound ..]++allConnectionOptions :: [Text]+allConnectionOptions = ["binary", "hold-input", "disable-oob", "client-echo",+ "flush-command", "intrinsic-commands"]++connectionOption :: StrT -> Maybe (Connection -> Value)+connectionOption "binary" =+ Just (truthValue . connectionOptionBinary)+connectionOption "hold-input" =+ Just (truthValue . connectionOptionHoldInput)+connectionOption "disable-oob" =+ Just (truthValue . connectionOptionDisableOob)+connectionOption "client-echo" =+ Just (truthValue . connectionOptionClientEcho)+connectionOption "flush-command" =+ Just (Str . connectionOptionFlushCommand)+connectionOption "intrinsic-commands" =+ Just (fromListBy (Str . ic2text) .+ S.toList . connectionOptionIntrinsicCommands)+connectionOption _ = Nothing++setConnectionOption :: StrT -> Value -> Connection -> MOO Connection+setConnectionOption "binary" value conn =+ return conn { connectionOptionBinary = truthOf value }+setConnectionOption "hold-input" value conn =+ return conn { connectionOptionHoldInput = truthOf value }+setConnectionOption "disable-oob" value conn =+ return conn { connectionOptionDisableOob = truthOf value }+setConnectionOption "client-echo" value conn = do+ let clientEcho = truthOf value+ telnetCmd = BS.pack [ telnetIAC+ , if clientEcho then telnetWON'T else telnetWILL+ , telnetECHO+ ]+ telnetIAC = 255+ telnetWILL = 251+ telnetWON'T = 252+ telnetECHO = 1+ delayIO $ BS.hPut (connectionHandle conn) telnetCmd+ return conn { connectionOptionClientEcho = clientEcho }+setConnectionOption "flush-command" value conn =+ return conn { connectionOptionFlushCommand = flushCommand }+ where flushCommand = case value of+ Str t -> t+ _ -> T.empty+setConnectionOption "intrinsic-commands" value conn = do+ intrinsicCommands <- case value of+ Lst v -> foldM command S.empty (V.toList v)+ where command set (Str cmd) = maybe (raise E_INVARG)+ (return . flip S.insert set) $ text2ic cmd+ command _ _ = raise E_INVARG+ Int 0 -> return S.empty+ Int _ -> return allIntrinsicCommands+ _ -> raise E_INVARG+ return conn { connectionOptionIntrinsicCommands = intrinsicCommands }+setConnectionOption _ _ _ = raise E_INVARG++bootPlayer :: ObjId -> MOO ()+bootPlayer oid = notyet "bootPlayer"++notify :: ObjId -> Text -> MOO ()+notify who what = delayIO (putStrLn $ T.unpack what)++getConnectionName :: ObjId -> MOO Text+getConnectionName player = do+ world <- getWorld+ case M.lookup player (connections world) of+ Just conn -> return $ connectionName conn+ Nothing -> raise E_INVARG++listen :: PortNumber -> ObjId -> Bool -> MOO PortNumber+listen port object printMessages = do+ world <- getWorld+ when (M.member port $ listeners world) $ raise E_INVARG++ world' <- getWorld'+ result <- requestIO $ do+ result <- try $ listenOn (PortNumber port)+ case result of+ Left err+ | isPermissionError err -> return (Left E_PERM)+ | otherwise -> return (Left E_QUOTA)+ Right socket -> do+ port <- socketPort socket+ let listener = initListener {+ listenerSocket = socket+ , listenerPort = port+ , listenerObject = object+ , listenerPrintMessages = printMessages+ }+ thread <- forkIO $ listenerIO world' listener+ return $ Right listener { listenerThread = thread }++ case result of+ Left err -> raise err+ Right listener -> do+ let (PortNumber canon) = listenerPort listener+ putWorld world { listeners = M.insert canon listener (listeners world) }+ return canon++unlisten :: PortNumber -> MOO ()+unlisten port = do+ world <- getWorld+ case M.lookup port $ listeners world of+ Just Listener { listenerThread = thread, listenerSocket = socket } -> do+ putWorld world { listeners = M.delete port (listeners world) }+ delayIO $ killThread thread >> sClose socket+ Nothing -> raise E_INVARG++listenerIO :: TVar World -> Listener -> IO ()+listenerIO world' Listener {+ listenerSocket = socket+ , listenerPort = port+ , listenerObject = object+ , listenerPrintMessages = printMessages+ } = mask $ \restore -> do++ let lport = case port of+ PortNumber port -> T.pack (show port)+ UnixSocket path -> T.pack (show path)++ forever $ do+ (handle, host, port) <- accept socket++ now <- getCurrentTime+ let connection = initConnection {+ connectionHandle = handle+ , connectionName = T.concat [ "port ", lport+ , " from ", T.pack host+ , ", port ", T.pack (show port)+ ]+ , connectionActivityTime = now+ }++ connId <- addConnection world' connection++ forkIO $+ restore (connectionIO world' object printMessages (connId, connection))+ `finally` (removeConnection world' connId >> hClose handle)++addConnection :: TVar World -> Connection -> IO ObjId+addConnection world' connection = atomically $ do+ world <- readTVar world'+ let connId = nextConnectionId world+ writeTVar world' world {+ connections = M.insert connId connection (connections world)+ , nextConnectionId = connId - 1+ }+ return connId++removeConnection :: TVar World -> ObjId -> IO ()+removeConnection world' connId =+ atomically $ modifyTVar world' $ \world ->+ world { connections = M.delete connId (connections world) }++openNetworkConnection :: HostName -> PortNumber -> ObjId -> MOO ObjId+openNetworkConnection host port object = do+ world' <- getWorld'+ result <- requestIO $ do+ result <- try $ connectTo host (PortNumber port)+ case result of+ Left err+ | isDoesNotExistError err -> return (Left E_INVARG)+ | otherwise -> return (Left E_QUOTA)+ Right handle -> do+ now <- getCurrentTime+ let lport = "0" -- XXX+ connection = initConnection {+ connectionHandle = handle+ , connectionName =+ T.concat [ "port ", lport+ , " to ", T.pack host+ , ", port ", T.pack (show port)+ ]+ , connectionActivityTime = now+ }++ connId <- addConnection world' connection+ return $ Right (connId, connection)++ case result of+ Left err -> raise err+ Right (connId, connection) -> do+ delayIO $ void $ forkIO $+ connectionIO world' object False (connId, connection)+ `finally` do+ removeConnection world' connId+ hClose $ connectionHandle connection++ return connId++connectionIO :: TVar World -> ObjId -> Bool -> (ObjId, Connection) -> IO ()+connectionIO world' object printMessages (connId, connection) = do+ let handle = connectionHandle connection+ hSetBuffering handle LineBuffering+ return ()++serverMessage :: ObjId -> Id -> [Text] -> MOO [Text]+serverMessage object name defaultMessage = do+ maybeValue <- getServerOption' object name+ undefined
+ src/MOO/Network.hs-boot view
@@ -0,0 +1,18 @@+-- -*- Haskell -*-++module MOO.Network ( Listener+ , Connection+ , PortNumber+ , notify+ ) where++import Data.Text (Text)+import Network (PortNumber)++import MOO.Types (ObjId)+import {-# SOURCE #-} MOO.Task (MOO)++data Listener+data Connection++notify :: ObjId -> Text -> MOO ()
+ src/MOO/Object.hs view
@@ -0,0 +1,257 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Object ( Object (..)+ , Property (..)+ , initObject+ , initProperty+ , getParent+ , getChildren+ , addChild+ , builtinProperties+ , builtinProperty+ , isBuiltinProperty+ , objectForMaybe+ , setProperties+ , setVerbs+ , lookupPropertyRef+ , lookupProperty+ , lookupVerbRef+ , lookupVerb+ , replaceVerb+ , addVerb+ , deleteVerb+ , definedProperties+ , definedVerbs+ ) where++import Control.Arrow (second)+import Control.Concurrent.STM+import Control.Monad (liftM)+import Data.HashMap.Strict (HashMap)+import Data.IntSet (IntSet)+import Data.Maybe+import Data.List (find)++import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.IntSet as IS++import MOO.Types+import MOO.Verb++data Object = Object {+ -- Attributes+ objectIsPlayer :: Bool+ , objectParent :: Maybe ObjId+ , objectChildren :: IntSet++ -- Built-in properties+ , objectName :: StrT+ , objectOwner :: ObjId+ , objectLocation :: Maybe ObjId+ , objectContents :: IntSet+ , objectProgrammer :: Bool+ , objectWizard :: Bool+ , objectPermR :: Bool+ , objectPermW :: Bool+ , objectPermF :: Bool++ -- Definitions+ , objectProperties :: HashMap StrT (TVar Property)+ , objectVerbs :: [([StrT], TVar Verb)]+}++instance Sizeable IntSet where+ storageBytes x = storageBytes () + storageBytes (0 :: Int) * IS.size x++instance (Sizeable k, Sizeable v) => Sizeable (HashMap k v) where+ storageBytes = HM.foldrWithKey bytes (storageBytes ())+ where bytes k v s = s + storageBytes k + storageBytes v++instance Sizeable (TVar a) where+ storageBytes _ = storageBytes ()++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+ storageBytes obj =+ storageBytes (objectIsPlayer obj) ++ storageBytes (objectParent obj) ++ storageBytes (objectChildren obj) ++ storageBytes (objectName obj) ++ storageBytes (objectOwner obj) ++ storageBytes (objectLocation obj) ++ storageBytes (objectContents obj) ++ storageBytes (objectProgrammer obj) ++ storageBytes (objectWizard obj) ++ storageBytes (objectPermR obj) ++ storageBytes (objectPermW obj) ++ storageBytes (objectPermF obj) ++ storageBytes (objectProperties obj) ++ storageBytes (objectVerbs obj)++initObject = Object {+ objectIsPlayer = False+ , objectParent = Nothing+ , objectChildren = IS.empty++ , objectName = T.empty+ , objectOwner = -1+ , objectLocation = Nothing+ , objectContents = IS.empty+ , objectProgrammer = False+ , objectWizard = False+ , objectPermR = False+ , objectPermW = False+ , objectPermF = False++ , objectProperties = HM.empty+ , objectVerbs = []+}++instance Show Object where+ show _ = "<object>"++getParent :: Object -> ObjId+getParent = objectForMaybe . objectParent++getChildren :: Object -> [ObjId]+getChildren = IS.elems . objectChildren++addChild :: Object -> ObjId -> Object+addChild obj childOid =+ obj { objectChildren = IS.insert childOid (objectChildren obj) }++data Property = Property {+ propertyName :: StrT+ , propertyValue :: Maybe Value+ , propertyInherited :: Bool++ , propertyOwner :: ObjId+ , propertyPermR :: Bool+ , propertyPermW :: Bool+ , propertyPermC :: Bool+} deriving Show++instance Sizeable Property where+ storageBytes prop =+ storageBytes (propertyName prop) ++ storageBytes (propertyValue prop) ++ storageBytes (propertyInherited prop) ++ storageBytes (propertyOwner prop) ++ storageBytes (propertyPermR prop) ++ storageBytes (propertyPermW prop) ++ storageBytes (propertyPermC prop)++initProperty = Property {+ propertyName = ""+ , propertyValue = Nothing+ , propertyInherited = False++ , propertyOwner = -1+ , propertyPermR = False+ , propertyPermW = False+ , propertyPermC = False+}++builtinProperties :: [StrT]+builtinProperties = [ "name", "owner"+ , "location", "contents"+ , "programmer", "wizard"+ , "r", "w", "f"+ ]++builtinProperty :: StrT -> Maybe (Object -> Value)+builtinProperty "name" = Just (Str . objectName)+builtinProperty "owner" = Just (Obj . objectOwner)+builtinProperty "location" = Just (Obj . objectForMaybe . objectLocation)+builtinProperty "contents" = Just (objectList . IS.elems . objectContents)+builtinProperty "programmer" = Just (truthValue . objectProgrammer)+builtinProperty "wizard" = Just (truthValue . objectWizard)+builtinProperty "r" = Just (truthValue . objectPermR)+builtinProperty "w" = Just (truthValue . objectPermW)+builtinProperty "f" = Just (truthValue . objectPermF)+builtinProperty _ = Nothing++isBuiltinProperty :: StrT -> Bool+isBuiltinProperty = isJust . builtinProperty . T.toCaseFold++objectForMaybe :: Maybe ObjId -> ObjId+objectForMaybe (Just oid) = oid+objectForMaybe Nothing = -1++setProperties :: [Property] -> Object -> IO Object+setProperties props obj = do+ propHash <- mkHash props+ return obj { objectProperties = propHash }+ where mkHash = liftM HM.fromList . mapM mkAssoc+ mkAssoc prop = do+ tvarProp <- newTVarIO prop+ return (propertyKey prop, tvarProp)++propertyKey :: Property -> StrT+propertyKey = T.toCaseFold . propertyName++setVerbs :: [Verb] -> Object -> IO Object+setVerbs verbs obj = do+ verbList <- mkList verbs+ return obj { objectVerbs = verbList }+ where mkList = mapM mkVerb+ mkVerb verb = do+ tvarVerb <- newTVarIO verb+ return (verbKey verb, tvarVerb)++verbKey :: Verb -> [StrT]+verbKey = T.words . T.toCaseFold . verbNames++lookupPropertyRef :: Object -> StrT -> Maybe (TVar Property)+lookupPropertyRef obj name = HM.lookup name (objectProperties obj)++lookupProperty :: Object -> StrT -> STM (Maybe Property)+lookupProperty obj name = maybe (return Nothing) (fmap Just . readTVar) $+ lookupPropertyRef obj name++lookupVerbRef :: Object -> Value -> Maybe (Int, TVar Verb)+lookupVerbRef obj (Str name) =+ fmap (second snd) $ find matchVerb (zip [0..] $ objectVerbs obj)+ where matchVerb (_, (names, _)) = verbNameMatch (T.toCaseFold name) names+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++lookupVerb :: Object -> Value -> STM (Maybe Verb)+lookupVerb obj desc = maybe (return Nothing) (fmap Just . readTVar . snd) $+ lookupVerbRef obj desc++replaceVerb :: Object -> Int -> Verb -> Object+replaceVerb obj index verb =+ obj { objectVerbs = pre ++ [(verbKey verb, tvarVerb)] ++ tail post }+ where (pre, post) = splitAt index (objectVerbs obj)+ tvarVerb = snd $ head post++addVerb :: Verb -> Object -> STM Object+addVerb verb obj = do+ verbTVar <- newTVar verb+ return obj { objectVerbs = objectVerbs obj ++ [(verbKey verb, verbTVar)] }++deleteVerb :: Int -> Object -> STM Object+deleteVerb index obj = return obj { objectVerbs = verbs }+ where verbs = before ++ tail after+ (before, after) = splitAt index (objectVerbs obj)++definedProperties :: Object -> STM [StrT]+definedProperties obj = do+ props <- mapM readTVar $ HM.elems (objectProperties obj)+ return $ map propertyName $ filter (not . propertyInherited) props++definedVerbs :: Object -> STM [StrT]+definedVerbs obj = do+ verbs <- mapM (readTVar . snd) $ objectVerbs obj+ return $ map verbNames verbs
+ src/MOO/Object.hs-boot view
@@ -0,0 +1,5 @@+-- -*- Haskell -*-++module MOO.Object ( Object ) where++data Object
+ src/MOO/Parser.hs view
@@ -0,0 +1,556 @@++module MOO.Parser ( Program, parse, runParser, initParserState+ , expression, between, whiteSpace, eof, program+ , parseInt, parseFlt, parseNum, parseObj, keywords ) where++import Text.Parsec hiding (parse)+import Text.Parsec.Text+import Text.Parsec.Token (GenLanguageDef(..))+import qualified Text.Parsec.Token as T+import Text.Parsec.Error+import Control.Monad.Identity+import Data.Text (Text, pack, unpack, toCaseFold)+import Data.Ratio+import Data.Maybe+import Data.List++import MOO.Types+import MOO.AST++data ParserState = ParserState {+ dollarContext :: Int+ , loopStack :: [[Maybe Id]]+ , lineNumber :: Int+}++initParserState = ParserState {+ dollarContext = 0+ , loopStack = [[]]+ , lineNumber = 1+}++type MOOParser = GenParser ParserState++keywords :: [String]+keywords = ["if", "elseif", "else", "endif", "for", "in", "endfor",+ "while", "endwhile", "fork", "endfork", "return",+ "try", "except", "finally", "endtry", "ANY",+ "break", "continue"] ++ map show ([minBound..maxBound] :: [Error])++mooDef :: GenLanguageDef Text u Identity+mooDef = LanguageDef {+ T.commentStart = "/*"+ , T.commentEnd = "*/"+ , T.commentLine = ""+ , T.nestedComments = False+ , T.identStart = letter <|> char '_'+ , T.identLetter = alphaNum <|> char '_'+ , T.opStart = T.opLetter mooDef+ , T.opLetter = oneOf "+-*/%^=!<>?&|."+ , T.reservedNames = keywords+ , T.reservedOpNames = ["+", "-", "*", "/", "%", "^",+ "==", "!=", "<", "<=", ">=", ">", "&&", "||",+ "?", "|", ".."]+ , T.caseSensitive = False+ }++lexer = T.makeTokenParser mooDef++{-# ANN identifier ("HLint: ignore Use liftM" :: String) #-}++identifier = T.identifier lexer >>= return . pack+reserved = T.reserved lexer+decimal = T.decimal lexer+symbol = T.symbol lexer+lexeme = T.lexeme lexer+whiteSpace = T.whiteSpace lexer+parens = T.parens lexer+braces = T.braces lexer+brackets = T.brackets lexer+semi = T.semi lexer+colon = T.colon lexer+dot = T.dot lexer+commaSep = T.commaSep lexer+commaSep1 = T.commaSep1 lexer++{-+operator = T.operator lexer+reservedOp = T.reservedOp lexer+charLiteral = T.charLiteral lexer+stringLiteral = T.stringLiteral lexer+natural = T.natural lexer+integer = T.integer lexer+float = T.float lexer+naturalOrFloat = T.naturalOrFloat lexer+hexadecimal = T.hexadecimal lexer+octal = T.octal lexer+angles = T.angles lexer+comma = T.comma lexer+semiSep = T.semiSep lexer+semiSep1 = T.semiSep1 lexer+-}++-- Literal values++signed :: (Num a) => MOOParser a -> MOOParser a+signed parser = negative <|> parser+ where negative = char '-' >> fmap 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+ <?> "integer literal"++floatLiteral :: MOOParser Value+floatLiteral = try (lexeme $ signed real) >>= checkRange >>= return . Flt+ <?> "floating-point literal"+ where real = try withDot <|> withoutDot+ withDot = do+ pre <- many digit+ char '.' >> notFollowedBy (char '.')+ post <- (if null pre then many1 else many) digit+ exp <- optionMaybe exponent+ mkFloat pre post exp+ withoutDot = do+ pre <- many1 digit+ exp <- exponent+ mkFloat pre "" (Just exp)++ exponent = oneOf "eE" >> plusMinus decimal <?> "exponent"++ 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)+ mantissa = whole + frac+ in return $ case exp of+ Nothing -> fromRational mantissa+ Just e | e < -500 ||+ e > 500 -> fromRational mantissa * (10 ^^ e)+ | 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++stringLiteral :: MOOParser Value+stringLiteral = lexeme mooString <?> "string literal"+ where mooString = between (char '"') (char '"' <?> "terminating quote") $+ fmap (Str . pack) $ many stringChar+ stringChar = noneOf "\"\\" <|> (char '\\' >> anyChar <?> "")++objectLiteral :: MOOParser Value+objectLiteral = lexeme (char '#' >> signed decimal) >>=+ return . Obj . fromIntegral+ <?> "object number"++errorLiteral :: MOOParser Value+errorLiteral = checkPrefix >> fmap 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++-- Expressions++expression :: MOOParser Expr+expression = scatterAssign <|> valueOrAssign <?> "expression"+ where scatterAssign = do+ scat <- try $ do+ s <- braces scatList+ lexeme $ char '=' >> notFollowedBy (oneOf "=>")+ return s+ expr <- expression+ mkScatter scat expr++ valueOrAssign = do+ val <- value+ assign val <|> return val+ assign val = do+ try $ lexeme $ char '=' >> notFollowedBy (oneOf "=>")+ expr <- expression+ case val of+ List args -> do+ scat <- scatFromArgList args+ mkScatter scat expr+ val | isLValue val -> return $ Assign val expr+ _ -> fail "Illegal expression on left side of assignment."++value :: MOOParser Expr+value = do+ cond <- conditional+ question cond <|> return cond+ where question cond = do+ symbol "?"+ t <- expression+ symbol "|"+ f <- conditional+ return $ Conditional cond t f++conditional :: MOOParser Expr+conditional = chainl1 logical (try op)+ where op = and <|> or+ and = symbol "&&" >> return And+ or = symbol "||" >> return Or++logical :: MOOParser Expr+logical = chainl1 relational (try op)+ where op = equal <|> notEqual <|> lessThan <|> lessEqual <|>+ greaterThan <|> greaterEqual <|> inOp+ equal = symbol "==" >> return Equal+ notEqual = symbol "!=" >> return NotEqual+ lessThan = lt >> return LessThan+ lessEqual = symbol "<=" >> return LessEqual+ greaterThan = gt >> return GreaterThan+ greaterEqual = symbol ">=" >> return GreaterEqual+ inOp = reserved "in" >> return In++ lt = try $ lexeme $ char '<' >> notFollowedBy (char '=')+ gt = try $ lexeme $ char '>' >> notFollowedBy (char '=')++relational :: MOOParser Expr+relational = chainl1 term (try op)+ where op = plus <|> minus+ plus = symbol "+" >> return Plus+ minus = symbol "-" >> return Minus++term :: MOOParser Expr+term = chainl1 factor (try op)+ where op = times <|> divide <|> mod+ times = symbol "*" >> return Times+ divide = symbol "/" >> return Divide+ mod = symbol "%" >> return Remain++factor :: MOOParser Expr+factor = chainr1 base power+ where power = symbol "^" >> return Power++base :: MOOParser Expr+base = bangThing <|> minusThing <|> unary+ where bangThing = symbol "!" >> fmap Not base+ minusThing = do+ try $ lexeme $ char '-' >> notFollowedBy (digit <|> char '.')+ fmap Negate base++unary :: MOOParser Expr+unary = primary >>= modifiers++primary :: MOOParser Expr+primary = subexpression <|> dollarThing <|> identThing <|>+ list <|> catchExpr <|> literal+ where subexpression = parens expression++ dollarThing = do+ symbol "$"+ dollarRef <|> justDollar+ dollarRef = do+ name <- fmap (Literal . Str) identifier+ dollarVerb name <|> return (PropRef objectZero name)+ dollarVerb name = fmap (VerbCall objectZero name) $ parens argList+ objectZero = Literal $ Obj 0+ justDollar = do+ dc <- fmap dollarContext getState+ unless (dc > 0) $ fail "Illegal context for `$' expression."+ return Length++ identThing = do+ ident <- identifier+ let builtin = fmap (BuiltinFunc ident) $ parens argList+ builtin <|> return (Variable ident)++ list = fmap List $ braces argList++ catchExpr = do+ symbol "`"+ expr <- expression+ symbol "!"+ cs <- codes+ dv <- optionMaybe $ symbol "=>" >> expression+ symbol "'"+ return $ Catch expr cs (Default dv)++ literal = fmap Literal $ stringLiteral <|> objectLiteral <|>+ floatLiteral <|> integerLiteral <|> errorLiteral++modifiers :: Expr -> MOOParser Expr+modifiers expr = (propRef >>= modifiers) <|>+ (verbCall >>= modifiers) <|>+ (index >>= modifiers) <|> return expr+ where propRef = do+ try $ dot >> notFollowedBy dot+ ref <- parens expression <|> fmap (Literal . Str) identifier+ return $ PropRef expr ref+ verbCall = do+ colon+ ref <- parens expression <|> fmap (Literal . Str) identifier+ args <- parens argList+ return $ VerbCall expr ref args+ index = between (symbol "[" >> dollars succ)+ (symbol "]" >> dollars pred) $ do+ i <- expression+ range i <|> return (Index expr i)+ range start = do+ try $ symbol ".."+ end <- expression+ return $ Range expr (start, end)+ dollars f = modifyState $+ \st -> st { dollarContext = f $ dollarContext st }++codes :: MOOParser Codes+codes = any <|> fmap Codes nonEmptyArgList <?> "codes"+ where any = reserved "ANY" >> return ANY++nonEmptyArgList :: MOOParser [Arg]+nonEmptyArgList = arguments False++argList :: MOOParser [Arg]+argList = arguments True++arguments :: Bool -> MOOParser [Arg]+arguments allowEmpty+ | allowEmpty = commaSep arg+ | otherwise = commaSep1 arg+ where arg = splice <|> normal+ splice = symbol "@" >> fmap ArgSplice expression+ normal = fmap ArgNormal expression++scatList :: MOOParser [ScatItem]+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++scatFromArgList :: [Arg] -> MOOParser [ScatItem]+scatFromArgList [] = fail "Empty list in scattering assignment."+scatFromArgList args = go args+ where go (a:as) = do+ a' <- case a of+ ArgNormal (Variable v) -> return $ ScatRequired v+ ArgSplice (Variable v) -> return $ ScatRest v+ _ -> fail "Scattering assignment targets must be simple variables."+ as' <- go as+ return (a':as')+ go [] = return []++mkScatter :: [ScatItem] -> Expr -> MOOParser Expr+mkScatter scat expr = checkScatter True scat+ where checkScatter restValid (s:ss) = case s of+ ScatRest{} | restValid -> checkScatter False ss+ | otherwise -> fail tooMany+ _ -> checkScatter restValid ss+ checkScatter _ [] = return $ ScatterAssign scat expr+ tooMany = "More than one `@' target in scattering assignment."++-- Statements++incLineNumber :: MOOParser ()+incLineNumber = modifyState $ \st -> st { lineNumber = succ (lineNumber st) }++getLineNumber :: MOOParser Int+getLineNumber = fmap lineNumber getState++statements :: MOOParser [Statement]+statements = fmap catMaybes (many statement) <?> "statements"++statement :: MOOParser (Maybe Statement)+statement = fmap Just someStatement <|> nullStatement <?> "statement"+ where someStatement = ifStatement <|> forStatement <|> whileStatement <|>+ breakStatement <|> continueStatement <|>+ returnStatement <|> tryStatement <|> forkStatement <|>+ expressionStatement+ nullStatement = semi >> return Nothing++ifStatement :: MOOParser Statement+ifStatement = do+ reserved "if"+ (lineNumber, cond, body) <- ifThen+ elseIfs <- many elseIf+ elsePart <- option [] $ reserved "else" >> incLineNumber >> statements+ reserved "endif" >> incLineNumber++ return $ If lineNumber cond (Then body) elseIfs (Else elsePart)++ where ifThen = do+ lineNumber <- getLineNumber+ cond <- parens expression+ incLineNumber+ body <- statements+ return (lineNumber, cond, body)++ elseIf = do+ reserved "elseif"+ (lineNumber, cond, body) <- ifThen+ return $ ElseIf lineNumber cond body++forStatement :: MOOParser Statement+forStatement = do+ reserved "for"+ lineNumber <- getLineNumber+ ident <- identifier+ reserved "in"+ forList lineNumber ident <|> forRange lineNumber ident+ where forList lineNumber ident = do+ expr <- parens expression+ body <- forBody ident+ return $ ForList lineNumber ident expr body++ forRange lineNumber ident = do+ range <- brackets $ do+ start <- expression+ symbol ".."+ end <- expression+ return (start, end)+ body <- forBody ident+ return $ ForRange lineNumber ident range body++ forBody ident = do+ incLineNumber+ body <- between (pushLoopName $ Just ident) popLoopName statements+ reserved "endfor" >> incLineNumber+ return body++blockStart :: MOOParser (Int, Maybe Id, Expr)+blockStart = do+ lineNumber <- getLineNumber+ ident <- optionMaybe identifier+ expr <- parens expression+ incLineNumber+ return (lineNumber, ident, expr)++whileStatement :: MOOParser Statement+whileStatement = do+ reserved "while"+ (lineNumber, ident, expr) <- blockStart+ body <- between (pushLoopName ident) popLoopName statements+ reserved "endwhile" >> incLineNumber+ return $ While lineNumber ident expr body++modifyLoopStack :: ([[Maybe Id]] -> [[Maybe Id]]) -> MOOParser ()+modifyLoopStack f = modifyState $ \st -> st { loopStack = f $ loopStack st }++pushLoopName :: Maybe Id -> MOOParser ()+pushLoopName ident = modifyLoopStack $ \(s:ss) -> (fmap toCaseFold ident:s):ss++popLoopName :: MOOParser ()+popLoopName = modifyLoopStack $ \(s:ss) -> tail s : ss++suspendLoopScope :: MOOParser ()+suspendLoopScope = modifyLoopStack $ \ss -> [] : ss++resumeLoopScope :: MOOParser ()+resumeLoopScope = modifyLoopStack tail++checkLoopName :: String -> Maybe Id -> MOOParser ()+checkLoopName kind ident = do+ stack <- fmap (head . loopStack) getState+ case ident of+ Nothing -> when (null stack) $+ fail $ "No enclosing loop for `" ++ kind ++ "' statement"+ Just name -> when (fmap toCaseFold ident `notElem` stack) $+ fail $ "Invalid loop name in `" ++ kind ++ "' statement: " +++ unpack name++breakStatement :: MOOParser Statement+breakStatement = do+ reserved "break"+ ident <- optionMaybe identifier+ checkLoopName "break" ident+ semi >> incLineNumber >> return (Break ident)++continueStatement :: MOOParser Statement+continueStatement = do+ reserved "continue"+ ident <- optionMaybe identifier+ checkLoopName "continue" ident+ semi >> incLineNumber >> return (Continue ident)++returnStatement :: MOOParser Statement+returnStatement = do+ reserved "return"+ lineNumber <- getLineNumber+ expr <- optionMaybe expression+ semi >> incLineNumber >> return (Return lineNumber expr)++tryStatement :: MOOParser Statement+tryStatement = do+ reserved "try"+ incLineNumber+ body <- statements+ tryExcept body <|> tryFinally body+ where tryExcept body = do+ excepts <- many1 except+ reserved "endtry" >> incLineNumber+ return $ TryExcept body excepts+ except = do+ reserved "except"+ lineNumber <- getLineNumber+ ident <- optionMaybe identifier+ cs <- parens codes+ incLineNumber+ handler <- statements+ return $ Except lineNumber ident cs handler++ tryFinally body = do+ reserved "finally" >> incLineNumber+ cleanup <- statements+ reserved "endtry" >> incLineNumber+ return $ TryFinally body (Finally cleanup)++forkStatement :: MOOParser Statement+forkStatement = do+ reserved "fork"+ (lineNumber, ident, expr) <- blockStart+ body <- between suspendLoopScope resumeLoopScope statements+ reserved "endfork" >> incLineNumber+ return $ Fork lineNumber ident expr body++expressionStatement :: MOOParser Statement+expressionStatement = do+ lineNumber <- getLineNumber+ expr <- expression+ semi >> incLineNumber >> return (Expression lineNumber expr)++-- Main parser interface++program :: MOOParser Program+program = between whiteSpace eof $ fmap 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]++-- Auxiliary parser interface++standalone :: MOOParser Value -> Text -> Maybe Value+standalone parser input = case runParser parser' initParserState "" input of+ Right v -> Just v+ Left _ -> Nothing+ where parser' = between whiteSpace eof parser++parseInt :: Text -> Maybe Value+parseInt = standalone integerLiteral++parseFlt :: Text -> Maybe Value+parseFlt = standalone floatLiteral++parseNum :: Text -> Maybe Value+parseNum str = parseInt str `mplus` parseFlt str++parseObj :: Text -> Maybe Value+parseObj = standalone objectLiteral
+ src/MOO/Task.hs view
@@ -0,0 +1,1248 @@++{-# LANGUAGE OverloadedStrings, ExistentialQuantification #-}++module MOO.Task ( MOO+ , World(..)+ , Task(..)+ , TaskStatus(..)+ , TaskDisposition(..)+ , Resource(..)+ , Wake(..)+ , Resume(..)+ , DelayedIO(..)+ , Environment(..)+ , TaskState(..)+ , CallStack(..)+ , Continuation(..)+ , StackFrame(..)+ , Exception(..)+ , initWorld+ , initTask+ , newTaskId+ , newTask+ , taskOwner+ , isQueued+ , queuedTasks+ , timeoutException+ , stepTask+ , runTask+ , forkTask+ , interrupt+ , requestIO+ , liftSTM+ , initEnvironment+ , initState+ , newState+ , getWorld+ , getWorld'+ , putWorld+ , modifyWorld+ , getTask+ , putTask+ , purgeTask+ , getDatabase+ , putDatabase+ , getPlayer+ , getObject+ , getProperty+ , getVerb+ , findVerb+ , callCommandVerb+ , callVerb+ , callFromFunc+ , evalFromFunc+ , runVerb+ , runTick+ , modifyProperty+ , modifyVerb+ , readProperty+ , writeProperty+ , setBuiltinProperty+ , initFrame+ , formatFrames+ , pushFrame+ , popFrame+ , activeFrame+ , frame+ , caller+ , modifyFrame+ , setLineNumber+ , pushTryFinallyContext+ , pushLoopContext+ , setLoopContinue+ , popContext+ , breakLoop+ , continueLoop+ , mkVariables+ , catchException+ , passException+ , raiseException+ , notyet+ , raise+ , isWizard+ , checkFloat+ , checkProgrammer+ , checkWizard+ , checkPermission+ , checkValid+ , checkFertile+ , binaryString+ , random+ , newRandomGen+ , formatTraceback+ , delayIO+ ) where++import Control.Arrow (first, (&&&))+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Writer+import Data.ByteString (ByteString)+import Data.List (find)+import Data.Map (Map)+import Data.Maybe (isNothing, fromMaybe, fromJust)+import Data.Text (Text)+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import System.Posix (nanosleep)+import System.Random hiding (random)++import qualified Data.ByteString as BS+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Vector as V++import MOO.Types+import {-# SOURCE #-} MOO.Database+import {-# SOURCE #-} MOO.Network+import MOO.Object+import MOO.Verb+import MOO.Command++-- | 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.+type MOO = ReaderT Environment+ (ContT TaskDisposition+ (StateT TaskState STM))++-- | Lift an 'STM' transaction into the 'MOO' monad.+liftSTM :: STM a -> MOO a+liftSTM = lift . lift . lift++-- | The known universe, as far as the MOO server is concerned+data World = World {+ database :: Database -- ^ The database of objects+ , tasks :: Map TaskId Task -- ^ Queued and running tasks++ , listeners :: Map PortNumber Listener -- ^ Network listening points+ , connections :: Map ObjId Connection -- ^ Network connections++ , nextConnectionId :: ObjId -- ^ The (negative) object+ -- number to be assigned to+ -- the next inbound or+ -- outbound connection+ }++initWorld = World {+ database = undefined+ , tasks = M.empty++ , listeners = M.empty+ , connections = M.empty++ , nextConnectionId = -1+ }++-- | A structure representing a queued or running task+data Task = Task {+ taskId :: TaskId+ , taskStatus :: TaskStatus++ , taskThread :: ThreadId+ , taskWorld :: TVar World+ , taskPlayer :: ObjId++ , taskState :: TaskState+ , taskComputation :: MOO Value+}++instance Show Task where+ show task = "<Task " ++ show (taskId task) +++ ": " ++ show (taskStatus task) ++ ">"++initTask = Task {+ taskId = 0+ , taskStatus = Pending++ , taskThread = undefined+ , taskWorld = undefined+ , taskPlayer = -1++ , taskState = initState+ , taskComputation = return nothing+ }++instance Sizeable Task where+ storageBytes task =+ storageBytes (taskId task) ++ storageBytes (taskThread task) ++ storageBytes (taskWorld task) ++ storageBytes (taskPlayer task) ++ storageBytes (taskStatus task) ++ storageBytes (taskState task)+ -- storageBytes (taskComputation task)++instance Eq Task where+ Task { taskId = taskId1 } == Task { taskId = taskId2 } =+ taskId1 == taskId2++instance Ord Task where+ Task { taskState = state1 } `compare` Task { taskState = state2 } =+ startTime state1 `compare` startTime state2++type TaskId = Int++-- | Generate and return a (random) 'TaskId' not currently in use by any+-- existing task.+newTaskId :: World -> StdGen -> STM TaskId+newTaskId world gen =+ return $ fromJust $ find unused $ randomRs (1, maxBound) gen+ where unused taskId = M.notMember taskId (tasks world)++-- | Create a pending 'Task' for the given computation on behalf of the given+-- player. A new 'TaskId' is reserved for the task and the task is added to+-- the 'World'. (The task will not actually run until passed to 'runTask'.)+newTask :: TVar World -> ObjId -> MOO Value -> IO Task+newTask world' player comp = do+ gen <- newStdGen+ state <- newState++ atomically $ do+ world <- readTVar world'+ taskId <- newTaskId world gen++ let task = initTask {+ taskId = taskId++ , taskWorld = world'+ , taskPlayer = player++ , taskState = state+ , taskComputation = comp+ }++ writeTVar world' world { tasks = M.insert taskId task (tasks world) }+ return task++taskOwner :: Task -> ObjId+taskOwner = permissions . activeFrame++-- | The running state of a task+data TaskStatus = Pending | Running | Forked | Suspended Wake | Reading+ deriving Show++isQueued :: TaskStatus -> Bool+isQueued Pending = False+isQueued Running = False+isQueued _ = True++isRunning :: TaskStatus -> Bool+isRunning Running = True+isRunning _ = False++queuedTasks :: MOO [Task]+queuedTasks =+ (filter (isQueued . taskStatus) . M.elems . tasks) `liftM` getWorld++instance Sizeable TaskStatus where+ storageBytes (Suspended _) = 2 * storageBytes ()+ storageBytes _ = storageBytes ()++-- | 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)+ | forall a. RequestIO (IO a) (Resume a)+ | Uncaught Exception CallStack+ | Timeout Resource CallStack+ | Suicide++-- | A continuation to resume the execution of a task where it left off+newtype Resume a = Resume (a -> MOO Value)++-- | Task resource limits+data Resource = Ticks | Seconds++showResource :: Resource -> Text+showResource Ticks = "ticks"+showResource Seconds = "seconds"++timeoutException :: Resource -> Exception+timeoutException resource =+ Exception (Err E_QUOTA) ("Task ran out of " <> showResource resource) nothing++stepTask :: Task -> IO (TaskDisposition, Task)+stepTask task = do+ let env = initEnvironment task+ comp = taskComputation task+ comp' = callCC $ \k ->+ Complete `liftM` 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+ runDelayed $ delayedIO state'+ return (result, task { taskState = state' { delayedIO = mempty }})++stepTaskWithIO :: Task -> IO (TaskDisposition, Task)+stepTaskWithIO task = do+ (disposition, task') <- stepTask task+ case disposition of+ RequestIO io (Resume resume) -> do+ result <- io+ stepTaskWithIO task' { taskComputation = resume result }+ _ -> return (disposition, task')++-- | Run a task in a new Haskell thread, returning either the value produced+-- by the task, or 'Nothing' if the task suspends or aborts before producing a+-- value. If the task suspends, it may continue running after this function+-- returns. After the task is finished, it is removed from the task queue.+runTask :: Task -> IO (Maybe Value)+runTask task = do+ resultMVar <- newEmptyMVar++ forkIO $ do+ threadId <- myThreadId+ let task' = task { taskThread = threadId }++ atomically $ modifyTVar (taskWorld task) $ \world ->+ world { tasks = M.insert (taskId task)+ task' { taskStatus = Running } $ tasks world }++ runTask' task' $ putMVar resultMVar++ atomically $ modifyTVar (taskWorld task) $ \world ->+ world { tasks = M.delete (taskId task) $ tasks world }++ takeMVar resultMVar++ where noOp = const $ return ()++ runTask' :: Task -> (Maybe Value -> IO ()) -> IO ()+ runTask' task putResult = do+ (disposition, task') <- stepTaskWithIO task+ case disposition of+ Complete value -> putResult (Just value)++ Suspend _ (Resume resume) -> do+ putResult Nothing++ -- restart this task only when there are none other running+ atomically $ do+ world <- readTVar (taskWorld task')+ when (any (isRunning . taskStatus) $ M.elems $ tasks world)+ retry++ runTask' task' { taskComputation = resume () } noOp++ Read _ _ -> error "read() not yet implemented"++ Uncaught exception@(Exception code message value)+ stack@(Stack frames) ->+ handleAbortedTask task' formatted putResult $+ callSystemVerb "handle_uncaught_error"+ [code, Str message, value, traceback, stringList formatted]+ where traceback = formatFrames True frames+ formatted = formatTraceback exception stack++ Timeout resource stack@(Stack frames) ->+ handleAbortedTask task' formatted putResult $+ callSystemVerb "handle_task_timeout"+ [Str $ showResource resource, traceback, stringList formatted]+ where traceback = formatFrames True frames+ formatted = formatTraceback+ (timeoutException resource) stack++ Suicide -> putResult Nothing++ 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 nothing `fmap` call+ }++ 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+ -- 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 stack -> do+ informPlayer traceback+ informPlayer $ formatTraceback exception stack+ putResult Nothing+ Timeout resource stack -> do+ informPlayer traceback+ informPlayer $ formatTraceback+ (timeoutException resource) stack+ putResult Nothing+ Suicide -> putResult Nothing++ where informPlayer :: [Text] -> IO ()+ informPlayer = mapM_ (putStrLn . T.unpack) -- XXX++-- | 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+-- to 'newTaskId'.)+forkTask :: TaskId -> Integer -> MOO Value -> MOO ()+forkTask taskId usecs code = do+ state <- get++ let now = startTime state+ estimatedWakeup = (fromIntegral usecs / 1000000) `addUTCTime` now++ when (estimatedWakeup < now || estimatedWakeup > endOfTime) $ raise E_INVARG++ task <- asks task+ gen <- newRandomGen++ let frame = currentFrame (stack state)++ frame' = frame {+ depthLeft = depthLeft initFrame+ , contextStack = contextStack initFrame+ , lineNumber = lineNumber frame + 1+ }++ state' = initState {+ ticksLeft = 15000 -- XXX+ , stack = Stack [frame']+ , startTime = estimatedWakeup+ , randomGen = gen+ }++ task' = task {+ taskId = taskId+ , taskStatus = Forked+ , taskState = state'+ , taskComputation = code+ }++ -- make sure the forked task doesn't start before the current task commits+ startSignal <- liftSTM newEmptyTMVar++ threadId <- requestIO $ forkIO $ do+ if usecs <= fromIntegral (maxBound :: Int)+ then threadDelay (fromIntegral usecs)+ else nanosleep (usecs * 1000)+ atomically $ takeTMVar startSignal+ now <- getCurrentTime+ void $ runTask task' { taskState = state' { startTime = now } }++ modifyWorld $ \world ->+ world { tasks = M.insert taskId task' { taskThread = threadId } $+ tasks world }+ liftSTM $ putTMVar startSignal ()++-- | A continuation for returning to the task dispatcher to handle an+-- interrupt request. Note that calling this continuation implies a commit to+-- the current task's transaction.+newtype InterruptHandler = Interrupt (TaskDisposition -> MOO TaskDisposition)++-- | Commit the current task's transaction, and return to the task dispatcher+-- with an interrupt request. The task dispatcher may resume execution of the+-- task later if the request is one which supplies an appropriate+-- continuation.+interrupt :: TaskDisposition -> MOO a+interrupt disp = do+ Interrupt handler <- asks interruptHandler+ handler disp+ error "Returned from interrupt handler"++-- | An 'IO' computation to be performed after the current task commits its+-- 'STM' transaction+newtype DelayedIO = DelayedIO { runDelayed :: IO () }++instance Monoid DelayedIO where+ mempty = DelayedIO $ return ()+ DelayedIO a `mappend` DelayedIO b = DelayedIO (a >> b)++-- | Interrupt the current task to perform the given IO computation, and+-- return the result. Note this implies a commit of the task's 'STM'+-- transaction.+requestIO :: IO a -> MOO a+requestIO io = callCC $ interrupt . RequestIO io . Resume++-- | Perform the given IO computation after the current task commits its 'STM'+-- transaction.+--+-- Since IO can't be performed within a transaction, this is a simple+-- 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 }++-- | A 'Reader' environment for state that either doesn't change, or can be+-- locally modified for subcomputations+data Environment = Env {+ task :: Task+ , interruptHandler :: InterruptHandler+ , exceptionHandler :: ExceptionHandler+ , indexLength :: MOO Int+}++initEnvironment :: Task -> Environment+initEnvironment task = Env {+ task = task+ , interruptHandler = error "Undefined interrupt handler"+ , exceptionHandler = Handler $ \e cs -> interrupt (Uncaught e cs)+ , indexLength = error "Invalid index context"+ }++-- | A 'State' structure for data that may normally change during computation+data TaskState = State {+ ticksLeft :: Int+ , stack :: CallStack+ , startTime :: UTCTime+ , randomGen :: StdGen+ , delayedIO :: DelayedIO+}++initState = State {+ ticksLeft = 30000+ , stack = Stack []+ , startTime = posixSecondsToUTCTime 0+ , randomGen = mkStdGen 0+ , delayedIO = mempty+ }++instance Sizeable TaskState where+ storageBytes state =+ storageBytes (ticksLeft state) ++ storageBytes (stack state) ++ storageBytes (startTime state) ++ storageBytes (randomGen state)+ -- storageBytes (delayedIO state)++newState :: IO TaskState+newState = do+ startTime <- getCurrentTime+ gen <- newStdGen+ return initState {+ startTime = startTime+ , randomGen = gen+ }++getWorld :: MOO World+getWorld = liftSTM . readTVar . taskWorld =<< asks task++getWorld' :: MOO (TVar World)+getWorld' = asks (taskWorld . task)++putWorld :: World -> MOO ()+putWorld world = do+ world' <- getWorld'+ liftSTM $ writeTVar world' world++modifyWorld :: (World -> World) -> MOO ()+modifyWorld f = do+ world' <- getWorld'+ liftSTM $ modifyTVar world' f++getTask :: TaskId -> MOO (Maybe Task)+getTask taskId = (M.lookup taskId . tasks) `liftM` getWorld++putTask :: Task -> MOO ()+putTask task = modifyWorld $ \world ->+ world { tasks = M.insert (taskId task) task $ tasks world }++purgeTask :: Task -> MOO ()+purgeTask task = modifyWorld $ \world ->+ world { tasks = M.delete (taskId task) $ tasks world }++getDatabase :: MOO Database+getDatabase = database `liftM` getWorld++putDatabase :: Database -> MOO ()+putDatabase db = modifyWorld $ \world -> world { database = db }++getPlayer :: MOO ObjId+getPlayer = asks (taskPlayer . task)++getObject :: ObjId -> MOO (Maybe Object)+getObject oid = liftSTM . dbObject oid =<< getDatabase++getProperty :: Object -> StrT -> MOO Property+getProperty obj name = do+ maybeProp <- liftSTM $ lookupProperty obj (T.toCaseFold name)+ maybe (raise E_PROPNF) return maybeProp++getVerb :: Object -> Value -> MOO Verb+getVerb obj desc@Str{} = do+ maybeVerb <- liftSTM $ lookupVerb obj desc+ maybe (raise E_VERBNF) return maybeVerb+getVerb obj desc@(Int index)+ | index < 1 = raise E_INVARG+ | otherwise = do+ maybeVerb <- liftSTM $ lookupVerb obj desc+ maybe (raise E_VERBNF) return maybeVerb+getVerb _ _ = raise E_TYPE++findVerb :: (Verb -> Bool) -> StrT -> ObjId -> MOO (Maybe ObjId, Maybe Verb)+findVerb acceptable name = findVerb'+ where findVerb' oid = do+ maybeObj <- getObject oid+ case maybeObj of+ Nothing -> return (Nothing, Nothing)+ Just obj -> do+ maybeVerb <- searchVerbs (objectVerbs obj)+ case maybeVerb of+ Just verb -> return (Just oid, Just verb)+ Nothing -> maybe (return (Just oid, Nothing))+ findVerb' (objectParent obj)++ 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 [] = return Nothing++ name' = T.toCaseFold name++callSystemVerb :: Id -> [Value] -> MOO (Maybe Value)+callSystemVerb name args = do+ player <- asks (taskPlayer . task)+ (maybeOid, maybeVerb) <- findVerb verbPermX name systemObject+ case (maybeOid, maybeVerb) of+ (Just verbOid, Just verb) -> do+ let vars = mkVariables [+ ("player", Obj player)+ , ("this" , Obj systemObject)+ , ("verb" , Str name)+ , ("args" , fromList args)+ ]+ Just `liftM` runVerb verb initFrame {+ variables = vars+ , verbName = name+ , verbLocation = verbOid+ , initialThis = systemObject+ , 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 [+ ("player" , Obj player)+ , ("this" , Obj this)+ , ("caller" , Obj player)+ , ("verb" , Str $ commandVerb command)+ , ("argstr" , Str $ commandArgStr command)+ , ("args" , stringList $ commandArgs command)+ , ("dobjstr", Str $ commandDObjStr command)+ , ("dobj" , Obj dobj)+ , ("prepstr", Str $ commandPrepStr command)+ , ("iobjstr", Str $ commandIObjStr command)+ , ("iobj" , Obj iobj)+ ]++ runVerb verb initFrame {+ variables = vars+ , verbName = commandVerb command+ , verbLocation = verbOid+ , initialThis = this+ , initialPlayer = player+ }++callVerb' :: (ObjId, Verb) -> ObjId -> StrT -> [Value] -> MOO Value+callVerb' (verbOid, verb) this name args = do+ thisFrame <- frame id+ wizard <- isWizard (permissions thisFrame)+ let player = if wizard+ then case vars M.! "player" of+ (Obj oid) -> oid+ _ -> initialPlayer thisFrame+ else 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")+ ]++ runVerb verb initFrame {+ variables = vars'+ , verbName = name+ , verbLocation = verbOid+ , initialThis = this+ , initialPlayer = player+ }++callVerb :: ObjId -> ObjId -> StrT -> [Value] -> MOO Value+callVerb verbLoc this name args = do+ (maybeOid, maybeVerb) <- findVerb verbPermX name verbLoc+ case (maybeOid, maybeVerb) of+ (Nothing , _) -> raise E_INVIND+ (Just _ , Nothing) -> raise E_VERBNF+ (Just verbOid, Just verb) -> callVerb' (verbOid, verb) this name args++callFromFunc :: Id -> IntT -> (ObjId, StrT) -> [Value] -> MOO (Maybe Value)+callFromFunc func index (oid, name) args = do+ (maybeOid, maybeVerb) <- findVerb verbPermX name oid+ case (maybeOid, maybeVerb) of+ (Just verbOid, Just verb) -> liftM Just $ evalFromFunc func index $+ callVerb' (verbOid, verb) oid name args+ (_ , _) -> return Nothing++evalFromFunc :: Id -> IntT -> MOO Value -> MOO Value+evalFromFunc func index code = do+ (depthLeft, player) <- frame (depthLeft &&& initialPlayer)+ pushFrame initFrame {+ depthLeft = depthLeft+ , verbName = func+ , initialPlayer = player+ , builtinFunc = True+ , lineNumber = index+ }+ value <- code `catchException` \except callStack -> do+ popFrame+ passException except callStack+ 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+ unless (depthLeft' > 0) $ raise E_MAXREC++ pushFrame verbFrame {+ depthLeft = depthLeft' - 1+ , debugBit = verbPermD verb+ , permissions = verbOwner verb+ , verbFullName = verbNames verb+ }+ value <- verbCode verb `catchException` \except callStack -> do+ popFrame+ passException except callStack+ popFrame++ return value++runTick :: MOO ()+runTick = do+ ticksLeft <- gets ticksLeft+ unless (ticksLeft > 0) $ interrupt . Timeout Ticks =<< gets stack+ modify $ \state -> state { ticksLeft = ticksLeft - 1 }++modifyProperty :: Object -> StrT -> (Property -> MOO Property) -> MOO ()+modifyProperty obj name f =+ case lookupPropertyRef obj (T.toCaseFold name) of+ Nothing -> raise E_PROPNF+ Just propTVar -> do+ prop <- liftSTM $ readTVar propTVar+ prop' <- f prop+ liftSTM $ writeTVar propTVar prop'++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+ verb' <- f verb+ liftSTM $ writeTVar verbTVar verb'+ let names = T.toCaseFold $ verbNames verb+ names' = T.toCaseFold $ verbNames verb'+ when (names /= names') $ do+ db <- getDatabase+ liftSTM $ modifyObject oid db $ \obj ->+ return $ replaceVerb obj index verb'++readProperty :: ObjId -> StrT -> MOO (Maybe Value)+readProperty oid name = do+ maybeObj <- getObject oid+ 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+ 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 " +++ T.unpack name) search parentObj+ just -> return just++writeProperty :: ObjId -> StrT -> Value -> MOO ()+writeProperty oid name value = do+ maybeObj <- getObject oid+ 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 }++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 }+setBuiltinProperty (oid, _) "owner" (Obj owner) = do+ checkWizard+ db <- getDatabase+ liftSTM $ modifyObject oid db $ \obj -> return 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+ checkWizard+ db <- getDatabase+ liftSTM $ modifyObject oid db $ \obj ->+ return obj { objectWizard = truthOf bit }+setBuiltinProperty (oid, obj) "r" bit = do+ checkPermission (objectOwner obj)+ db <- getDatabase+ liftSTM $ modifyObject oid db $ \obj ->+ return 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 }+setBuiltinProperty (oid, obj) "f" bit = do+ checkPermission (objectOwner obj)+ db <- getDatabase+ liftSTM $ modifyObject oid db $ \obj ->+ return 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++-- | A local continuation for loop constructs+newtype Continuation = Continuation (Value -> MOO Value)++instance Sizeable Continuation where+ storageBytes _ = storageBytes ()++instance Show Continuation where+ show _ = "<Continuation>"++-- | A structure describing a (possibly nested) context for the current frame,+-- used to manage loop break/continue and try/finally interactions+data Context =+ Loop {+ loopName :: Maybe Id+ , loopBreak :: Continuation+ , loopContinue :: Continuation+ } |+ TryFinally {+ finally :: MOO Value+ }++instance Sizeable Context where+ storageBytes context@Loop{} =+ storageBytes (loopName context) ++ storageBytes (loopBreak context) ++ storageBytes (loopContinue context)+ 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+ , debugBit :: Bool+ , permissions :: ObjId++ , verbName :: StrT+ , verbFullName :: StrT+ , verbLocation :: ObjId+ , initialThis :: ObjId+ , initialPlayer :: ObjId++ , builtinFunc :: Bool+ , lineNumber :: IntT+} deriving Show++initFrame = Frame {+ depthLeft = 50++ , contextStack = []+ , variables = initVariables+ , debugBit = True+ , permissions = -1++ , verbName = T.empty+ , verbFullName = T.empty+ , verbLocation = -1+ , initialThis = -1+ , initialPlayer = -1++ , builtinFunc = False+ , lineNumber = 0+}++instance Sizeable StackFrame where+ storageBytes frame =+ storageBytes (depthLeft frame) ++ storageBytes (contextStack frame) ++ storageBytes (variables frame) ++ storageBytes (debugBit frame) ++ storageBytes (permissions frame) ++ storageBytes (verbName frame) ++ storageBytes (verbFullName frame) ++ storageBytes (verbLocation frame) ++ storageBytes (initialThis frame) ++ storageBytes (initialPlayer frame) ++ storageBytes (builtinFunc frame) ++ storageBytes (lineNumber frame)++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) }++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"++previousFrame :: CallStack -> Maybe StackFrame+previousFrame (Stack (_:frames)) = previousFrame' frames+ where previousFrame' (frame:frames)+ | builtinFunc frame = previousFrame' frames+ | otherwise = Just frame+ previousFrame' [] = Nothing+previousFrame (Stack []) = error "previousFrame: Empty call stack"++activeFrame :: Task -> StackFrame+activeFrame = currentFrame . stack . taskState++frame :: (StackFrame -> a) -> MOO a+frame f = gets (f . currentFrame . stack)++caller :: (StackFrame -> a) -> MOO (Maybe a)+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) }++setLineNumber :: Int -> MOO ()+setLineNumber lineNumber = modifyFrame $ \frame ->+ frame { lineNumber = fromIntegral lineNumber }++pushContext :: Context -> MOO ()+pushContext context = modifyFrame $ \frame ->+ frame { contextStack = context : contextStack frame }++pushTryFinallyContext :: MOO Value -> MOO ()+pushTryFinallyContext finally =+ pushContext TryFinally { finally = finally }++pushLoopContext :: Maybe Id -> Continuation -> MOO ()+pushLoopContext name break =+ pushContext Loop {+ loopName = name+ , loopBreak = break+ , loopContinue = undefined+ }++setLoopContinue :: Continuation -> MOO ()+setLoopContinue continue =+ modifyFrame $ \frame@Frame { contextStack = loop:loops } ->+ frame { contextStack = loop { loopContinue = continue } : loops }++popContext :: MOO ()+popContext = modifyFrame $ \frame@Frame { contextStack = _:contexts } ->+ frame { contextStack = contexts }++unwindContexts :: (Context -> Bool) -> MOO [Context]+unwindContexts p = do+ 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 }+ finally+ _ -> return nothing+ unwind next+ unwind [] = return []++unwindLoopContext :: Maybe Id -> MOO Context+unwindLoopContext maybeName = do+ loop:_ <- unwindContexts testContext+ return loop+ where testContext Loop { loopName = name } =+ isNothing maybeName || maybeName == name+ testContext _ = False++breakLoop :: Maybe Id -> MOO Value+breakLoop maybeName = do+ Loop { loopBreak = Continuation break } <- unwindLoopContext maybeName+ break nothing++continueLoop :: Maybe Id -> MOO Value+continueLoop maybeName = do+ Loop { loopContinue = Continuation continue } <- unwindLoopContext maybeName+ continue nothing++-- | The default collection of verb variables+initVariables :: Map Id Value+initVariables = M.fromList $ [+ ("player" , Obj (-1))+ , ("this" , Obj (-1))+ , ("caller" , Obj (-1))++ , ("args" , Lst V.empty)+ , ("argstr" , Str T.empty)++ , ("verb" , Str T.empty)+ , ("dobjstr", Str T.empty)+ , ("dobj" , Obj (-1))+ , ("prepstr", Str T.empty)+ , ("iobjstr", Str T.empty)+ , ("iobj" , Obj (-1))+ ] ++ typeVariables++ where typeVariables = map (first T.toCaseFold) [+ ("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)+ ]++-- | Create a variable block for a verb by overriding the default.+mkVariables :: [(Id, Value)] -> Map Id Value+mkVariables = foldr (uncurry M.insert) initVariables++newtype ExceptionHandler = Handler (Exception -> CallStack -> MOO Value)++instance Show ExceptionHandler where+ show _ = "<ExceptionHandler>"++-- | A MOO exception+data Exception = Exception Code Message Value+type Code = Value+type Message = StrT++-- | Install a local exception handler for the duration of the passed+-- computation.+catchException :: MOO a -> (Exception -> CallStack -> MOO a) -> MOO a+catchException action handler = callCC $ \k -> local (mkHandler k) action+ where mkHandler k env = env { exceptionHandler = Handler $ \e cs ->+ local (const env) $ handler e cs >>= k }++-- | Re-raise an exception to the next enclosing handler.+passException :: Exception -> CallStack -> MOO a+passException except callStack = do+ Handler handler <- asks exceptionHandler+ handler except callStack+ error "Returned from exception handler"++-- | Abort execution of the current computation and call the closest enclosing+-- exception handler.+raiseException :: Exception -> MOO a+raiseException except = passException except =<< gets stack++-- | Placeholder for features not yet implemented+notyet :: String -> MOO a+notyet what = raiseException $+ Exception (Err E_QUOTA) "Not yet implemented" (Str $ T.pack what)++-- | Create and raise an exception for the given MOO error.+raise :: Error -> MOO a+raise err = raiseException $ Exception (Err err) (error2text err) nothing++-- | Verify that the given floating point number is neither infinite nor NaN,+-- raising 'E_FLOAT' or 'E_INVARG' respectively if so. Also, return the+-- corresponding MOO value.+checkFloat :: FltT -> MOO Value+checkFloat flt+ | isInfinite flt = raise E_FLOAT+ | isNaN flt = raise E_INVARG+ | otherwise = return (Flt flt)++-- | Verify that the given object has a programmer bit, raising 'E_PERM' if+-- not.+checkProgrammer' :: ObjId -> MOO ()+checkProgrammer' perm = do+ programmer <- maybe False objectProgrammer `liftM` getObject perm+ unless programmer $ raise E_PERM++-- | Verify that the current task permissions have programmer privileges,+-- raising 'E_PERM' if not.+checkProgrammer :: MOO ()+checkProgrammer = checkProgrammer' =<< frame permissions++-- | Determine whether the given object has its wizard bit set.+isWizard :: ObjId -> MOO Bool+isWizard = liftM (maybe False objectWizard) . getObject++-- | Verify that the given object is a wizard, raising 'E_PERM' if not.+checkWizard' :: ObjId -> MOO ()+checkWizard' perm = do+ wizard <- isWizard perm+ unless wizard $ raise E_PERM++-- | Verify that the current task permissions have wizard privileges, raising+-- 'E_PERM' if not.+checkWizard :: MOO ()+checkWizard = checkWizard' =<< frame permissions++-- | Verify that the current task permissions either have wizard privileges or+-- are the same as the given object, raising 'E_PERM' if not.+checkPermission :: ObjId -> MOO ()+checkPermission who = do+ perm <- frame permissions+ unless (perm == who) $ checkWizard' perm++-- | Verify that the given object is valid, raising 'E_INVARG' if not. Also,+-- return the referenced object.+checkValid :: ObjId -> MOO Object+checkValid = getObject >=> maybe (raise E_INVARG) return++-- | 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)++-- | 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 . BS.pack) . text2binary++-- | Generate and return a pseudorandom number 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++-- | 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+ modify $ \state -> state { randomGen = gen }+ return gen'++-- | Generate traceback lines for an exception, suitable for displaying to a+-- user.+formatTraceback :: Exception -> CallStack -> [Text]+formatTraceback (Exception _ message _) (Stack frames) =+ T.splitOn "\n" $ execWriter (traceback frames)++ where traceback (frame:frames) = do+ describeVerb frame+ tell $ ": " <> message+ traceback' frames+ traceback [] = traceback' []++ traceback' (frame:frames) = do+ tell "\n... called from "+ describeVerb frame+ traceback' frames+ traceback' [] = tell "\n(End of traceback)"++ describeVerb Frame { builtinFunc = False+ , verbLocation = loc, verbFullName = name+ , initialThis = this, lineNumber = line } = do+ tell $ "#" <> T.pack (show loc) <> ":" <> name+ when (loc /= this) $ tell $ " (this == #" <> T.pack (show this) <> ")"+ when (line > 0) $ tell $ ", line " <> T.pack (show line)+ describeVerb Frame { builtinFunc = True, verbName = name } =+ tell $ "built-in function " <> name <> "()"
+ src/MOO/Task.hs-boot view
@@ -0,0 +1,53 @@+-- -*- Haskell -*-++module MOO.Task ( MOO+ , World+ , requestIO+ , delayIO+ , getWorld+ , getWorld'+ , putWorld+ , getPlayer+ , getObject+ , readProperty+ , findVerb+ , callCommandVerb+ , raise+ , notyet+ ) where++import Control.Concurrent.STM+import Control.Monad.Reader+import Control.Monad.Cont+import Control.Monad.State.Strict++import MOO.Types+import {-# SOURCE #-} MOO.Object+import {-# SOURCE #-} MOO.Verb+import {-# SOURCE #-} MOO.Command++data World++data Environment+data TaskDisposition+data TaskState++type MOO = ReaderT Environment+ (ContT TaskDisposition+ (StateT TaskState STM))++requestIO :: IO a -> MOO a+delayIO :: IO () -> MOO ()++getWorld :: MOO World+getWorld' :: MOO (TVar World)+putWorld :: World -> MOO ()+getPlayer :: MOO ObjId+getObject :: ObjId -> MOO (Maybe Object)+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++raise :: Error -> MOO a+notyet :: String -> MOO a
+ src/MOO/Types.hs view
@@ -0,0 +1,375 @@++{-# LANGUAGE CPP, OverloadedStrings #-}++-- | Basic data types used throughout the MOO server code+module MOO.Types (++ -- * Haskell Types Representing MOO Values+ IntT+ , FltT+ , StrT+ , ObjT+ , ErrT+ , LstT++ , ObjId+ , Id++ -- * MOO Type and Value Reification+ , Type(..)+ , Value(..)+ , Error(..)++ , nothing++ -- * Type and Value Functions+ , fromInt+ , fromFlt+ , fromStr+ , fromObj+ , fromErr+ , fromLst++ , equal+ , truthOf+ , truthValue+ , typeOf++ , typeCode++ , toText+ , toLiteral+ , error2text++ , text2binary++ -- * List Convenience Functions+ , fromList+ , fromListBy+ , stringList+ , objectList++ , listSet++ -- * Miscellaneous+ , validStrChar+ , endOfTime++ -- * Estimating Haskell Storage Sizes+ , Sizeable(..)++ ) where++import Control.Concurrent (ThreadId)+import Data.Char (isAscii, isPrint, isDigit)+import Data.Int (Int32, Int64)+import Data.Map (Map)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Vector (Vector)+import Data.Word (Word8)+import Foreign.Storable (sizeOf)+import System.Random (StdGen)++import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM++-- | The 'Sizeable' class is used to estimate the storage requirements of+-- various values, for use by several built-in functions which are supposed to+-- return the byte sizes of certain internal structures.+--+-- The sizes calculated by instances of this class are necessarily+-- approximate, since it may be difficult or impossible to measure them+-- precisely in the Haskell runtime environment.+class Sizeable t where+ -- | Return the estimated storage size of the given value, in bytes.+ storageBytes :: t -> Int++instance Sizeable () where+ storageBytes _ = sizeOf (undefined :: Int)++instance Sizeable Bool where+ storageBytes = sizeOf++instance Sizeable Int where+ storageBytes = sizeOf++instance Sizeable Int32 where+ storageBytes = sizeOf++instance Sizeable Int64 where+ storageBytes = sizeOf++instance Sizeable Double where+ storageBytes = sizeOf++instance Sizeable Text where+ storageBytes t = sizeOf 'x' * (T.length t + 1)++instance Sizeable a => Sizeable (Vector a) where+ storageBytes v = V.sum (V.map storageBytes v)++instance Sizeable a => Sizeable [a] where+ storageBytes = foldr bytes (storageBytes ())+ where bytes x s = s + storageBytes () + storageBytes x++instance Sizeable a => Sizeable (Maybe a) where+ storageBytes Nothing = storageBytes ()+ storageBytes (Just x) = storageBytes () + storageBytes x++instance (Sizeable a, Sizeable b) => Sizeable (a, b) where+ storageBytes (x, y) = storageBytes () + storageBytes x + storageBytes y++instance (Sizeable k, Sizeable v) => Sizeable (Map k v) where+ storageBytes =+ M.foldrWithKey' (\k v s -> s + storageBytes k + storageBytes v) 0++instance Sizeable StdGen where+ storageBytes _ = storageBytes () + 2 * storageBytes (undefined :: Int32)++instance Sizeable UTCTime where+ storageBytes _ = 4 * storageBytes ()++instance Sizeable ThreadId where+ storageBytes _ = storageBytes ()++type IntT = Int32+ -- ^ MOO integer+type FltT = Double -- ^ MOO floating-point number+type StrT = Text -- ^ MOO string+type ObjT = Int -- ^ MOO object number+type ErrT = Error -- ^ MOO error+type LstT = Vector Value -- ^ MOO list++type ObjId = ObjT -- ^ MOO object number+type Id = StrT -- ^ MOO identifier (string)++-- | 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 Show++instance Sizeable Value where+ storageBytes value = case value of+ Int x -> box + storageBytes x+ Flt x -> box + storageBytes x+ Str x -> box + storageBytes x+ Obj x -> box + storageBytes x+ Err x -> box + storageBytes x+ Lst x -> box + storageBytes x+ where box = storageBytes ()++-- | The default false value (zero)+nothing :: Value+nothing = truthValue False++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++-- Case-insensitive equality+instance Eq Value where+ (Int a) == (Int b) = a == b+ (Flt a) == (Flt b) = a == b+ (Str a) == (Str b) = T.toCaseFold a == T.toCaseFold b+ (Obj a) == (Obj b) = a == b+ (Err a) == (Err b) = a == b+ (Lst a) == (Lst b) = a == b+ _ == _ = False++-- | Test two MOO values for indistinguishable (case-sensitive) equality.+equal :: Value -> Value -> Bool+(Str a) `equal` (Str b) = a == b+(Lst a) `equal` (Lst b) = V.length a == V.length b &&+ V.and (V.zipWith equal a b)+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) = T.toCaseFold a `compare` T.toCaseFold b+ (Obj a) `compare` (Obj b) = a `compare` b+ (Err a) `compare` (Err b) = a `compare` b+ _ `compare` _ = error "Illegal comparison"++-- | A 'Type' represents one or more MOO value types.+data Type = TAny -- ^ any type+ | TNum -- ^ integer or floating-point number+ | TInt -- ^ integer+ | TFlt -- ^ floating-point number+ | TStr -- ^ string+ | TObj -- ^ object number+ | TErr -- ^ error+ | TLst -- ^ list+ deriving (Eq, Show)++-- | A MOO error+data Error = E_NONE -- ^ No error+ | E_TYPE -- ^ Type mismatch+ | E_DIV -- ^ Division by zero+ | E_PERM -- ^ Permission denied+ | E_PROPNF -- ^ Property not found+ | E_VERBNF -- ^ Verb not found+ | E_VARNF -- ^ Variable not found+ | E_INVIND -- ^ Invalid indirection+ | E_RECMOVE -- ^ Recursive move+ | E_MAXREC -- ^ Too many verb calls+ | E_RANGE -- ^ Range error+ | E_ARGS -- ^ Incorrect number of arguments+ | E_NACC -- ^ Move refused by destination+ | E_INVARG -- ^ Invalid argument+ | E_QUOTA -- ^ Resource limit exceeded+ | E_FLOAT -- ^ Floating-point arithmetic error+ deriving (Eq, Ord, Enum, Bounded, Show)++instance Sizeable Error where+ storageBytes _ = storageBytes ()++-- | Is the given MOO value considered to be /true/ or /false/?+truthOf :: Value -> Bool+truthOf (Int x) = x /= 0+truthOf (Flt x) = x /= 0.0+truthOf (Str t) = not (T.null t)+truthOf (Lst v) = not (V.null v)+truthOf _ = False++-- | Return a default MOO value (integer) having the given boolean value.+truthValue :: Bool -> Value+truthValue False = Int 0+truthValue True = Int 1++-- | Return a 'Type' indicating the type of the given value.+typeOf :: Value -> Type+typeOf Int{} = TInt+typeOf Flt{} = TFlt+typeOf Str{} = TStr+typeOf Obj{} = TObj+typeOf Err{} = TErr+typeOf Lst{} = TLst++-- | Return an integer code corresponding to the given type. These codes are+-- visible to MOO code via the @typeof()@ built-in function and various+-- predefined variables.+typeCode :: Type -> IntT+typeCode TNum = -2+typeCode TAny = -1+typeCode TInt = 0+typeCode TObj = 1+typeCode TStr = 2+typeCode TErr = 3+typeCode TLst = 4+typeCode TFlt = 9++-- | Return a string 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) = x+toText (Obj x) = T.pack $ '#' : show x+toText (Err x) = error2text x+toText (Lst _) = "{list}"++-- | Return a literal 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 x, "\""]+ where escape '"' = "\\\""+ escape '\\' = "\\\\"+ escape c = T.singleton c+toLiteral (Err x) = T.pack $ show x+toLiteral v = toText v++-- | Return a string description of the given error value.+error2text :: Error -> Text+error2text E_NONE = "No error"+error2text E_TYPE = "Type mismatch"+error2text E_DIV = "Division by zero"+error2text E_PERM = "Permission denied"+error2text E_PROPNF = "Property not found"+error2text E_VERBNF = "Verb not found"+error2text E_VARNF = "Variable not found"+error2text E_INVIND = "Invalid indirection"+error2text E_RECMOVE = "Recursive move"+error2text E_MAXREC = "Too many verb calls"+error2text E_RANGE = "Range error"+error2text E_ARGS = "Incorrect number of arguments"+error2text E_NACC = "Move refused by destination"+error2text E_INVARG = "Invalid argument"+error2text E_QUOTA = "Resource limit exceeded"+error2text E_FLOAT = "Floating-point arithmetic error"++-- | Parse a MOO /binary string/ and return the corresponding byte values, or+-- 'Nothing' if the string is improperly formatted.+text2binary :: Text -> Maybe [Word8]+text2binary = translate . T.unpack+ where translate ('~':x:y:rs) = do+ xv <- hexValue x+ yv <- hexValue y+ let b = 16 * xv + yv+ bs <- translate rs+ return (b:bs)+ translate ('~':_) = Nothing+ translate (c:cs) = do+ let b = fromIntegral $ fromEnum c+ bs <- translate cs+ return (b:bs)+ translate [] = return []+ hexValue x+ | isDigit x = Just $ distance '0' x+ | x >= 'a' && x <= 'f' = Just $ 10 + distance 'a' x+ | x >= 'A' && x <= 'F' = Just $ 10 + distance 'A' x+ | otherwise = Nothing+ where distance c0 c1 = fromIntegral $ fromEnum c1 - fromEnum c0++-- | May the given character appear in a valid MOO string?+validStrChar :: Char -> Bool+validStrChar c = isAscii c && (isPrint c || c == '\t')++fromList :: [Value] -> Value+fromList = Lst . V.fromList++fromListBy :: (a -> Value) -> [a] -> Value+fromListBy f = fromList . map f++stringList :: [StrT] -> Value+stringList = fromListBy Str++objectList :: [ObjT] -> Value+objectList = fromListBy Obj++listSet :: LstT -> Int -> Value -> LstT+listSet v i value = V.modify (\m -> VM.write m (i - 1) value) v++-- | This is the last UTC time value representable as a 32-bit+-- seconds-since-1970 value. Unfortunately it is used as a sentinel value in+-- LambdaMOO to represent the starting time of indefinitely suspended tasks,+-- so we really can't support time values beyond this point... yet.+endOfTime :: UTCTime+endOfTime = posixSecondsToUTCTime $ fromIntegral (maxBound :: Int32)
+ src/MOO/Unparser.hs view
@@ -0,0 +1,300 @@++{-# LANGUAGE OverloadedStrings #-}++-- | Recovering MOO code from an abstract syntax tree for the @verb_code()@+-- built-in function+module MOO.Unparser ( unparse ) where++import Control.Monad.Reader+import Control.Monad.Writer+import Data.Char+import Data.Set (Set)+import Data.Text (Text)++import qualified Data.Set as S+import qualified Data.Text as T++import MOO.AST+import MOO.Types+import MOO.Parser (keywords)++type Unparser = ReaderT UnparserEnv (Writer Text)++data UnparserEnv = UnparserEnv {+ fullyParenthesizing :: Bool+ , indenting :: Bool+ , indentation :: Text+}++initUnparserEnv = UnparserEnv {+ fullyParenthesizing = False+ , indenting = False+ , indentation = ""+}++-- | @unparse@ /fully-paren/ /indent/ /program/ synthesizes the MOO code+-- corresponding to the given abstract syntax tree. If /fully-paren/ is true,+-- all expressions are fully parenthesized, even when unnecessary given the+-- circumstances of precedence. If /indent/ is 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+-- newline characters.+unparse :: Bool -> Bool -> Program -> Text+unparse fullyParen indent (Program stmts) =+ execWriter $ runReaderT (tellStatements stmts) $ initUnparserEnv {+ fullyParenthesizing = fullyParen+ , indenting = indent+ }++indent :: Unparser ()+indent = do+ indenting <- asks indenting+ when indenting $ tell =<< asks indentation++moreIndented :: Unparser a -> Unparser a+moreIndented = local $ \env -> env { indentation = " " <> indentation env }++tellStatements :: [Statement] -> Unparser ()+tellStatements = mapM_ tellStatement++tellStatement :: Statement -> Unparser ()+tellStatement stmt = case stmt of+ Expression _ expr -> indent >> tellExpr expr >> tell ";\n"++ If _ cond (Then thens) elseIfs (Else elses) -> do+ indent >> tell "if (" >> tellExpr cond >> tell ")\n"+ moreIndented $ tellStatements thens+ mapM_ tellElseIf elseIfs+ unless (null elses) $ do+ indent >> tell "else\n"+ moreIndented $ tellStatements elses+ indent >> tell "endif\n"++ where tellElseIf (ElseIf _ cond thens) = do+ indent >> tell "elseif (" >> tellExpr cond >> tell ")\n"+ moreIndented $ tellStatements thens++ ForList _ var expr body -> tellBlock "for" (Just var) detail body+ where detail = tell " in" >> detailExpr expr++ ForRange _ var (start, end) body -> tellBlock "for" (Just var) detail body+ where detail = tell " in [" >> tellExpr start >> tell ".." >>+ tellExpr end >> tell "]\n"++ While _ var expr body -> tellBlock "while" var (detailExpr expr) body+ Fork _ var expr body -> tellBlock "fork" var (detailExpr expr) body++ Break var -> indent >> tell "break" >> maybeTellVar var >> tell ";\n"+ Continue var -> indent >> tell "continue" >> maybeTellVar var >> tell ";\n"++ Return _ Nothing -> indent >> tell "return;\n"+ Return _ (Just expr) -> indent >> tell "return " >>+ tellExpr expr >> tell ";\n"++ TryExcept body excepts -> do+ indent >> tell "try\n"+ moreIndented $ tellStatements body+ mapM_ tellExcept excepts+ indent >> tell "endtry\n"++ where tellExcept (Except _ var codes handler) = do+ indent >> tell "except" >> maybeTellVar var >> tell " ("+ case codes of+ ANY -> tell "ANY"+ Codes args -> tell =<< unparseArgs args+ tell ")\n"+ moreIndented $ tellStatements handler++ TryFinally body (Finally finally) -> do+ indent >> tell "try\n"+ moreIndented $ tellStatements body+ indent >> tell "finally\n"+ moreIndented $ tellStatements finally+ indent >> tell "endtry\n"++tellBlock :: StrT -> Maybe Id -> Unparser () -> [Statement] -> Unparser ()+tellBlock name maybeVar detail body = do+ indent >> tell name >> maybeTellVar maybeVar >> detail+ moreIndented $ tellStatements body+ indent >> tell "end" >> tell name >> tell "\n"++maybeTellVar :: Maybe Id -> Unparser ()+maybeTellVar Nothing = return ()+maybeTellVar (Just var) = tell " " >> tell var++detailExpr :: Expr -> Unparser ()+detailExpr expr = tell " (" >> tellExpr expr >> tell ")\n"++tellExpr :: Expr -> Unparser ()+tellExpr = tell <=< unparseExpr++unparseExpr :: Expr -> Unparser Text+unparseExpr expr = case expr of+ Literal value -> return $ toLiteral value++ List args -> do+ args' <- unparseArgs args+ return $ "{" <> args' <> "}"++ Variable var -> return var++ PropRef (Literal (Obj 0)) (Literal (Str name))+ | isIdentifier name -> return $ "$" <> name+ PropRef obj name -> do+ obj' <- case obj of+ Literal Int{} -> paren obj -- avoid digits followed by dot (-> float)+ _ -> parenL expr obj+ name' <- unparseNameExpr name+ return $ obj' <> "." <> name'++ Assign lhs rhs -> do+ lhs' <- unparseExpr lhs+ rhs' <- unparseExpr rhs+ return $ lhs' <> " = " <> rhs'++ ScatterAssign scats rhs -> do+ scats' <- unparseScatter scats+ rhs' <- unparseExpr rhs+ return $ "{" <> scats' <> "} = " <> rhs'++ VerbCall (Literal (Obj 0)) (Literal (Str name)) args+ | isIdentifier name -> do args' <- unparseArgs args+ return $ "$" <> name <> "(" <> args' <> ")"+ VerbCall obj name args -> do+ obj' <- parenL expr obj+ name' <- unparseNameExpr name+ args' <- unparseArgs args+ return $ obj' <> ":" <> name' <> "(" <> args' <> ")"++ BuiltinFunc func args -> do+ args' <- unparseArgs args+ return $ func <> "(" <> args' <> ")"++ Index lhs rhs -> do+ lhs' <- parenL expr lhs+ rhs' <- unparseExpr rhs+ return $ lhs' <> "[" <> rhs' <> "]"++ Range lhs (from, to) -> do+ lhs' <- parenL expr lhs+ from' <- unparseExpr from+ to' <- unparseExpr to+ return $ lhs' <> "[" <> from' <> ".." <> to' <> "]"++ Length -> return "$"++ -- Left-associative operators+ In lhs rhs -> binaryL lhs " in " rhs+ Plus lhs rhs -> binaryL lhs " + " rhs+ Minus lhs rhs -> binaryL lhs " - " rhs+ Times lhs rhs -> binaryL lhs " * " rhs+ Divide lhs rhs -> binaryL lhs " / " rhs+ Remain lhs rhs -> binaryL lhs " % " rhs+ And lhs rhs -> binaryL lhs " && " rhs+ Or lhs rhs -> binaryL lhs " || " rhs+ Equal lhs rhs -> binaryL lhs " == " rhs+ NotEqual lhs rhs -> binaryL lhs " != " rhs+ LessThan lhs rhs -> binaryL lhs " < " rhs+ LessEqual lhs rhs -> binaryL lhs " <= " rhs+ GreaterThan lhs rhs -> binaryL lhs " > " rhs+ GreaterEqual lhs rhs -> binaryL lhs " >= " rhs++ -- Right-associative operators+ Power lhs rhs -> binaryR lhs " ^ " rhs++ Negate lhs@(Literal x) | numeric x -> negateParen lhs+ Negate lhs@(Literal x `Index` _) | numeric x -> negateParen lhs+ Negate lhs@(Literal x `Range` _) | numeric x -> negateParen lhs+ Negate lhs@(Literal Flt{} `PropRef` _) -> negateParen lhs+ Negate lhs@(VerbCall (Literal x) _ _) | numeric x -> negateParen lhs+ Negate lhs -> ("-" <>) `liftM` parenL expr lhs++ Not lhs -> ("!" <>) `liftM` parenL expr lhs++ Conditional cond lhs rhs -> do+ cond' <- parenR expr cond+ lhs' <- unparseExpr lhs+ rhs' <- parenR expr rhs+ return $ cond' <> " ? " <> lhs' <> " | " <> rhs'++ Catch lhs codes (Default dv) -> do+ lhs' <- unparseExpr lhs+ codes' <- case codes of+ ANY -> return "ANY"+ Codes args -> unparseArgs args+ case dv of+ Nothing -> return $ "`" <> lhs' <> " ! " <> codes' <> "'"+ Just expr -> do+ expr' <- unparseExpr expr+ return $ "`" <> lhs' <> " ! " <> codes' <> " => " <> expr' <> "'"++ where binaryL lhs op rhs = do+ lhs' <- parenL expr lhs+ rhs' <- parenR expr rhs+ return $ lhs' <> op <> rhs'++ binaryR lhs op rhs = do+ lhs' <- parenR expr lhs+ rhs' <- parenL expr rhs+ return $ lhs' <> op <> rhs'++ numeric :: Value -> Bool+ numeric Int{} = True+ numeric Flt{} = True+ numeric _ = False++ negateParen = liftM ("-" <>) . paren++unparseArgs :: [Arg] -> Unparser Text+unparseArgs = liftM (T.intercalate ", ") . mapM unparseArg+ where unparseArg (ArgNormal expr) = unparseExpr expr+ unparseArg (ArgSplice expr) = ("@" <>) `liftM` unparseExpr expr++unparseScatter :: [ScatItem] -> Unparser Text+unparseScatter = liftM (T.intercalate ", ") . mapM unparseScat+ where unparseScat (ScatRequired var) = return var+ unparseScat (ScatRest var) = return $ "@" <> var+ unparseScat (ScatOptional var Nothing) = return $ "?" <> var+ unparseScat (ScatOptional var (Just expr)) = do+ expr' <- unparseExpr expr+ return $ "?" <> var <> " = " <> expr'++unparseNameExpr :: Expr -> Unparser Text+unparseNameExpr (Literal (Str name))+ | isIdentifier name = return name+unparseNameExpr expr = do+ expr' <- unparseExpr expr+ return $ "(" <> expr' <> ")"++paren :: Expr -> Unparser Text+paren expr = do+ expr' <- unparseExpr expr+ return $ "(" <> expr' <> ")"++mightParen :: (Int -> Int -> Bool) -> Expr -> Expr -> Unparser Text+mightParen cmp parent child = do+ fullyParenthesizing <- asks fullyParenthesizing+ if (fullyParenthesizing && precedence child < precedence PropRef{}) ||+ (precedence parent `cmp` precedence child)+ then paren child+ else unparseExpr child++parenL :: Expr -> Expr -> Unparser Text+parenL = mightParen (>)++parenR :: Expr -> Expr -> Unparser Text+parenR = mightParen (>=)++isIdentifier :: StrT -> Bool+isIdentifier name = isIdentifier' (T.unpack name) && not (isKeyword name)+ where isIdentifier' (c:cs) = isIdentStart c && all isIdentChar cs+ isIdentStart c = isAlpha c || c == '_'+ isIdentChar c = isAlphaNum c || c == '_'++isKeyword :: StrT -> Bool+isKeyword = (`S.member` keywordsSet) . T.toCaseFold++keywordsSet :: Set StrT+keywordsSet = S.fromList $ map (T.toCaseFold . T.pack) keywords
+ src/MOO/Verb.hs view
@@ -0,0 +1,163 @@++{-# LANGUAGE OverloadedStrings #-}++module MOO.Verb ( Verb(..)+ , ObjSpec(..)+ , PrepSpec(..)+ , initVerb+ , obj2text+ , text2obj+ , objMatch+ , prep2text+ , text2prep+ , prepMatch+ , prepPhrases+ , verbNameMatch+ ) where++import Data.Text (Text)++import MOO.Types+import MOO.AST+import {-# SOURCE #-} MOO.Task++import qualified Data.Text as T++data Verb = Verb {+ verbNames :: StrT+ , verbProgram :: Program+ , verbCode :: MOO Value++ , verbOwner :: ObjId+ , verbPermR :: Bool+ , verbPermW :: Bool+ , verbPermX :: Bool+ , verbPermD :: Bool++ , verbDirectObject :: ObjSpec+ , verbPreposition :: PrepSpec+ , verbIndirectObject :: ObjSpec+}++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) ++ storageBytes (verbPermX verb) ++ storageBytes (verbPermD verb) ++ storageBytes (verbDirectObject verb) ++ storageBytes (verbPreposition verb) ++ storageBytes (verbIndirectObject verb)++initVerb = Verb {+ verbNames = ""+ , verbProgram = Program []+ , verbCode = return nothing++ , verbOwner = -1+ , verbPermR = False+ , verbPermW = False+ , verbPermX = False+ , verbPermD = False++ , verbDirectObject = ObjNone+ , verbPreposition = PrepNone+ , verbIndirectObject = ObjNone+}++data ObjSpec = ObjNone+ | ObjAny+ | ObjThis+ deriving (Enum, Bounded, Show)++instance Sizeable ObjSpec where+ storageBytes _ = storageBytes ()++obj2text :: ObjSpec -> Text+obj2text ObjNone = "none"+obj2text ObjAny = "any"+obj2text ObjThis = "this"++text2obj :: Text -> Maybe ObjSpec+text2obj = flip lookup $ map mkAssoc [minBound ..]+ where mkAssoc objSpec = (obj2text objSpec, objSpec)++objMatch :: ObjId -> ObjSpec -> ObjId -> Bool+objMatch _ ObjNone (-1) = True+objMatch _ ObjNone _ = False+objMatch _ ObjAny _ = True+objMatch this ObjThis oid = oid == this++data PrepSpec = PrepAny+ | PrepNone+ | PrepWithUsing+ | PrepAtTo+ | PrepInfrontof+ | PrepInInsideInto+ | PrepOntopofOnOntoUpon+ | PrepOutofFrominsideFrom+ | PrepOver+ | PrepThrough+ | PrepUnderUnderneathBeneath+ | PrepBehind+ | PrepBeside+ | PrepForAbout+ | PrepIs+ | PrepAs+ | PrepOffOffof+ deriving (Enum, Bounded, Eq, Show)++instance Sizeable PrepSpec where+ storageBytes _ = storageBytes ()++prep2text :: PrepSpec -> Text+prep2text PrepAny = "any"+prep2text PrepNone = "none"+prep2text PrepWithUsing = "with/using"+prep2text PrepAtTo = "at/to"+prep2text PrepInfrontof = "in front of"+prep2text PrepInInsideInto = "in/inside/into"+prep2text PrepOntopofOnOntoUpon = "on top of/on/onto/upon"+prep2text PrepOutofFrominsideFrom = "out of/from inside/from"+prep2text PrepOver = "over"+prep2text PrepThrough = "through"+prep2text PrepUnderUnderneathBeneath = "under/underneath/beneath"+prep2text PrepBehind = "behind"+prep2text PrepBeside = "beside"+prep2text PrepForAbout = "for/about"+prep2text PrepIs = "is"+prep2text PrepAs = "as"+prep2text PrepOffOffof = "off/off of"++text2prep :: Text -> Maybe PrepSpec+text2prep = flip lookup $ concatMap mkAssoc [minBound ..]+ where mkAssoc prepSpec =+ [ (prep, prepSpec) | prep <- T.splitOn "/" $ prep2text prepSpec ] +++ [ (T.pack $ show index, prepSpec)+ | let index = fromEnum prepSpec - fromEnum (succ PrepNone)+ , index >= 0+ ]++prepMatch :: PrepSpec -> PrepSpec -> Bool+prepMatch PrepAny _ = True+prepMatch vp cp = vp == cp++prepPhrases :: [(PrepSpec, [Text])]+prepPhrases = [ (prepSpec, T.words prepPhrase)+ | prepSpec <- [succ PrepNone ..]+ , prepPhrase <- T.splitOn "/" $ prep2text prepSpec+ ]++verbNameMatch :: StrT -> [StrT] -> Bool+verbNameMatch name = any matchName+ where matchName vname+ | post == "" = name == vname+ | post == "*" = preName == pre+ | otherwise = preName == pre &&+ postName == T.take (T.length postName) (T.tail post)+ where (pre, post) = T.breakOn "*" vname+ (preName, postName) = T.splitAt (T.length pre) name
+ src/MOO/Verb.hs-boot view
@@ -0,0 +1,5 @@+-- -*- Haskell -*-++module MOO.Verb ( Verb ) where++data Verb
+ src/MOO/Version.hs view
@@ -0,0 +1,18 @@++module MOO.Version ( serverVersion+ , serverVersionText+ ) where++import Data.Text+import Data.Version++import Paths_EtaMOO++-- | The current version of the server code, as a 'Version' value+serverVersion :: Version+serverVersion = version++-- | The current version of the server code, as a displayable 'Text' value+-- (for use by the @server_version()@ built-in function)+serverVersionText :: Text+serverVersionText = pack (showVersion serverVersion)
+ src/etamoo.hs view
@@ -0,0 +1,168 @@++{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Text+import Network (withSocketsDo)+import System.Console.Haskeline+import System.Environment+import System.Posix (installHandler, sigPIPE, Handler(..))++import MOO.Parser+import MOO.Compiler+import MOO.Task+import MOO.Types+import MOO.Builtins+import MOO.Database+import MOO.Database.LambdaMOO+import MOO.Object+import MOO.Command++import qualified Data.Map as M++main :: IO ()+main = withSocketsDo $ do+ installHandler sigPIPE Ignore Nothing++ case verifyBuiltins of+ Left err -> putStrLn $ "Built-in function verification failed: " ++ err+ Right n -> do+ putStrLn $ show n ++ " built-in functions verified"+ db <- replDatabase+ worldTVar <- newTVarIO initWorld { database = db }+ testFrame <- atomically $ mkTestFrame db+ state <- newState++ runInputT (setComplete noCompletion defaultSettings) $+ repLoop worldTVar $ addFrame testFrame state++replDatabase :: IO Database+replDatabase = do+ args <- getArgs+ case args of+ [dbFile] -> loadLMDatabase dbFile >>= either (error . show) return+ [] -> return initDatabase++repLoop :: TVar World -> TaskState -> InputT IO ()+repLoop world state = do+ maybeLine <- getInputLine ">> "+ case maybeLine of+ Nothing -> return ()+ Just "" -> repLoop world state+ Just line -> repLoop world =<< liftIO (run world line state)++addFrame :: StackFrame -> TaskState -> TaskState+addFrame frame state@State { stack = Stack frames } =+ state { stack = Stack (frame : frames) }++mkTestFrame :: Database -> STM StackFrame+mkTestFrame db = do+ wizards <- filterM isWizard $ allPlayers db+ let player = fromMaybe (-1) $ listToMaybe wizards+ return initFrame {+ variables = mkVariables [("player", Obj player)]+ , permissions = player+ , verbFullName = "REPL"+ , initialPlayer = player+ }+ where isWizard oid = maybe False objectWizard `liftM` dbObject oid db++alterFrame :: TaskState -> (StackFrame -> StackFrame) -> TaskState+alterFrame state@State { stack = Stack (frame:stack) } f =+ state { stack = Stack (f frame : stack) }++run :: TVar World -> String -> TaskState -> IO TaskState+run _ ":+d" state = return $ alterFrame state $+ \frame -> frame { debugBit = True }+run _ ":-d" state = return $ alterFrame state $+ \frame -> frame { debugBit = False }++run _ (':':'p':'e':'r':'m':' ':perm) state =+ return $ alterFrame state $ \frame -> frame { permissions = read perm }++run _ ":stack" state = print (stack state) >> return state++run world' ":tasks" state = do+ world <- readTVarIO world'+ print (M.elems $ tasks world)+ return state++run world (';':';':line) state = evalP world line state+run world (';' :line) state = evalE world line state+run world line state = evalC world line state++evalC :: TVar World -> String -> TaskState -> IO TaskState+evalC world line state@State { stack = Stack (frame:_) } = do+ let player = initialPlayer frame+ command = parseCommand (pack line)+ runTask =<< newTask world player (runCommand command)+ return state++evalE :: TVar World -> String -> TaskState -> IO TaskState+evalE world line state@State { stack = Stack (frame:_) } =+ case runParser (between whiteSpace eof expression)+ initParserState "" (pack line) of+ Left err -> putStr "Parse error " >> print err >> return state+ Right expr -> eval state =<<+ newTask world (initialPlayer frame) (evaluate expr)++evalP :: TVar World -> String -> TaskState -> IO TaskState+evalP world line state@State { stack = Stack (frame:_) } =+ case runParser program initParserState "" (pack line) of+ Left err -> putStr "Parse error" >> print err >> return state+ Right program -> eval state =<<+ newTask world (initialPlayer frame) (compile program)++eval :: TaskState -> Task -> IO TaskState+eval state task = do+ state' <- taskState `liftM`+ evalPrint task { taskState = state {+ ticksLeft = ticksLeft (taskState task)+ , startTime = startTime (taskState task)+ } }++ atomically $ modifyTVar (taskWorld task) $ \world ->+ world { tasks = M.delete (taskId task) $ tasks world }++ return state'++evalPrint :: Task -> IO Task+evalPrint task = do+ (result, task') <- stepTask task+ case result of+ Complete value -> do+ putStrLn $ "=> " ++ unpack (toLiteral value)+ return task'+ Suspend Nothing _ -> do+ putStrLn ".. Suspended indefinitely"+ return task'+ Suspend (Just usecs) (Resume resume) -> do+ let secs = (fromIntegral usecs :: Double) / 1000000+ putStrLn $ ".. Suspended for " ++ show secs ++ " seconds"+ evalPrint task' { taskComputation = resume () }+ RequestIO io (Resume k) -> do+ result <- io+ evalPrint task' { taskComputation = k result }+ Uncaught exception@(Exception _ m v) callStack -> do+ notifyLines $ formatTraceback exception callStack+ putStrLn $ "** " ++ unpack m ++ formatValue v+ return task'+ Timeout resource callStack -> do+ let exception@(Exception _ message _) = timeoutException resource+ notifyLines $ formatTraceback exception callStack+ putStrLn $ "!! " ++ unpack message+ return task'+ Suicide -> do+ putStrLn "-- Task killed itself"+ return task'++ where formatValue (Int 0) = ""+ formatValue v = " [" ++ unpack (toLiteral v) ++ "]"++ notifyLines :: [Text] -> IO ()+ notifyLines = mapM_ (putStrLn . unpack)