diff --git a/EtaMOO.cabal b/EtaMOO.cabal new file mode 100644 --- /dev/null +++ b/EtaMOO.cabal @@ -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 +maintainer: Rob Leslie + +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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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: diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -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 diff --git a/src/MOO/AST.hs b/src/MOO/AST.hs new file mode 100644 --- /dev/null +++ b/src/MOO/AST.hs @@ -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 diff --git a/src/MOO/Builtins.hs b/src/MOO/Builtins.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins.hs @@ -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" diff --git a/src/MOO/Builtins.hs-boot b/src/MOO/Builtins.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins.hs-boot @@ -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 diff --git a/src/MOO/Builtins/Common.hs b/src/MOO/Builtins/Common.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Common.hs @@ -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) diff --git a/src/MOO/Builtins/Match.hsc b/src/MOO/Builtins/Match.hsc new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Match.hsc @@ -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 + +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 diff --git a/src/MOO/Builtins/Network.hs b/src/MOO/Builtins/Network.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Network.hs @@ -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) diff --git a/src/MOO/Builtins/Objects.hs b/src/MOO/Builtins/Objects.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Objects.hs @@ -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 diff --git a/src/MOO/Builtins/Tasks.hs b/src/MOO/Builtins/Tasks.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Tasks.hs @@ -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 diff --git a/src/MOO/Builtins/Values.hs b/src/MOO/Builtins/Values.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Values.hs @@ -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) diff --git a/src/MOO/Command.hs b/src/MOO/Command.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Command.hs @@ -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) diff --git a/src/MOO/Command.hs-boot b/src/MOO/Command.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Command.hs-boot @@ -0,0 +1,5 @@ +-- -*- Haskell -*- + +module MOO.Command ( Command ) where + +data Command diff --git a/src/MOO/Compiler.hs b/src/MOO/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Compiler.hs @@ -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 diff --git a/src/MOO/Compiler.hs-boot b/src/MOO/Compiler.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Compiler.hs-boot @@ -0,0 +1,9 @@ +-- -*- Haskell -*- + +module MOO.Compiler ( compile ) where + +import MOO.AST +import MOO.Task +import MOO.Types + +compile :: Program -> MOO Value diff --git a/src/MOO/Database.hs b/src/MOO/Database.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Database.hs @@ -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 } diff --git a/src/MOO/Database.hs-boot b/src/MOO/Database.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Database.hs-boot @@ -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 () diff --git a/src/MOO/Database/LambdaMOO.hs b/src/MOO/Database/LambdaMOO.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Database/LambdaMOO.hs @@ -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 diff --git a/src/MOO/Network.hs b/src/MOO/Network.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Network.hs @@ -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 diff --git a/src/MOO/Network.hs-boot b/src/MOO/Network.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Network.hs-boot @@ -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 () diff --git a/src/MOO/Object.hs b/src/MOO/Object.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Object.hs @@ -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 _ = "" + +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 diff --git a/src/MOO/Object.hs-boot b/src/MOO/Object.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Object.hs-boot @@ -0,0 +1,5 @@ +-- -*- Haskell -*- + +module MOO.Object ( Object ) where + +data Object diff --git a/src/MOO/Parser.hs b/src/MOO/Parser.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Parser.hs @@ -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 diff --git a/src/MOO/Task.hs b/src/MOO/Task.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Task.hs @@ -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 = "" + +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 _ = "" + +-- | 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 } = "" + show Loop { loopName = Just name } = "" + + show TryFinally{} = "" + +-- | The data tracked for each verb and/or built-in function call +data StackFrame = Frame { + depthLeft :: Int + + , contextStack :: [Context] + , variables :: Map Id Value + , 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 _ = "" + +-- | 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 <> "()" diff --git a/src/MOO/Task.hs-boot b/src/MOO/Task.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Task.hs-boot @@ -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 diff --git a/src/MOO/Types.hs b/src/MOO/Types.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Types.hs @@ -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) diff --git a/src/MOO/Unparser.hs b/src/MOO/Unparser.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Unparser.hs @@ -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 diff --git a/src/MOO/Verb.hs b/src/MOO/Verb.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Verb.hs @@ -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 diff --git a/src/MOO/Verb.hs-boot b/src/MOO/Verb.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Verb.hs-boot @@ -0,0 +1,5 @@ +-- -*- Haskell -*- + +module MOO.Verb ( Verb ) where + +data Verb diff --git a/src/MOO/Version.hs b/src/MOO/Version.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Version.hs @@ -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) diff --git a/src/etamoo.hs b/src/etamoo.hs new file mode 100644 --- /dev/null +++ b/src/etamoo.hs @@ -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)