diff --git a/EtaMOO.cabal b/EtaMOO.cabal --- a/EtaMOO.cabal +++ b/EtaMOO.cabal @@ -1,6 +1,6 @@ name: EtaMOO -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A new implementation of the LambdaMOO server @@ -16,13 +16,13 @@ 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, + /N.B./ This is (currently) incomplete software. It is not yet fully usable, although with further development it is hoped that it soon will be. license: BSD3 license-file: LICENSE -copyright: © 2014 Rob Leslie +copyright: © 2014–2015 Robert Leslie author: Rob Leslie maintainer: Rob Leslie @@ -31,11 +31,14 @@ build-type: Simple cabal-version: >=1.8 +tested-with: GHC == 7.6.3 -homepage: https://github.com/verement/etamoo +homepage: http://verement.github.io/etamoo bug-reports: https://github.com/verement/etamoo/issues -extra-source-files: README.md configure Makefile +extra-source-files: README.md + src/cbits/crypt.h + src/cbits/match.h source-repository head type: git @@ -49,6 +52,14 @@ description: Use GHC's LLVM backend to compile the code default: False +flag 64bit + description: Enable 64-bit MOO integers + default: False + +flag outbound-network + description: Enable open_network_connection() by default + default: False + executable etamoo hs-source-dirs: src main-is: etamoo.hs @@ -56,6 +67,7 @@ other-modules: MOO.AST MOO.Builtins MOO.Builtins.Common + MOO.Builtins.Crypt MOO.Builtins.Match MOO.Builtins.Network MOO.Builtins.Objects @@ -63,11 +75,16 @@ MOO.Builtins.Values MOO.Command MOO.Compiler + MOO.Connection MOO.Database MOO.Database.LambdaMOO MOO.Network + MOO.Network.Console + MOO.Network.TCP MOO.Object MOO.Parser + MOO.Server + MOO.String MOO.Task MOO.Types MOO.Unparser @@ -79,27 +96,48 @@ if flag(llvm) ghc-options: -fllvm - extensions: OverloadedStrings, ForeignFunctionInterface, - EmptyDataDecls, ExistentialQuantification + extensions: CPP + EmptyDataDecls + ExistentialQuantification + FlexibleInstances + ForeignFunctionInterface + OverloadedStrings + TypeSynonymInstances + extra-libraries: pcre if !os(darwin) extra-libraries: crypt - extra-libraries: pcre + if flag(64bit) + cpp-options: -DMOO_64BIT_INTEGER + + if flag(outbound-network) + cpp-options: -DMOO_OUTBOUND_NETWORK + includes: unistd.h pcre.h + c-sources: src/cbits/crypt.c + src/cbits/match.c + build-depends: array , base ==4.* , bytestring + , case-insensitive , containers >= 0.4 + , hashable , haskeline , mtl , network , old-locale , parsec + , pipes + , pipes-bytestring + , pipes-concurrency + , pipes-network , random , stm - , text + , stm-chans + , text >= 1.2 , time , unix , unordered-containers diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Rob Leslie +Copyright (c) 2014-2015, Robert Leslie All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Rob Leslie nor the names of other + * Neither the name of Robert Leslie nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -1,56 +0,0 @@ - -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 --- a/README.md +++ b/README.md @@ -3,22 +3,16 @@ ========== **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._ +fully usable, although with further development it is hoped that it soon will +be.** -_Once the code is in at least a minimally useful state, this message will be -updated or removed._ +_At present, the code will load a database and listen for network +connections. You can connect using any `telnet` client and interact with the +MOO environment, however no changes to the database will be saved, and a few +other features have also yet to be implemented._ -EtaMOO -====== +About +===== EtaMOO is a new implementation of the LambdaMOO server written in Haskell. @@ -37,13 +31,10 @@ 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. + * EtaMOO supports 64-bit MOO integers via compile-time build option. - * It is anticipated that EtaMOO will easily support 64-bit MOO integers - and/or Unicode MOO strings via independent build options. + * EtaMOO is Unicode-aware, and will eventually include support for Unicode + MOO strings via compile-time build option. * EtaMOO supports IPv6. @@ -77,4 +68,12 @@ _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. + +Hacking +------- + +[Documentation][] is available for the various types, data structures, and +functions used internally by EtaMOO. + + [Documentation]: http://verement.github.io/etamoo/doc/ diff --git a/configure b/configure deleted file mode 100644 --- a/configure +++ /dev/null @@ -1,17 +0,0 @@ -#! /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 --- a/src/MOO/AST.hs +++ b/src/MOO/AST.hs @@ -13,8 +13,8 @@ , Expr(..) , Codes(..) , Default(..) - , Arg(..) - , ScatItem(..) + , Argument(..) + , ScatterItem(..) -- * Utility Functions , isLValue @@ -87,16 +87,16 @@ storageBytes codes + storageBytes body data Expr = Literal Value - | List [Arg] + | List [Argument] | Variable Id - | PropRef Expr Expr + | PropertyRef Expr Expr | Assign Expr Expr - | ScatterAssign [ScatItem] Expr + | Scatter [ScatterItem] Expr - | VerbCall Expr Expr [Arg] - | BuiltinFunc Id [Arg] + | VerbCall Expr Expr [Argument] + | BuiltinFunc Id [Argument] | Expr `Index` Expr | Expr `Range` (Expr, Expr) @@ -117,12 +117,12 @@ | Expr `Or` Expr | Not Expr - | Expr `Equal` Expr - | Expr `NotEqual` Expr - | Expr `LessThan` Expr - | Expr `LessEqual` Expr - | Expr `GreaterThan` Expr - | Expr `GreaterEqual` Expr + | Expr `CompareEQ` Expr + | Expr `CompareNE` Expr + | Expr `CompareLT` Expr + | Expr `CompareLE` Expr + | Expr `CompareGT` Expr + | Expr `CompareGE` Expr | Catch Expr Codes Default @@ -132,11 +132,11 @@ storageBytes (Literal value) = storageBytes () + storageBytes value storageBytes (List args) = storageBytes () + storageBytes args storageBytes (Variable var) = storageBytes () + storageBytes var - storageBytes (PropRef obj name) = + storageBytes (PropertyRef obj name) = storageBytes () + storageBytes obj + storageBytes name storageBytes (Assign lhs rhs) = storageBytes () + storageBytes lhs + storageBytes rhs - storageBytes (ScatterAssign scats expr) = + storageBytes (Scatter scats expr) = storageBytes () + storageBytes scats + storageBytes expr storageBytes (VerbCall obj name args) = storageBytes () + storageBytes obj + storageBytes name + storageBytes args @@ -158,41 +158,42 @@ 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 (CompareEQ x y) = storageBytes () + storageBytes x + storageBytes y - storageBytes (LessThan x y) = + storageBytes (CompareNE x y) = storageBytes () + storageBytes x + storageBytes y - storageBytes (LessEqual x y) = + storageBytes (CompareLT x y) = storageBytes () + storageBytes x + storageBytes y - storageBytes (GreaterThan x y) = + storageBytes (CompareLE x y) = storageBytes () + storageBytes x + storageBytes y - storageBytes (GreaterEqual x y) = + storageBytes (CompareGT x y) = storageBytes () + storageBytes x + storageBytes y + storageBytes (CompareGE 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 +data Codes = ANY | Codes [Argument] 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 +data Argument = ArgNormal Expr + | ArgSplice Expr + deriving Show -instance Sizeable Arg where +instance Sizeable Argument 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 +data ScatterItem = ScatRequired Id + | ScatOptional Id (Maybe Expr) + | ScatRest Id + deriving Show -instance Sizeable ScatItem where +instance Sizeable ScatterItem where storageBytes (ScatRequired var) = storageBytes () + storageBytes var storageBytes (ScatOptional var expr) = storageBytes () + storageBytes var + storageBytes expr @@ -204,47 +205,47 @@ isLValue e = isLValue' e isLValue' :: Expr -> Bool -isLValue' Variable{} = True -isLValue' PropRef{} = True -isLValue' (Index e _) = isLValue' e -isLValue' _ = False +isLValue' Variable{} = True +isLValue' PropertyRef{} = 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 + Assign{} -> 1 + Scatter{} -> 1 - Conditional{} -> 2 + Conditional{} -> 2 - And{} -> 3 - Or{} -> 3 + And{} -> 3 + Or{} -> 3 - Equal{} -> 4 - NotEqual{} -> 4 - LessThan{} -> 4 - LessEqual{} -> 4 - GreaterThan{} -> 4 - GreaterEqual{} -> 4 - In{} -> 4 + CompareEQ{} -> 4 + CompareNE{} -> 4 + CompareLT{} -> 4 + CompareLE{} -> 4 + CompareGT{} -> 4 + CompareGE{} -> 4 + In{} -> 4 - Plus{} -> 5 - Minus{} -> 5 + Plus{} -> 5 + Minus{} -> 5 - Times{} -> 6 - Divide{} -> 6 - Remain{} -> 6 + Times{} -> 6 + Divide{} -> 6 + Remain{} -> 6 - Power{} -> 7 + Power{} -> 7 - Not{} -> 8 - Negate{} -> 8 + Not{} -> 8 + Negate{} -> 8 - PropRef{} -> 9 - VerbCall{} -> 9 - Index{} -> 9 - Range{} -> 9 + PropertyRef{} -> 9 + VerbCall{} -> 9 + Index{} -> 9 + Range{} -> 9 - _ -> 10 + _ -> 10 diff --git a/src/MOO/Builtins.hs b/src/MOO/Builtins.hs --- a/src/MOO/Builtins.hs +++ b/src/MOO/Builtins.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module MOO.Builtins ( builtinFunctions, callBuiltin, verifyBuiltins ) where -import Control.Monad (when, foldM, liftM, join) +import Control.Monad (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) +# ifdef __GLASGOW_HASKELL__ +import GHC.Stats (GCStats(..), getGCStats, getGCStatsEnabled) +# endif + 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 @@ -29,33 +30,42 @@ import MOO.Builtins.Network as Network import MOO.Builtins.Tasks as Tasks +import qualified MOO.String as Str + {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} -- | A 'Map' of all built-in functions, keyed by name -builtinFunctions :: Map Id (Builtin, Info) +builtinFunctions :: Map Id Builtin builtinFunctions = - M.fromList $ miscBuiltins ++ + M.fromList $ map assoc $ miscBuiltins ++ Values.builtins ++ Objects.builtins ++ Network.builtins ++ Tasks.builtins + where assoc builtin = (builtinName builtin, builtin) -- | 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) + Just builtin -> checkArgs builtin args >> builtinFunction builtin args + Nothing -> raiseException (Err E_INVARG) + "Unknown built-in function" (Str $ fromId func) - where checkArgs (Info min max types _) args = do + where checkArgs :: Builtin -> [Value] -> MOO () + checkArgs Builtin { builtinMinArgs = min + , builtinMaxArgs = max + , builtinArgTypes = types + } args = let nargs = length args - in when (nargs < min || nargs > fromMaybe nargs max) $ raise E_ARGS - checkTypes types args + in if nargs < min || nargs > fromMaybe nargs max then raise E_ARGS + else checkTypes types args - checkTypes (t:ts) (a:as) = do - when (typeMismatch t $ typeOf a) $ raise E_TYPE - checkTypes ts as + checkTypes :: [Type] -> [Value] -> MOO () + checkTypes (t:ts) (a:as) = + if typeMismatch t (typeOf a) then raise E_TYPE + else checkTypes ts as checkTypes _ _ = return () + typeMismatch :: Type -> Type -> Bool typeMismatch x y | x == y = False typeMismatch TAny _ = False typeMismatch TNum TInt = False @@ -70,17 +80,23 @@ -- 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 +verifyBuiltins = foldM accum 0 $ M.elems 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" + valid Builtin { builtinName = name + , builtinMinArgs = min + , builtinMaxArgs = max + , builtinArgTypes = types + , builtinFunction = func + } | 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 + where invalid msg = Left $ "problem with built-in function " ++ + fromId name ++ ": " ++ msg ok = Right 1 + testArgs :: ([Value] -> MOO Value) -> Int -> Maybe Int -> [Type] -> Bool testArgs func min max types = all test argSpecs where argSpecs = drop min $ inits $ map mkArgs augmentedTypes augmentedTypes = maybe (types ++ [TAny]) (const types) max @@ -99,45 +115,41 @@ mkArgs TNum = mkArgs TInt ++ mkArgs TFlt mkArgs TInt = [Int 0] mkArgs TFlt = [Flt 0] - mkArgs TStr = [Str T.empty] + mkArgs TStr = [emptyString] mkArgs TObj = [Obj 0] mkArgs TErr = [Err E_NONE] - mkArgs TLst = [Lst V.empty] + mkArgs TLst = [emptyList] --- 4.4 Built-in Functions +-- § 4.4 Built-in Functions -miscBuiltins :: [BuiltinSpec] +miscBuiltins :: [Builtin] miscBuiltins = [ - -- 4.4.1 Object-Oriented Programming - ("pass" , (bf_pass , Info 0 Nothing [] TAny)) + -- § 4.4.1 Object-Oriented Programming + bf_pass - -- 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.5 Operations Involving Times and Dates + , bf_time + , bf_ctime - -- 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.7 Administrative Operations + , bf_dump_database + , bf_shutdown + , bf_load_server_options + , bf_server_log + , bf_renumber + , bf_reset_max_object - -- 4.4.8 Server Statistics and Miscellaneous Information - , ("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.8 Server Statistics and Miscellaneous Information + , bf_server_version + , bf_memory_usage + , bf_db_disk_size + , bf_verb_cache_stats + , bf_log_cache_stats ] --- 4.4.1 Object-Oriented Programming +-- § 4.4.1 Object-Oriented Programming -bf_pass args = do +bf_pass = Builtin "pass" 0 Nothing [] TAny $ \args -> do (name, verbLoc, this) <- frame $ \frame -> (verbName frame, verbLocation frame, initialThis frame) maybeMaybeParent <- fmap objectParent `liftM` getObject verbLoc @@ -145,49 +157,99 @@ Just parent -> callVerb parent this name args Nothing -> raise E_VERBNF --- 4.4.5 Operations Involving Times and Dates +-- § 4.4.5 Operations Involving Times and Dates currentTime :: MOO IntT currentTime = (floor . utcTimeToPOSIXSeconds) `liftM` gets startTime -bf_time [] = Int `liftM` currentTime +bf_time = Builtin "time" 0 (Just 0) [] TInt $ \[] -> Int `liftM` currentTime -bf_ctime [] = ctime =<< currentTime -bf_ctime [Int time] = ctime time +bf_ctime = Builtin "ctime" 0 (Just 1) [TInt] TStr $ \arg -> case arg of + [] -> ctime =<< currentTime + [Int time] -> ctime time ctime :: IntT -> MOO Value -ctime time = - return $ Str $ T.pack $ formatTime defaultTimeLocale format zonedTime - where format = "%a %b %_d %T %Y %Z" - zonedTime = unsafePerformIO $ utcToLocalZonedTime utcTime - utcTime = posixSecondsToUTCTime (fromIntegral time) +ctime time = do + zonedTime <- unsafeIOtoMOO (utcToLocalZonedTime utcTime) + return $ Str $ Str.fromString $ formatTime defaultTimeLocale format zonedTime + where utcTime = posixSecondsToUTCTime (fromIntegral time) + format = "%a %b %_d %T %Y %Z" --- 4.4.7 Administrative Operations +-- § 4.4.7 Administrative Operations -bf_dump_database [] = notyet "dump_database" +bf_dump_database = Builtin "dump_database" 0 (Just 0) [] TAny $ \[] -> + notyet "dump_database" -bf_shutdown optional = notyet "shutdown" - where (message : _) = maybeDefaults optional +bf_shutdown = Builtin "shutdown" 0 (Just 1) [TStr] TAny $ \optional -> do + let (message : _) = maybeDefaults optional -bf_load_server_options [] = checkWizard >> loadServerOptions >> return nothing + checkWizard -bf_server_log (Str message : optional) = notyet "server_log" - where [is_error] = booleanDefaults optional [False] + name <- getObjectName =<< frame permissions + let msg = "shutdown() called by " `Str.append` name -bf_renumber [Obj object] = notyet "renumber" + shutdown $ maybe msg (\(Str reason) -> Str.concat [msg, ": ", reason]) message + return zero -bf_reset_max_object [] = do +bf_load_server_options = Builtin "load_server_options" 0 (Just 0) + [] TAny $ \[] -> + checkWizard >> loadServerOptions >> return zero + +bf_server_log = Builtin "server_log" 1 (Just 2) + [TStr, TAny] TAny $ \(Str message : optional) -> + let [is_error] = booleanDefaults optional [False] + in notyet "server_log" + +bf_renumber = Builtin "renumber" 1 (Just 1) [TObj] TObj $ \[Obj object] -> + notyet "renumber" + +bf_reset_max_object = Builtin "reset_max_object" 0 (Just 0) [] TAny $ \[] -> do checkWizard getDatabase >>= liftSTM . resetMaxObject >>= putDatabase - return nothing + return zero --- 4.4.8 Server Statistics and Miscellaneous Information +-- § 4.4.8 Server Statistics and Miscellaneous Information -bf_server_version [] = return (Str serverVersionText) +bf_server_version = Builtin "server_version" 0 (Just 0) [] TStr $ \[] -> + return (Str $ Str.fromText serverVersion) -bf_memory_usage [] = return $ Lst V.empty -- ... nothing to see here +bf_memory_usage = Builtin "memory_usage" 0 (Just 0) [] TLst $ \[] -> +# ifdef __GLASGOW_HASKELL__ + -- Server must be run with +RTS -T to enable statistics + do maybeStats <- requestIO $ do + enabled <- getGCStatsEnabled + if enabled then Just `liftM` getGCStats else return Nothing -bf_db_disk_size [] = raise E_QUOTA -- not yet? + return $ case maybeStats of + Just stats -> + let nused = currentBytesUsed stats + nfree = maxBytesUsed stats - nused + maxBlockSize = 2 ^ (floor $ logBase (2 :: Double) $ + fromIntegral $ max nused nfree :: Int) + in fromListBy (fromListBy $ Int . fromIntegral) $ + blocks maxBlockSize nused nfree + Nothing -> emptyList -bf_verb_cache_stats [] = notyet "verb_cache_stats" -bf_log_cache_stats [] = notyet "log_cache_stats" + where blocks :: (Integral a) => a -> a -> a -> [[a]] + blocks _ 0 0 = [] + blocks blockSize nused nfree = + let nusedBlocks = nused `div` blockSize + nfreeBlocks = nfree `div` blockSize + rest = blocks (blockSize `div` 2) + (nused - nusedBlocks * blockSize) + (nfree - nfreeBlocks * blockSize) + in case (nusedBlocks, nfreeBlocks) of + (0, 0) -> rest + _ -> [blockSize, nusedBlocks, nfreeBlocks] : rest +# else + return emptyList -- ... nothing to see here +# endif + +bf_db_disk_size = Builtin "db_disk_size" 0 (Just 0) [] TInt $ \[] -> + notyet "db_disk_size" + -- raise E_QUOTA + +bf_verb_cache_stats = Builtin "verb_cache_stats" 0 (Just 0) [] TLst $ \[] -> + notyet "verb_cache_stats" +bf_log_cache_stats = Builtin "log_cache_stats" 0 (Just 0) [] TAny $ \[] -> + notyet "log_cache_stats" diff --git a/src/MOO/Builtins.hs-boot b/src/MOO/Builtins.hs-boot --- a/src/MOO/Builtins.hs-boot +++ b/src/MOO/Builtins.hs-boot @@ -8,5 +8,5 @@ import MOO.Task import MOO.Builtins.Common -builtinFunctions :: Map Id (Builtin, Info) +builtinFunctions :: Map Id Builtin callBuiltin :: Id -> [Value] -> MOO Value diff --git a/src/MOO/Builtins/Common.hs b/src/MOO/Builtins/Common.hs --- a/src/MOO/Builtins/Common.hs +++ b/src/MOO/Builtins/Common.hs @@ -1,25 +1,21 @@ -module MOO.Builtins.Common ( BuiltinSpec, Builtin, Info(..) +module MOO.Builtins.Common ( Builtin(..) , 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 +-- | A complete description of a builtin function, including its name, the +-- number and types of required and optional arguments, the return type, and +-- the implementing Haskell function +data Builtin = Builtin { + builtinName :: Id + , builtinMinArgs :: Int + , builtinMaxArgs :: Maybe Int + , builtinArgTypes :: [Type] + , builtinReturnType :: Type + , builtinFunction :: [Value] -> MOO Value + } defaultOptions :: (Value -> a) -> [Value] -> [a] -> [a] defaultOptions f = defaultOptions' diff --git a/src/MOO/Builtins/Crypt.hs b/src/MOO/Builtins/Crypt.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Builtins/Crypt.hs @@ -0,0 +1,33 @@ + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# CFILES src/cbits/crypt.c #-} + +module MOO.Builtins.Crypt (crypt) where + +import Control.Monad (liftM) +import Foreign (allocaBytes) +import Foreign.C (CString, CInt(..), withCString, peekCString) +import System.IO.Unsafe (unsafePerformIO) + +-- This must be /unsafe/ to block other threads while it executes, since it +-- relies on a non-reentrant C function. +foreign import ccall unsafe "static crypt.h" + crypt_helper :: CString -> CString -> CString -> CInt -> IO CInt + +-- | Encrypt a password using the POSIX @crypt()@ function. +crypt :: String -- ^ key + -> String -- ^ salt + -> Maybe String -- ^ encrypted password (or 'Nothing' on error) +crypt key salt = + unsafePerformIO $ + withCString key $ \c_key -> + withCString salt $ \c_salt -> crypt' c_key c_salt 16 + +crypt' :: CString -> CString -> CInt -> IO (Maybe String) +crypt' key salt len = + allocaBytes (fromIntegral len) $ \encrypted -> do + result <- crypt_helper key salt encrypted len + case result of + 0 -> Just `liftM` peekCString encrypted + -1 -> return Nothing + req -> crypt' key salt req diff --git a/src/MOO/Builtins/Match.hsc b/src/MOO/Builtins/Match.hsc --- a/src/MOO/Builtins/Match.hsc +++ b/src/MOO/Builtins/Match.hsc @@ -1,5 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{-# CFILES src/cbits/match.c #-} -- | Regular expression matching via PCRE through the FFI module MOO.Builtins.Match ( @@ -14,15 +15,14 @@ , rmatch ) where -import Foreign hiding (unsafePerformIO) -import Foreign.C -import Control.Monad -import Control.Exception -import Control.Concurrent.MVar +import Foreign (Ptr, FunPtr, ForeignPtr, alloca, allocaArray, nullPtr, + peek, peekArray, peekByteOff, pokeByteOff, + newForeignPtr, mallocForeignPtrBytes, withForeignPtr, (.|.)) +import Foreign.C (CString, CInt(..), CULong, peekCString) +import Control.Monad (liftM) import Data.Text (Text) -import Data.Text.Encoding +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.ByteString (ByteString, useAsCString, useAsCStringLen) -import Data.IORef import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text as T @@ -34,11 +34,8 @@ 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) @@ -49,18 +46,20 @@ 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) +-- This must be /unsafe/ to block other threads while it executes, since it +-- relies on being able to modify and use some PCRE global state. +foreign import ccall unsafe "static match.h" + match_helper :: Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> + CInt -> Ptr CInt -> IO CInt -foreign import ccall "wrapper" - mkCallout :: Callout -> IO (FunPtr Callout) +-- This must be /unsafe/ to block other threads while it executes, since it +-- relies on being able to modify and use some PCRE global state. +foreign import ccall unsafe "static match.h" + rmatch_helper :: Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> + CInt -> Ptr CInt -> IO CInt data Regexp = Regexp { pattern :: Text @@ -68,8 +67,7 @@ , code :: ForeignPtr PCRE , extra :: ForeignPtr PCREExtra - } - deriving Show + } deriving Show instance Eq Regexp where Regexp { pattern = p1, caseMatters = cm1 } == @@ -148,60 +146,68 @@ 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) +-- | Compile a regular expression pattern into a 'Regexp' value, or return an +-- error description if the pattern is malformed. The returned 'Int' is a byte +-- offset into an internally translated pattern, and thus is probably not very +-- useful. +newRegexp :: Text -- ^ pattern + -> Bool -- ^ case matters? + -> Either (String, Int) 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 + unsafePerformIO $ + useAsCString string $ \pattern -> + alloca $ \errorPtr -> + alloca $ \errorOffsetPtr -> do - 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} + code <- pcre_compile pattern options errorPtr errorOffsetPtr nullPtr + if code == nullPtr + then do + error <- peek errorPtr >>= peekCString + errorOffset <- peek errorOffsetPtr + return $ Left (patchError error, fromIntegral 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 string = encodeUtf8 (translate regexp) - matchLimit = 100000 :: CULong - matchLimitRecursion = 5000 :: CULong + 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 - patchError = concatMap patch - where patch '\\' = "%" - patch '(' = "%(" - patch ')' = "%)" - patch c = [c] + 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} - 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} + 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 @@ -210,26 +216,23 @@ | 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 #-} +-- | Perform regular expression matching. +match :: Regexp -> Text -> MatchResult +match regexp text = unsafePerformIO $ doMatch match_helper regexp text -match :: Regexp -> Text -> IO MatchResult -match Regexp { code = codeFP, extra = extraFP } text = - bracket (takeMVar matchLock) (putMVar matchLock) $ \_ -> +-- | Perform regular expression matching, returning the rightmost match. +rmatch :: Regexp -> Text -> MatchResult +rmatch regexp text = unsafePerformIO $ doMatch rmatch_helper regexp text + +doMatch :: (Ptr PCRE -> Ptr PCREExtra -> CString -> CInt -> + CInt -> Ptr CInt -> IO CInt) -> Regexp -> Text -> IO MatchResult +doMatch helper Regexp { code = codeFP, extra = extraFP } text = 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) + rc <- helper code extra cstring (fromIntegral len) options ovec if rc < 0 then case rc of #{const PCRE_ERROR_NOMATCH} -> return MatchFailed @@ -240,42 +243,6 @@ 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` @@ -290,41 +257,3 @@ -- 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 --- a/src/MOO/Builtins/Network.hs +++ b/src/MOO/Builtins/Network.hs @@ -3,122 +3,182 @@ module MOO.Builtins.Network ( builtins ) where -import Control.Monad (liftM) +import Control.Concurrent.STM (readTVar) +import Control.Monad (liftM, unless, (<=<)) import Control.Monad.State (gets) -import Data.Time +import Data.Time (UTCTime, diffUTCTime) -import MOO.Types -import MOO.Task -import MOO.Network -import MOO.Database (systemObject) +import qualified Data.Map as M + import MOO.Builtins.Common +import MOO.Network +import MOO.Connection +import MOO.Object (systemObject) +import MOO.Task +import MOO.Types -import qualified Data.Map as M -import qualified Data.Text as T +import qualified MOO.String as Str {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} -- | § 4.4.4 Operations on Network Connections -builtins :: [BuiltinSpec] +builtins :: [Builtin] 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 + , bf_connected_seconds + , bf_idle_seconds + , bf_notify + , bf_buffered_output_length + , bf_read + , bf_force_input + , bf_flush_input + , bf_output_delimiters + , bf_boot_player + , bf_connection_name + , bf_set_connection_option + , bf_connection_options + , bf_connection_option + , bf_open_network_connection + , bf_listen + , bf_unlisten + , bf_listeners ] -bf_connected_players optional = do - world <- getWorld - let objects = M.keys $ connections world +bf_connected_players = Builtin "connected_players" 0 (Just 1) + [TAny] TLst $ \optional -> do + let [include_all] = booleanDefaults optional [False] + + objects <- withConnections $ return . M.keys 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 +secondsSince :: UTCTime -> MOO Value +secondsSince utcTime = do + now <- gets startTime + return (Int $ floor $ now `diffUTCTime` utcTime) - where secondsSince :: UTCTime -> MOO Value - secondsSince utcTime = do - now <- gets startTime - return (Int $ floor $ now `diffUTCTime` utcTime) +bf_connected_seconds = Builtin "connected_seconds" 1 (Just 1) + [TObj] TInt $ \[Obj player] -> + withConnection player $ maybe (raise E_INVARG) secondsSince <=< + liftSTM . readTVar . connectionConnectedTime -bf_connected_seconds [Obj player] = - connectionSeconds player (connectionEstablishedTime =<<) +bf_idle_seconds = Builtin "idle_seconds" 1 (Just 1) + [TObj] TInt $ \[Obj player] -> + withConnection player $ secondsSince <=< + liftSTM . readTVar . connectionActivityTime -bf_idle_seconds [Obj player] = - connectionSeconds player (connectionActivityTime `fmap`) +bf_notify = Builtin "notify" 2 (Just 3) + [TObj, TStr, TAny] TAny $ \(Obj conn : Str string : optional) -> do + let [no_flush] = booleanDefaults optional [False] -bf_notify (Obj conn : Str string : optional) = do - notify conn string - return $ truthValue True - where [no_flush] = booleanDefaults optional [False] + checkPermission conn + truthValue `liftM` notify' no_flush conn string -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_buffered_output_length = Builtin "buffered_output_length" 0 (Just 1) + [TObj] TInt $ \optional -> do + let (conn : _) = maybeDefaults optional -bf_connection_name [Obj player] = do + len <- case conn of + Just (Obj oid) -> do + checkPermission oid + withConnection oid $ liftSTM . bufferedOutputLength . Just + Nothing -> liftSTM $ bufferedOutputLength Nothing + + return (Int $ fromIntegral len) + +bf_read = Builtin "read" 0 (Just 2) [TObj, TAny] TAny $ \optional -> + notyet "read" + +bf_force_input = Builtin "force_input" 2 (Just 3) [TObj, TStr, TAny] + TAny $ \(Obj conn : Str line : optional) -> do + let [at_front] = booleanDefaults optional [False] + + checkPermission conn + forceInput at_front conn line + return zero + +bf_flush_input = Builtin "flush_input" 1 (Just 2) + [TObj, TAny] TAny $ \(Obj conn : optional) -> do + let [show_messages] = booleanDefaults optional [False] + + checkPermission conn + withMaybeConnection conn $ maybe (return ()) $ + liftSTM . flushInput show_messages + return zero + +bf_output_delimiters = Builtin "output_delimiters" 1 (Just 1) + [TObj] TLst $ \[Obj player] -> do checkPermission player - Str `liftM` getConnectionName player + (prefix, suffix) <- withConnection player $ + liftSTM . readTVar . connectionOutputDelimiters + return $ stringList [Str.fromText prefix, Str.fromText suffix] -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_boot_player = Builtin "boot_player" 1 (Just 1) [TObj] TAny $ \[Obj player] -> + checkPermission player >> bootPlayer player >> return zero -bf_open_network_connection (Str host : Int port : optional) = do +bf_connection_name = Builtin "connection_name" 1 (Just 1) + [TObj] TStr $ \[Obj player] -> do + checkPermission player + (Str . Str.fromString) `liftM` + withConnection player (liftSTM . connectionName) + +bf_set_connection_option = Builtin "set_connection_option" 3 (Just 3) + [TObj, TStr, TAny] + TAny $ \[Obj conn, Str option, value] -> do + checkPermission conn + setConnectionOption conn (toId option) value + return zero + +bf_connection_options = Builtin "connection_options" 1 (Just 1) + [TObj] TLst $ \[Obj conn] -> do + checkPermission conn + (fromListBy pair . M.toList) `liftM` getConnectionOptions conn + + where pair (k, v) = fromList [Str $ fromId k, v] + +bf_connection_option = Builtin "connection_option" 2 (Just 2) + [TObj, TStr] TAny $ \[Obj conn, Str name] -> do + checkPermission conn + getConnectionOptions conn >>= + maybe (raise E_INVARG) return . M.lookup (toId name) + +bf_open_network_connection = Builtin "open_network_connection" 2 (Just 3) + [TStr, TInt, TObj] + TObj $ \(Str host : Int port : optional) -> do + let [Obj listener] = defaults optional [Obj systemObject] + checkWizard - connId <- openNetworkConnection (T.unpack host) (fromIntegral port) listener + world <- getWorld + unless (outboundNetwork world) $ raise E_PERM + + notyet "open_network_connection" + +{- + checkWizard + connId <- openNetworkConnection + (Str.toString host) (fromIntegral port) listener return (Obj connId) +-} - where [Obj listener] = defaults optional [Obj systemObject] +bf_listen = Builtin "listen" 2 (Just 3) + [TObj, TAny, TAny] TAny $ \(Obj object : point : optional) -> do + let [print_messages] = booleanDefaults optional [False] -bf_listen (Obj object : Int point : optional) = do checkWizard checkValid object - canon <- listen (fromIntegral point) object print_messages - return (Int $ fromIntegral canon) + point <- value2point point + point2value `liftM` listen object point print_messages - where [print_messages] = booleanDefaults optional [False] +bf_unlisten = Builtin "unlisten" 1 (Just 1) [TAny] TAny $ \[canon] -> do + checkWizard -bf_unlisten [Int canon] = - checkWizard >> unlisten (fromIntegral canon) >> return nothing + unlisten =<< value2point canon + return zero -bf_listeners [] = do - world <- getWorld - return $ fromListBy formatListener $ M.elems (listeners world) +bf_listeners = Builtin "listeners" 0 (Just 0) [] TLst $ \[] -> + (fromListBy formatListener . M.elems . listeners) `liftM` getWorld + + where formatListener Listener { listenerObject = object + , listenerPoint = point + , listenerPrintMessages = printMessages } = + fromList [Obj object, point2value point, truthValue printMessages] diff --git a/src/MOO/Builtins/Objects.hs b/src/MOO/Builtins/Objects.hs --- a/src/MOO/Builtins/Objects.hs +++ b/src/MOO/Builtins/Objects.hs @@ -3,82 +3,96 @@ module MOO.Builtins.Objects ( builtins ) where -import Control.Concurrent.STM -import Control.Monad (when, unless, liftM, void, join) -import Data.Maybe +import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar) +import Control.Monad (when, unless, liftM, void, forM_, foldM, join) +import Data.Maybe (isJust, isNothing, fromJust) import Data.Set (Set) +import Data.Text (Text) +import Prelude hiding (getContents) import qualified Data.HashMap.Strict as HM import qualified Data.IntSet as IS import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Vector as V +import MOO.AST import MOO.Builtins.Common +import {-# SOURCE #-} MOO.Compiler +import MOO.Connection 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 +import MOO.Task +import MOO.Types +import MOO.Unparser +import MOO.Verb +import qualified MOO.String as Str + {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} -- | § 4.4.3 Manipulating Objects -builtins :: [BuiltinSpec] +builtins :: [Builtin] 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)) + -- § 4.4.3.1 Fundamental Operations on Objects + bf_create + , bf_chparent + , bf_valid + , bf_parent + , bf_children + , bf_recycle + , bf_object_bytes + , bf_max_object - , ("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)) + -- § 4.4.3.2 Object Movement + , bf_move - , ("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)) + -- § 4.4.3.3 Operations on Properties + , bf_properties + , bf_property_info + , bf_set_property_info + , bf_add_property + , bf_delete_property + , bf_is_clear_property + , bf_clear_property - , ("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.4 Operations on Verbs + , bf_verbs + , bf_verb_info + , bf_set_verb_info + , bf_verb_args + , bf_set_verb_args + , bf_add_verb + , bf_delete_verb + , bf_verb_code + , bf_set_verb_code + , bf_disassemble + + -- § 4.4.3.5 Operations on Player Objects + , bf_players + , bf_is_player + , bf_set_player_flag ] -- § 4.4.3.1 Fundamental Operations on Objects -bf_create (Obj parent : optional) = do +modifyQuota :: ObjId -> (IntT -> MOO IntT) -> MOO () +modifyQuota player f = do + maybeQuota <- readProperty player ownershipQuota + case maybeQuota of + Just (Int quota) -> do + quota' <- f quota + writeProperty player ownershipQuota (Int quota') + _ -> return () + + where ownershipQuota = "ownership_quota" + +bf_create = Builtin "create" 1 (Just 2) + [TObj, TObj] TObj $ \(Obj parent : optional) -> do + let (maybeOwner : _) = maybeDefaults optional + maybeParent <- case parent of -1 -> return Nothing oid -> checkFertile oid >> return (Just oid) @@ -91,30 +105,26 @@ 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 () + modifyQuota ownerOid $ \quota -> + if quota <= 0 then raise E_QUOTA else return (quota - 1) 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 + liftSTM $ modifyObject oid db $ addChild newOid -- properties inherited from parent Just parent <- getObject oid HM.fromList `liftM` mapM mkProperty (HM.toList $ objectProperties parent) - where mkProperty (name, propTVar) = liftSTM $ do + where mkProperty :: (StrT, TVar Property) -> MOO (StrT, TVar Property) + mkProperty (name, propTVar) = liftSTM $ do prop <- readTVar propTVar let prop' = prop { propertyValue = Nothing , propertyInherited = True - , propertyOwner = if propertyPermC prop - then ownerOid + , propertyOwner = if propertyPermC prop then ownerOid else propertyOwner prop } propTVar' <- newTVar prop' @@ -131,19 +141,159 @@ callFromFunc "create" 0 (newOid, "initialize") [] return (Obj newOid) - where (maybeOwner : _) = maybeDefaults optional +reparentObject :: (ObjId, Object) -> (ObjId, Maybe Object) -> MOO () +reparentObject (object, obj) (new_parent, maybeNewParent) = do + -- Verify that neither object nor any of its descendants defines a property + -- with the same name as one defined on new_parent or any of its ancestors + case maybeNewParent of + Just newParent -> do + let props = HM.keys (objectProperties newParent) + flip traverseDescendants object $ \obj -> forM_ props $ \propName -> do + maybeProp <- liftSTM $ lookupProperty obj propName + case maybeProp of + Just prop | not (propertyInherited prop) -> raise E_INVARG + _ -> return () + Nothing -> return () -bf_chparent [Obj object, Obj new_parent] = notyet "chparent" + -- Find the nearest ancestor that object and new_parent have in common + oldAncestors <- ancestors object + newAncestors <- case maybeNewParent of + Just _ -> ancestors' new_parent + Nothing -> return [] + let maybeCommon = findCommon oldAncestors newAncestors + underCommon ancestors = maybe ancestors prefix maybeCommon + where prefix common = takeWhile (/= common) ancestors -bf_valid [Obj object] = (truthValue . isJust) `liftM` getObject object + -- Remove properties defined by ancestors of object under common, and add + -- properties defined by new_parent or its ancestors under common + db <- getDatabase + oldProperties <- allDefinedProperties (underCommon oldAncestors) + newProperties <- case maybeNewParent of + Just newParent -> + allDefinedProperties (underCommon newAncestors) >>= + mapM (liftSTM . liftM fromJust . lookupProperty newParent) + Nothing -> return [] -bf_parent [Obj object] = (Obj . getParent) `liftM` checkValid object + flip (modifyDescendants db) object $ \obj -> do + obj' <- foldM (flip deleteProperty) obj oldProperties + foldM (flip addInheritedProperty) obj' newProperties -bf_children [Obj object] = (objectList . getChildren) `liftM` checkValid object + -- Update the parent/child hierarchy + liftSTM $ modifyObject object db $ \obj -> + return obj { objectParent = const new_parent `fmap` maybeNewParent } + case objectParent obj of + Just parentOid -> liftSTM $ modifyObject parentOid db $ deleteChild object + Nothing -> return () + case maybeNewParent of + Just _ -> liftSTM $ modifyObject new_parent db $ addChild object + Nothing -> return () -bf_recycle [Obj object] = notyet "recycle" + where ancestors :: ObjId -> MOO [ObjId] + ancestors oid = do + maybeObject <- getObject oid + case join $ objectParent `fmap` maybeObject of + Just parent -> do + ancestors <- ancestors parent + return (parent : ancestors) + Nothing -> return [] -bf_object_bytes [Obj object] = do + ancestors' :: ObjId -> MOO [ObjId] + ancestors' oid = (oid :) `liftM` ancestors oid + + findCommon :: [ObjId] -> [ObjId] -> Maybe ObjId + findCommon xs ys = findCommon' (reverse xs) (reverse ys) Nothing + findCommon' (x:xs) (y:ys) _ + | x == y = findCommon' xs ys (Just x) + findCommon' _ _ common = common + + allDefinedProperties :: [ObjId] -> MOO [StrT] + allDefinedProperties = liftM ($ []) . foldM concatProps id + where concatProps acc oid = do + Just obj <- getObject oid + props <- liftSTM $ definedProperties obj + return (acc props ++) + +bf_chparent = Builtin "chparent" 2 (Just 2) + [TObj, TObj] TAny $ \[Obj object, Obj new_parent] -> do + obj <- checkValid object + maybeNewParent <- case new_parent of + -1 -> return Nothing + oid -> do + newParent <- checkValid oid + checkFertile oid + return (Just newParent) + checkPermission (objectOwner obj) + checkRecurrence objectParent object new_parent + + reparentObject (object, obj) (new_parent, maybeNewParent) + + return zero + +bf_valid = Builtin "valid" 1 (Just 1) [TObj] TInt $ \[Obj object] -> + (truthValue . isJust) `liftM` getObject object + +bf_parent = Builtin "parent" 1 (Just 1) [TObj] TObj $ \[Obj object] -> + (Obj . getParent) `liftM` checkValid object + +bf_children = Builtin "children" 1 (Just 1) [TObj] TLst $ \[Obj object] -> + (objectList . getChildren) `liftM` checkValid object + +bf_recycle = Builtin "recycle" 1 (Just 1) [TObj] TAny $ \[Obj object] -> do + obj <- checkValid object + let owner = objectOwner obj + checkPermission owner + + callFromFunc "recycle" 0 (object, "recycle") [] + + moveContentsToNothing object + moveToNothing object + + reparentChildren object (objectParent obj) + reparent object Nothing + + setPlayerFlag True object False + getDatabase >>= liftSTM . deleteObject object + + modifyQuota owner $ return . (+ 1) + + return zero + + where moveContentsToNothing :: ObjId -> MOO () + moveContentsToNothing object = do + maybeObj <- getObject object + case getContents `fmap` maybeObj of + Just (oid:_) -> do + moveToNothing oid + moveContentsToNothing object + _ -> return () + + moveToNothing :: ObjId -> MOO () + moveToNothing oid = moveObject "recycle" oid nothing + + reparentChildren :: ObjId -> Maybe ObjId -> MOO () + reparentChildren object maybeParent = do + maybeObj <- getObject object + case getChildren `fmap` maybeObj of + Just (oid:_) -> do + reparent oid maybeParent + reparentChildren object maybeParent + _ -> return () + + reparent :: ObjId -> Maybe ObjId -> MOO () + reparent object maybeParent = do + maybeObj <- getObject object + case maybeObj of + Just obj -> do + newParent <- case maybeParent of + Just parentOid -> do + parent <- getObject parentOid + return (parentOid, parent) + Nothing -> return (nothing, Nothing) + reparentObject (object, obj) newParent + Nothing -> return () + +bf_object_bytes = Builtin "object_bytes" 1 (Just 1) + [TObj] TInt $ \[Obj object] -> do checkWizard obj <- checkValid object @@ -154,24 +304,13 @@ return $ Int $ fromIntegral $ storageBytes obj + propertyBytes + verbBytes -bf_max_object [] = (Obj . maxObject) `liftM` getDatabase +bf_max_object = Builtin "max_object" 0 (Just 0) [] TObj $ \[] -> + (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 - +moveObject :: StrT -> ObjId -> ObjId -> MOO () +moveObject funcName what where_ = do let newWhere = case where_ of -1 -> Nothing oid -> Just oid @@ -182,7 +321,7 @@ Just whatObj -> unless (objectLocation whatObj == newWhere) $ do maybeWhere <- getObject where_ when (isNothing newWhere || isJust maybeWhere) $ do - checkRecurse what where_ + checkRecurrence objectLocation what where_ let oldWhere = objectLocation whatObj db <- getDatabase @@ -201,42 +340,54 @@ case oldWhere of Nothing -> return () Just oldWhere' -> - void $ callFromFunc "move" 1 (oldWhere', "exitfunc") [Obj what] + void $ callFromFunc funcName 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] + void $ callFromFunc funcName 2 (where_, "enterfunc") [Obj what] - return nothing +bf_move = Builtin "move" 2 (Just 2) + [TObj, TObj] TAny $ \[Obj what, Obj where_] -> do + what' <- checkValid what + where' <- case where_ of + -1 -> return Nothing + oid -> Just `liftM` checkValid oid + checkPermission (objectOwner what') - 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 () + 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 + moveObject "move" what where_ + + return zero + -- § 4.4.3.3 Operations on Properties -bf_properties [Obj object] = do +bf_properties = Builtin "properties" 1 (Just 1) + [TObj] TLst $ \[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 +bf_property_info = Builtin "property_info" 2 (Just 2) + [TObj, TStr] TLst $ \[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]] + where perms prop = Str.fromString $ concat [['r' | propertyPermR prop], + ['w' | propertyPermW prop], + ['c' | propertyPermC prop]] traverseDescendants :: (Object -> MOO a) -> ObjId -> MOO () traverseDescendants f oid = do @@ -254,11 +405,13 @@ checkPerms :: [Char] -> StrT -> MOO (Set Char) checkPerms valid perms = do - let permSet = S.fromList (T.unpack $ T.toCaseFold perms) + let permSet = S.fromList (T.unpack $ Str.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 +bf_set_property_info = Builtin "set_property_info" 3 (Just 3) + [TObj, TStr, TLst] + TAny $ \[Obj object, Str prop_name, Lst info] -> do (owner, perms, new_name) <- case V.toList info of [Obj owner, Str perms] -> return (owner, perms, Nothing) [_ , _ ] -> raise E_TYPE @@ -284,30 +437,30 @@ case new_name of Nothing -> setInfo Just newName -> do - let newName' = T.toCaseFold newName - oldName' = T.toCaseFold prop_name + let oldName = 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 + 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' + 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) } + HM.insert newName propTVar $ + HM.delete oldName (objectProperties obj) } - return nothing + return zero -bf_add_property [Obj object, Str prop_name, value, Lst info] = do +bf_add_property = Builtin "add_property" 4 (Just 4) [TObj, TStr, TAny, TLst] + TAny $ \[Obj object, Str prop_name, value, Lst info] -> do (owner, perms) <- case V.toList info of [Obj owner, Str perms] -> return (owner, perms) [_ , _ ] -> raise E_TYPE @@ -319,11 +472,11 @@ unless (objectPermW obj) $ checkPermission (objectOwner obj) checkPermission owner - when (isBuiltinProperty name) $ raise E_INVARG + when (isBuiltinProperty prop_name) $ raise E_INVARG flip traverseDescendants object $ \obj -> - when (isJust $ lookupPropertyRef obj name) $ raise E_INVARG + when (isJust $ lookupPropertyRef obj prop_name) $ raise E_INVARG - let definedProp = initProperty { + let newProperty = initProperty { propertyName = prop_name , propertyValue = Just value , propertyInherited = False @@ -331,29 +484,17 @@ , 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 + db <- getDatabase + liftSTM $ modifyObject object db (addProperty newProperty) + forM_ (getChildren obj) $ + modifyDescendants db $ addInheritedProperty newProperty - where name = T.toCaseFold prop_name + return zero -bf_delete_property [Obj object, Str prop_name] = do +bf_delete_property = Builtin "delete_property" 2 (Just 2) + [TObj, TStr] TAny $ \[Obj object, Str prop_name] -> do obj <- checkValid object unless (objectPermW obj) $ checkPermission (objectOwner obj) prop <- getProperty obj prop_name @@ -361,13 +502,12 @@ db <- getDatabase flip (modifyDescendants db) object $ \obj -> - return obj { objectProperties = HM.delete name (objectProperties obj) } - - return nothing + return obj { objectProperties = HM.delete prop_name (objectProperties obj) } - where name = T.toCaseFold prop_name + return zero -bf_is_clear_property [Obj object, Str prop_name] = do +bf_is_clear_property = Builtin "is_clear_property" 2 (Just 2) + [TObj, TStr] TInt $ \[Obj object, Str prop_name] -> do obj <- checkValid object if isBuiltinProperty prop_name then return $ truthValue False @@ -377,7 +517,8 @@ return (truthValue $ isNothing $ propertyValue prop) -bf_clear_property [Obj object, Str prop_name] = do +bf_clear_property = Builtin "clear_property" 2 (Just 2) + [TObj, TStr] TAny $ \[Obj object, Str prop_name] -> do obj <- checkValid object if isBuiltinProperty prop_name then raise E_PERM @@ -387,17 +528,18 @@ unless (propertyInherited prop) $ raise E_INVARG return prop { propertyValue = Nothing } - return nothing + return zero -- § 4.4.3.4 Operations on Verbs -bf_verbs [Obj object] = do +bf_verbs = Builtin "verbs" 1 (Just 1) [TObj] TLst $ \[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 +bf_verb_info = Builtin "verb_info" 2 (Just 2) + [TObj, TAny] TLst $ \[Obj object, verb_desc] -> do obj <- checkValid object verb <- getVerb obj verb_desc unless (verbPermR verb) $ checkPermission (verbOwner verb) @@ -405,10 +547,10 @@ 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]] + where perms verb = Str.fromString $ concat [['r' | verbPermR verb], + ['w' | verbPermW verb], + ['x' | verbPermX verb], + ['d' | verbPermD verb]] verbInfo :: LstT -> MOO (ObjId, Set Char, StrT) verbInfo info = do @@ -418,11 +560,12 @@ _ -> raise E_INVARG permSet <- checkPerms "rwxd" perms checkValid owner - when (null $ T.words names) $ raise E_INVARG + when (null $ Str.words names) $ raise E_INVARG return (owner, permSet, names) -bf_set_verb_info [Obj object, verb_desc, Lst info] = do +bf_set_verb_info = Builtin "set_verb_info" 3 (Just 3) [TObj, TAny, TLst] + TAny $ \[Obj object, verb_desc, Lst info] -> do (owner, permSet, names) <- verbInfo info obj <- checkValid object @@ -430,9 +573,7 @@ unless (verbPermW verb) $ checkPermission (verbOwner verb) checkPermission owner - let newNames = T.toCaseFold names - oldNames = T.toCaseFold (verbNames verb) - unless (newNames == oldNames || objectPermW obj) $ + unless (names == verbNames verb || objectPermW obj) $ checkPermission (objectOwner obj) modifyVerb (object, obj) verb_desc $ \verb -> @@ -445,33 +586,35 @@ , verbPermD = 'd' `S.member` permSet } - return nothing + return zero -bf_verb_args [Obj object, verb_desc] = do +bf_verb_args = Builtin "verb_args" 2 (Just 2) + [TObj, TAny] TLst $ \[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 + where dobj = obj2string . verbDirectObject + iobj = obj2string . verbIndirectObject + prep = prep2string . 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 "/" + where breakSlash = fst . Str.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) + dobj' <- maybe (raise E_INVARG) return $ string2obj dobj + prep' <- maybe (raise E_INVARG) return $ string2prep prep + iobj' <- maybe (raise E_INVARG) return $ string2obj iobj return (dobj', prep', iobj') -bf_set_verb_args [Obj object, verb_desc, Lst args] = do +bf_set_verb_args = Builtin "set_verb_args" 3 (Just 3) [TObj, TAny, TLst] + TAny $ \[Obj object, verb_desc, Lst args] -> do (dobj, prep, iobj) <- verbArgs args obj <- checkValid object @@ -485,9 +628,10 @@ , verbIndirectObject = iobj } - return nothing + return zero -bf_add_verb [Obj object, Lst info, Lst args] = do +bf_add_verb = Builtin "add_verb" 3 (Just 3) + [TObj, TLst, TLst] TInt $ \[Obj object, Lst info, Lst args] -> do (owner, permSet, names) <- verbInfo info (dobj, prep, iobj) <- verbArgs args @@ -512,7 +656,8 @@ return $ Int $ fromIntegral $ length (objectVerbs obj) + 1 -bf_delete_verb [Obj object, verb_desc] = do +bf_delete_verb = Builtin "delete_verb" 2 (Just 2) + [TObj, TAny] TAny $ \[Obj object, verb_desc] -> do obj <- checkValid object getVerb obj verb_desc unless (objectPermW obj) $ checkPermission (objectOwner obj) @@ -523,21 +668,23 @@ db <- getDatabase liftSTM $ modifyObject object db $ deleteVerb index - return nothing + return zero -bf_verb_code (Obj object : verb_desc : optional) = do +bf_verb_code = Builtin "verb_code" 2 (Just 4) [TObj, TAny, TAny, TAny] + TLst $ \(Obj object : verb_desc : optional) -> do + let [fully_paren, indent] = booleanDefaults optional [False, True] + obj <- checkValid object verb <- getVerb obj verb_desc unless (verbPermR verb) $ checkPermission (verbOwner verb) checkProgrammer - let code = init $ T.splitOn "\n" $ + let code = init $ Str.splitOn "\n" $ Str.fromText $ TL.toStrict $ 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 +bf_set_verb_code = Builtin "set_verb_code" 3 (Just 3) [TObj, TAny, TLst] + TLst $ \[Obj object, verb_desc, Lst code] -> do obj <- checkValid object verb <- getVerb obj verb_desc text <- (T.concat . ($ [])) `liftM` V.foldM addLine id code @@ -545,45 +692,50 @@ checkProgrammer case parse text of - Left errors -> return $ fromListBy (Str . T.pack) errors + Left errors -> return $ fromListBy (Str . Str.fromString) errors Right program -> do modifyVerb (object, obj) verb_desc $ \verb -> return verb { verbProgram = program , verbCode = compile program } - return $ Lst V.empty + return emptyList - where addLine :: ([StrT] -> [StrT]) -> Value -> MOO ([StrT] -> [StrT]) - addLine add (Str line) = return (add [line, "\n"] ++) + where addLine :: ([Text] -> [Text]) -> Value -> MOO ([Text] -> [Text]) + addLine add (Str line) = return (add [Str.toText line, "\n"] ++) addLine _ _ = raise E_INVARG -bf_disassemble [Obj object, verb_desc] = do +bf_disassemble = Builtin "disassemble" 2 (Just 2) + [TObj, TAny] TLst $ \[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 + return $ fromListBy (Str . Str.fromString . show) statements -- § 4.4.3.5 Operations on Player Objects -bf_players [] = (objectList . allPlayers) `liftM` getDatabase +bf_players = Builtin "players" 0 (Just 0) [] TLst $ \[] -> + (objectList . allPlayers) `liftM` getDatabase -bf_is_player [Obj object] = +bf_is_player = Builtin "is_player" 1 (Just 1) [TObj] TInt $ \[Obj object] -> (truthValue . objectIsPlayer) `liftM` checkValid object -bf_set_player_flag [Obj object, value] = do - checkValid object - checkWizard - +setPlayerFlag :: Bool -> ObjId -> Bool -> MOO () +setPlayerFlag recycled object isPlayer = do db <- getDatabase - liftSTM $ modifyObject object db $ - \obj -> return obj { objectIsPlayer = isPlayer } + liftSTM $ modifyObject object db $ \obj -> + return obj { objectIsPlayer = isPlayer } putDatabase $ setPlayer isPlayer object db - unless isPlayer $ bootPlayer object + unless isPlayer $ bootPlayer' recycled object - return nothing +bf_set_player_flag = Builtin "set_player_flag" 2 (Just 2) + [TObj, TAny] TAny $ \[Obj object, value] -> do + checkValid object + checkWizard - where isPlayer = truthOf value + setPlayerFlag False object (truthOf value) + + return zero diff --git a/src/MOO/Builtins/Tasks.hs b/src/MOO/Builtins/Tasks.hs --- a/src/MOO/Builtins/Tasks.hs +++ b/src/MOO/Builtins/Tasks.hs @@ -3,8 +3,8 @@ module MOO.Builtins.Tasks ( builtins ) where -import Control.Concurrent (forkIO, threadDelay, killThread) -import Control.Concurrent.STM +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.STM (atomically, newEmptyTMVar, takeTMVar, putTMVar) import Control.Monad (liftM, void) import Control.Monad.Cont (callCC) import Control.Monad.Reader (asks) @@ -12,106 +12,117 @@ 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 qualified Data.Map as M +import qualified Data.Set as S + +import MOO.Builtins.Common +import {-# SOURCE #-} MOO.Builtins +import {-# SOURCE #-} MOO.Compiler import MOO.Object -import MOO.Verb import MOO.Parser -import {-# SOURCE #-} MOO.Compiler -import {-# SOURCE #-} MOO.Builtins -import MOO.Builtins.Common +import MOO.Task +import MOO.Types +import MOO.Verb -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T +import qualified MOO.String as Str {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} -- | § 4.4.6 MOO-Code Evaluation and Task Manipulation -builtins :: [BuiltinSpec] +builtins :: [Builtin] 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 + , bf_call_function + , bf_function_info + , bf_eval + , bf_set_task_perms + , bf_caller_perms + , bf_ticks_left + , bf_seconds_left + , bf_task_id + , bf_suspend + , bf_resume + , bf_queue_info + , bf_queued_tasks + , bf_kill_task + , bf_callers + , bf_task_stack ] -bf_raise (code : optional) = raiseException $ Exception code message value - where [Str message, value] = defaults optional [Str $ toText code, nothing] +bf_raise = Builtin "raise" 1 (Just 3) + [TAny, TStr, TAny] TAny $ \(code : optional) -> + let [Str message, value] = + defaults optional [Str $ Str.fromText $ toText code, zero] + in raiseException code message value -bf_call_function (Str func_name : args) = - callBuiltin (T.toCaseFold func_name) args +bf_call_function = Builtin "call_function" 1 Nothing + [TStr] TAny $ \(Str func_name : args) -> + callBuiltin (toId 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 = Builtin "function_info" 0 (Just 1) + [TStr] TLst $ \args -> case args of + [] -> return $ fromListBy formatInfo $ M.elems builtinFunctions + [Str name] -> case M.lookup (toId name) builtinFunctions of + Just builtin -> return $ formatInfo builtin + Nothing -> raise E_INVARG -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 + where formatInfo :: Builtin -> Value + formatInfo Builtin { builtinName = name + , builtinMinArgs = min + , builtinMaxArgs = max + , builtinArgTypes = types + } = + fromList [ Str $ fromId name + , Int $ fromIntegral min + , Int $ maybe (-1) fromIntegral max + , fromListBy (Int . typeCode) types + ] -bf_eval [Str string] = do - checkProgrammer - case parse string of - Left errors -> return $ fromList [truthValue False, - fromListBy (Str . T.pack) errors] +bf_eval = Builtin "eval" 1 (Just 1) [TStr] TLst $ \[Str string] -> + checkProgrammer >> case parse (Str.toText string) of + Left errors -> + return $ fromList [truthValue False, + fromListBy (Str . Str.fromString) errors] 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) - ] + 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 - } + runVerb verb initFrame { variables = vars + , initialPlayer = player + } return $ fromList [truthValue True, value] -bf_set_task_perms [Obj who] = do +bf_set_task_perms = Builtin "set_task_perms" 1 (Just 1) + [TObj] TAny $ \[Obj who] -> do checkPermission who modifyFrame $ \frame -> frame { permissions = who } - return nothing + return zero -bf_caller_perms [] = (Obj . objectForMaybe) `liftM` caller permissions +bf_caller_perms = Builtin "caller_perms" 0 (Just 0) [] TObj $ \[] -> + (Obj . objectForMaybe) `liftM` caller permissions -bf_ticks_left [] = (Int . fromIntegral) `liftM` gets ticksLeft +bf_ticks_left = Builtin "ticks_left" 0 (Just 0) [] TInt $ \[] -> + (Int . fromIntegral) `liftM` gets ticksLeft -bf_seconds_left [] = return (Int 5) -- XXX can this be measured? +bf_seconds_left = Builtin "seconds_left" 0 (Just 0) [] TInt $ \[] -> + return (Int 5) -- XXX can this be measured? -bf_task_id [] = (Int . fromIntegral) `liftM` asks (taskId . task) +bf_task_id = Builtin "task_id" 0 (Just 0) [] TInt $ \[] -> + (Int . fromIntegral) `liftM` asks (taskId . task) -bf_suspend optional = do +bf_suspend = Builtin "suspend" 0 (Just 1) [TNum] TAny $ \optional -> do + let (maybeSeconds : _) = maybeDefaults optional + maybeMicroseconds <- case maybeSeconds of Just (Int secs) | secs < 0 -> raise E_INVARG @@ -127,7 +138,7 @@ Just usecs | time < now || time > endOfTime -> raise E_INVARG | otherwise -> return time - where now = startTime state + where now = startTime state time = (fromIntegral usecs / 1000000) `addUTCTime` now Nothing -> return endOfTime -- XXX this is a sad wart in need of remedy @@ -145,12 +156,8 @@ } 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 () + Just usecs -> delayIO $ void $ forkIO $ delay usecs >> wake zero + Nothing -> return () putTask task' @@ -165,10 +172,11 @@ Err error -> raise error _ -> return value - where (maybeSeconds : _) = maybeDefaults optional +bf_resume = Builtin "resume" 1 (Just 2) + [TInt, TAny] TAny $ \(Int task_id : optional) -> do + let [value] = defaults optional [zero] -bf_resume (Int task_id : optional) = do - maybeTask <- getTask task_id' + maybeTask <- getTask (fromIntegral task_id) case maybeTask of Just task@Task { taskStatus = Suspended (Wake wake) } -> do checkPermission (taskOwner task) @@ -176,20 +184,17 @@ 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 + return zero -bf_queue_info [Obj player] = - (Int . fromIntegral . length . filter ((== player) . taskOwner)) `liftM` - queuedTasks +bf_queue_info = Builtin "queue_info" 0 (Just 1) [TObj] TAny $ \args -> + let info = case args of + [] -> objectList . S.toList . + foldr (S.insert . taskOwner) S.empty + [Obj player] -> Int . fromIntegral . length . + filter ((== player) . taskOwner) + in info `liftM` queuedTasks -bf_queued_tasks [] = do +bf_queued_tasks = Builtin "queued_tasks" 0 (Just 0) [] TLst $ \[] -> do tasks <- queuedTasks programmer <- frame permissions wizard <- isWizard programmer @@ -198,7 +203,8 @@ return $ fromListBy formatTask $ sort ownedTasks - where formatTask task = fromListBy ($ task) [ + where formatTask :: Task -> Value + formatTask task = fromListBy ($ task) [ Int . fromIntegral . taskId -- task-id , Int . floor . utcTimeToPOSIXSeconds . startTime . taskState -- start-time @@ -212,36 +218,36 @@ , Int . fromIntegral . storageBytes -- task-size ] -bf_kill_task [Int task_id] = do +bf_kill_task = Builtin "kill_task" 1 (Just 1) [TInt] TAny $ \[Int task_id] -> do + let task_id' = fromIntegral task_id 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 + return zero _ -> 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 = Builtin "callers" 0 (Just 1) [TAny] TLst $ \optional -> do + let [include_line_numbers] = booleanDefaults optional [False] -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 = Builtin "task_stack" 1 (Just 2) + [TInt, TAny] TLst $ \(Int task_id : optional) -> do + let [include_line_numbers] = booleanDefaults optional [False] -bf_task_stack (Int task_id : optional) = do - maybeTask <- getTask task_id' + maybeTask <- getTask (fromIntegral 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 --- a/src/MOO/Builtins/Values.hs +++ b/src/MOO/Builtins/Values.hs @@ -1,113 +1,111 @@ -{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} 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 Control.Applicative ((<$>), (<*>)) +import Control.Monad (mplus, unless, liftM, (>=>)) +import Data.ByteString (ByteString) +import Data.Char (isDigit) +import Data.Digest.Pure.MD5 (MD5Digest) 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.Word (Word8) +import Text.Printf (printf) -import Data.Digest.Pure.MD5 (MD5Digest) +import qualified Data.ByteString as BS import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.Vector as V +import qualified Data.Text as T -import MOO.Types -import MOO.Task -import MOO.Parser (parseNum, parseObj) import MOO.Builtins.Common +import MOO.Builtins.Crypt import MOO.Builtins.Match +import MOO.Parser (parseNum, parseObj) +import MOO.Task +import MOO.Types +import qualified MOO.String as Str + {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} -- | § 4.4.2 Manipulating MOO Values -builtins :: [BuiltinSpec] +builtins :: [Builtin] 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)) + -- § 4.4.2.1 General Operations Applicable to all Values + bf_typeof + , bf_tostr + , bf_toliteral + , bf_toint + , bf_tonum + , bf_toobj + , bf_tofloat + , bf_equal + , bf_value_bytes + , bf_value_hash - , ("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)) + -- § 4.4.2.2 Operations on Numbers + , bf_random + , bf_min + , bf_max + , bf_abs + , bf_floatstr + , bf_sqrt + , bf_sin + , bf_cos + , bf_tan + , bf_asin + , bf_acos + , bf_atan + , bf_sinh + , bf_cosh + , bf_tanh + , bf_exp + , bf_log + , bf_log10 + , bf_ceil + , bf_floor + , bf_trunc - , ("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)) + -- § 4.4.2.3 Operations on Strings + , bf_length + , bf_strsub + , bf_index + , bf_rindex + , bf_strcmp + , bf_decode_binary + , bf_encode_binary + , bf_match + , bf_rmatch + , bf_substitute + , bf_crypt + , bf_string_hash + , bf_binary_hash - , ("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.4 Operations on Lists + , bf_is_member + , bf_listinsert + , bf_listappend + , bf_listdelete + , bf_listset + , bf_setadd + , bf_setremove ] -- § 4.4.2.1 General Operations Applicable to all Values -bf_typeof [value] = return $ Int $ typeCode $ typeOf value +bf_typeof = Builtin "typeof" 1 (Just 1) [TAny] TInt $ \[value] -> + return $ Int $ typeCode $ typeOf value -bf_tostr values = return $ Str $ T.concat $ map toText values +bf_tostr = Builtin "tostr" 0 Nothing [] TStr $ + return . Str . Str.fromText . T.concat . map toText -bf_toliteral [value] = return $ Str $ toLiteral value +bf_toliteral = Builtin "toliteral" 1 (Just 1) [TAny] TStr $ \[value] -> + return $ Str $ Str.fromText $ toLiteral value -- XXX toint(" - 34 ") does not parse as -34 -bf_toint [value] = toint value +bf_toint = Builtin "toint" 1 (Just 1) [TAny] TInt $ \[value] -> toint value where toint value = case value of Int _ -> return value Flt x | x >= 0 -> if x > fromIntegral (maxBound :: IntT) @@ -115,11 +113,13 @@ | 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) + Str x -> maybe (return $ Int 0) toint (parseNum $ Str.toText x) Err x -> return (Int $ fromIntegral $ fromEnum x) Lst _ -> raise E_TYPE -bf_toobj [value] = toobj value +bf_tonum = bf_toint { builtinName = "tonum" } + +bf_toobj = Builtin "toobj" 1 (Just 1) [TAny] TObj $ \[value] -> toobj value where toobj value = case value of Int x -> return (Obj $ fromIntegral x) Flt x | x >= 0 -> if x > fromIntegral (maxBound :: ObjT) @@ -127,39 +127,45 @@ | 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 + Str x -> maybe (return $ Obj 0) toobj $ + parseNum (Str.toText x) `mplus` parseObj (Str.toText x) Err x -> return (Obj $ fromIntegral $ fromEnum x) Lst _ -> raise E_TYPE -bf_tofloat [value] = tofloat value +bf_tofloat = Builtin "tofloat" 1 (Just 1) + [TAny] TFlt $ \[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) + Str x -> maybe (return $ Flt 0) tofloat (parseNum $ Str.toText x) Err x -> return (Flt $ fromIntegral $ fromEnum x) Lst _ -> raise E_TYPE -bf_equal [value1, value2] = return $ truthValue (value1 `equal` value2) +bf_equal = Builtin "equal" 2 (Just 2) [TAny, TAny] TInt $ \[value1, value2] -> + return $ truthValue (value1 `equal` value2) -bf_value_bytes [value] = return $ Int $ fromIntegral $ storageBytes value +bf_value_bytes = Builtin "value_bytes" 1 (Just 1) [TAny] TInt $ \[value] -> + return $ Int $ fromIntegral $ storageBytes value -bf_value_hash [value] = do - literal <- bf_toliteral [value] - bf_string_hash [literal] +bf_value_hash = Builtin "value_hash" 1 (Just 1) [TAny] TStr $ + builtinFunction bf_toliteral >=> + builtinFunction bf_string_hash . return -- § 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_random = Builtin "random" 0 (Just 1) [TInt] TInt $ \optional -> + let [Int mod] = defaults optional [Int maxBound] + in if mod < 1 then raise E_INVARG + else Int `liftM` random (1, mod) -bf_min (Int x:xs) = minMaxInt min x xs -bf_min (Flt x:xs) = minMaxFlt min x xs +bf_min = Builtin "min" 1 Nothing [TNum] TNum $ \args -> case args of + Int x:xs -> minMaxInt min x xs + Flt x:xs -> minMaxFlt min x xs -bf_max (Int x:xs) = minMaxInt max x xs -bf_max (Flt x:xs) = minMaxFlt max x xs +bf_max = Builtin "max" 1 Nothing [TNum] TNum $ \args -> case args of + Int x:xs -> minMaxInt max x xs + Flt x:xs -> minMaxFlt max x xs minMaxInt :: (IntT -> IntT -> IntT) -> IntT -> [Value] -> MOO Value minMaxInt f = go @@ -173,162 +179,172 @@ 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_abs = Builtin "abs" 1 (Just 1) [TNum] TNum $ \[arg] -> case arg of + Int x -> return $ Int $ abs x + 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_floatstr = Builtin "floatstr" 2 (Just 3) + [TFlt, TInt, TAny] TStr $ \(Flt x : Int precision : optional) -> + let [scientific] = booleanDefaults optional [False] + prec = min precision 19 + format = printf "%%.%d%c" prec $ if scientific then 'e' else 'f' + in if precision < 0 then raise E_INVARG + else return $ Str $ Str.fromString $ printf format x -bf_sqrt [Flt x] = checkFloat $ sqrt x +floatBuiltin :: Id -> (FltT -> FltT) -> Builtin +floatBuiltin name f = Builtin name 1 (Just 1) + [TFlt] TFlt $ \[Flt x] -> checkFloat (f x) -bf_sin [Flt x] = checkFloat $ sin x -bf_cos [Flt x] = checkFloat $ cos x -bf_tan [Flt x] = checkFloat $ tan x +bf_sqrt = floatBuiltin "sqrt" sqrt -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_sin = floatBuiltin "sin" sin +bf_cos = floatBuiltin "cos" cos +bf_tan = floatBuiltin "tan" tan -bf_sinh [Flt x] = checkFloat $ sinh x -bf_cosh [Flt x] = checkFloat $ cosh x -bf_tanh [Flt x] = checkFloat $ tanh x +bf_asin = floatBuiltin "asin" asin +bf_acos = floatBuiltin "acos" acos +bf_atan = Builtin "atan" 1 (Just 2) [TFlt, TFlt] TFlt $ \args -> + checkFloat $ case args of + [Flt y] -> atan y + [Flt y, Flt x] -> atan2 y x -bf_exp [Flt x] = checkFloat $ exp x -bf_log [Flt x] = checkFloat $ log x -bf_log10 [Flt x] = checkFloat $ logBase 10 x +bf_sinh = floatBuiltin "sinh" sinh +bf_cosh = floatBuiltin "cosh" cosh +bf_tanh = floatBuiltin "tanh" tanh -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) +bf_exp = floatBuiltin "exp" exp +bf_log = floatBuiltin "log" log +bf_log10 = floatBuiltin "log10" (logBase 10) +bf_ceil = floatBuiltin "ceil" $ fromInteger . ceiling +bf_floor = floatBuiltin "floor" $ fromInteger . floor +bf_trunc = floatBuiltin "trunc" $ \x -> + fromInteger $ if x < 0 then ceiling x else floor x + -- § 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_length = Builtin "length" 1 (Just 1) [TAny] TInt $ \[arg] -> case arg of + Str string -> return $ Int $ fromIntegral $ Str.length string + Lst list -> return $ Int $ fromIntegral $ V.length list + _ -> 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_strsub = Builtin "strsub" 3 (Just 4) [TStr, TStr, TStr, TAny] + TStr $ \(Str subject : Str what : Str with : optional) -> + let [case_matters] = booleanDefaults optional [False] + caseFold str = if case_matters then str + else Str.fromText (Str.toCaseFold str) + -- XXX this won't work for Unicode in general + subs "" = [] + subs subject = case Str.breakOn (caseFold what) (caseFold subject) of + (_, "") -> [subject] + (prefix, _) -> let (s, r) = Str.splitAt (Str.length prefix) subject + in s : with : subs (Str.drop whatLen r) + whatLen = Str.length what + in if Str.null what then raise E_INVARG + else return $ Str $ Str.concat $ subs subject -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 +indexBuiltin :: Id -> (StrT -> IntT) -> (StrT -> StrT -> IntT) -> Builtin +indexBuiltin name nullCase mainCase = + Builtin name 2 (Just 3) [TStr, TStr, TAny] + TInt $ \(Str str1 : Str str2 : optional) -> + let [case_matters] = booleanDefaults optional [False] + caseFold str = if case_matters then str + else Str.fromText (Str.toCaseFold str) + -- XXX this won't work for Unicode in general + in return $ Int $ if Str.null str2 then nullCase str1 + else mainCase (caseFold str2) (caseFold str1) -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_index = indexBuiltin "index" nullCase mainCase + where nullCase = const 1 + mainCase needle haystack = case Str.breakOn needle haystack of + (_, "") -> 0 + (prefix, _) -> fromIntegral $ 1 + Str.length prefix -bf_strcmp [Str str1, Str str2] = - return $ Int $ case compare str1 str2 of +bf_rindex = indexBuiltin "rindex" nullCase mainCase + where nullCase haystack = fromIntegral $ Str.length haystack + 1 + mainCase needle haystack = case Str.breakOnEnd needle haystack of + ("", _) -> 0 + (prefix, _) -> fromIntegral $ + 1 + Str.length prefix - Str.length needle + +bf_strcmp = Builtin "strcmp" 2 (Just 2) + [TStr, TStr] TInt $ \[Str str1, Str str2] -> + return $ Int $ case Str.toText str1 `compare` Str.toText 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 ("" ++) +bf_decode_binary = Builtin "decode_binary" 1 (Just 2) + [TStr, TAny] TLst $ \(Str bin_string : optional) -> + let [fully] = booleanDefaults optional [False] + mkResult | fully = fromListBy (Int . fromIntegral) + | otherwise = fromList . groupPrinting ("" ++) + in (mkResult . BS.unpack) `liftM` binaryString bin_string + + where groupPrinting :: (String -> String) -> [Word8] -> [Value] 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 + | Str.validChar c = groupPrinting (g [c] ++) ws + | null group = Int (fromIntegral w) : groupPrinting g ws + | otherwise = Str (Str.fromString group) : + Int (fromIntegral w) : groupPrinting ("" ++) ws where c = toEnum (fromIntegral w) group = g "" groupPrinting g [] | null group = [] - | otherwise = [Str $ T.pack group] + | otherwise = [Str $ Str.fromString group] where group = g "" -bf_encode_binary = liftM (Str . T.pack) . encodeBinary +bf_encode_binary = Builtin "encode_binary" 0 Nothing [] TStr $ + liftM (Str . Str.fromBinary) . 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 "" +encodeBinary :: [Value] -> MOO ByteString +encodeBinary = maybe (raise E_INVARG) (return . BS.pack) . encode + where encode :: [Value] -> Maybe [Word8] + encode (Int n : rest) + | n >= 0 && n <= 255 = (fromIntegral n :) <$> encode rest + | otherwise = Nothing + encode (Str s : rest) = (++) <$> encodeStr s <*> encode rest + encode (Lst v : rest) = (++) <$> encode (V.toList v) <*> encode rest + encode (_ : _ ) = Nothing + encode [] = Just [] -bf_match (Str subject : Str pattern : optional) = - runMatch match subject pattern case_matters - where [case_matters] = booleanDefaults optional [False] + encodeStr :: StrT -> Maybe [Word8] + encodeStr = mapM encodeChar . Str.toString -bf_rmatch (Str subject : Str pattern : optional) = - runMatch rmatch subject pattern case_matters - where [case_matters] = booleanDefaults optional [False] + encodeChar :: Char -> Maybe Word8 + encodeChar c + | n >= 0 && n <= 255 = Just (fromIntegral n) + | otherwise = Nothing + where n = fromEnum c -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) +matchBuiltin :: Id -> (Regexp -> Text -> MatchResult) -> Builtin +matchBuiltin name matchFunc = Builtin name 2 (Just 3) [TStr, TStr, TAny] + TLst $ \(Str subject : Str pattern : optional) -> + let [case_matters] = booleanDefaults optional [False] + in runMatch matchFunc subject pattern case_matters + +bf_match = matchBuiltin "match" match +bf_rmatch = matchBuiltin "rmatch" rmatch + +runMatch :: (Regexp -> Text -> MatchResult) -> StrT -> StrT -> Bool -> MOO Value +runMatch match subject pattern caseMatters = + case Str.toRegexp caseMatters pattern of + Left (err, at) -> raiseException (Err E_INVARG) + (Str.fromString $ "Invalid pattern: " ++ err) (Int $ fromIntegral at) - Right regexp -> 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] + Right regexp -> case match regexp (Str.toText subject) of + MatchFailed -> return emptyList + 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) + where convert :: (Int, Int) -> (IntT, IntT) + convert (s, e) = (1 + fromIntegral s, fromIntegral e) + -- convert from 0-based open interval to 1-based closed one repls :: Int -> [(Int, Int)] -> [Value] repls n (r:rs) = let (s,e) = convert r @@ -337,13 +353,14 @@ | n > 0 = fromList [Int 0, Int (-1)] : repls (n - 1) [] | otherwise = [] -bf_substitute [Str template, Lst subs] = +bf_substitute = Builtin "substitute" 2 (Just 2) + [TStr, TLst] TStr $ \[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' + subject = Str.toString subject' + subjectLen = Str.length subject' valid s e = (s == 0 && e == -1) || (s > 0 && e >= s - 1 && e <= subjectLen) @@ -361,7 +378,8 @@ _ -> raise E_INVARG substitution _ = raise E_INVARG - unless (valid start end && V.length replacements' == 9) $ raise E_INVARG + unless (valid start end && V.length replacements' == 9) $ + raise E_INVARG replacements <- (substr start end :) `liftM` mapM substitution (V.toList replacements') @@ -373,103 +391,76 @@ walk (c:cs) = ([c] ++) `liftM` walk cs walk [] = return [] - (Str . T.pack) `liftM` walk (T.unpack template) + (Str . Str.fromString) `liftM` walk (Str.toString 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 = Builtin "crypt" 1 (Just 2) + [TStr, TStr] TStr $ \(Str text : optional) -> + let (saltArg : _) = maybeDefaults optional + go salt = case crypt (Str.toString text) (Str.toString salt) of + Just encrypted -> return $ Str $ Str.fromString encrypted + Nothing -> raise E_QUOTA + in if maybe True invalidSalt saltArg + then generateSalt >>= go + else go $ fromStr $ fromJust saltArg -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 + where invalidSalt (Str salt) = salt `Str.compareLength` 2 == LT generateSalt = do c1 <- randSaltChar c2 <- randSaltChar - return $ T.pack [c1, c2] + return $ Str.fromString [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 +hash bs = Str $ Str.fromString $ show md5hash where md5hash = MD5.hash' bs :: MD5Digest -bf_string_hash [Str text] = return $ hash $ encodeUtf8 text +bf_string_hash = Builtin "string_hash" 1 (Just 1) + [TStr] TStr $ \[Str text] -> + return $ hash $ encodeUtf8 (Str.toText text) -bf_binary_hash [Str bin_string] = hash `liftM` binaryString bin_string +bf_binary_hash = Builtin "binary_hash" 1 (Just 1) + [TStr] TStr $ \[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] = +bf_is_member = Builtin "is_member" 2 (Just 2) + [TAny, TLst] TInt $ \[value, Lst list] -> return $ Int $ maybe 0 (fromIntegral . succ) $ V.findIndex (`equal` value) list -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_listinsert = Builtin "listinsert" 2 (Just 3) + [TLst, TAny, TInt] TLst $ \(Lst list : value : optional) -> + let [Int index] = defaults optional [Int 1] + in return $ Lst $ listInsert list (fromIntegral index - 1) value -bf_listappend (Lst list : value : optional) = - return $ Lst $ listInsert list (fromIntegral index) value - where [Int index] = defaults optional [Int $ fromIntegral $ V.length list] +bf_listappend = Builtin "listappend" 2 (Just 3) + [TLst, TAny, TInt] TLst $ \(Lst list : value : optional) -> + let [Int index] = defaults optional [Int $ fromIntegral $ V.length list] + in return $ Lst $ listInsert list (fromIntegral index) value -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_listdelete = Builtin "listdelete" 2 (Just 2) + [TLst, TInt] TLst $ \[Lst list, Int index] -> + let index' = fromIntegral index + in if index' < 1 || index' > V.length list then raise E_RANGE + else return $ Lst $ listDelete list (index' - 1) -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_listset = Builtin "listset" 3 (Just 3) + [TLst, TAny, TInt] TLst $ \[Lst list, value, Int index] -> + let index' = fromIntegral index + in if index' < 1 || index' > V.length list then raise E_RANGE + else return $ Lst $ listSet list (index' - 1) value -bf_setadd [Lst list, value] = +bf_setadd = Builtin "setadd" 2 (Just 2) + [TLst, TAny] TLst $ \[Lst list, value] -> return $ Lst $ if value `V.elem` list then list else V.snoc list value -bf_setremove [Lst list, value] = +bf_setremove = Builtin "setremove" 2 (Just 2) + [TLst, TAny] TLst $ \[Lst list, value] -> return $ Lst $ case V.elemIndex value list of Nothing -> list Just index -> listDelete list (fromIntegral index) diff --git a/src/MOO/Command.hs b/src/MOO/Command.hs --- a/src/MOO/Command.hs +++ b/src/MOO/Command.hs @@ -18,21 +18,24 @@ import Control.Monad (liftM, void, foldM, join) import Data.Char (isSpace, isDigit) -import Data.Monoid +import Data.Monoid (Monoid(mempty, mappend, mconcat), First(First, getFirst)) import Data.Text (Text) -import Text.Parsec +import Text.Parsec (parse, try, many, many1, char, anyChar, noneOf, spaces, + satisfy, between, eof, (<|>)) 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 {-# SOURCE #-} MOO.Connection import MOO.Object +import {-# SOURCE #-} MOO.Task +import MOO.Types import MOO.Verb -import {-# SOURCE #-} MOO.Network +import qualified MOO.String as Str + commandWord :: Parser Text commandWord = do word <- many1 wordChar @@ -71,12 +74,13 @@ argstr <- T.pack `liftM` many anyChar return (verb, argstr) -matchPrep :: [Text] -> (Text, (PrepSpec, Text), Text) +matchPrep :: [StrT] -> (StrT, (PrepSpec, StrT), StrT) matchPrep = matchPrep' id prepPhrases - where matchPrep' dobj _ [] = (T.unwords $ dobj [], (PrepNone, ""), "") + where matchPrep' dobj _ [] = (Str.unwords $ dobj [], (PrepNone, ""), "") matchPrep' dobj ((spec,phrase):phrases) args - | phrase == map T.toCaseFold argsPhrase = - (T.unwords $ dobj [], (spec, T.unwords argsPhrase), T.unwords iobj) + | phrase == argsPhrase = + (Str.unwords $ dobj [], (spec, Str.unwords argsPhrase), + Str.unwords iobj) | otherwise = matchPrep' dobj phrases args where (argsPhrase, iobj) = splitAt (length phrase) args matchPrep' dobj [] (arg:args) = @@ -84,25 +88,33 @@ -- | A structure describing a player's parsed command data Command = Command { - commandVerb :: Text - , commandArgs :: [Text] - , commandArgStr :: Text - , commandDObjStr :: Text + commandVerb :: StrT + , commandArgs :: [StrT] + , commandArgStr :: StrT + , commandDObjStr :: StrT , commandPrepSpec :: PrepSpec - , commandPrepStr :: Text - , commandIObjStr :: Text + , commandPrepStr :: StrT + , commandIObjStr :: StrT } deriving Show -- | Split a typed command into words according to the MOO rules for quoting -- and escaping. -parseWords :: Text -> [Text] -parseWords argstr = args +parseWords :: Text -> [StrT] +parseWords argstr = map Str.fromText 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 +parseCommand cmd = Command { + commandVerb = Str.fromText verb + , commandArgs = args + , commandArgStr = Str.fromText argstr + , commandDObjStr = dobjstr + , commandPrepSpec = prepSpec + , commandPrepStr = prepstr + , commandIObjStr = iobjstr + } where Right (verb, argstr) = parse command "" cmd args = parseWords argstr (dobjstr, (prepSpec, prepstr), iobjstr) = matchPrep args @@ -112,8 +124,8 @@ matchObject :: ObjId -> StrT -> MOO ObjId matchObject player str - | T.null str = return nothing - | otherwise = case parse objectNumber "" str of + | Str.null str = return nothing + | otherwise = case parse objectNumber "" (Str.toText str) of Right oid -> do obj <- getObject oid case obj of @@ -122,7 +134,7 @@ Left _ -> matchObject' player str where matchObject' :: ObjId -> StrT -> MOO ObjId - matchObject' player str = case str' of + matchObject' player str = case str of "me" -> return player "here" -> maybe nothing (objectForMaybe . objectLocation) `liftM` getObject player @@ -137,8 +149,7 @@ 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 str $ IS.toList (holding `IS.union` roomContents) matchName :: StrT -> [ObjId] -> MOO ObjId matchName str = liftM (uncurry matchResult) . @@ -166,17 +177,11 @@ 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 + | str == name = ExactMatch + | str `Str.isPrefixOf` name = PrefixMatch + | otherwise = NoMatch nameMatch _ _ = NoMatch - nothing = -1 - ambiguousMatch = -2 - failedMatch = -3 - data Match = NoMatch | PrefixMatch | ExactMatch instance Monoid Match where @@ -190,6 +195,7 @@ -- for the current player, matching @dobj@ and @iobj@ objects against the -- strings in the typed command. runCommand :: Command -> MOO Value +runCommand Command { commandVerb = "" } = return zero runCommand command = do player <- getPlayer dobj <- matchObject player (commandDObjStr command) @@ -205,7 +211,7 @@ case maybeVerb of (Just oid, Just verb) -> callCommandVerb player (oid, verb) room command (dobj, iobj) - _ -> notify player "I couldn't understand that." >> return nothing + _ -> notify player "I couldn't understand that." >> return zero where locateVerb :: ObjId -> ObjId -> ObjId -> MOO (Maybe (ObjId, (ObjId, Verb))) diff --git a/src/MOO/Compiler.hs b/src/MOO/Compiler.hs --- a/src/MOO/Compiler.hs +++ b/src/MOO/Compiler.hs @@ -10,7 +10,6 @@ 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 @@ -19,13 +18,15 @@ import MOO.Builtins import MOO.Object +import qualified MOO.String as Str + -- | 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 +compileStatements (statement:rest) yield = case statement of Expression lineNumber expr -> do setLineNumber lineNumber evaluate expr @@ -39,107 +40,107 @@ compileIf ((lineNumber,cond,thens):conds) elses = do setLineNumber lineNumber - cond' <- truthOf `liftM` evaluate cond - if cond' then compile' thens + cond' <- evaluate cond + if truthOf 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 + handleDebug $ 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 + callCC $ \break -> do + pushLoopContext (Just var) (Continuation break) + loop var elts (compile' body) + popContext + return zero compile' rest - where var' = T.toCaseFold var - loop var (elt:elts) body = runTick >> do + where loop var (elt:elts) body = runTick >> do storeVariable var elt callCC $ \continue -> do setLoopContinue (Continuation continue) - body + void body loop var elts body - loop _ [] _ = return nothing + loop _ [] _ = return () 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 + handleDebug $ 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 + callCC $ \break -> do + pushLoopContext (Just var) (Continuation break) + loop var ty s e (compile' body) + popContext + return zero compile' rest - where var' = T.toCaseFold var - loop var ty i end body - | i > end = return nothing + where loop var ty i end body + | i > end = return () | otherwise = runTick >> do storeVariable var (ty i) callCC $ \continue -> do setLoopContinue (Continuation continue) - body + void 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 + pushLoopContext var (Continuation break) + loop lineNumber var (evaluate expr) (compile' body) popContext compile' rest - where var' = fmap T.toCaseFold var - loop lineNumber var expr body = runTick >> do + where 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 + void 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 + handleDebug $ do + setLineNumber lineNumber + delay' <- evaluate delay + usecs <- case delay' of + Int secs + | secs < 0 -> raise E_INVARG + | otherwise -> return (fromIntegral secs * 1000000) + Flt secs + | secs < 0 -> raise E_INVARG + | otherwise -> return (ceiling $ secs * 1000000) + _ -> raise E_TYPE - world <- getWorld - gen <- newRandomGen - taskId <- liftSTM $ newTaskId world gen - case var of - Just ident -> void $ storeVariable ident (Int $ fromIntegral taskId) - Nothing -> return () + world <- getWorld + gen <- newRandomGen + let taskId = newTaskId world gen + maybe return storeVariable var (Int $ fromIntegral taskId) - forkTask taskId usecs (compileStatements body return) + forkTask taskId usecs (compileStatements body return) + return zero compile' rest - Break name -> breakLoop (fmap T.toCaseFold name) - Continue name -> continueLoop (fmap T.toCaseFold name) + Break name -> breakLoop name + Continue name -> continueLoop name - Return _ Nothing -> runTick >> yield nothing + Return _ Nothing -> runTick >> yield zero Return lineNumber (Just expr) -> runTick >> do setLineNumber lineNumber yield =<< evaluate expr @@ -156,9 +157,13 @@ 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 + dispatch ((codes, var, handler):next) except@Exception { + exceptionCode = code + , exceptionMessage = message + , exceptionValue = value + , exceptionCallStack = Stack errorFrames + } + | maybe True (code `elem`) codes = do Stack currentFrames <- gets stack let traceback = formatFrames True $ take stackLen errorFrames stackLen = length errorFrames - length currentFrames + 1 @@ -172,10 +177,10 @@ let finally' = compile' finally pushTryFinallyContext finally' - compile' body `catchException` \except callStack -> do + compile' body `catchException` \except -> do popContext finally' - passException except callStack + passException except popContext finally' @@ -184,28 +189,22 @@ 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 +compileStatements [] _ = return zero -- | 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 +evaluate expr@Variable{} = handleDebug $ fetch (lValue expr) +evaluate expr = runTick >>= \_ -> handleDebug $ case expr of List args -> fromList `liftM` expand args - PropRef{} -> fetch (lValue expr) + PropertyRef{} -> fetch (lValue expr) Assign what expr -> store (lValue what) =<< evaluate expr - ScatterAssign items expr -> do + Scatter items expr -> do expr' <- evaluate expr case expr' of Lst v -> scatterAssign items v @@ -213,18 +212,16 @@ VerbCall target vname args -> do target' <- evaluate target - oid <- case target' of - Obj oid -> return oid - _ -> raise E_TYPE + vname' <- evaluate vname + args' <- expand args - vname' <- evaluate vname - name <- case vname' of - Str name -> return name - _ -> raise E_TYPE + (oid, name) <- case (target', vname') of + (Obj oid, Str name) -> return (oid, name) + (_ , _ ) -> raise E_TYPE - callVerb oid oid name =<< expand args + callVerb oid oid name args' - BuiltinFunc func args -> callBuiltin (T.toCaseFold func) =<< expand args + BuiltinFunc func args -> callBuiltin func =<< expand args a `Plus` b -> binary plus a b a `Minus` b -> binary minus a b @@ -233,14 +230,16 @@ 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 + Negate x -> do + x' <- evaluate x + case x' of + Int z -> return (Int $ negate z) + Flt z -> return (Flt $ negate z) + _ -> raise E_TYPE - Conditional c x y -> do c' <- evaluate c - evaluate $ if truthOf c' then x else y + Conditional cond x y -> do + cond' <- evaluate cond + evaluate $ if truthOf cond' then x else y x `And` y -> do x' <- evaluate x if truthOf x' then evaluate y else return x' @@ -249,12 +248,12 @@ 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 + x `CompareEQ` y -> equality (==) x y + x `CompareNE` y -> equality (/=) x y + x `CompareLT` y -> comparison (<) x y + x `CompareLE` y -> comparison (<=) x y + x `CompareGT` y -> comparison (>) x y + x `CompareGE` y -> comparison (>=) x y Index{} -> fetch (lValue expr) Range{} -> fetch (lValue expr) @@ -273,17 +272,19 @@ codes' <- case codes of ANY -> return Nothing Codes args -> Just `liftM` expand args - evaluate expr `catchException` \except@(Exception code _ _) callStack -> + evaluate expr `catchException` \except@Exception { exceptionCode = code } -> if maybe True (code `elem`) codes' then maybe (return code) evaluate dv - else passException except callStack + else passException except 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 @@ -303,11 +304,10 @@ 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 + maybe (search False obj) (return . ($ obj)) $ builtinProperty name - search skipPermCheck obj = do - prop <- getProperty obj name' + where search skipPermCheck obj = do + prop <- getProperty obj name unless (skipPermCheck || propertyPermR prop) $ checkPermission (propertyOwner prop) case propertyValue prop of @@ -315,24 +315,23 @@ Nothing -> do parentObj <- maybe (return Nothing) getObject (objectParent obj) maybe (error $ "No inherited value for property " ++ - T.unpack name) (search True) parentObj + Str.toString 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 + 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) + Str t -> return (Str.length t) _ -> raise E_TYPE } @@ -340,7 +339,8 @@ 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 +checkStrRange t i = when (i < 1 || + t `Str.compareLength` i == LT) $ raise E_RANGE checkIndex :: Value -> MOO Int checkIndex (Int i) = return (fromIntegral i) @@ -355,22 +355,21 @@ lValue :: Expr -> LValue lValue (Variable var) = LValue fetch store change - where var' = T.toCaseFold var - fetch = fetchVariable var' - store = storeVariable var' + where fetch = fetchVariable var + store = storeVariable var change = do value <- fetch return (value, store) -lValue (PropRef objExpr nameExpr) = LValue fetch store change +lValue (PropertyRef 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? + refs <- getRefs + value <- fetchProperty refs + return (value, storeProperty refs) getRefs = do objRef <- evaluate objExpr @@ -395,17 +394,17 @@ 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)) + return (Str $ Str.singleton $ t `Str.index` (index' - 1)) _ -> raise E_TYPE return (value', changeValue value index' changeExpr) changeValue (Lst v) index changeExpr newValue = - changeExpr $ Lst $ listSet v index newValue + changeExpr $ Lst $ listSet v (index - 1) 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] + when (c `Str.compareLength` 1 /= EQ) $ raise E_INVARG + let (s, r) = Str.splitAt (index - 1) t + changeExpr $ Str $ Str.concat [s, c, Str.tail r] changeValue _ _ _ _ = raise E_TYPE @@ -415,14 +414,14 @@ (start', end') <- getIndices value if start' > end' then case value of - Lst{} -> return $ Lst V.empty - Str{} -> return $ Str T.empty + Lst{} -> return emptyList + Str{} -> return emptyString _ -> 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 + return $ Str $ Str.take len $ Str.drop (start' - 1) t _ -> raise E_TYPE getIndices value = withIndexLength value $ do @@ -448,13 +447,13 @@ changeValue (Str t) start end changeExpr (Str r) = do when (end < 0 || - t `T.compareLength` (start - 1) == LT) $ raise E_RANGE + t `Str.compareLength` (start - 1) == LT) $ raise E_RANGE let pre = substr t 1 (start - 1) - post = substr t (end + 1) (T.length t) + post = substr t (end + 1) (Str.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] + | e < s = Str.empty + | otherwise = Str.take (e - s + 1) $ Str.drop (s - 1) t + changeExpr $ Str $ Str.concat [pre, r, post] changeValue _ _ _ _ _ = raise E_TYPE @@ -468,7 +467,7 @@ value <- fetch return (value, store) -scatterAssign :: [ScatItem] -> LstT -> MOO Value +scatterAssign :: [ScatterItem] -> LstT -> MOO Value scatterAssign items args = do when (nargs < nreqs || (not haveRest && nargs > ntarg)) $ raise E_ARGS walk items args (nargs - nreqs) @@ -493,24 +492,23 @@ walk (item:items) args noptAvail = case item of ScatRequired var -> do - assign var (V.head args) + storeVariable var (V.head args) walk items (V.tail args) noptAvail ScatOptional var opt - | noptAvail > 0 -> do assign var (V.head args) + | noptAvail > 0 -> do storeVariable var (V.head args) walk items (V.tail args) (noptAvail - 1) | otherwise -> do - case opt of Nothing -> return () - Just expr -> void $ assign var =<< evaluate expr + case opt of + Nothing -> return () + Just expr -> void $ storeVariable var =<< evaluate expr walk items args noptAvail ScatRest var -> do let (s, r) = V.splitAt nrest args - assign var (Lst s) + storeVariable var (Lst s) walk items r noptAvail walk [] _ _ = return () - assign var = storeVariable (T.toCaseFold var) - -expand :: [Arg] -> MOO [Value] +expand :: [Argument] -> MOO [Value] expand (a:as) = case a of ArgNormal expr -> do a' <- evaluate expr (a' :) `liftM` expand as @@ -521,34 +519,36 @@ 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 +Int a `plus` Int b = return $ Int (a + b) +Flt a `plus` Flt b = checkFloat (a + b) +Str a `plus` Str b = return $ Str (a `Str.append` b) +_ `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 +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 +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 +Int _ `divide` Int 0 = raise E_DIV +Int a `divide` Int (-1) -- avoid arithmetic overflow + | a == minBound = return $ Int a +Int a `divide` Int b = return $ Int (a `quot` b) +Flt _ `divide` Flt 0 = raise E_DIV +Flt a `divide` Flt b = checkFloat (a / b) +_ `divide` _ = raise E_TYPE 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 +Int _ `remain` Int 0 = raise E_DIV +Int a `remain` Int b = return $ Int (a `rem` b) +Flt _ `remain` Flt 0 = raise E_DIV +Flt a `remain` Flt b = checkFloat (a `fmod` b) +_ `remain` _ = raise E_TYPE fmod :: FltT -> FltT -> FltT x `fmod` y = x - fromIntegral n * y @@ -559,16 +559,14 @@ | otherwise = round q power :: Value -> Value -> MOO Value -(Int a) `power` (Int b) +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 + 1 -> return $ Int 1 + _ -> return $ Int 0 +Flt a `power` Int b = checkFloat (a ^^ b) +Flt a `power` Flt b = checkFloat (a ** b) +_ `power` _ = raise E_TYPE diff --git a/src/MOO/Connection.hs b/src/MOO/Connection.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Connection.hs @@ -0,0 +1,729 @@ + +{-# LANGUAGE OverloadedStrings #-} + +module MOO.Connection ( + Connection + , ConnectionHandler + , connectionHandler + + , firstConnectionId + + , withConnections + , withConnection + , withMaybeConnection + + , connectionName + , connectionConnectedTime + , connectionActivityTime + , connectionOutputDelimiters + + , sendToConnection + , closeConnection + + , notify + , notify' + + , bufferedOutputLength + , forceInput + , flushInput + + , bootPlayer + , bootPlayer' + + , setConnectionOption + , getConnectionOptions + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.STM (STM, TVar, TMVar, atomically, newTVar, + newEmptyTMVar, tryPutTMVar, takeTMVar, + readTVar, writeTVar, modifyTVar, swapTVar, + readTVarIO) +import Control.Concurrent.STM.TBMQueue (TBMQueue, newTBMQueue, closeTBMQueue, + readTBMQueue, writeTBMQueue, + tryReadTBMQueue, tryWriteTBMQueue, + unGetTBMQueue, isEmptyTBMQueue, + freeSlotsTBMQueue) +import Control.Exception (SomeException, try, bracket) +import Control.Monad ((<=<), join, when, unless, foldM, forever, void, liftM) +import Control.Monad.Trans (lift) +import Data.ByteString (ByteString) +import Data.Map (Map) +import Data.Maybe (fromMaybe, isNothing, fromJust) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (Decoding(..), encodeUtf8, streamDecodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (UTCTime, getCurrentTime) +import Pipes (Producer, Consumer, Pipe, await, yield, runEffect, + for, cat, (>->)) +import Pipes.Concurrent (Buffer(..), Output(..), spawn, spawn', + fromInput, toOutput) + +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V + +import MOO.Command +import MOO.Database +import MOO.Object +import MOO.Task +import MOO.Types + +import qualified MOO.String as Str + +data Connection = Connection { + connectionObject :: ObjId + , connectionPlayer :: TVar ObjId + + , connectionInput :: TBMQueue ConnectionMessage + , connectionOutput :: TBMQueue ConnectionMessage + + , connectionName :: ConnectionName + , connectionConnectedTime :: TVar (Maybe UTCTime) + , connectionActivityTime :: TVar UTCTime + + , connectionOutputDelimiters :: TVar (Text, Text) + , connectionOptions :: TVar ConnectionOptions + + , connectionReader :: TMVar Wake + , connectionDisconnect :: TMVar Disconnect + } + +data ConnectionMessage = Line Text | Binary ByteString + +data ConnectionOptions = ConnectionOptions { + optionBinaryMode :: Bool + , optionHoldInput :: Bool + , optionDisableOOB :: Bool + , optionClientEcho :: Bool + , optionFlushCommand :: Text + , optionIntrinsicCommands :: Map Text IntrinsicCommand + } + +initConnectionOptions = ConnectionOptions { + optionBinaryMode = False + , optionHoldInput = False + , optionDisableOOB = False + , optionClientEcho = True + , optionFlushCommand = ".flush" + , optionIntrinsicCommands = allIntrinsicCommands + } + +data ConnectionOption = Option { + optionName :: Id + , optionGet :: ConnectionOptions -> Value + , optionSet :: Connection -> Value -> + ConnectionOptions -> MOO ConnectionOptions + } + +coBinary = Option "binary" get set + where get = truthValue . optionBinaryMode + set _ v options = return options { optionBinaryMode = truthOf v } + +coHoldInput = Option "hold-input" get set + where get = truthValue . optionHoldInput + set _ v options = return options { optionHoldInput = truthOf v } + +coDisableOOB = Option "disable-oob" get set + where get = truthValue . optionDisableOOB + set _ v options = return options { optionDisableOOB = truthOf v } + +coClientEcho = Option "client-echo" get set + where get = truthValue . optionClientEcho + set conn v options = do + let clientEcho = truthOf v + telnetCommand = BS.pack [telnetIAC, telnetOption, telnetECHO] + telnetOption = if clientEcho then telnetWON'T else telnetWILL + liftSTM $ enqueueOutput False conn (Binary telnetCommand) + return options { optionClientEcho = clientEcho } + + where telnetIAC = 255 + telnetWILL = 251 + telnetWON'T = 252 + telnetECHO = 1 + +coFlushCommand = Option "flush-command" get set + where get = Str . Str.fromText . optionFlushCommand + set _ v options = do + let flushCommand = case v of + Str flush -> Str.toText flush + _ -> T.empty + return options { optionFlushCommand = flushCommand } + +coIntrinsicCommands = Option "intrinsic-commands" get set + where get = fromListBy (Str . Str.fromText) . M.keys . optionIntrinsicCommands + set _ v options = do + commands <- case v of + Lst vs -> foldM addCommand M.empty (V.toList vs) + Int 0 -> return M.empty + Int _ -> return allIntrinsicCommands + _ -> raise E_INVARG + + return options { optionIntrinsicCommands = commands } + + addCommand cmds value = case value of + Str cmd -> do + ic <- maybe (raise E_INVARG) return $ + M.lookup (Str.toText cmd) allIntrinsicCommands + return $ M.insert (intrinsicCommand ic) ic cmds + _ -> raise E_INVARG + +allConnectionOptions :: Map Id ConnectionOption +allConnectionOptions = M.fromList $ map assoc connectionOptions + where assoc co = (optionName co, co) + connectionOptions = [ + coBinary + , coHoldInput + , coDisableOOB + , coClientEcho + , coFlushCommand + , coIntrinsicCommands + ] + +data IntrinsicCommand = Intrinsic { + intrinsicCommand :: Text + , intrinsicFunction :: Connection -> Text -> IO () + } + +modifyOutputDelimiters :: Connection -> ((Text, Text) -> (Text, Text)) -> IO () +modifyOutputDelimiters conn = + atomically . modifyTVar (connectionOutputDelimiters conn) + +icPREFIX = Intrinsic "PREFIX" $ \conn prefix -> + modifyOutputDelimiters conn $ \(_, suffix) -> (prefix, suffix) + +icSUFFIX = Intrinsic "SUFFIX" $ \conn suffix -> + modifyOutputDelimiters conn $ \(prefix, _) -> (prefix, suffix) + +icOUTPUTPREFIX = icPREFIX { intrinsicCommand = "OUTPUTPREFIX" } +icOUTPUTSUFFIX = icSUFFIX { intrinsicCommand = "OUTPUTSUFFIX" } + +icProgram = Intrinsic ".program" $ \conn argstr -> + -- XXX verify programmer + atomically $ sendToConnection conn ".program: Not yet implemented" -- XXX + +allIntrinsicCommands :: Map Text IntrinsicCommand +allIntrinsicCommands = M.fromList $ map assoc intrinsicCommands + where assoc ic = (intrinsicCommand ic, ic) + intrinsicCommands = [ + icPREFIX + , icSUFFIX + , icOUTPUTPREFIX + , icOUTPUTSUFFIX + , icProgram + ] + +outOfBandPrefix :: Text +outOfBandPrefix = "#$#" + +outOfBandQuotePrefix :: Text +outOfBandQuotePrefix = "#$\"" + +maxQueueLength :: Int +maxQueueLength = 512 + +type ConnectionName = STM String +type ConnectionHandler = ConnectionName -> (Producer ByteString IO (), + Consumer ByteString IO ()) -> IO () + +data Disconnect = Disconnected | ClientDisconnected + +connectionHandler :: TVar World -> ObjId -> Bool -> ConnectionHandler +connectionHandler world' object printMessages connectionName (input, output) = + bracket newConnection deleteConnection $ \conn -> do + forkIO $ runConnection world' printMessages conn + + forkIO $ do + try (runEffect $ input >-> connectionRead conn) >>= + either (\err -> let _ = err :: SomeException in return ()) return + atomically $ do + tryPutTMVar (connectionDisconnect conn) ClientDisconnected + closeTBMQueue (connectionOutput conn) + + runEffect $ connectionWrite conn >-> output + atomically $ do + tryPutTMVar (connectionDisconnect conn) Disconnected + closeTBMQueue (connectionInput conn) + + where newConnection :: IO Connection + newConnection = do + now <- getCurrentTime + + atomically $ do + world <- readTVar world' + + let connectionId = nextConnectionId world + + playerVar <- newTVar connectionId + + inputQueue <- newTBMQueue maxQueueLength + outputQueue <- newTBMQueue maxQueueLength + + cTimeVar <- newTVar Nothing + aTimeVar <- newTVar now + + delimsVar <- newTVar (T.empty, T.empty) + optionsVar <- newTVar initConnectionOptions { + optionFlushCommand = defaultFlushCommand $ + serverOptions (database world) } + + readerVar <- newEmptyTMVar + disconnectVar <- newEmptyTMVar + + let connection = Connection { + connectionObject = object + , connectionPlayer = playerVar + + , connectionInput = inputQueue + , connectionOutput = outputQueue + + , connectionName = connectionName + , connectionConnectedTime = cTimeVar + , connectionActivityTime = aTimeVar + + , connectionOutputDelimiters = delimsVar + , connectionOptions = optionsVar + + , connectionReader = readerVar + , connectionDisconnect = disconnectVar + } + nextId = succConnectionId + (`M.member` connections world) connectionId + + writeTVar world' world { + connections = M.insert connectionId connection + (connections world) + , nextConnectionId = nextId + } + + writeTBMQueue inputQueue (Line T.empty) + + return connection + + deleteConnection :: Connection -> IO () + deleteConnection conn = do + atomically $ do + connectionId <- readTVar (connectionPlayer conn) + modifyTVar world' $ \world -> + world { connections = M.delete connectionId (connections world) } + + how <- atomically $ takeTMVar (connectionDisconnect conn) + player <- readTVarIO (connectionPlayer conn) + let systemVerb = case how of + Disconnected -> "user_disconnected" + ClientDisconnected -> "user_client_disconnected" + comp = fromMaybe zero `liftM` + callSystemVerb' object systemVerb [Obj player] Str.empty + void $ runTask =<< newTask world' player comp + +runConnection :: TVar World -> Bool -> Connection -> IO () +runConnection world' printMessages conn = loop + where loop = do + input <- atomically $ readTBMQueue (connectionInput conn) + + options <- readTVarIO (connectionOptions conn) + let processLine' + | optionDisableOOB options = processLine options + | otherwise = processLineWithOOB options + case input of + Just (Line line) -> processLine' line >> loop + Just (Binary bytes) -> processBinary bytes >> loop + Nothing -> return () + + processLineWithOOB :: ConnectionOptions -> Text -> IO () + processLineWithOOB options line + | outOfBandQuotePrefix `T.isPrefixOf` line = processLine options line' + | outOfBandPrefix `T.isPrefixOf` line = processOOB line + | otherwise = processLine options line + where line' = T.drop (T.length outOfBandQuotePrefix) line + + processOOB :: Text -> IO () + processOOB line = + void $ runServerVerb' "do_out_of_band_command" (cmdWords line) line + + processLine :: ConnectionOptions -> Text -> IO () + processLine options line = do + player <- readTVarIO (connectionPlayer conn) + if player < 0 then processUnLoggedIn line + else do + let cmd = parseCommand line + case M.lookup (Str.toText $ commandVerb cmd) + (optionIntrinsicCommands options) of + Just Intrinsic { intrinsicFunction = runIntrinsic } -> + runIntrinsic conn (Str.toText $ commandArgStr cmd) + Nothing -> do + (prefix, suffix) <- readTVarIO (connectionOutputDelimiters conn) + let maybeSend delim = unless (T.null delim) $ + sendToConnection conn delim + void $ runServerTask $ do + liftSTM $ maybeSend prefix + delayIO $ atomically $ maybeSend suffix + -- XXX it would be better to send the suffix as part of the + -- atomic command, but we don't currently have a way of + -- ensuring anything is run after an uncaught exception + result <- callSystemVerb "do_command" (cmdWords line) line + case result of + Just value | truthOf value -> return zero + _ -> runCommand cmd + + processBinary :: ByteString -> IO () + processBinary bytes = return () + + processUnLoggedIn :: Text -> IO () + processUnLoggedIn line = do + result <- runServerTask $ do + maxObject <- maxObject `liftM` getDatabase + player <- fromMaybe zero `liftM` + callSystemVerb "do_login_command" (cmdWords line) line + return $ fromList [Obj maxObject, player] + case result of + Just (Lst v) -> case V.toList v of + [Obj maxObject, Obj player] -> connectPlayer player maxObject + _ -> return () + _ -> return () + + connectPlayer :: ObjId -> ObjId -> IO () + connectPlayer player maxObject = do + now <- getCurrentTime + + maybeOldConn <- atomically $ do + writeTVar (connectionConnectedTime conn) (Just now) + + oldPlayer <- swapTVar (connectionPlayer conn) player + + world <- readTVar world' + let maybeOldConn = M.lookup player (connections world) + case maybeOldConn of + Just oldConn -> do + writeTVar (connectionPlayer oldConn) oldPlayer + + let oldObject = connectionObject oldConn + newObject = connectionObject conn + when (oldObject /= newObject) $ void $ + tryPutTMVar (connectionDisconnect oldConn) ClientDisconnected + -- print' oldConn redirectFromMsg + closeConnection oldConn + Nothing -> return () + + writeTVar world' world { + connections = M.insert player conn $ + M.delete oldPlayer (connections world) } + return maybeOldConn + + let (systemVerb, msg) + | player > maxObject = ("user_created", createMsg) + | isNothing maybeOldConn || + connectionObject (fromJust maybeOldConn) /= + connectionObject conn = ("user_connected", connectMsg) + | otherwise = ("user_reconnected", redirectToMsg) + print msg + runServerVerb systemVerb [Obj player] + + callSystemVerb :: StrT -> [Value] -> Text -> MOO (Maybe Value) + callSystemVerb vname args argstr = + callSystemVerb' object vname args (Str.fromText argstr) + where object = connectionObject conn + + runServerVerb :: StrT -> [Value] -> IO () + runServerVerb vname args = void $ runServerVerb' vname args T.empty + + runServerVerb' :: StrT -> [Value] -> Text -> IO (Maybe Value) + runServerVerb' vname args argstr = runServerTask $ + fromMaybe zero `liftM` + callSystemVerb' object vname args (Str.fromText argstr) + where object = connectionObject conn + + runServerTask :: MOO Value -> IO (Maybe Value) + runServerTask comp = do + player <- readTVarIO (connectionPlayer conn) + runTask =<< newTask world' player comp + + print' :: Connection -> (ObjId -> MOO [Text]) -> IO () + print' conn msg + | printMessages = void $ runServerTask $ + printMessage conn msg >> return zero + | otherwise = return () + + print :: (ObjId -> MOO [Text]) -> IO () + print = print' conn + + cmdWords :: Text -> [Value] + cmdWords = map Str . parseWords + +-- | Connection reading thread: deliver messages from the network to our input +-- 'TBMQueue' until EOF, handling binary mode and the flush command, if any. +connectionRead :: Connection -> Consumer ByteString IO () +connectionRead conn = do + (outputLines, inputLines) <- lift $ spawn Unbounded + (outputMessages, inputMessages) <- lift $ spawn Unbounded + + lift $ forkIO $ runEffect $ + fromInput inputLines >-> + readUtf8 >-> readLines >-> sanitize >-> lineMessage >-> + toOutput outputMessages + + lift $ forkIO $ runEffect $ fromInput inputMessages >-> deliverMessages + + forever $ do + bytes <- await + + lift $ getCurrentTime >>= + atomically . writeTVar (connectionActivityTime conn) + + options <- lift $ readTVarIO (connectionOptions conn) + lift $ atomically $ + if optionBinaryMode options + then send outputMessages (Binary bytes) + else send outputLines bytes + + where readUtf8 :: Monad m => Pipe ByteString Text m () + readUtf8 = await >>= readUtf8' . streamDecodeUtf8With lenientDecode + where readUtf8' (Some text _ continue) = do + unless (T.null text) $ yield text + await >>= readUtf8' . continue + + readLines :: Monad m => Pipe Text Text m () + readLines = readLines' TL.empty + where readLines' prev = await >>= yieldLines prev >>= readLines' + + yieldLines :: Monad m => TL.Text -> Text -> + Pipe Text Text m TL.Text + yieldLines prev text = + let concatenate = TL.append prev . TL.fromStrict + (end, rest) = T.break (== '\n') text + line = TL.toStrict (concatenate end) + line' = if not (T.null line) && T.last line == '\r' + then T.init line else line + in if T.null rest + then return $ concatenate text + else do + yield line' + yieldLines TL.empty (T.tail rest) + + sanitize :: Monad m => Pipe Text Text m () + sanitize = for cat (yield . T.filter Str.validChar) + + lineMessage :: Monad m => Pipe Text ConnectionMessage m () + lineMessage = for cat (yield . Line) + + deliverMessages :: Consumer ConnectionMessage IO () + deliverMessages = forever $ do + message <- await + case message of + Line line -> do + options <- lift $ readTVarIO (connectionOptions conn) + let flushCmd = optionFlushCommand options + lift $ if not (T.null flushCmd) && line == flushCmd + then flushQueue else enqueue message + Binary _ -> lift $ enqueue message + + enqueue :: ConnectionMessage -> IO () + enqueue = atomically . writeTBMQueue (connectionInput conn) + + flushQueue :: IO () + flushQueue = atomically $ flushInput True conn + +-- | Connection writing thread: deliver messages from our output 'TBMQueue' to +-- the network until the queue is closed, which is our signal to close the +-- connection. +connectionWrite :: Connection -> Producer ByteString IO () +connectionWrite conn = do + (outputBinary, inputBinary, sealBinary) <- lift $ spawn' Unbounded + (outputLines, inputLines, sealLines) <- lift $ spawn' Unbounded + + lift $ forkIO $ do + runEffect $ fromInput inputLines >-> writeLines >-> writeUtf8 >-> + toOutput outputBinary + atomically sealBinary + + lift $ forkIO $ processQueue outputLines outputBinary sealLines + + fromInput inputBinary + + where writeLines :: Monad m => Pipe Text Text m () + writeLines = forever $ await >>= yield >> yield "\r\n" + + writeUtf8 :: Monad m => Pipe Text ByteString m () + writeUtf8 = for cat (yield . encodeUtf8) + + processQueue :: Output Text -> Output ByteString -> STM () -> IO () + processQueue outputLines outputBinary sealLines = loop + where loop = do + message <- atomically $ readTBMQueue (connectionOutput conn) + case message of + Just (Line text) -> + atomically (send outputLines text) >> loop + Just (Binary bytes) -> + atomically (send outputBinary bytes) >> loop + Nothing -> atomically sealLines + +-- | The first un-logged-in connection ID. Avoid conflicts with #-1 +-- ($nothing), #-2 ($ambiguous_match), and #-3 ($failed_match). +firstConnectionId :: ObjId +firstConnectionId = -4 + +-- | Determine the next valid un-logged-in connection ID, making sure it +-- remains negative and doesn't pass the predicate. +succConnectionId :: (ObjId -> Bool) -> ObjId -> ObjId +succConnectionId invalid = findNext + where findNext connId + | nextId >= 0 = findNext firstConnectionId + | invalid nextId = findNext nextId + | otherwise = nextId + where nextId = connId - 1 + +-- | Do something with the 'Map' of all active connections. +withConnections :: (Map ObjId Connection -> MOO a) -> MOO a +withConnections f = f . connections =<< getWorld + +-- | Do something with the connection for given object, if any. +withMaybeConnection :: ObjId -> (Maybe Connection -> MOO a) -> MOO a +withMaybeConnection oid f = withConnections $ f . M.lookup oid + +-- | Do something with the connection for the given object, raising 'E_INVARG' +-- if no such connection exists. +withConnection :: ObjId -> (Connection -> MOO a) -> MOO a +withConnection oid = withMaybeConnection oid . maybe (raise E_INVARG) + +enqueueOutput :: Bool -> Connection -> ConnectionMessage -> STM Bool +enqueueOutput noFlush conn message = do + let queue = connectionOutput conn + result <- tryWriteTBMQueue queue message + case result of + Just False -> if noFlush then return False + else do readTBMQueue queue -- XXX count flushed lines + enqueueOutput noFlush conn message + _ -> return True + +sendToConnection :: Connection -> Text -> STM () +sendToConnection conn line = void $ enqueueOutput False conn (Line line) + +printMessage :: Connection -> (ObjId -> MOO [Text]) -> MOO () +printMessage conn msg = serverMessage conn msg >>= liftSTM + +serverMessage :: Connection -> (ObjId -> MOO [Text]) -> MOO (STM ()) +serverMessage conn msg = + mapM_ (sendToConnection conn) `liftM` msg (connectionObject conn) + +-- | Send data to a connection, flushing if necessary. +notify :: ObjId -> StrT -> MOO Bool +notify = notify' False + +-- | Send data to a connection, optionally without flushing. +notify' :: Bool -> ObjId -> StrT -> MOO Bool +notify' noFlush who what = + withMaybeConnection who . maybe (return True) $ \conn -> do + options <- liftSTM $ readTVar (connectionOptions conn) + message <- if optionBinaryMode options + then Binary `fmap` binaryString what + else return (Line $ Str.toText what) + liftSTM $ enqueueOutput noFlush conn message + +-- | Return the number of items currently buffered for output to a connection, +-- or the maximum number of items that will be buffered up for output on any +-- connection. +bufferedOutputLength :: Maybe Connection -> STM Int +bufferedOutputLength Nothing = return maxQueueLength +bufferedOutputLength (Just conn) = + (maxQueueLength -) `fmap` freeSlotsTBMQueue (connectionOutput conn) + +-- | Force a line of input for a connection. +forceInput :: Bool -> ObjId -> StrT -> MOO () +forceInput atFront oid line = + withConnection oid $ \conn -> do + let queue = connectionInput conn + message = Line (Str.toText line) + success <- liftSTM $ + if atFront then unGetTBMQueue queue message >> return True + else fromMaybe True `fmap` tryWriteTBMQueue queue message + unless success $ raise E_QUOTA + +-- | Flush a connection's input queue, optionally showing what was flushed. +flushInput :: Bool -> Connection -> STM () +flushInput showMessages conn = do + let queue = connectionInput conn + notify = when showMessages . void . enqueueOutput False conn . Line + empty <- isEmptyTBMQueue queue + if empty then notify ">> No pending input to flush..." + else do notify ">> Flushing the following pending input:" + flushQueue queue notify + notify ">> (Done flushing)" + + where flushQueue queue notify = loop + where loop = do + item <- join `fmap` tryReadTBMQueue queue + case item of + Just (Line line) -> do + notify $ ">> " <> line + loop + Just (Binary _) -> do + notify ">> * [binary data]" + loop + Nothing -> return () + +-- | Initiate the closing of a connection by closing its output queue. +closeConnection :: Connection -> STM () +closeConnection = closeTBMQueue . connectionOutput + +-- | Close the connection associated with an object. +bootPlayer :: ObjId -> MOO () +bootPlayer = bootPlayer' False + +-- | Close the connection associated with an object, with message varying on +-- whether the object is being recycled. +bootPlayer' :: Bool -> ObjId -> MOO () +bootPlayer' recycled oid = + withMaybeConnection oid . maybe (return ()) $ \conn -> do + printMessage conn $ if recycled then recycleMsg else bootMsg + liftSTM $ closeConnection conn + modifyWorld $ \world -> world { connections = + M.delete oid (connections world) } + return () + +withConnectionOptions :: ObjId -> (ConnectionOptions -> MOO a) -> MOO a +withConnectionOptions oid f = + withConnection oid $ f <=< liftSTM . readTVar . connectionOptions + +modifyConnectionOptions :: ObjId -> (Connection -> ConnectionOptions -> + MOO ConnectionOptions) -> MOO () +modifyConnectionOptions oid f = + withConnection oid $ \conn -> do + let optionsVar = connectionOptions conn + options <- liftSTM (readTVar optionsVar) + liftSTM . writeTVar optionsVar =<< f conn options + +-- | Set a connection option for an active connection. +setConnectionOption :: ObjId -> Id -> Value -> MOO () +setConnectionOption oid option value = + modifyConnectionOptions oid $ \conn options -> do + option <- maybe (raise E_INVARG) return $ + M.lookup option allConnectionOptions + optionSet option conn value options + +-- | Return a 'Map' of all currently set connection options for a connection. +getConnectionOptions :: ObjId -> MOO (Map Id Value) +getConnectionOptions oid = + withConnectionOptions oid $ \options -> + let optionValue option = optionGet option options + in return $ M.map optionValue allConnectionOptions + +msgFor :: Id -> [Text] -> ObjId -> MOO [Text] +msgFor msg def oid + | oid == systemObject = systemMessage + | otherwise = getServerMessage oid msg systemMessage + where systemMessage = getServerMessage systemObject msg (return def) + +bootMsg = msgFor "boot_msg" ["*** Disconnected ***"] +connectMsg = msgFor "connect_msg" ["*** Connected ***"] +createMsg = msgFor "create_msg" ["*** Created ***"] +recycleMsg = msgFor "recycle_msg" ["*** Recycled ***"] +redirectFromMsg = msgFor "redirect_from_msg" + ["*** Redirecting connection to new port ***"] +redirectToMsg = msgFor "redirect_to_msg" + ["*** Redirecting old connection to this port ***"] +serverFullMsg = msgFor "server_full_msg" + [ "*** Sorry, but the server cannot accept any more connections right now." + , "*** Please try again later." ] diff --git a/src/MOO/Connection.hs-boot b/src/MOO/Connection.hs-boot new file mode 100644 --- /dev/null +++ b/src/MOO/Connection.hs-boot @@ -0,0 +1,22 @@ +-- -*- Haskell -*- + +module MOO.Connection ( + Connection + , firstConnectionId + , sendToConnection + , notify + , bootPlayer + ) where + +import Control.Concurrent.STM (STM) +import Data.Text (Text) + +import {-# SOURCE #-} MOO.Task (MOO) +import MOO.Types (ObjId, StrT) + +data Connection + +firstConnectionId :: ObjId +sendToConnection :: Connection -> Text -> STM () +notify :: ObjId -> StrT -> MOO Bool +bootPlayer :: ObjId -> MOO () diff --git a/src/MOO/Database.hs b/src/MOO/Database.hs --- a/src/MOO/Database.hs +++ b/src/MOO/Database.hs @@ -1,42 +1,48 @@ {-# LANGUAGE OverloadedStrings #-} -module MOO.Database ( Database - , ServerOptions(..) - , serverOptions - , initDatabase - , systemObject - , dbObjectRef - , dbObject - , maxObject - , resetMaxObject - , setObjects - , addObject - , modifyObject - , allPlayers - , setPlayer - , getServerOption - , getServerOption' - , loadServerOptions - ) where +module MOO.Database ( + Database + , ServerOptions(..) + , serverOptions + , initDatabase + , dbObjectRef + , dbObject + , maxObject + , resetMaxObject + , setObjects + , addObject + , deleteObject + , modifyObject + , allPlayers + , setPlayer + , getServerOption + , getServerOption' + , loadServerOptions + , getServerMessage + ) where -import Control.Concurrent.STM +import Control.Concurrent.STM (STM, TVar, newTVarIO, newTVar, + readTVar, writeTVar) import Control.Monad (forM, liftM) import Data.Monoid ((<>)) import Data.Vector (Vector) import Data.IntSet (IntSet) import Data.Set (Set) +import Data.Text (Text) 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 {-# SOURCE #-} MOO.Builtins (builtinFunctions) import MOO.Object import MOO.Task -import {-# SOURCE #-} MOO.Builtins (builtinFunctions) +import MOO.Types +import qualified MOO.String as Str + data Database = Database { objects :: Vector (TVar (Maybe Object)) , players :: IntSet @@ -68,7 +74,7 @@ where findLastValid oid | oid >= 0 = dbObject oid db >>= maybe (findLastValid $ oid - 1) (return . const oid) - | otherwise = return (-1) + | otherwise = return nothing setObjects :: [Maybe Object] -> Database -> IO Database setObjects objs db = do @@ -80,6 +86,12 @@ objTVar <- newTVar (Just obj) return db { objects = V.snoc (objects db) objTVar } +deleteObject :: ObjId -> Database -> STM () +deleteObject oid db = + case dbObjectRef oid db of + Just objTVar -> writeTVar objTVar Nothing + Nothing -> return () + modifyObject :: ObjId -> Database -> (Object -> STM Object) -> STM () modifyObject oid db f = case dbObjectRef oid db of @@ -99,69 +111,66 @@ 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 +setPlayer yesno oid db = db { players = change oid (players db) } + where change = if yesno then IS.insert else IS.delete data ServerOptions = Options { bgSeconds :: IntT - -- The number of seconds allotted to background tasks. + -- ^ The number of seconds allotted to background tasks , bgTicks :: IntT - -- The number of ticks allotted to background tasks. + -- ^ 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. + -- ^ 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. + , defaultFlushCommand :: Text + -- ^ The initial setting of each new connection’s flush command , fgSeconds :: IntT - -- The number of seconds allotted to foreground tasks. + -- ^ The number of seconds allotted to foreground tasks , fgTicks :: IntT - -- The number of ticks allotted to foreground tasks. + -- ^ The number of ticks allotted to foreground tasks , maxStackDepth :: IntT - -- The maximum number of levels of nested verb calls. + -- ^ The maximum number of levels of nested verb calls , queuedTaskLimit :: Maybe IntT - -- The default maximum number of tasks a player can have. + -- ^ 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. + -- ^ 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. + -- ^ 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. + -- ^ Restrict reading of built-in property to wizards , protectFunction :: Set Id - -- Restrict use of built-in function to wizards. + -- ^ Restrict use of built-in function to wizards , supportNumericVerbnameStrings :: Bool - -- Enables use of an obsolete verb-naming mechanism. + -- ^ Enables use of an obsolete verb-naming mechanism } -systemObject :: ObjId -systemObject = 0 +getServerOption :: Id -> MOO (Maybe Value) +getServerOption = getServerOption' systemObject +getServerOption' :: ObjId -> Id -> MOO (Maybe Value) +getServerOption' oid option = getServerOptions oid >>= ($ option) + getServerOptions :: ObjId -> MOO (Id -> MOO (Maybe Value)) getServerOptions oid = do serverOptions <- readProperty oid "server_options" return $ case serverOptions of - Just (Obj oid) -> readProperty oid + Just (Obj oid) -> readProperty oid . fromId _ -> 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_" <>) @@ -222,8 +231,9 @@ _ -> 5 , defaultFlushCommand = case defaultFlushCommand of - Just (Str cmd) -> cmd - _ -> ".flush" + Just (Str cmd) -> Str.toText cmd + Just _ -> "" + Nothing -> ".flush" , supportNumericVerbnameStrings = case supportNumericVerbnameStrings of Just v -> truthOf v @@ -235,3 +245,17 @@ db <- getDatabase putDatabase db { serverOptions = options } + +getServerMessage :: ObjId -> Id -> MOO [Text] -> MOO [Text] +getServerMessage oid msg def = do + maybeValue <- getServerOption' oid msg + case maybeValue of + Just (Str s) -> return [Str.toText s] + Just (Lst v) -> maybe (return []) return $ strings (V.toList v) + Just _ -> return [] + Nothing -> def + where strings :: [Value] -> Maybe [Text] + strings (v:vs) = case v of + Str s -> (Str.toText s :) `fmap` strings vs + _ -> Nothing + strings [] = Just [] diff --git a/src/MOO/Database.hs-boot b/src/MOO/Database.hs-boot --- a/src/MOO/Database.hs-boot +++ b/src/MOO/Database.hs-boot @@ -1,25 +1,23 @@ -- -*- Haskell -*- module MOO.Database ( Database - , systemObject , serverOptions , maxStackDepth , getServerOption' , dbObject , modifyObject + , loadServerOptions ) where import Control.Concurrent.STM (STM) -import MOO.Types import {-# SOURCE #-} MOO.Object (Object) import {-# SOURCE #-} MOO.Task (MOO) +import MOO.Types data Database data ServerOptions -systemObject :: ObjId - serverOptions :: Database -> ServerOptions maxStackDepth :: ServerOptions -> IntT @@ -27,3 +25,5 @@ dbObject :: ObjId -> Database -> STM (Maybe Object) modifyObject :: ObjId -> Database -> (Object -> STM Object) -> STM () + +loadServerOptions :: MOO () diff --git a/src/MOO/Database/LambdaMOO.hs b/src/MOO/Database/LambdaMOO.hs --- a/src/MOO/Database/LambdaMOO.hs +++ b/src/MOO/Database/LambdaMOO.hs @@ -1,35 +1,65 @@ -module MOO.Database.LambdaMOO ( loadLMDatabase ) where +{-# LANGUAGE OverloadedStrings #-} -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 +module MOO.Database.LambdaMOO ( loadLMDatabase, saveLMDatabase ) where + +import Control.Concurrent.STM (STM, atomically, readTVar, writeTVar) +import Control.Monad (unless, when, forM, forM_, join, liftM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, runReaderT, local, asks, ask) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Writer (WriterT, execWriterT, tell) +import Data.Array (Array, listArray, inRange, bounds, (!), elems, assocs) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Data.IntSet (IntSet) -import System.IO (hFlush, stdout) +import Data.List (sort, foldl', elemIndex) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Builder (Builder, toLazyText, + fromLazyText, fromString, singleton) +import Data.Text.Lazy.Builder.Int (decimal) +import Data.Text.Lazy.Builder.RealFloat (realFloat) +import Data.Word (Word) +import System.IO (Handle, hFlush, stdout, withFile, IOMode(..), + hSetBuffering, BufferMode(..), + hSetNewlineMode, NewlineMode(..), Newline(..), + hSetEncoding, utf8) +import Text.Parsec (ParseError, ParsecT, runParserT, string, count, + getState, putState, many1, oneOf, manyTill, anyToken, + digit, char, option, try, lookAhead, (<|>), ()) +import Text.Parsec.Text.Lazy () -import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM import qualified Data.IntSet as IS +import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TL +import qualified Data.Vector as V import MOO.Database import MOO.Object import MOO.Verb import MOO.Types import MOO.Parser +import MOO.Unparser import MOO.Compiler +import qualified MOO.String as Str + {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} +withDBFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a +withDBFile dbFile mode io = withFile dbFile mode $ \handle -> do + hSetBuffering handle (BlockBuffering Nothing) + hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = LF } + hSetEncoding handle utf8 + io handle + loadLMDatabase :: FilePath -> IO (Either ParseError Database) -loadLMDatabase dbFile = do - contents <- readFile dbFile +loadLMDatabase dbFile = withDBFile dbFile ReadMode $ \handle -> do + contents <- TL.hGetContents handle runReaderT (runParserT lmDatabase initDatabase dbFile contents) initDBEnv -type DBParser = ParsecT String Database (ReaderT DBEnv IO) +type DBParser = ParsecT Text Database (ReaderT DBEnv IO) data DBEnv = DBEnv { input_version :: Word @@ -119,8 +149,8 @@ data VerbDef = VerbDef { vbName :: String , vbOwner :: ObjId - , vbPerms :: IntT - , vbPrep :: IntT + , vbPerms :: Int + , vbPrep :: Int } type PropDef = String @@ -172,7 +202,7 @@ mkProperty :: Bool -> PropDef -> PropVal -> Property mkProperty inherited propdef propval = initProperty { - propertyName = T.pack propdef + propertyName = Str.fromString propdef , propertyValue = either (const Nothing) id $ valueFromVar (propVar propval) , propertyInherited = inherited @@ -184,7 +214,7 @@ mkVerb :: VerbDef -> Verb mkVerb def = initVerb { - verbNames = T.pack $ vbName def + verbNames = Str.fromString $ vbName def , verbOwner = vbOwner def , verbPermR = vbPerms def .&. vf_read /= 0 , verbPermW = vbPerms def .&. vf_write /= 0 @@ -220,8 +250,8 @@ objectParent = maybeObject (objParent def) , objectChildren = IS.fromList $ objectTrail dbArray def objChild objSibling - , objectName = T.pack $ objName def - , objectOwner = objOwner def + , objectName = Str.fromString $ objName def + , objectOwner = objOwner def , objectLocation = maybeObject (objLocation def) , objectContents = IS.fromList $ objectTrail dbArray def objContents objNext @@ -258,15 +288,18 @@ where doesNotExist what = what ++ " for program " ++ desc ++ " does not exist" desc = "#" ++ show oid ++ ":" ++ show vnum +integer :: DBParser Integer +integer = signed (read `fmap` many1 digit) + unsignedInt :: DBParser Word -unsignedInt = fmap read $ many1 digit +unsignedInt = read `fmap` many1 digit signedInt :: DBParser Int -signedInt = fmap fromIntegral $ signed unsignedInt +signedInt = signed (read `fmap` many1 digit) signed :: (Num a) => DBParser a -> DBParser a signed parser = negative <|> parser - where negative = char '-' >> fmap negate parser + where negative = char '-' >> negate `fmap` parser line :: DBParser a -> DBParser a line parser = do @@ -275,10 +308,10 @@ return x read_num :: DBParser IntT -read_num = line (signed (fmap read $ many1 digit)) "num" +read_num = line (fmap fromInteger integer) "num" read_objid :: DBParser ObjId -read_objid = fmap fromIntegral read_num "objid" +read_objid = line (fmap fromInteger integer) "objid" read_float :: DBParser FltT read_float = line (fmap read $ many1 $ oneOf "-0123456789.eE+") "float" @@ -346,8 +379,8 @@ return VerbDef { vbName = name , vbOwner = owner - , vbPerms = perms - , vbPrep = prep + , vbPerms = fromIntegral perms + , vbPrep = fromIntegral prep } read_propdef :: DBParser PropDef @@ -378,7 +411,7 @@ valueFromVar :: LMVar -> Either LMVar (Maybe Value) valueFromVar LMClear = Right Nothing -valueFromVar (LMStr str) = Right $ Just (Str $ T.pack str) +valueFromVar (LMStr str) = Right $ Just (Str $ Str.fromString str) valueFromVar (LMObj obj) = Right $ Just (Obj $ fromIntegral obj) valueFromVar (LMErr err) = Right $ Just (Err $ toEnum $ fromIntegral err) valueFromVar (LMInt int) = Right $ Just (Int int) @@ -392,7 +425,7 @@ read_var = ( "var") $ do l <- read_num l <- if l == type_any - then do input_version <- reader input_version + then do input_version <- asks input_version return $ if input_version == dbv_prehistory then type_none else l else return l @@ -437,7 +470,7 @@ read_program = ( "program") $ do source <- try (string ".\n" >> return "") <|> manyTill anyToken (try $ string "\n.\n") - return $ MOO.Parser.parse (T.pack source) + return $ parse (T.pack source) read_task_queue :: DBParser () read_task_queue = ( "task_queue") $ do @@ -491,7 +524,7 @@ read_activ :: DBParser () read_activ = ( "activ") $ do - input_version <- reader input_version + input_version <- asks input_version version <- if input_version < dbv_float then return input_version else string "language version " >> unsignedInt unless (version < num_db_versions) $ @@ -556,25 +589,22 @@ read_bi_func_data :: DBParser () read_bi_func_data = return () -read_active_connections :: DBParser () -read_active_connections = ( "active_connections") $ eof <|> do +read_active_connections :: DBParser [(Int, Int)] +read_active_connections = ( "active_connections") $ (eof >> return []) <|> 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 () + count nconnections $ + 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) -- Enumeration constants from LambdaMOO type_int = 0 @@ -622,3 +652,173 @@ iobjShift = 6 objMask = 0x3 permMask = 0xF + +-- Database writing ... + +type DBWriter = ReaderT Database (WriterT Builder STM) + +liftSTM :: STM a -> DBWriter a +liftSTM = lift . lift + +saveLMDatabase :: FilePath -> Database -> IO () +saveLMDatabase dbFile database = withDBFile dbFile WriteMode $ \handle -> do + let writer = runReaderT writeDatabase database + stm = execWriterT writer + TL.hPutStr handle . toLazyText =<< atomically stm + +tellLn :: Builder -> DBWriter () +tellLn line = tell line >> tell (singleton '\n') + +writeDatabase :: DBWriter () +writeDatabase = do + let (before, after) = header_format_string + tell (fromString before) + tell (decimal $ num_db_versions - 1) + tellLn (fromString after) + + db <- ask + let nobjs = maxObject db + 1 + tellLn (decimal nobjs) + + objects <- listArray (0, maxObject db) `liftM` + forM [0..maxObject db] (\oid -> liftSTM $ dbObject oid db) + + let nprogs = foldl' numVerbs 0 (elems objects) + where numVerbs acc Nothing = acc + numVerbs acc (Just obj) = acc + length (objectVerbs obj) + tellLn (decimal nprogs) + + let dummy = 0 :: Int + tellLn (decimal dummy) + + let users = allPlayers db + nusers = length users + tellLn (decimal nusers) + forM_ users $ tellLn . decimal + + verbs <- forM (assocs objects) $ tellObject objects + forM_ verbs tellVerbs + + tellLn "0 clocks" + tellLn "0 queued tasks" + tellLn "0 suspended tasks" + +tellObject :: Array ObjId (Maybe Object) -> (ObjId, Maybe Object) -> + DBWriter (ObjId, [Verb]) +tellObject objects (oid, Just obj) = do + tell (singleton '#') + tellLn (decimal oid) + + tellLn (string2builder $ objectName obj) + tellLn "" -- old handles string + + let flags = flag objectIsPlayer flag_user .|. + flag objectProgrammer flag_programmer .|. + flag objectWizard flag_wizard .|. + flag objectPermR flag_read .|. + flag objectPermW flag_write .|. + flag objectPermF flag_fertile + flag test fl = if test obj then 1 `shiftL` fl else 0 :: Int + tellLn (decimal flags) + + tellLn (decimal $ objectOwner obj) + + let location = objectLocation obj + tellLn (decimal $ objectForMaybe location) + + let contents = IS.toList (objectContents obj) + tellLn (decimal $ objectForMaybe $ listToMaybe contents) + tellLn (decimal $ nextLink objects oid objectContents location) + + let parent = objectParent obj + tellLn (decimal $ objectForMaybe parent) + + let children = IS.toList (objectChildren obj) + tellLn (decimal $ objectForMaybe $ listToMaybe children) + tellLn (decimal $ nextLink objects oid objectChildren parent) + + verbs <- liftSTM $ mapM (readTVar . snd) $ objectVerbs obj + tellLn (decimal $ length verbs) + forM_ verbs $ \verb -> do + tellLn (string2builder $ verbNames verb) + tellLn (decimal $ verbOwner verb) + + let flags = flag verbPermR vf_read .|. + flag verbPermW vf_write .|. + flag verbPermX vf_exec .|. + flag verbPermD vf_debug .|. + objectArgs + flag test fl = if test verb then fl else 0 + objectArgs = fromEnum (verbDirectObject verb) `shiftL` dobjShift .|. + fromEnum (verbIndirectObject verb) `shiftL` iobjShift + tellLn (decimal flags) + + tellLn (decimal $ fromEnum (verbPreposition verb) - 2) + + definedProperties <- liftSTM $ definedProperties obj + tellLn (decimal $ length definedProperties) + forM_ definedProperties $ tellLn . string2builder + + tellLn (decimal $ HM.size $ objectProperties obj) + tellProperties objects obj (Just oid) + + return (oid, verbs) + +tellObject _ (oid, Nothing) = do + tell (singleton '#') + tell (decimal oid) + tellLn " recycled" + + return (oid, []) + +nextLink :: Array ObjId (Maybe Object) -> ObjId -> + (Object -> IntSet) -> Maybe ObjId -> ObjId +nextLink objects oid projection superior = next + where nexts = maybe [] (IS.toList . projection) $ + join $ (objects !) `fmap` superior + myIndex = elemIndex oid nexts + next = objectForMaybe $ listToMaybe $ + maybe (const []) (drop . (+ 1)) myIndex nexts + +tellProperties :: Array ObjId (Maybe Object) -> Object -> Maybe ObjId -> + DBWriter () +tellProperties objects obj (Just oid) = do + let Just definer = objects ! oid + properties <- liftSTM $ definedProperties definer + forM_ properties $ \propertyName -> do + Just property <- liftSTM $ lookupProperty obj propertyName + case propertyValue property of + Nothing -> tellLn (decimal type_clear) + Just value -> tellValue value + + tellLn (decimal $ propertyOwner property) + + let flags = flag propertyPermR pf_read .|. + flag propertyPermW pf_write .|. + flag propertyPermC pf_chown + flag test fl = if test property then fl else 0 + tellLn (decimal flags) + + tellProperties objects obj (objectParent definer) + +tellProperties _ _ Nothing = return () + +tellValue :: Value -> DBWriter () +tellValue value = case value of + Int x -> tellLn (decimal type_int) >> tellLn (decimal x) + Flt x -> tellLn (decimal _type_float) >> tellLn (realFloat x) + Str x -> tellLn (decimal _type_str) >> tellLn (string2builder x) + Obj x -> tellLn (decimal type_obj) >> tellLn (decimal x) + Err x -> tellLn (decimal type_err) >> tellLn (decimal $ fromEnum x) + Lst x -> tellLn (decimal _type_list) >> tellLn (decimal $ V.length x) >> + V.forM_ x tellValue + +tellVerbs :: (ObjId, [Verb]) -> DBWriter () +tellVerbs (oid, verbs) = forM_ (zip [0..] verbs) $ \(vnum, verb) -> do + tell (singleton '#') + tell (decimal oid) + tell (singleton ':') + tellLn $ decimal (vnum :: Int) + + tell (fromLazyText $ unparse True False $ verbProgram verb) + tellLn (singleton '.') diff --git a/src/MOO/Network.hs b/src/MOO/Network.hs --- a/src/MOO/Network.hs +++ b/src/MOO/Network.hs @@ -1,329 +1,106 @@ {-# LANGUAGE OverloadedStrings #-} -module MOO.Network ( Listener - , Connection - , PortNumber - , connectionEstablishedTime - , connectionActivityTime - , formatListener - , connectionOption - , setConnectionOption - , bootPlayer - , notify - , getConnectionName - , listen - , unlisten - , openNetworkConnection - ) where +module MOO.Network ( + Point(..) + , Listener(..) + , HostName + , PortNumber + , value2point + , point2value + , createListener + , listen + , unlisten + ) 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 Control.Concurrent.STM (TVar, atomically, modifyTVar) +import Control.Exception (try) +import Control.Monad (when) +import System.IO.Error (isPermissionError) +import MOO.Connection (connectionHandler) +import MOO.Network.Console (createConsoleListener) +import MOO.Network.TCP (HostName, PortNumber, createTCPListener) +import MOO.Object +import {-# SOURCE #-} MOO.Task 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 +data Point = Console (TVar World) | TCP (Maybe HostName) PortNumber + deriving (Eq) - , listenerPort :: PortID - , listenerObject :: ObjId +instance Ord Point where + TCP _ port1 `compare` TCP _ port2 = port1 `compare` port2 + TCP{} `compare` _ = GT + Console{} `compare` Console{} = EQ + Console{} `compare` _ = LT + +data Listener = Listener { + listenerObject :: ObjId + , listenerPoint :: Point , listenerPrintMessages :: Bool + + , listenerCancel :: IO () } initListener = Listener { - listenerSocket = undefined - , listenerThread = undefined - - , listenerPort = PortNumber 0 - , listenerObject = systemObject + listenerObject = systemObject + , listenerPoint = TCP Nothing 0 , 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 + , listenerCancel = return () } -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"] +value2point :: Value -> MOO Point +value2point value = do + world <- getWorld + case value of + Int port -> return $ TCP (bindAddress world) (fromIntegral port) + Str "Console" -> Console `fmap` getWorld' + _ -> raise E_TYPE -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 +point2value :: Point -> Value +point2value point = case point of + TCP _ port -> Int (fromIntegral port) + Console{} -> Str "Console" -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 +createListener :: TVar World -> ObjId -> Point -> Bool -> IO Listener +createListener world' object point printMessages = do + let listener = initListener { + listenerObject = object + , listenerPoint = point + , listenerPrintMessages = printMessages + } + handler = connectionHandler world' object printMessages -bootPlayer :: ObjId -> MOO () -bootPlayer oid = notyet "bootPlayer" + listener <- case point of + TCP{} -> createTCPListener listener handler + Console{} -> createConsoleListener listener handler -notify :: ObjId -> Text -> MOO () -notify who what = delayIO (putStrLn $ T.unpack what) + let canon = listenerPoint listener + atomically $ modifyTVar world' $ \world -> world { + listeners = M.insert canon listener (listeners world) } -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 + return listener -listen :: PortNumber -> ObjId -> Bool -> MOO PortNumber -listen port object printMessages = do +listen :: ObjId -> Point -> Bool -> MOO Point +listen object point printMessages = do world <- getWorld - when (M.member port $ listeners world) $ raise E_INVARG + when (point `M.member` 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 } - + result <- requestIO $ try $ createListener world' object point printMessages 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 + Left err | isPermissionError err -> raise E_PERM + | otherwise -> raise E_QUOTA + Right listener -> return (listenerPoint listener) -unlisten :: PortNumber -> MOO () -unlisten port = do +unlisten :: Point -> MOO () +unlisten point = 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 + case point `M.lookup` listeners world of + Just Listener { listenerCancel = cancelListener } -> do + putWorld world { listeners = M.delete point (listeners world) } + delayIO cancelListener 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 --- a/src/MOO/Network.hs-boot +++ b/src/MOO/Network.hs-boot @@ -1,18 +1,28 @@ -- -*- Haskell -*- -module MOO.Network ( Listener - , Connection - , PortNumber - , notify - ) where +module MOO.Network ( + Point(..) + , Listener(..) + , HostName + , createListener + , unlisten + ) where -import Data.Text (Text) -import Network (PortNumber) +import Control.Concurrent.STM (TVar) +import Network.Socket (HostName, PortNumber) +import {-# SOURCE #-} MOO.Task import MOO.Types (ObjId) -import {-# SOURCE #-} MOO.Task (MOO) -data Listener -data Connection +data Point = Console (TVar World) | TCP (Maybe HostName) PortNumber -notify :: ObjId -> Text -> MOO () +data Listener = Listener { + listenerObject :: ObjId + , listenerPoint :: Point + , listenerPrintMessages :: Bool + + , listenerCancel :: IO () + } + +createListener :: TVar World -> ObjId -> Point -> Bool -> IO Listener +unlisten :: Point -> MOO () diff --git a/src/MOO/Network/Console.hs b/src/MOO/Network/Console.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Network/Console.hs @@ -0,0 +1,187 @@ + +module MOO.Network.Console ( createConsoleListener ) where + +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.STM (STM, TVar, atomically, readTVar) +import Control.Exception (SomeException, try) +import Control.Monad (liftM, when, unless, forever) +import Control.Monad.Trans (lift) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.List ((\\), sort, nub) +import Data.Maybe (mapMaybe, catMaybes) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Pipes (Producer, Pipe, runEffect, await, yield, for, cat, (>->)) +import Pipes.ByteString (stdout) +import Pipes.Concurrent (Buffer(..), Output, spawn, send, fromInput, toOutput) +import System.Console.Haskeline (InputT, CompletionFunc, Completion(..), + runInputT, getInputLine, + setComplete, defaultSettings, + completeWordWithPrev, simpleCompletion) +import System.IO (hIsClosed, stdin) + +import qualified Data.HashMap.Strict as HM +import qualified Data.IntSet as IS +import qualified Data.Text as T +import qualified Data.Vector as V + +import MOO.Connection (ConnectionHandler) +import {-# SOURCE #-} MOO.Network (Point(..), Listener(..)) +import MOO.Object +import MOO.Task +import MOO.Types +import MOO.Verb + +import qualified MOO.String as Str + +createConsoleListener :: Listener -> ConnectionHandler -> IO Listener +createConsoleListener listener handler = do + let Console world' = listenerPoint listener + + thread <- forkIO $ acceptConnection world' handler + + return listener { listenerCancel = killThread thread } + +acceptConnection :: TVar World -> ConnectionHandler -> IO () +acceptConnection worldTVar handler = do + let connectionName :: STM String + connectionName = return "console" + + (output, input) <- spawn Unbounded + + thread <- forkIO $ runInputT defaultSettings $ runEffect $ + consoleInput >-> writeLines >-> writeUtf8 >-> toOutput output + + handler connectionName (fromInput input, stdout) + killThread thread + + eof <- try (hIsClosed stdin) >>= + either (\err -> let _ = err :: SomeException in return True) return + unless eof $ acceptConnection worldTVar handler + + where writeLines :: Monad m => Pipe Text Text m () + writeLines = forever $ await >>= yield . flip T.snoc '\n' + + writeUtf8 :: Monad m => Pipe Text ByteString m () + writeUtf8 = for cat (yield . encodeUtf8) + +consoleInput :: Producer Text (InputT IO) () +consoleInput = loop + where loop = do + maybeLine <- lift $ getInputLine "" + case maybeLine of + Just line -> yield (T.pack line) >> loop + Nothing -> return () + +{- + let completion = mooCompletion worldTVar (initialPlayer testFrame) + runInputT (setComplete completion defaultSettings) $ + repLoop worldTVar $ addFrame testFrame state + +mooCompletion :: TVar World -> ObjId -> CompletionFunc IO +mooCompletion world player = completeWordWithPrev Nothing sep completions + where sep = " \t.:$" + + completions prev word = + liftM (mkCompletions $ null prev) $ + runTask =<< newTask world player completionTask + where completionTask = + getCompletions prev word `catchException` \_ -> return zero + + mkCompletions :: Bool -> Maybe Value -> [Completion] + mkCompletions finished (Just (Lst v)) = + mapMaybe (mkCompletion finished) (V.toList v) + mkCompletions _ _ = [] + + mkCompletion :: Bool -> Value -> Maybe Completion + mkCompletion finished (Str str) = + Just $ (simpleCompletion $ Str.toString str) { isFinished = finished } + mkCompletion _ _ = Nothing + + getCompletions :: String -> String -> MOO Value + getCompletions "" word = completeCommandVerb word + getCompletions ('$':_) word = completeProperty word 0 + getCompletions ('.':prev) word = + objectForCompletion prev >>= completeProperty word + getCompletions (':':prev) word = + objectForCompletion prev >>= completeVerb word + getCompletions _ word = completeName word + + objectForCompletion :: String -> MOO ObjId + objectForCompletion prev = return nothing + + completeProperty :: String -> ObjId -> MOO Value + completeProperty word oid = do + maybeObj <- getObject oid + case maybeObj of + Nothing -> return zero + Just obj -> do + unless (objectPermR obj) $ checkPermission (objectOwner obj) + properties <- liftSTM $ mapM readTVar $ + HM.elems $ objectProperties obj + return $ mkResults word $ + map fromId builtinProperties ++ map propertyName properties + + completeVerb :: String -> ObjId -> MOO Value + completeVerb word oid = return zero + + completeCommandVerb :: String -> MOO Value + completeCommandVerb word = do + objects <- localObjects True + verbs <- concat `liftM` mapM verbsForObject objects + return $ mkResults word $ concatMap simpleVerbNames $ + filter isCommandVerb verbs + + simpleVerbNames :: Verb -> [StrT] + simpleVerbNames = map removeStar . Str.words . verbNames + where removeStar name = + let (before, after) = Str.break (== '*') name + in before `Str.append` if Str.null after + then after else Str.tail after + + isCommandVerb :: Verb -> Bool + isCommandVerb verb = + not $ verbDirectObject verb /= ObjNone && + verbPreposition verb == PrepNone && + verbIndirectObject verb /= ObjNone + + verbsForObject :: Object -> MOO [Verb] + verbsForObject obj = do + verbs <- liftSTM $ mapM (readTVar . snd) $ objectVerbs obj + case objectParent obj of + Nothing -> return verbs + Just parentOid -> do + maybeParent <- getObject parentOid + case maybeParent of + Nothing -> return verbs + Just parent -> (verbs ++) `liftM` verbsForObject parent + + completeName :: String -> MOO Value + completeName word = do + objects <- localObjects False + return $ mkResults word $ map objectName objects ++ ["me", "here"] + + localObjects :: Bool -> MOO [Object] + localObjects includeRoom = do + player <- getPlayer + maybePlayer <- getObject player + case maybePlayer of + Nothing -> return [] + Just player' -> do + let holding = objectContents player' + maybeRoom = objectLocation player' + roomContents <- + maybe (return IS.empty) + (liftM (maybe IS.empty objectContents) . getObject) maybeRoom + let oids = maybe id (:) (if includeRoom + then maybeRoom else Nothing) $ + IS.toList (holding `IS.union` roomContents) + liftM ((player' :) . catMaybes) $ + mapM getObject (oids \\ [player]) + + mkResults :: String -> [StrT] -> Value + mkResults word = stringList . sort . nub . filter isPrefix + where isPrefix name = word' `Str.isPrefixOf` name + word' = Str.fromString word +-} diff --git a/src/MOO/Network/TCP.hs b/src/MOO/Network/TCP.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Network/TCP.hs @@ -0,0 +1,109 @@ + +module MOO.Network.TCP ( + HostName + , PortNumber + , createTCPListener + ) where + +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.STM (STM, TMVar, newEmptyTMVarIO, atomically, + putTMVar, readTMVar) +import Control.Exception (SomeException, mask, try, finally, bracketOnError) +import Control.Monad (liftM, forever) +import Data.Maybe (fromMaybe) +import Network.Socket (PortNumber, Socket, SockAddr, SocketOption(..), + Family(AF_INET6), SocketType(Stream), + AddrInfo(..), AddrInfoFlag(..), NameInfoFlag(..), + HostName, ServiceName, maxListenQueue, + defaultHints, getAddrInfo, setSocketOption, + socket, bind, listen, accept, close, + getNameInfo, socketPort) +import Pipes.Network.TCP (fromSocket, toSocket) + +import MOO.Connection (ConnectionHandler) +import {-# SOURCE #-} MOO.Network (Point(..), Listener(..)) + +maxBufferSize :: Int +maxBufferSize = 1024 + +serverAddrInfo :: Maybe HostName -> PortNumber -> IO [AddrInfo] +serverAddrInfo host port = + let hints = defaultHints { + addrFlags = [AI_PASSIVE, AI_NUMERICSERV, + AI_ADDRCONFIG, AI_V4MAPPED] + , addrFamily = AF_INET6 + , addrSocketType = Stream + } + in getAddrInfo (Just hints) host (Just $ show port) + +createTCPListener :: Listener -> ConnectionHandler -> IO Listener +createTCPListener listener handler = do + let TCP host port = listenerPoint listener + (ai:_) <- serverAddrInfo host port + + let mkSocket = socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) + + bracketOnError mkSocket close $ \sock -> do + setSocketOption sock ReuseAddr 1 + + sock `bind` addrAddress ai + sock `listen` maxListenQueue + + boundPort <- socketPort sock + + acceptThread <- forkIO $ acceptConnections sock handler + + return $ listener { + listenerPoint = TCP host boundPort + , listenerCancel = killThread acceptThread >> close sock + } + +acceptConnections :: Socket -> ConnectionHandler -> IO () +acceptConnections sock handler = + forever $ mask $ \restore -> do + (conn, addr) <- accept sock + forkIO $ restore (serveConnection conn addr handler) `finally` + (try $ close conn :: IO (Either SomeException ())) + +serveConnection :: Socket -> SockAddr -> ConnectionHandler -> IO () +serveConnection sock peerAddr connectionHandler = do + setSocketOption sock KeepAlive 1 + + peerName <- addrName peerAddr + localPort <- socketPort sock + + let connectionName :: STM String + connectionName = do + peerHost <- hostName peerName + return $ "port " ++ show localPort ++ " from " ++ + peerHost ++ ", port " ++ addrPort peerName + + input = fromSocket sock maxBufferSize + output = toSocket sock + + connectionHandler connectionName (input, output) + +data AddrName = AddrName { + addrHostName :: TMVar (Maybe HostName) + , addrNumeric :: HostName + , addrPort :: ServiceName + } + +addrName :: SockAddr -> IO AddrName +addrName addr = do + nameVar <- newEmptyTMVarIO + + forkIO $ do + maybeHost <- try (fst `liftM` getNameInfo [NI_NAMEREQD] True False addr) >>= + either (\except -> let _ = except :: SomeException + in return Nothing) return + atomically $ putTMVar nameVar maybeHost + + (Just numericHost, Just port) <- + getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr + + return $ AddrName nameVar numericHost port + +hostName :: AddrName -> STM HostName +hostName addr = + return . fromMaybe (addrNumeric addr) =<< readTMVar (addrHostName addr) diff --git a/src/MOO/Object.hs b/src/MOO/Object.hs --- a/src/MOO/Object.hs +++ b/src/MOO/Object.hs @@ -8,6 +8,8 @@ , getParent , getChildren , addChild + , deleteChild + , getContents , builtinProperties , builtinProperty , isBuiltinProperty @@ -16,6 +18,9 @@ , setVerbs , lookupPropertyRef , lookupProperty + , addProperty + , addInheritedProperty + , deleteProperty , lookupVerbRef , lookupVerb , replaceVerb @@ -23,23 +28,31 @@ , deleteVerb , definedProperties , definedVerbs + + -- * Special Object Numbers + , systemObject + , nothing + , ambiguousMatch + , failedMatch ) where import Control.Arrow (second) -import Control.Concurrent.STM +import Control.Concurrent.STM (STM, TVar, newTVarIO, newTVar, readTVar) import Control.Monad (liftM) import Data.HashMap.Strict (HashMap) import Data.IntSet (IntSet) -import Data.Maybe +import Data.Maybe (isJust) import Data.List (find) +import Prelude hiding (getContents) 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 +import qualified MOO.String as Str + data Object = Object { -- Attributes objectIsPlayer :: Bool @@ -62,16 +75,6 @@ , 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 @@ -96,8 +99,8 @@ , objectParent = Nothing , objectChildren = IS.empty - , objectName = T.empty - , objectOwner = -1 + , objectName = Str.empty + , objectOwner = nothing , objectLocation = Nothing , objectContents = IS.empty , objectProgrammer = False @@ -119,10 +122,20 @@ getChildren :: Object -> [ObjId] getChildren = IS.elems . objectChildren -addChild :: Object -> ObjId -> Object -addChild obj childOid = - obj { objectChildren = IS.insert childOid (objectChildren obj) } +addChild :: ObjId -> Object -> STM Object +addChild childOid obj = + return obj { objectChildren = IS.insert childOid (objectChildren obj) } +deleteChild :: ObjId -> Object -> STM Object +deleteChild childOid obj = + return obj { objectChildren = IS.delete childOid (objectChildren obj) } + +getLocation :: Object -> ObjId +getLocation = objectForMaybe . objectLocation + +getContents :: Object -> [ObjId] +getContents = IS.elems . objectContents + data Property = Property { propertyName :: StrT , propertyValue :: Maybe Value @@ -149,13 +162,13 @@ , propertyValue = Nothing , propertyInherited = False - , propertyOwner = -1 + , propertyOwner = nothing , propertyPermR = False , propertyPermW = False , propertyPermC = False } -builtinProperties :: [StrT] +builtinProperties :: [Id] builtinProperties = [ "name", "owner" , "location", "contents" , "programmer", "wizard" @@ -165,8 +178,8 @@ 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 "location" = Just (Obj . getLocation) +builtinProperty "contents" = Just (objectList . getContents) builtinProperty "programmer" = Just (truthValue . objectProgrammer) builtinProperty "wizard" = Just (truthValue . objectWizard) builtinProperty "r" = Just (truthValue . objectPermR) @@ -175,11 +188,11 @@ builtinProperty _ = Nothing isBuiltinProperty :: StrT -> Bool -isBuiltinProperty = isJust . builtinProperty . T.toCaseFold +isBuiltinProperty = isJust . builtinProperty objectForMaybe :: Maybe ObjId -> ObjId objectForMaybe (Just oid) = oid -objectForMaybe Nothing = -1 +objectForMaybe Nothing = nothing setProperties :: [Property] -> Object -> IO Object setProperties props obj = do @@ -191,7 +204,7 @@ return (propertyKey prop, tvarProp) propertyKey :: Property -> StrT -propertyKey = T.toCaseFold . propertyName +propertyKey = propertyName setVerbs :: [Verb] -> Object -> IO Object setVerbs verbs obj = do @@ -203,7 +216,7 @@ return (verbKey verb, tvarVerb) verbKey :: Verb -> [StrT] -verbKey = T.words . T.toCaseFold . verbNames +verbKey = Str.words . verbNames lookupPropertyRef :: Object -> StrT -> Maybe (TVar Property) lookupPropertyRef obj name = HM.lookup name (objectProperties obj) @@ -212,10 +225,27 @@ lookupProperty obj name = maybe (return Nothing) (fmap Just . readTVar) $ lookupPropertyRef obj name +addProperty :: Property -> Object -> STM Object +addProperty prop obj = do + propTVar <- newTVar prop + return obj { objectProperties = + HM.insert (propertyKey prop) propTVar $ objectProperties obj } + +addInheritedProperty :: Property -> Object -> STM Object +addInheritedProperty prop obj = + flip addProperty obj $ if propertyPermC prop + then prop' { propertyOwner = objectOwner obj } + else prop' + where prop' = prop { propertyInherited = True, propertyValue = Nothing } + +deleteProperty :: StrT -> Object -> STM Object +deleteProperty name obj = + return obj { objectProperties = HM.delete name (objectProperties obj) } + lookupVerbRef :: Object -> Value -> Maybe (Int, TVar Verb) lookupVerbRef obj (Str name) = fmap (second snd) $ find matchVerb (zip [0..] $ objectVerbs obj) - where matchVerb (_, (names, _)) = verbNameMatch (T.toCaseFold name) names + where matchVerb (_, (names, _)) = verbNameMatch name names lookupVerbRef obj (Int index) | index' < 1 = Nothing | index' > numVerbs = Nothing @@ -230,9 +260,9 @@ 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 } +replaceVerb :: Int -> Verb -> Object -> STM Object +replaceVerb index verb obj = + return obj { objectVerbs = pre ++ [(verbKey verb, tvarVerb)] ++ tail post } where (pre, post) = splitAt index (objectVerbs obj) tvarVerb = snd $ head post @@ -255,3 +285,19 @@ definedVerbs obj = do verbs <- mapM (readTVar . snd) $ objectVerbs obj return $ map verbNames verbs + +-- | The system object (@#0@) +systemObject :: ObjId +systemObject = 0 + +-- | @$nothing@ (@#-1@) +nothing :: ObjId +nothing = -1 + +-- | @$ambiguous_match@ (@#-2@) +ambiguousMatch :: ObjId +ambiguousMatch = -2 + +-- | @$failed_match@ (@#-3@) +failedMatch :: ObjId +failedMatch = -3 diff --git a/src/MOO/Object.hs-boot b/src/MOO/Object.hs-boot --- a/src/MOO/Object.hs-boot +++ b/src/MOO/Object.hs-boot @@ -1,5 +1,11 @@ -- -*- Haskell -*- -module MOO.Object ( Object ) where +module MOO.Object ( Object + , nothing + ) where +import MOO.Types (ObjId) + data Object + +nothing :: ObjId diff --git a/src/MOO/Parser.hs b/src/MOO/Parser.hs --- a/src/MOO/Parser.hs +++ b/src/MOO/Parser.hs @@ -3,19 +3,25 @@ , 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 Control.Monad (when, unless, mplus) +import Control.Monad.Identity (Identity) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.Ratio ((%)) +import Data.String (fromString) +import Data.Text (Text) +import Text.Parsec (try, many, many1, digit, letter, char, anyChar, alphaNum, + oneOf, noneOf, lookAhead, notFollowedBy, chainl1, chainr1, + option, optionMaybe, choice, between, getState, modifyState, + eof, runParser, sourceLine, errorPos, (<|>), ()) +import Text.Parsec.Error (Message(Message), errorMessages, messageString) +import Text.Parsec.Text (GenParser) +import Text.Parsec.Token (GenLanguageDef(LanguageDef)) + 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 +import MOO.Types data ParserState = ParserState { dollarContext :: Int @@ -58,7 +64,7 @@ {-# ANN identifier ("HLint: ignore Use liftM" :: String) #-} -identifier = T.identifier lexer >>= return . pack +identifier = T.identifier lexer >>= return . fromString reserved = T.reserved lexer decimal = T.decimal lexer symbol = T.symbol lexer @@ -140,7 +146,7 @@ stringLiteral :: MOOParser Value stringLiteral = lexeme mooString "string literal" where mooString = between (char '"') (char '"' "terminating quote") $ - fmap (Str . pack) $ many stringChar + fmap (Str . fromString) $ many stringChar stringChar = noneOf "\"\\" <|> (char '\\' >> anyChar "") objectLiteral :: MOOParser Value @@ -200,12 +206,12 @@ 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 + equal = symbol "==" >> return CompareEQ + notEqual = symbol "!=" >> return CompareNE + lessThan = lt >> return CompareLT + lessEqual = symbol "<=" >> return CompareLE + greaterThan = gt >> return CompareGT + greaterEqual = symbol ">=" >> return CompareGE inOp = reserved "in" >> return In lt = try $ lexeme $ char '<' >> notFollowedBy (char '=') @@ -247,8 +253,8 @@ symbol "$" dollarRef <|> justDollar dollarRef = do - name <- fmap (Literal . Str) identifier - dollarVerb name <|> return (PropRef objectZero name) + name <- fmap (Literal . Str . fromId) identifier + dollarVerb name <|> return (PropertyRef objectZero name) dollarVerb name = fmap (VerbCall objectZero name) $ parens argList objectZero = Literal $ Obj 0 justDollar = do @@ -281,11 +287,11 @@ (index >>= modifiers) <|> return expr where propRef = do try $ dot >> notFollowedBy dot - ref <- parens expression <|> fmap (Literal . Str) identifier - return $ PropRef expr ref + ref <- parens expression <|> fmap (Literal . Str . fromId) identifier + return $ PropertyRef expr ref verbCall = do colon - ref <- parens expression <|> fmap (Literal . Str) identifier + ref <- parens expression <|> fmap (Literal . Str . fromId) identifier args <- parens argList return $ VerbCall expr ref args index = between (symbol "[" >> dollars succ) @@ -303,13 +309,13 @@ codes = any <|> fmap Codes nonEmptyArgList "codes" where any = reserved "ANY" >> return ANY -nonEmptyArgList :: MOOParser [Arg] +nonEmptyArgList :: MOOParser [Argument] nonEmptyArgList = arguments False -argList :: MOOParser [Arg] +argList :: MOOParser [Argument] argList = arguments True -arguments :: Bool -> MOOParser [Arg] +arguments :: Bool -> MOOParser [Argument] arguments allowEmpty | allowEmpty = commaSep arg | otherwise = commaSep1 arg @@ -317,7 +323,7 @@ splice = symbol "@" >> fmap ArgSplice expression normal = fmap ArgNormal expression -scatList :: MOOParser [ScatItem] +scatList :: MOOParser [ScatterItem] scatList = commaSep1 scat where scat = optional <|> rest <|> required optional = do @@ -328,7 +334,7 @@ rest = symbol "@" >> fmap ScatRest identifier required = fmap ScatRequired identifier -scatFromArgList :: [Arg] -> MOOParser [ScatItem] +scatFromArgList :: [Argument] -> MOOParser [ScatterItem] scatFromArgList [] = fail "Empty list in scattering assignment." scatFromArgList args = go args where go (a:as) = do @@ -340,13 +346,13 @@ return (a':as') go [] = return [] -mkScatter :: [ScatItem] -> Expr -> MOOParser Expr +mkScatter :: [ScatterItem] -> 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 + checkScatter _ [] = return $ Scatter scat expr tooMany = "More than one `@' target in scattering assignment." -- Statements @@ -437,7 +443,7 @@ modifyLoopStack f = modifyState $ \st -> st { loopStack = f $ loopStack st } pushLoopName :: Maybe Id -> MOOParser () -pushLoopName ident = modifyLoopStack $ \(s:ss) -> (fmap toCaseFold ident:s):ss +pushLoopName ident = modifyLoopStack $ \(s:ss) -> (ident : s) : ss popLoopName :: MOOParser () popLoopName = modifyLoopStack $ \(s:ss) -> tail s : ss @@ -454,9 +460,9 @@ case ident of Nothing -> when (null stack) $ fail $ "No enclosing loop for `" ++ kind ++ "' statement" - Just name -> when (fmap toCaseFold ident `notElem` stack) $ + Just name -> when (ident `notElem` stack) $ fail $ "Invalid loop name in `" ++ kind ++ "' statement: " ++ - unpack name + fromId name breakStatement :: MOOParser Statement breakStatement = do diff --git a/src/MOO/Server.hs b/src/MOO/Server.hs new file mode 100644 --- /dev/null +++ b/src/MOO/Server.hs @@ -0,0 +1,56 @@ + +{-# LANGUAGE OverloadedStrings #-} + +module MOO.Server ( startServer ) where + +import Control.Concurrent (takeMVar) +import Control.Concurrent.STM (TVar, atomically, readTVarIO, readTVar) +import Control.Monad (forM_) +import Data.Text (Text) +import Network (withSocketsDo) +import System.Posix (installHandler, sigPIPE, Handler(..)) + +import qualified Data.Map as M +import qualified Data.Text as T + +import MOO.Builtins +import MOO.Connection +import MOO.Database.LambdaMOO +import MOO.Task +import MOO.Types +import MOO.Network +import MOO.Object + +-- | Start the main server and create the first listening point. +startServer :: Maybe FilePath -> FilePath -> FilePath -> + Bool -> (TVar World -> Point) -> IO () +startServer logFile inputDB outputDB outboundNet pf = withSocketsDo $ do + either error return verifyBuiltins + installHandler sigPIPE Ignore Nothing + + db <- loadLMDatabase inputDB >>= either (error . show) return + + world' <- newWorld db outboundNet + + runTask =<< newTask world' nothing + (callSystemVerb "server_started" [] >> return zero) + + createListener world' systemObject (pf world') True + putStrLn "Listening for connections..." + + world <- readTVarIO world' + takeMVar (shutdownMessage world) >>= shutdownServer world' + +shutdownServer :: TVar World -> Text -> IO () +shutdownServer world' message = do + atomically $ do + world <- readTVar world' + + forM_ (M.elems $ connections world) $ \conn -> do + sendToConnection conn $ T.concat ["*** Shutting down: ", message, " ***"] + closeConnection conn + + -- Give connections time to close + delay 5000000 + + return () diff --git a/src/MOO/String.hs b/src/MOO/String.hs new file mode 100644 --- /dev/null +++ b/src/MOO/String.hs @@ -0,0 +1,247 @@ + +-- | Abstract MOO string type +module MOO.String ( + MOOString + + -- * Creation and elimination + , fromText + , fromBinary + , fromString + , toText + , toCaseFold + , toBinary + , toString + , toRegexp + , singleton + , empty + + -- * Basic interface + , append + , tail + , null + , length + , compareLength + , storageBytes + , equal + + -- * Transformations + , intercalate + + -- * Special folds + , concat + , concatMap + + -- * Substrings + -- ** Breaking strings + , take + , drop + , splitAt + , breakOn + , breakOnEnd + , break + -- ** Breaking into many substrings + , splitOn + -- ** Breaking into lines and words + , words + , unwords + + -- * Predicates + , validChar + , isPrefixOf + + -- * Indexing + , index + ) where + +import Data.ByteString (ByteString) +import Data.Char (isAscii, isPrint, isHexDigit, digitToInt, intToDigit) +import Data.Function (on) +import Data.Hashable (Hashable(..)) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Word (Word8) +import Foreign.Storable (sizeOf) +import Prelude hiding (tail, null, length, concat, concatMap, take, drop, + splitAt, break, words, unwords) + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Prelude + +import MOO.Builtins.Match (Regexp, newRegexp) + +type CompiledRegexp = Either (String, Int) Regexp + +data MOOString = MOOString { + toText :: Text + , toCaseFold :: Text + , toBinary :: Maybe ByteString + , length :: Int + , regexp :: CompiledRegexp + , regexpCaseless :: CompiledRegexp + } + +instance IsString MOOString where + fromString = fromText . T.pack + +instance Eq MOOString where + (==) = (==) `on` toCaseFold + +instance Ord MOOString where + compare = compare `on` toCaseFold + +instance Hashable MOOString where + hashWithSalt salt = hashWithSalt salt . toCaseFold + +instance Monoid MOOString where + mempty = empty + mappend = append + mconcat = concat + +instance Show MOOString where + show = show . toText + +fromText :: Text -> MOOString +fromText text = MOOString { + toText = text + , toCaseFold = caseFold text + , toBinary = decodeBinary text + , length = T.length text + , regexp = newRegexp text True + , regexpCaseless = newRegexp text False + } + +fromBinary :: ByteString -> MOOString +fromBinary bytes = (fromText $ encodeBinary bytes) { toBinary = Just bytes } + +toString :: MOOString -> String +toString = T.unpack . toText + +toRegexp :: Bool -- ^ case-matters + -> MOOString -> CompiledRegexp +toRegexp True = regexp +toRegexp False = regexpCaseless + +-- | Case-fold the argument, returning the same argument if the result is +-- unchanged to avoid wasting memory. +caseFold :: Text -> Text +caseFold text + | text == folded = text + | otherwise = folded + where folded = T.toCaseFold text + +-- | Encode a MOO /binary string/. +encodeBinary :: ByteString -> Text +encodeBinary = T.pack . Prelude.concatMap encode . BS.unpack + where encode :: Word8 -> String + encode b + | isAscii c && isPrint c && c /= '~' = [c] + | otherwise = ['~', hex q, hex r] + where n = fromIntegral b + c = toEnum n + (q, r) = n `divMod` 16 + hex = intToDigit + +-- | Decode a MOO /binary string/ or return 'Nothing' if the string is +-- improperly formatted. +decodeBinary :: Text -> Maybe ByteString +decodeBinary = fmap BS.pack . decode . T.unpack + where decode :: String -> Maybe [Word8] + decode ('~':q:r:rest) = do + q' <- fromHex q + r' <- fromHex r + let b = 16 * q' + r' + (b :) `fmap` decode rest + decode ('~':_) = Nothing + decode (c:rest) + | isAscii c && isPrint c = (b :) `fmap` decode rest + | otherwise = Nothing + where b = fromIntegral (fromEnum c) + decode [] = return [] + + fromHex :: Char -> Maybe Word8 + fromHex c + | isHexDigit c = Just b + | otherwise = Nothing + where b = fromIntegral (digitToInt c) + +-- | May the given character appear in a MOO string? +validChar :: Char -> Bool +validChar c = isAscii c && (isPrint c || c == '\t') + +singleton :: Char -> MOOString +singleton = fromText . T.singleton + +storageBytes :: MOOString -> Int +storageBytes str = sizeOf 'x' * (length str + 1) + + sizeOf (undefined :: Int) * 4 + +-- | Test two strings for indistinguishable (case-sensitive) equality. +equal :: MOOString -> MOOString -> Bool +equal = (==) `on` toText + +empty :: MOOString +empty = fromText T.empty + +tail :: MOOString -> MOOString +tail = fromText . T.tail . toText + +append :: MOOString -> MOOString -> MOOString +append str1 str2 = fromText $ T.append (toText str1) (toText str2) + +null :: MOOString -> Bool +null = T.null . toText + +compareLength :: MOOString -> Int -> Ordering +compareLength str = T.compareLength (toText str) + +intercalate :: MOOString -> [MOOString] -> MOOString +intercalate sep = fromText . T.intercalate (toText sep) . map toText + +concat :: [MOOString] -> MOOString +concat = fromText . T.concat . map toText + +concatMap :: (Char -> MOOString) -> MOOString -> MOOString +concatMap f = fromText . T.concatMap (toText . f) . toText + +take :: Int -> MOOString -> MOOString +take len = fromText . T.take len . toText + +drop :: Int -> MOOString -> MOOString +drop len = fromText . T.drop len . toText + +splitAt :: Int -> MOOString -> (MOOString, MOOString) +splitAt n str = (fromText prefix, fromText remainder) + where (prefix, remainder) = T.splitAt n (toText str) + +-- XXX Need caseless versions... + +breakOn :: MOOString -> MOOString -> (MOOString, MOOString) +breakOn sep str = (fromText before, fromText match) + where (before, match) = T.breakOn (toText sep) (toText str) + +breakOnEnd :: MOOString -> MOOString -> (MOOString, MOOString) +breakOnEnd sep str = (fromText before, fromText match) + where (before, match) = T.breakOnEnd (toText sep) (toText str) + +break :: (Char -> Bool) -> MOOString -> (MOOString, MOOString) +break p str = (fromText prefix, fromText remainder) + where (prefix, remainder) = T.break p (toText str) + +splitOn :: MOOString -> MOOString -> [MOOString] +splitOn sep = map fromText . T.splitOn (toText sep) . toText + +-- + +words :: MOOString -> [MOOString] +words = map fromText . T.words . toText + +unwords :: [MOOString] -> MOOString +unwords = fromText . T.unwords . map toText + +isPrefixOf :: MOOString -> MOOString -> Bool +isPrefixOf = T.isPrefixOf `on` toCaseFold + +index :: MOOString -> Int -> Char +index str = T.index (toText str) diff --git a/src/MOO/Task.hs b/src/MOO/Task.hs --- a/src/MOO/Task.hs +++ b/src/MOO/Task.hs @@ -1,127 +1,169 @@ {-# 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 +module MOO.Task ( + -- * Monad Interface + MOO + , Environment(..) + , initEnvironment + , liftSTM -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 + -- * World Interface + , World(..) + , newWorld + , getWorld + , getWorld' + , putWorld + , modifyWorld + , getDatabase + , putDatabase + + -- * Task Interface + , Task(..) + , TaskStatus(..) + , Wake(..) + , TaskState(..) + , CallStack(..) + , DelayedIO(..) + , TaskDisposition(..) + , Resume(..) + , Resource(..) + , initState + , newState + , initTask + , newTaskId + , newTask + , taskOwner + , isQueued + , queuedTasks + , stepTask + , runTask + , forkTask + , interrupt + , requestIO + , delayIO + , unsafeIOtoMOO + , getTask + , putTask + , purgeTask + + -- * Object Interface + , getPlayer + , getObject + , getObjectName + , getProperty + , modifyProperty + , modifyVerb + , readProperty + , writeProperty + , setBuiltinProperty + + -- * Verb Execution Interface + , getVerb + , findVerb + , callSystemVerb + , callSystemVerb' + , callCommandVerb + , callVerb + , callFromFunc + , evalFromFunc + , runVerb + , runTick + + -- * Verb Frame Interface + , StackFrame(..) + , Continuation(..) + , initFrame + , formatFrames + , pushFrame + , popFrame + , activeFrame + , frame + , caller + , modifyFrame + , setLineNumber + , mkVariables + , formatTraceback + + -- * Loop and Try/Finally Control Functions + , pushTryFinallyContext + , pushLoopContext + , setLoopContinue + , popContext + , breakLoop + , continueLoop + + -- * Exception Handling + , Exception(..) + , Code + , Message + , raiseException + , raise + , catchException + , passException + , handleDebug + , timeoutException + + -- * Utility Check Functions + , isWizard + , checkFloat + , checkProgrammer + , checkWizard + , checkPermission + , checkValid + , checkFertile + , checkRecurrence + + -- * Miscellaneous + , binaryString + , random + , newRandomGen + , delay + + , shutdown + , notyet + ) where + +import Control.Arrow ((&&&)) +import Control.Concurrent (MVar, ThreadId, myThreadId, forkIO, threadDelay, + newEmptyMVar, putMVar, tryPutMVar, takeMVar) +import Control.Concurrent.STM (STM, TVar, atomically, retry, throwSTM, + newEmptyTMVar, putTMVar, takeTMVar, + newTVarIO, readTVar, writeTVar, modifyTVar) +import Control.Exception (SomeException, catch) +import Control.Monad (when, unless, join, liftM, void, (>=>)) +import Control.Monad.Cont (ContT, runContT, callCC) +import Control.Monad.Reader (ReaderT, runReaderT, local, asks) +import Control.Monad.State.Strict (StateT, runStateT, get, gets, modify) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Writer (execWriter, tell) import Data.ByteString (ByteString) +import Data.Int (Int32) import Data.List (find) import Data.Map (Map) import Data.Maybe (isNothing, fromMaybe, fromJust) +import Data.Monoid (Monoid(mempty, mappend), (<>)) import Data.Text (Text) -import Data.Time +import Data.Time (UTCTime, getCurrentTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import System.IO.Unsafe (unsafePerformIO) import System.Posix (nanosleep) -import System.Random hiding (random) +import System.Random (Random, StdGen, newStdGen, mkStdGen, split, + randomR, randomRs) -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 MOO.Command import {-# SOURCE #-} MOO.Database import {-# SOURCE #-} MOO.Network +import {-# SOURCE #-} MOO.Connection import MOO.Object +import MOO.Types import MOO.Verb -import MOO.Command +import qualified MOO.String as Str + -- | This is the basic MOO monad transformer stack. A computation of type -- @'MOO' a@ is an 'STM' transaction that returns a value of type @a@ within -- an environment that supports state, continuations, and local modification. @@ -135,16 +177,23 @@ -- | 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 + 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 + , listeners :: Map Point 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 + , nextConnectionId :: ObjId + -- ^ The (negative) object number to be assigned to the next inbound or + -- outbound connection + + , outboundNetwork :: Bool + -- ^ Is @open_network_connection()@ enabled? + , bindAddress :: Maybe HostName + -- ^ Interface address to bind to for incoming connections + + , shutdownMessage :: MVar Text + -- ^ Shutdown signal } initWorld = World { @@ -154,9 +203,28 @@ , listeners = M.empty , connections = M.empty - , nextConnectionId = -1 + , nextConnectionId = firstConnectionId + + , outboundNetwork = False + , bindAddress = Nothing + + , shutdownMessage = undefined } +newWorld :: Database -> Bool -> IO (TVar World) +newWorld db outboundNetworkEnabled = do + shutdownVar <- newEmptyMVar + + world' <- newTVarIO initWorld { + database = db + , outboundNetwork = outboundNetworkEnabled + , shutdownMessage = shutdownVar + } + + runTask =<< newTask world' nothing (loadServerOptions >> return zero) + + return world' + -- | A structure representing a queued or running task data Task = Task { taskId :: TaskId @@ -168,7 +236,7 @@ , taskState :: TaskState , taskComputation :: MOO Value -} + } instance Show Task where show task = " StdGen -> STM TaskId -newTaskId world gen = - return $ fromJust $ find unused $ randomRs (1, maxBound) gen - where unused taskId = M.notMember taskId (tasks world) +-- | Generate a (random) 'TaskId' not currently in use by any existing task. +newTaskId :: World -> StdGen -> TaskId +newTaskId world = fromJust . find unused . randomRs (1, maxBound) + where unused = (`M.notMember` 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 @@ -223,9 +289,9 @@ atomically $ do world <- readTVar world' - taskId <- newTaskId world gen - let task = initTask { + let taskId = newTaskId world gen + task = initTask { taskId = taskId , taskWorld = world' @@ -273,7 +339,7 @@ | Suspend (Maybe Integer) (Resume ()) | Read ObjId (Resume Value) | forall a. RequestIO (IO a) (Resume a) - | Uncaught Exception CallStack + | Uncaught Exception | Timeout Resource CallStack | Suicide @@ -283,13 +349,14 @@ -- | Task resource limits data Resource = Ticks | Seconds -showResource :: Resource -> Text +showResource :: Resource -> StrT showResource Ticks = "ticks" showResource Seconds = "seconds" -timeoutException :: Resource -> Exception -timeoutException resource = - Exception (Err E_QUOTA) ("Task ran out of " <> showResource resource) nothing +timeoutException :: Resource -> CallStack -> Exception +timeoutException resource stack = except { exceptionCallStack = stack } + where message = "Task ran out of " <> showResource resource + except = newException (Err E_QUOTA) message zero stepTask :: Task -> IO (TaskDisposition, Task) stepTask task = do @@ -317,7 +384,7 @@ -- | 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. +-- returns. The task is removed from the task queue after it is finished. runTask :: Task -> IO (Maybe Value) runTask task = do resultMVar <- newEmptyMVar @@ -358,34 +425,37 @@ 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] + Uncaught exception@Exception { + exceptionCode = code + , exceptionMessage = message + , exceptionValue = value + , exceptionCallStack = 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 + formatted = formatTraceback exception 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 + formatted = formatTraceback $ + timeoutException resource stack Suicide -> putResult Nothing - handleAbortedTask :: Task -> [Text] -> (Maybe Value -> IO ()) -> + handleAbortedTask :: Task -> [StrT] -> (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 + , taskComputation = fromMaybe zero `fmap` call } - where handleAbortedTask' :: [Text] -> Task -> IO () + where handleAbortedTask' :: [StrT] -> Task -> IO () handleAbortedTask' traceback task = do (disposition, task') <- stepTaskWithIO task case disposition of @@ -399,19 +469,24 @@ putResult Nothing runTask' task' { taskComputation = resume () } noOp Read _ _ -> error "read() not yet implemented" - Uncaught exception stack -> do + Uncaught exception -> do informPlayer traceback - informPlayer $ formatTraceback exception stack + informPlayer $ formatTraceback exception putResult Nothing Timeout resource stack -> do informPlayer traceback - informPlayer $ formatTraceback - (timeoutException resource) stack + informPlayer $ formatTraceback $ + timeoutException resource stack putResult Nothing Suicide -> putResult Nothing - where informPlayer :: [Text] -> IO () - informPlayer = mapM_ (putStrLn . T.unpack) -- XXX + informPlayer :: [StrT] -> IO () + informPlayer lines = atomically $ do + world <- readTVar (taskWorld task) + let maybeConnection = M.lookup (taskPlayer task) (connections world) + case maybeConnection of + Just conn -> mapM_ (sendToConnection conn . Str.toText) lines + Nothing -> return () -- XXX write to server log? -- | 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 @@ -455,9 +530,7 @@ startSignal <- liftSTM newEmptyTMVar threadId <- requestIO $ forkIO $ do - if usecs <= fromIntegral (maxBound :: Int) - then threadDelay (fromIntegral usecs) - else nanosleep (usecs * 1000) + delay usecs atomically $ takeTMVar startSignal now <- getCurrentTime void $ runTask task' { taskState = state' { startTime = now } } @@ -467,6 +540,13 @@ tasks world } liftSTM $ putTMVar startSignal () +-- | Wait for the given number of microseconds to elapse. +delay :: Integer -> IO () +delay usecs = + if usecs <= fromIntegral (maxBound :: Int) + then threadDelay (fromIntegral usecs) + else nanosleep (usecs * 1000) + -- | 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. @@ -499,12 +579,30 @@ -- | 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 +-- Since general 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 } +-- | Unsafely perform the given IO computation within the current 'STM' +-- transaction. +-- +-- Since 'STM' transactions may be aborted at any time, the IO is performed in +-- a separate thread in order to guarantee consistency with any finalizers, +-- brackets, and so forth. The IO must be idempotent as it may be run more +-- than once. +unsafeIOtoMOO :: IO a -> MOO a +unsafeIOtoMOO io = liftSTM $ do + let result = unsafePerformIO $ do + r <- newEmptyMVar + forkIO $ (io >>= putMVar r . Right) `catch` \e -> + putMVar r $ Left (e :: SomeException) + takeMVar r + case result of + Right x -> return x + Left e -> throwSTM e + -- | A 'Reader' environment for state that either doesn't change, or can be -- locally modified for subcomputations data Environment = Env { @@ -512,13 +610,13 @@ , 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) + , exceptionHandler = Handler $ interrupt . Uncaught , indexLength = error "Invalid index context" } @@ -529,7 +627,7 @@ , startTime :: UTCTime , randomGen :: StdGen , delayedIO :: DelayedIO -} + } initState = State { ticksLeft = 30000 @@ -595,9 +693,17 @@ getObject :: ObjId -> MOO (Maybe Object) getObject oid = liftSTM . dbObject oid =<< getDatabase +getObjectName :: ObjId -> MOO StrT +getObjectName oid = do + obj <- getObject oid + let objNum = Str.fromText (toText $ Obj oid) + + return $ maybe objNum (\obj -> Str.concat [objectName obj, + " (", objNum, ")"]) obj + getProperty :: Object -> StrT -> MOO Property getProperty obj name = do - maybeProp <- liftSTM $ lookupProperty obj (T.toCaseFold name) + maybeProp <- liftSTM $ lookupProperty obj name maybe (raise E_PROPNF) return maybeProp getVerb :: Object -> Value -> MOO Verb @@ -625,7 +731,7 @@ findVerb' (objectParent obj) searchVerbs ((names,verbTVar):rest) = - if verbNameMatch name' names + if verbNameMatch name names then do verb <- liftSTM $ readTVar verbTVar if acceptable verb @@ -634,25 +740,27 @@ else searchVerbs rest searchVerbs [] = return Nothing - name' = T.toCaseFold name +callSystemVerb :: StrT -> [Value] -> MOO (Maybe Value) +callSystemVerb name args = callSystemVerb' systemObject name args Str.empty -callSystemVerb :: Id -> [Value] -> MOO (Maybe Value) -callSystemVerb name args = do +callSystemVerb' :: ObjId -> StrT -> [Value] -> StrT -> MOO (Maybe Value) +callSystemVerb' object name args argstr = do player <- asks (taskPlayer . task) - (maybeOid, maybeVerb) <- findVerb verbPermX name systemObject - case (maybeOid, maybeVerb) of + maybeVerb <- findVerb verbPermX name object + case maybeVerb of (Just verbOid, Just verb) -> do let vars = mkVariables [ ("player", Obj player) - , ("this" , Obj systemObject) + , ("this" , Obj object) , ("verb" , Str name) , ("args" , fromList args) + , ("argstr", Str argstr) ] Just `liftM` runVerb verb initFrame { variables = vars , verbName = name , verbLocation = verbOid - , initialThis = systemObject + , initialThis = object , initialPlayer = player } _ -> return Nothing @@ -686,11 +794,9 @@ 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 + let player = case (wizard, vars M.! "player") of + (True, Obj oid) -> oid + _ -> initialPlayer thisFrame vars = variables thisFrame vars' = mkVariables [ ("this" , Obj this) @@ -716,21 +822,21 @@ 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 + maybeVerb <- findVerb verbPermX name verbLoc + case maybeVerb of (Just verbOid, Just verb) -> callVerb' (verbOid, verb) this name args + (Nothing , _) -> raise E_INVIND + (_ , Nothing) -> raise E_VERBNF -callFromFunc :: Id -> IntT -> (ObjId, StrT) -> [Value] -> MOO (Maybe Value) +callFromFunc :: StrT -> IntT -> (ObjId, StrT) -> [Value] -> MOO (Maybe Value) callFromFunc func index (oid, name) args = do - (maybeOid, maybeVerb) <- findVerb verbPermX name oid - case (maybeOid, maybeVerb) of + maybeVerb <- findVerb verbPermX name oid + case maybeVerb of (Just verbOid, Just verb) -> liftM Just $ evalFromFunc func index $ callVerb' (verbOid, verb) oid name args - (_ , _) -> return Nothing + _ -> return Nothing -evalFromFunc :: Id -> IntT -> MOO Value -> MOO Value +evalFromFunc :: StrT -> IntT -> MOO Value -> MOO Value evalFromFunc func index code = do (depthLeft, player) <- frame (depthLeft &&& initialPlayer) pushFrame initFrame { @@ -740,9 +846,9 @@ , builtinFunc = True , lineNumber = index } - value <- code `catchException` \except callStack -> do + value <- code `catchException` \except -> do popFrame - passException except callStack + passException except popFrame return value @@ -760,9 +866,9 @@ , permissions = verbOwner verb , verbFullName = verbNames verb } - value <- verbCode verb `catchException` \except callStack -> do + value <- verbCode verb `catchException` \except -> do popFrame - passException except callStack + passException except popFrame return value @@ -775,7 +881,7 @@ modifyProperty :: Object -> StrT -> (Property -> MOO Property) -> MOO () modifyProperty obj name f = - case lookupPropertyRef obj (T.toCaseFold name) of + case lookupPropertyRef obj name of Nothing -> raise E_PROPNF Just propTVar -> do prop <- liftSTM $ readTVar propTVar @@ -790,12 +896,9 @@ 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 + unless (verbNames verb `Str.equal` verbNames verb') $ do db <- getDatabase - liftSTM $ modifyObject oid db $ \obj -> - return $ replaceVerb obj index verb' + liftSTM $ modifyObject oid db $ replaceVerb index verb' readProperty :: ObjId -> StrT -> MOO (Maybe Value) readProperty oid name = do @@ -812,7 +915,7 @@ Nothing -> do parentObj <- maybe (return Nothing) getObject (objectParent obj) maybe (error $ "No inherited value for property " ++ - T.unpack name) search parentObj + Str.toString name) search parentObj just -> return just writeProperty :: ObjId -> StrT -> Value -> MOO () @@ -877,14 +980,11 @@ storageBytes (Stack stack) = storageBytes stack -- | A local continuation for loop constructs -newtype Continuation = Continuation (Value -> MOO Value) +newtype Continuation = Continuation (() -> 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 = @@ -928,7 +1028,7 @@ , builtinFunc :: Bool , lineNumber :: IntT -} deriving Show + } deriving Show initFrame = Frame { depthLeft = 50 @@ -936,17 +1036,17 @@ , contextStack = [] , variables = initVariables , debugBit = True - , permissions = -1 + , permissions = nothing - , verbName = T.empty - , verbFullName = T.empty - , verbLocation = -1 - , initialThis = -1 - , initialPlayer = -1 + , verbName = Str.empty + , verbFullName = Str.empty + , verbLocation = nothing + , initialThis = nothing + , initialPlayer = nothing , builtinFunc = False , lineNumber = 0 -} + } instance Sizeable StackFrame where storageBytes frame = @@ -1049,8 +1149,8 @@ case this of TryFinally { finally = finally } -> do modifyFrame $ \frame -> frame { contextStack = next } - finally - _ -> return nothing + void finally + _ -> return () unwind next unwind [] = return [] @@ -1065,32 +1165,32 @@ breakLoop :: Maybe Id -> MOO Value breakLoop maybeName = do Loop { loopBreak = Continuation break } <- unwindLoopContext maybeName - break nothing + break () continueLoop :: Maybe Id -> MOO Value continueLoop maybeName = do Loop { loopContinue = Continuation continue } <- unwindLoopContext maybeName - continue nothing + continue () -- | The default collection of verb variables initVariables :: Map Id Value initVariables = M.fromList $ [ - ("player" , Obj (-1)) - , ("this" , Obj (-1)) - , ("caller" , Obj (-1)) + ("player" , Obj nothing) + , ("this" , Obj nothing) + , ("caller" , Obj nothing) - , ("args" , Lst V.empty) - , ("argstr" , Str T.empty) + , ("args" , emptyList) + , ("argstr" , emptyString) - , ("verb" , Str T.empty) - , ("dobjstr", Str T.empty) - , ("dobj" , Obj (-1)) - , ("prepstr", Str T.empty) - , ("iobjstr", Str T.empty) - , ("iobj" , Obj (-1)) + , ("verb" , emptyString) + , ("dobjstr", emptyString) + , ("dobj" , Obj nothing) + , ("prepstr", emptyString) + , ("iobjstr", emptyString) + , ("iobj" , Obj nothing) ] ++ typeVariables - where typeVariables = map (first T.toCaseFold) [ + where typeVariables = [ ("INT" , Int $ typeCode TInt) , ("NUM" , Int $ typeCode TInt) , ("FLOAT", Int $ typeCode TFlt) @@ -1104,43 +1204,86 @@ mkVariables :: [(Id, Value)] -> Map Id Value mkVariables = foldr (uncurry M.insert) initVariables -newtype ExceptionHandler = Handler (Exception -> CallStack -> MOO Value) +newtype ExceptionHandler = Handler (Exception -> MOO Value) instance Show ExceptionHandler where show _ = "" -- | A MOO exception -data Exception = Exception Code Message Value -type Code = Value +data Exception = Exception { + exceptionCode :: Code + , exceptionMessage :: Message + , exceptionValue :: Value + + , exceptionCallStack :: CallStack + , exceptionDebugBit :: Bool + -- ^ A copy of the debug bit from the verb frame in which the exception + -- was raised + } + +type Code = Value type Message = StrT +initException = Exception { + exceptionCode = Err E_NONE + , exceptionMessage = Str.fromText (error2text E_NONE) + , exceptionValue = zero + + , exceptionCallStack = Stack [] + , exceptionDebugBit = True + } + +newException :: Code -> Message -> Value -> Exception +newException code message value = initException { + exceptionCode = code + , exceptionMessage = message + , exceptionValue = value + } + -- | Install a local exception handler for the duration of the passed -- computation. -catchException :: MOO a -> (Exception -> CallStack -> MOO a) -> MOO a +catchException :: MOO a -> (Exception -> 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 } + where mkHandler k env = env { exceptionHandler = Handler $ \e -> + local (const env) $ handler e >>= k } -- | Re-raise an exception to the next enclosing handler. -passException :: Exception -> CallStack -> MOO a -passException except callStack = do +passException :: Exception -> MOO a +passException except = do Handler handler <- asks exceptionHandler - handler except callStack + handler except error "Returned from exception handler" --- | Abort execution of the current computation and call the closest enclosing +-- | Abort execution of the current computation and call the nearest enclosing -- exception handler. -raiseException :: Exception -> MOO a -raiseException except = passException except =<< gets stack +raiseException :: Code -> Message -> Value -> MOO a +raiseException code message value = do + let except = newException code message value + callStack <- gets stack + debug <- frame debugBit + passException except { + exceptionCallStack = callStack + , exceptionDebugBit = debug + } +-- | Execute the passed computation, capturing any exception raised in verb +-- frames with debug bit unset and returning the error code as an ordinary +-- value instead of propagating the exception. +handleDebug :: MOO Value -> MOO Value +handleDebug = (`catchException` handler) + where handler Exception { + exceptionDebugBit = False + , exceptionCode = code + } = return code + handler except = passException except + -- | Placeholder for features not yet implemented -notyet :: String -> MOO a -notyet what = raiseException $ - Exception (Err E_QUOTA) "Not yet implemented" (Str $ T.pack what) +notyet :: StrT -> MOO a +notyet = raiseException (Err E_QUOTA) "Not yet implemented" . Str -- | Create and raise an exception for the given MOO error. raise :: Error -> MOO a -raise err = raiseException $ Exception (Err err) (error2text err) nothing +raise err = raiseException (Err err) (Str.fromText $ error2text err) zero -- | Verify that the given floating point number is neither infinite nor NaN, -- raising 'E_FLOAT' or 'E_INVARG' respectively if so. Also, return the @@ -1199,10 +1342,24 @@ Nothing -> raise E_PERM Just obj -> unless (objectPermF obj) $ checkPermission (objectOwner obj) +-- | Verify that the given /object/ does not have a recursive relationship +-- with the given /subject/, raising 'E_RECMOVE' if so. +checkRecurrence :: (Object -> Maybe ObjId) -- ^ relationship projection + -> ObjId -- ^ /subject/ + -> ObjId -- ^ /object/ to check + -> MOO () +checkRecurrence relation subject = checkRecurrence' + where checkRecurrence' object = do + when (object == subject) $ raise E_RECMOVE + maybeObject <- getObject object + case join $ relation `fmap` maybeObject of + Just oid -> checkRecurrence' oid + Nothing -> return () + -- | 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 +binaryString = maybe (raise E_INVARG) return . Str.toBinary -- | Generate and return a pseudorandom number in the given range, modifying -- the local generator state. @@ -1222,13 +1379,13 @@ -- | 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) +formatTraceback :: Exception -> [StrT] +formatTraceback except@Exception { exceptionCallStack = Stack frames } = + map Str.fromText $ T.splitOn "\n" $ execWriter (traceback frames) where traceback (frame:frames) = do describeVerb frame - tell $ ": " <> message + tell $ ": " <> Str.toText (exceptionMessage except) traceback' frames traceback [] = traceback' [] @@ -1241,8 +1398,15 @@ describeVerb Frame { builtinFunc = False , verbLocation = loc, verbFullName = name , initialThis = this, lineNumber = line } = do - tell $ "#" <> T.pack (show loc) <> ":" <> name + tell $ "#" <> T.pack (show loc) <> ":" <> Str.toText name when (loc /= this) $ tell $ " (this == #" <> T.pack (show this) <> ")" when (line > 0) $ tell $ ", line " <> T.pack (show line) describeVerb Frame { builtinFunc = True, verbName = name } = - tell $ "built-in function " <> name <> "()" + tell $ "built-in function " <> Str.toText name <> "()" + +-- | Begin the server shutdown process. +shutdown :: StrT -> MOO () +shutdown message = do + world <- getWorld + mapM_ unlisten (M.keys $ listeners world) + delayIO $ void $ tryPutMVar (shutdownMessage world) (Str.toText message) diff --git a/src/MOO/Task.hs-boot b/src/MOO/Task.hs-boot --- a/src/MOO/Task.hs-boot +++ b/src/MOO/Task.hs-boot @@ -16,18 +16,17 @@ , notyet ) where -import Control.Concurrent.STM -import Control.Monad.Reader -import Control.Monad.Cont -import Control.Monad.State.Strict +import Control.Concurrent.STM (STM, TVar) +import Control.Monad.Reader (ReaderT) +import Control.Monad.Cont (ContT) +import Control.Monad.State.Strict (StateT) -import MOO.Types +import {-# SOURCE #-} MOO.Command import {-# SOURCE #-} MOO.Object +import MOO.Types import {-# SOURCE #-} MOO.Verb -import {-# SOURCE #-} MOO.Command data World - data Environment data TaskDisposition data TaskState @@ -50,4 +49,4 @@ Command -> (ObjId, ObjId) -> MOO Value raise :: Error -> MOO a -notyet :: String -> MOO a +notyet :: StrT -> MOO a diff --git a/src/MOO/Types.hs b/src/MOO/Types.hs --- a/src/MOO/Types.hs +++ b/src/MOO/Types.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -- | Basic data types used throughout the MOO server code module MOO.Types ( @@ -20,9 +20,15 @@ , Value(..) , Error(..) - , nothing + , zero + , emptyString + , emptyList -- * Type and Value Functions + , fromId + , toId + , string2builder + , fromInt , fromFlt , fromStr @@ -41,8 +47,6 @@ , toLiteral , error2text - , text2binary - -- * List Convenience Functions , fromList , fromListBy @@ -50,9 +54,10 @@ , objectList , listSet + , listInsert + , listDelete -- * Miscellaneous - , validStrChar , endOfTime -- * Estimating Haskell Storage Sizes @@ -61,22 +66,33 @@ ) where import Control.Concurrent (ThreadId) -import Data.Char (isAscii, isPrint, isDigit) +import Control.Concurrent.STM (TVar) +import Control.Monad (liftM) +import Data.CaseInsensitive (CI) +import Data.HashMap.Strict (HashMap) import Data.Int (Int32, Int64) +import Data.IntSet (IntSet) import Data.Map (Map) import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) 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.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HM +import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM +import MOO.String (MOOString) +import qualified MOO.String as Str + -- | 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. @@ -109,6 +125,12 @@ instance Sizeable Text where storageBytes t = sizeOf 'x' * (T.length t + 1) +instance Sizeable MOOString where + storageBytes = Str.storageBytes + +instance Sizeable s => Sizeable (CI s) where + storageBytes = (* 2) . storageBytes . CI.original + instance Sizeable a => Sizeable (Vector a) where storageBytes v = V.sum (V.map storageBytes v) @@ -136,17 +158,55 @@ instance Sizeable ThreadId where storageBytes _ = storageBytes () +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 () + +# ifdef MOO_64BIT_INTEGER +type IntT = Int64 +# else type IntT = Int32 +# endif -- ^ MOO integer type FltT = Double -- ^ MOO floating-point number -type StrT = Text -- ^ MOO string -type ObjT = Int -- ^ MOO object number +type StrT = MOOString -- ^ MOO string +type ObjT = ObjId -- ^ 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) +type ObjId = Int -- ^ MOO object number +type Id = CI Text -- ^ MOO identifier (string lite) +-- | Convert an identifier to and from another type. +class Ident a where + fromId :: Id -> a + toId :: a -> Id + +instance Ident String where + fromId = T.unpack . CI.original + toId = CI.mk . T.pack + +instance Ident Text where + fromId = CI.original + toId = CI.mk + +instance Ident MOOString where + fromId = Str.fromText . CI.original + toId = CI.mk . Str.toText + +instance Ident Builder where + fromId = TLB.fromText . CI.original + toId = error "Unsupported conversion from Builder to Id" + +string2builder :: StrT -> Builder +string2builder = TLB.fromText . Str.toText + -- | A 'Value' represents any MOO value. data Value = Int !IntT -- ^ integer | Flt !FltT -- ^ floating-point number @@ -154,7 +214,7 @@ | Obj !ObjT -- ^ object number | Err !ErrT -- ^ error | Lst !LstT -- ^ list - deriving Show + deriving (Eq, Show) instance Sizeable Value where storageBytes value = case value of @@ -166,10 +226,18 @@ Lst x -> box + storageBytes x where box = storageBytes () --- | The default false value (zero) -nothing :: Value -nothing = truthValue False +-- | A default (false) MOO value +zero :: Value +zero = truthValue False +-- | An empty MOO string +emptyString :: Value +emptyString = Str Str.empty + +-- | An empty MOO list +emptyList :: Value +emptyList = Lst V.empty + fromInt :: Value -> IntT fromInt (Int x) = x @@ -188,19 +256,9 @@ 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 +(Str a) `equal` (Str b) = a `Str.equal` b (Lst a) `equal` (Lst b) = V.length a == V.length b && V.and (V.zipWith equal a b) x `equal` y = x == y @@ -209,7 +267,7 @@ 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 + (Str a) `compare` (Str b) = a `compare` b (Obj a) `compare` (Obj b) = a `compare` b (Err a) `compare` (Err b) = a `compare` b _ `compare` _ = error "Illegal comparison" @@ -251,7 +309,7 @@ truthOf :: Value -> Bool truthOf (Int x) = x /= 0 truthOf (Flt x) = x /= 0.0 -truthOf (Str t) = not (T.null t) +truthOf (Str t) = not (Str.null t) truthOf (Lst v) = not (V.null v) truthOf _ = False @@ -285,10 +343,10 @@ -- | 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 (Int x) = T.pack (show x) +toText (Flt x) = T.pack (show x) +toText (Str x) = Str.toText x +toText (Obj x) = T.pack ('#' : show x) toText (Err x) = error2text x toText (Lst _) = "{list}" @@ -299,11 +357,11 @@ [ "{" , T.intercalate ", " $ map toLiteral (V.toList vs) , "}"] -toLiteral (Str x) = T.concat ["\"", T.concatMap escape x, "\""] +toLiteral (Str x) = T.concat ["\"", T.concatMap escape $ Str.toText x, "\""] where escape '"' = "\\\"" escape '\\' = "\\\\" escape c = T.singleton c -toLiteral (Err x) = T.pack $ show x +toLiteral (Err x) = T.pack (show x) toLiteral v = toText v -- | Return a string description of the given error value. @@ -325,49 +383,59 @@ 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') - +-- | Turn a Haskell list into a MOO list. fromList :: [Value] -> Value fromList = Lst . V.fromList +-- | Turn a Haskell list into a MOO list, using a function to map Haskell +-- values to MOO values. fromListBy :: (a -> Value) -> [a] -> Value fromListBy f = fromList . map f +-- | Turn a list of strings into a MOO list. stringList :: [StrT] -> Value stringList = fromListBy Str +-- | Turn a list of object numbers into a MOO list. objectList :: [ObjT] -> Value objectList = fromListBy Obj +-- | Return a modified list with the given 0-based index replaced with the +-- given value. listSet :: LstT -> Int -> Value -> LstT -listSet v i value = V.modify (\m -> VM.write m (i - 1) value) v +listSet v i value = V.modify (\m -> VM.write m i value) v --- | This is the last UTC time value representable as a 32-bit +-- | Return a modified list with the given value inserted at the given 0-based +-- index. +listInsert :: LstT -> Int -> Value -> LstT +listInsert list index value + | index <= 0 = V.cons value list + | index > listLen = V.snoc list value + | otherwise = V.create $ do + list' <- V.thaw list >>= flip VM.grow 1 + let moveLen = listLen - index + s = VM.slice index moveLen list' + t = VM.slice (index + 1) moveLen list' + VM.move t s + VM.write list' index value + return list' + where listLen = V.length list + +-- | Return a modified list with the value at the given 0-based index removed. +listDelete :: LstT -> Int -> LstT +listDelete list index + | index == 0 = V.create $ VM.tail `liftM` V.thaw list + | index == listLen - 1 = V.create $ VM.init `liftM` V.thaw list + | otherwise = V.create $ do + list' <- V.thaw list + let moveLen = listLen - index - 1 + s = VM.slice index moveLen list' + t = VM.slice (index + 1) moveLen list' + VM.move s t + return $ VM.init list' + where listLen = V.length list + +-- | This is the last UTC time value representable as a signed 32-bit -- seconds-since-1970 value. Unfortunately it is used as a sentinel value in -- LambdaMOO to represent the starting time of indefinitely suspended tasks, -- so we really can't support time values beyond this point... yet. diff --git a/src/MOO/Unparser.hs b/src/MOO/Unparser.hs --- a/src/MOO/Unparser.hs +++ b/src/MOO/Unparser.hs @@ -5,25 +5,30 @@ -- built-in function module MOO.Unparser ( unparse ) where -import Control.Monad.Reader -import Control.Monad.Writer -import Data.Char +import Control.Monad (when, unless, liftM, (<=<)) +import Control.Monad.Reader (ReaderT, runReaderT, asks, local) +import Control.Monad.Writer (Writer, execWriter, tell) +import Data.Char (isAlpha, isAlphaNum) +import Data.List (intersperse) +import Data.Monoid ((<>), mconcat) import Data.Set (Set) -import Data.Text (Text) +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Builder (Builder, toLazyText, fromText) import qualified Data.Set as S -import qualified Data.Text as T import MOO.AST -import MOO.Types import MOO.Parser (keywords) +import MOO.Types -type Unparser = ReaderT UnparserEnv (Writer Text) +import qualified MOO.String as Str +type Unparser = ReaderT UnparserEnv (Writer Builder) + data UnparserEnv = UnparserEnv { fullyParenthesizing :: Bool , indenting :: Bool - , indentation :: Text + , indentation :: Builder } initUnparserEnv = UnparserEnv { @@ -32,18 +37,21 @@ , 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. +-- | Synthesize 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 :: Bool -- ^ /fully-paren/ + -> Bool -- ^ /indent/ + -> Program + -> Text unparse fullyParen indent (Program stmts) = - execWriter $ runReaderT (tellStatements stmts) $ initUnparserEnv { + toLazyText $ execWriter $ runReaderT (tellStatements stmts) $ + initUnparserEnv { fullyParenthesizing = fullyParen , indenting = indent } @@ -114,7 +122,7 @@ moreIndented $ tellStatements finally indent >> tell "endtry\n" -tellBlock :: StrT -> Maybe Id -> Unparser () -> [Statement] -> Unparser () +tellBlock :: Builder -> Maybe Id -> Unparser () -> [Statement] -> Unparser () tellBlock name maybeVar detail body = do indent >> tell name >> maybeTellVar maybeVar >> detail moreIndented $ tellStatements body @@ -122,7 +130,7 @@ maybeTellVar :: Maybe Id -> Unparser () maybeTellVar Nothing = return () -maybeTellVar (Just var) = tell " " >> tell var +maybeTellVar (Just var) = tell " " >> tell (fromId var) detailExpr :: Expr -> Unparser () detailExpr expr = tell " (" >> tellExpr expr >> tell ")\n" @@ -130,19 +138,19 @@ tellExpr :: Expr -> Unparser () tellExpr = tell <=< unparseExpr -unparseExpr :: Expr -> Unparser Text +unparseExpr :: Expr -> Unparser Builder unparseExpr expr = case expr of - Literal value -> return $ toLiteral value + Literal value -> return (fromText $ toLiteral value) List args -> do args' <- unparseArgs args return $ "{" <> args' <> "}" - Variable var -> return var + Variable var -> return (fromId var) - PropRef (Literal (Obj 0)) (Literal (Str name)) - | isIdentifier name -> return $ "$" <> name - PropRef obj name -> do + PropertyRef (Literal (Obj 0)) (Literal (Str name)) + | isIdentifier name -> return $ "$" <> string2builder name + PropertyRef obj name -> do obj' <- case obj of Literal Int{} -> paren obj -- avoid digits followed by dot (-> float) _ -> parenL expr obj @@ -154,14 +162,15 @@ rhs' <- unparseExpr rhs return $ lhs' <> " = " <> rhs' - ScatterAssign scats rhs -> do + Scatter 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' <> ")" + return $ "$" <> string2builder name <> + "(" <> args' <> ")" VerbCall obj name args -> do obj' <- parenL expr obj name' <- unparseNameExpr name @@ -170,7 +179,7 @@ BuiltinFunc func args -> do args' <- unparseArgs args - return $ func <> "(" <> args' <> ")" + return $ fromId func <> "(" <> args' <> ")" Index lhs rhs -> do lhs' <- parenL expr lhs @@ -186,28 +195,28 @@ 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 + 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 + CompareEQ lhs rhs -> binaryL lhs " == " rhs + CompareNE lhs rhs -> binaryL lhs " != " rhs + CompareLT lhs rhs -> binaryL lhs " < " rhs + CompareLE lhs rhs -> binaryL lhs " <= " rhs + CompareGT lhs rhs -> binaryL lhs " > " rhs + CompareGE lhs rhs -> binaryL lhs " >= " rhs -- Right-associative operators - Power lhs rhs -> binaryR lhs " ^ " rhs + 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@(Literal Flt{} `PropertyRef` _) -> negateParen lhs Negate lhs@(VerbCall (Literal x) _ _) | numeric x -> negateParen lhs Negate lhs -> ("-" <>) `liftM` parenL expr lhs @@ -247,54 +256,52 @@ negateParen = liftM ("-" <>) . paren -unparseArgs :: [Arg] -> Unparser Text -unparseArgs = liftM (T.intercalate ", ") . mapM unparseArg - where unparseArg (ArgNormal expr) = unparseExpr expr +unparseArgs :: [Argument] -> Unparser Builder +unparseArgs = liftM (mconcat . intersperse ", ") . 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 +unparseScatter :: [ScatterItem] -> Unparser Builder +unparseScatter = liftM (mconcat . intersperse ", ") . mapM unparseScat + where unparseScat (ScatRequired var) = return $ fromId var + unparseScat (ScatRest var) = return $ "@" <> fromId var + unparseScat (ScatOptional var Nothing) = return $ "?" <> fromId var unparseScat (ScatOptional var (Just expr)) = do expr' <- unparseExpr expr - return $ "?" <> var <> " = " <> expr' + return $ "?" <> fromId var <> " = " <> expr' -unparseNameExpr :: Expr -> Unparser Text +unparseNameExpr :: Expr -> Unparser Builder unparseNameExpr (Literal (Str name)) - | isIdentifier name = return name -unparseNameExpr expr = do - expr' <- unparseExpr expr - return $ "(" <> expr' <> ")" + | isIdentifier name = return (string2builder name) +unparseNameExpr expr = paren expr -paren :: Expr -> Unparser Text +paren :: Expr -> Unparser Builder paren expr = do expr' <- unparseExpr expr return $ "(" <> expr' <> ")" -mightParen :: (Int -> Int -> Bool) -> Expr -> Expr -> Unparser Text +mightParen :: (Int -> Int -> Bool) -> Expr -> Expr -> Unparser Builder mightParen cmp parent child = do fullyParenthesizing <- asks fullyParenthesizing - if (fullyParenthesizing && precedence child < precedence PropRef{}) || + if (fullyParenthesizing && precedence child < precedence PropertyRef{}) || (precedence parent `cmp` precedence child) then paren child else unparseExpr child -parenL :: Expr -> Expr -> Unparser Text +parenL :: Expr -> Expr -> Unparser Builder parenL = mightParen (>) -parenR :: Expr -> Expr -> Unparser Text +parenR :: Expr -> Expr -> Unparser Builder parenR = mightParen (>=) isIdentifier :: StrT -> Bool -isIdentifier name = isIdentifier' (T.unpack name) && not (isKeyword name) +isIdentifier name = isIdentifier' (Str.toString name) && not (isKeyword name) where isIdentifier' (c:cs) = isIdentStart c && all isIdentChar cs isIdentStart c = isAlpha c || c == '_' isIdentChar c = isAlphaNum c || c == '_' isKeyword :: StrT -> Bool -isKeyword = (`S.member` keywordsSet) . T.toCaseFold +isKeyword = (`S.member` keywordsSet) . toId -keywordsSet :: Set StrT -keywordsSet = S.fromList $ map (T.toCaseFold . T.pack) keywords +keywordsSet :: Set Id +keywordsSet = S.fromList $ map toId keywords diff --git a/src/MOO/Verb.hs b/src/MOO/Verb.hs --- a/src/MOO/Verb.hs +++ b/src/MOO/Verb.hs @@ -5,23 +5,22 @@ , ObjSpec(..) , PrepSpec(..) , initVerb - , obj2text - , text2obj + , obj2string + , string2obj , objMatch - , prep2text - , text2prep + , prep2string + , string2prep , prepMatch , prepPhrases , verbNameMatch ) where -import Data.Text (Text) - -import MOO.Types import MOO.AST +import {-# SOURCE #-} MOO.Object (nothing) import {-# SOURCE #-} MOO.Task +import MOO.Types -import qualified Data.Text as T +import qualified MOO.String as Str data Verb = Verb { verbNames :: StrT @@ -56,9 +55,9 @@ initVerb = Verb { verbNames = "" , verbProgram = Program [] - , verbCode = return nothing + , verbCode = return zero - , verbOwner = -1 + , verbOwner = nothing , verbPermR = False , verbPermW = False , verbPermX = False @@ -69,75 +68,77 @@ , verbIndirectObject = ObjNone } -data ObjSpec = ObjNone - | ObjAny - | ObjThis - deriving (Enum, Bounded, Show) +-- | Argument (direct/indirect object) specifier +data ObjSpec = ObjNone -- ^ none + | ObjAny -- ^ any + | ObjThis -- ^ this + deriving (Enum, Bounded, Eq, Show) instance Sizeable ObjSpec where storageBytes _ = storageBytes () -obj2text :: ObjSpec -> Text -obj2text ObjNone = "none" -obj2text ObjAny = "any" -obj2text ObjThis = "this" +obj2string :: ObjSpec -> StrT +obj2string ObjNone = "none" +obj2string ObjAny = "any" +obj2string ObjThis = "this" -text2obj :: Text -> Maybe ObjSpec -text2obj = flip lookup $ map mkAssoc [minBound ..] - where mkAssoc objSpec = (obj2text objSpec, objSpec) +string2obj :: StrT -> Maybe ObjSpec +string2obj = flip lookup $ map mkAssoc [minBound ..] + where mkAssoc objSpec = (obj2string objSpec, objSpec) objMatch :: ObjId -> ObjSpec -> ObjId -> Bool -objMatch _ ObjNone (-1) = True -objMatch _ ObjNone _ = False -objMatch _ ObjAny _ = True -objMatch this ObjThis oid = oid == this +objMatch _ ObjNone oid = oid == nothing +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 +-- | Preposition specifier +data PrepSpec = PrepAny -- ^ any + | PrepNone -- ^ none + | PrepWithUsing -- ^ with\/using + | PrepAtTo -- ^ at\/to + | PrepInfrontof -- ^ in front of + | PrepInInsideInto -- ^ in\/inside\/into + | PrepOntopofOnOntoUpon -- ^ on top of\/on\/onto\/upon + | PrepOutofFrominsideFrom -- ^ out of\/from inside\/from + | PrepOver -- ^ over + | PrepThrough -- ^ through + | PrepUnderUnderneathBeneath -- ^ under\/underneath\/beneath + | PrepBehind -- ^ behind + | PrepBeside -- ^ beside + | PrepForAbout -- ^ for\/about + | PrepIs -- ^ is + | PrepAs -- ^ as + | PrepOffOffof -- ^ off\/off of 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" +prep2string :: PrepSpec -> StrT +prep2string PrepAny = "any" +prep2string PrepNone = "none" +prep2string PrepWithUsing = "with/using" +prep2string PrepAtTo = "at/to" +prep2string PrepInfrontof = "in front of" +prep2string PrepInInsideInto = "in/inside/into" +prep2string PrepOntopofOnOntoUpon = "on top of/on/onto/upon" +prep2string PrepOutofFrominsideFrom = "out of/from inside/from" +prep2string PrepOver = "over" +prep2string PrepThrough = "through" +prep2string PrepUnderUnderneathBeneath = "under/underneath/beneath" +prep2string PrepBehind = "behind" +prep2string PrepBeside = "beside" +prep2string PrepForAbout = "for/about" +prep2string PrepIs = "is" +prep2string PrepAs = "as" +prep2string PrepOffOffof = "off/off of" -text2prep :: Text -> Maybe PrepSpec -text2prep = flip lookup $ concatMap mkAssoc [minBound ..] +string2prep :: StrT -> Maybe PrepSpec +string2prep = flip lookup $ concatMap mkAssoc [minBound ..] where mkAssoc prepSpec = - [ (prep, prepSpec) | prep <- T.splitOn "/" $ prep2text prepSpec ] ++ - [ (T.pack $ show index, prepSpec) + [ (prep, prepSpec) | prep <- Str.splitOn "/" $ + prep2string prepSpec ] ++ + [ (Str.fromString $ show index, prepSpec) | let index = fromEnum prepSpec - fromEnum (succ PrepNone) , index >= 0 ] @@ -146,18 +147,20 @@ prepMatch PrepAny _ = True prepMatch vp cp = vp == cp -prepPhrases :: [(PrepSpec, [Text])] -prepPhrases = [ (prepSpec, T.words prepPhrase) +prepPhrases :: [(PrepSpec, [StrT])] +prepPhrases = [ (prepSpec, Str.words prepPhrase) | prepSpec <- [succ PrepNone ..] - , prepPhrase <- T.splitOn "/" $ prep2text prepSpec + , prepPhrase <- Str.splitOn "/" $ prep2string prepSpec ] +-- | Does the given verb name match any of the given aliases? Each alias may +-- use @*@ to separate required and optional text to match. 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 + postName `Str.isPrefixOf` Str.tail post + where (pre, post) = Str.breakOn "*" vname + (preName, postName) = Str.splitAt (Str.length pre) name diff --git a/src/MOO/Version.hs b/src/MOO/Version.hs --- a/src/MOO/Version.hs +++ b/src/MOO/Version.hs @@ -1,18 +1,12 @@ -module MOO.Version ( serverVersion - , serverVersionText - ) where - -import Data.Text -import Data.Version +module MOO.Version ( serverVersion ) where -import Paths_EtaMOO +import Data.Text (Text, pack) +import Data.Version (showVersion) --- | The current version of the server code, as a 'Version' value -serverVersion :: Version -serverVersion = version +import Paths_EtaMOO (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) +serverVersion :: Text +serverVersion = pack $ "EtaMOO/" ++ showVersion version diff --git a/src/cbits/crypt.c b/src/cbits/crypt.c new file mode 100644 --- /dev/null +++ b/src/cbits/crypt.c @@ -0,0 +1,34 @@ + +# define _XOPEN_SOURCE +# include +# include + +# include "crypt.h" + +/* + * Call the POSIX crypt() function + * + * The crypt() function is not reentrant, so this helper allows us to copy the + * results out while the Haskell runtime has blocked all other threads. + * + * To simplify memory management, we perform allocation for the results on the + * Haskell side. However, if the provided buffer is too small, we return an + * indication of the required size. + */ +int crypt_helper(const char *key, const char *salt, char *encrypted, int len) +{ + char *result; + int req; + + result = crypt(key, salt); + if (result == 0) + return -1; + + req = strlen(result) + 1; + if (req > len) + return req; + + strcpy(encrypted, result); + + return 0; +} diff --git a/src/cbits/crypt.h b/src/cbits/crypt.h new file mode 100644 --- /dev/null +++ b/src/cbits/crypt.h @@ -0,0 +1,2 @@ + +int crypt_helper(const char *, const char *, char *, int); diff --git a/src/cbits/match.c b/src/cbits/match.c new file mode 100644 --- /dev/null +++ b/src/cbits/match.c @@ -0,0 +1,93 @@ + +# include +# include "match.h" + +# define MAX_CAPTURES 10 + +/* + * Structure for capturing rmatch results + */ +typedef struct { + int ovec[MAX_CAPTURES * 2]; + int valid; +} rmatch_data_t; + +/* + * PCRE callout function used to capture rmatch results + * + * This function may be called by PCRE each time the (?C) pattern is + * encountered, which we have arranged to occur at the end of each successful + * pattern match. To find the rightmost match, we record the match found so + * far if it is further right and/or longer than the last found match, then + * tell PCRE to continue matching as if the match had failed. + */ +static +int rmatch_callout(pcre_callout_block *block) +{ + rmatch_data_t *rmatch = block->callout_data; + + if (!rmatch->valid || block->start_match > rmatch->ovec[0] || + (block->start_match == rmatch->ovec[0] && + block->current_position > rmatch->ovec[1])) { + /* make a copy of the offsets vector so the last such vector found can be + returned as the rightmost match */ + rmatch->ovec[0] = block->start_match; + rmatch->ovec[1] = block->current_position; + memcpy(&rmatch->ovec[2], &block->offset_vector[2], + sizeof(rmatch->ovec[2]) * 2 * (block->capture_top - 1)); + + rmatch->valid = block->capture_top; + } + + return 1; /* cause match failure at current point, but continue trying */ +} + +/* + * match() helper function + * + * This function exists so that it can be called by the Haskell runtime + * without any other threads running. This is necessary because it needs to + * convey callout information to PCRE via global variable. + */ +int match_helper(const pcre *code, pcre_extra *extra, + const char *subject, int length, + int options, int ovector[MAX_CAPTURES * 3]) +{ + extra->flags &= ~PCRE_EXTRA_CALLOUT_DATA; + + pcre_callout = 0; + + return pcre_exec(code, extra, subject, length, 0, + options, ovector, MAX_CAPTURES * 3); +} + +/* + * rmatch() helper function + * + * This function exists so that it can be called by the Haskell runtime + * without any other threads running. This is necessary because it needs to + * convey callout information to PCRE via global variable. + */ +int rmatch_helper(const pcre *code, pcre_extra *extra, + const char *subject, int length, + int options, int ovector[MAX_CAPTURES * 3]) +{ + rmatch_data_t rmatch; + int rc; + + rmatch.valid = 0; + + extra->callout_data = &rmatch; + extra->flags |= PCRE_EXTRA_CALLOUT_DATA; + + pcre_callout = rmatch_callout; + + rc = pcre_exec(code, extra, subject, length, 0, + options, ovector, MAX_CAPTURES * 3); + if (rc == PCRE_ERROR_NOMATCH && rmatch.valid) { + rc = rmatch.valid; + memcpy(ovector, &rmatch.ovec[0], sizeof(ovector[0]) * 2 * rc); + } + + return rc; +} diff --git a/src/cbits/match.h b/src/cbits/match.h new file mode 100644 --- /dev/null +++ b/src/cbits/match.h @@ -0,0 +1,5 @@ + +# include + +int match_helper(const pcre *, pcre_extra *, const char *, int, int, int *); +int rmatch_helper(const pcre *, pcre_extra *, const char *, int, int, int *); diff --git a/src/etamoo.hs b/src/etamoo.hs --- a/src/etamoo.hs +++ b/src/etamoo.hs @@ -1,168 +1,133 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where +{-# LANGUAGE CPP #-} -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(..)) +module Main (main) where -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 Control.Monad (foldM, unless) +import Data.List (isInfixOf, isPrefixOf) +import Data.Maybe (isJust, isNothing, fromJust) +import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), + getOpt, usageInfo) +import System.Environment (getArgs, getProgName) -import qualified Data.Map as M +import MOO.Network +import MOO.Server 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 } +main = parseArgs >>= run -run _ ":stack" state = print (stack state) >> return state +run :: Options -> IO () +run opts + | optHelp opts = putStrLn =<< usage + | optEmergency opts = error "Emergency Wizard Mode not yet implemented" + | otherwise = startServer (optLogFile opts) + (fromJust $ optInputDB opts) + (fromJust $ optOutputDB opts) + (optOutboundNetwork opts) + (const $ TCP (optBindAddress opts) (optPort opts)) -run world' ":tasks" state = do - world <- readTVarIO world' - print (M.elems $ tasks world) - return state +data Options = Options { + optHelp :: Bool + , optEmergency :: Bool + , optLogFile :: Maybe FilePath + , optInputDB :: Maybe FilePath + , optOutputDB :: Maybe FilePath + , optOutboundNetwork :: Bool + , optBindAddress :: Maybe HostName + , optPort :: PortNumber + , optPortSpecified :: Bool + } -run world (';':';':line) state = evalP world line state -run world (';' :line) state = evalE world line state -run world line state = evalC world line state +defaultOptions = Options { + optHelp = False + , optEmergency = False + , optLogFile = Nothing + , optInputDB = Nothing + , optOutputDB = Nothing +# ifdef MOO_OUTBOUND_NETWORK + , optOutboundNetwork = True +# else + , optOutboundNetwork = False +# endif + , optBindAddress = Nothing + , optPort = 7777 + , optPortSpecified = False + } -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 +options :: [OptDescr (Options -> Options)] +options = [ + Option "e" ["emergency"] + (NoArg (\opts -> opts { optEmergency = True })) + "Emergency Wizard Mode" + , Option "l" ["log-file"] + (ReqArg (\path opts -> opts { optLogFile = Just path }) "FILE") + "Log file" + , Option "" ["enable-outbound-network"] + (NoArg (\opts -> opts { optOutboundNetwork = True })) + $ "Enable open_network_connection()" ++ + if outboundNetwork then " *" else "" + , Option "O" ["disable-outbound-network"] + (NoArg (\opts -> opts { optOutboundNetwork = False })) + $ "Disable open_network_connection()" ++ + if not outboundNetwork then " *" else "" + , Option "a" ["bind-address"] + (ReqArg (\ip opts -> opts { optBindAddress = Just ip }) "IP-ADDR") + "Bind address for connections" + , Option "p" ["port"] + (ReqArg (\port opts -> opts { optPort = fromInteger $ read port, + optPortSpecified = True }) "PORT") + $ "Listening port (default: " ++ show (optPort defaultOptions) ++ ")" + , Option "h?" ["help"] + (NoArg (\opts -> opts { optHelp = True })) + "Show this usage" + ] + where outboundNetwork = optOutboundNetwork defaultOptions -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) +usage :: IO String +usage = do + argv0 <- getProgName + let header = "Usage: " ++ argv0 ++ " [-e] [-l FILE] " ++ + "INPUT-DB OUTPUT-DB [+O|-O] [-a IP-ADDR] [[-p] PORT]" + return $ patchUsage (usageInfo header options) ++ + "* Default outbound network option" -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) + where patchUsage :: String -> String + patchUsage = unlines . map patch . lines + where patch str + | "--enable-outbound-network" `isInfixOf` str && + " " `isPrefixOf` str = take 2 str ++ "+O" ++ drop 4 str + | otherwise = str -eval :: TaskState -> Task -> IO TaskState -eval state task = do - state' <- taskState `liftM` - evalPrint task { taskState = state { - ticksLeft = ticksLeft (taskState task) - , startTime = startTime (taskState task) - } } +usageError :: String -> IO a +usageError msg = usage >>= error . ((msg ++ "\n") ++) - atomically $ modifyTVar (taskWorld task) $ \world -> - world { tasks = M.delete (taskId task) $ tasks world } +serverOpts :: IO (Options, [String]) +serverOpts = do + args <- getArgs + case getOpt Permute options args of + (o, n, [] ) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> usageError (init $ concat errs) - return state' +parseArgs :: IO Options +parseArgs = do + (opts, nonOpts) <- serverOpts + opts <- foldM handleArg opts nonOpts -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' + unless (optHelp opts) $ do + unless (isJust $ optInputDB opts) $ usageError "missing INPUT-DB" + unless (isJust $ optOutputDB opts) $ usageError "missing OUTPUT-DB" - where formatValue (Int 0) = "" - formatValue v = " [" ++ unpack (toLiteral v) ++ "]" + return opts - notifyLines :: [Text] -> IO () - notifyLines = mapM_ (putStrLn . unpack) + where handleArg :: Options -> String -> IO Options + handleArg opts arg = case arg of + "+O" -> return opts { optOutboundNetwork = True } + '+':_ -> usageError $ "unrecognized option `" ++ arg ++ "'" + _ | isNothing (optInputDB opts) -> + return opts { optInputDB = Just arg } + | isNothing (optOutputDB opts) -> + return opts { optOutputDB = Just arg } + | not (optPortSpecified opts) -> + return opts { optPort = fromInteger $ read arg, + optPortSpecified = True } + | otherwise -> usageError $ "unknown argument `" ++ arg ++ "'"