EtaMOO 0.1.0.0 → 0.2.0.0
raw patch · 42 files changed
+4324/−2373 lines, 42 filesdep +case-insensitivedep +hashabledep +pipesdep ~text
Dependencies added: case-insensitive, hashable, pipes, pipes-bytestring, pipes-concurrency, pipes-network, stm-chans
Dependency ranges changed: text
Files
- EtaMOO.cabal +47/−9
- LICENSE +2/−2
- Makefile +0/−56
- README.md +19/−20
- configure +0/−17
- src/MOO/AST.hs +62/−61
- src/MOO/Builtins.hs +135/−73
- src/MOO/Builtins.hs-boot +1/−1
- src/MOO/Builtins/Common.hs +12/−16
- src/MOO/Builtins/Crypt.hs +33/−0
- src/MOO/Builtins/Match.hsc +85/−156
- src/MOO/Builtins/Network.hs +147/−87
- src/MOO/Builtins/Objects.hs +339/−187
- src/MOO/Builtins/Tasks.hs +113/−107
- src/MOO/Builtins/Values.hs +290/−299
- src/MOO/Command.hs +39/−33
- src/MOO/Compiler.hs +164/−166
- src/MOO/Connection.hs +729/−0
- src/MOO/Connection.hs-boot +22/−0
- src/MOO/Database.hs +76/−52
- src/MOO/Database.hs-boot +4/−4
- src/MOO/Database/LambdaMOO.hs +245/−45
- src/MOO/Network.hs +75/−298
- src/MOO/Network.hs-boot +21/−11
- src/MOO/Network/Console.hs +187/−0
- src/MOO/Network/TCP.hs +109/−0
- src/MOO/Object.hs +76/−30
- src/MOO/Object.hs-boot +7/−1
- src/MOO/Parser.hs +39/−33
- src/MOO/Server.hs +56/−0
- src/MOO/String.hs +247/−0
- src/MOO/Task.hs +404/−240
- src/MOO/Task.hs-boot +7/−8
- src/MOO/Types.hs +131/−63
- src/MOO/Unparser.hs +73/−66
- src/MOO/Verb.hs +73/−70
- src/MOO/Version.hs +6/−12
- src/cbits/crypt.c +34/−0
- src/cbits/crypt.h +2/−0
- src/cbits/match.c +93/−0
- src/cbits/match.h +5/−0
- src/etamoo.hs +115/−150
EtaMOO.cabal view
@@ -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 <rob@mars.org> maintainer: Rob Leslie <rob@mars.org> @@ -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
LICENSE view
@@ -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.
− Makefile
@@ -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:
README.md view
@@ -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/
− configure
@@ -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
src/MOO/AST.hs view
@@ -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
src/MOO/Builtins.hs view
@@ -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"
src/MOO/Builtins.hs-boot view
@@ -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
src/MOO/Builtins/Common.hs view
@@ -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'
+ src/MOO/Builtins/Crypt.hs view
@@ -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
src/MOO/Builtins/Match.hsc view
@@ -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
src/MOO/Builtins/Network.hs view
@@ -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]
src/MOO/Builtins/Objects.hs view
@@ -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
src/MOO/Builtins/Tasks.hs view
@@ -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
src/MOO/Builtins/Values.hs view
@@ -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)
src/MOO/Command.hs view
@@ -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)))
src/MOO/Compiler.hs view
@@ -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
+ src/MOO/Connection.hs view
@@ -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." ]
+ src/MOO/Connection.hs-boot view
@@ -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 ()
src/MOO/Database.hs view
@@ -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 []
src/MOO/Database.hs-boot view
@@ -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 ()
src/MOO/Database/LambdaMOO.hs view
@@ -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 '.')
src/MOO/Network.hs view
@@ -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
src/MOO/Network.hs-boot view
@@ -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 ()
+ src/MOO/Network/Console.hs view
@@ -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+-}
+ src/MOO/Network/TCP.hs view
@@ -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)
src/MOO/Object.hs view
@@ -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
src/MOO/Object.hs-boot view
@@ -1,5 +1,11 @@ -- -*- Haskell -*- -module MOO.Object ( Object ) where+module MOO.Object ( Object+ , nothing+ ) where +import MOO.Types (ObjId)+ data Object++nothing :: ObjId
src/MOO/Parser.hs view
@@ -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
+ src/MOO/Server.hs view
@@ -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 ()
+ src/MOO/String.hs view
@@ -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)
src/MOO/Task.hs view
@@ -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 = "<Task " ++ show (taskId task) ++@@ -180,10 +248,10 @@ , taskThread = undefined , taskWorld = undefined- , taskPlayer = -1+ , taskPlayer = nothing , taskState = initState- , taskComputation = return nothing+ , taskComputation = return zero } instance Sizeable Task where@@ -204,14 +272,12 @@ Task { taskState = state1 } `compare` Task { taskState = state2 } = startTime state1 `compare` startTime state2 -type TaskId = Int+type TaskId = Int32 --- | Generate and return a (random) 'TaskId' not currently in use by any--- existing task.-newTaskId :: World -> StdGen -> STM TaskId-newTaskId world gen =- return $ fromJust $ find unused $ randomRs (1, maxBound) gen- where unused taskId = M.notMember taskId (tasks world)+-- | 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 _ = "<Continuation>"- -- | 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 _ = "<ExceptionHandler>" -- | 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)
src/MOO/Task.hs-boot view
@@ -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
src/MOO/Types.hs view
@@ -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.
src/MOO/Unparser.hs view
@@ -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
src/MOO/Verb.hs view
@@ -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
src/MOO/Version.hs view
@@ -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
+ src/cbits/crypt.c view
@@ -0,0 +1,34 @@++# define _XOPEN_SOURCE+# include <unistd.h>+# include <string.h>++# include "crypt.h"++/*+ * Call the POSIX crypt() function+ *+ * The crypt() function is not reentrant, so this helper allows us to copy the+ * results out while the Haskell runtime has blocked all other threads.+ *+ * To simplify memory management, we perform allocation for the results on the+ * Haskell side. However, if the provided buffer is too small, we return an+ * indication of the required size.+ */+int crypt_helper(const char *key, const char *salt, char *encrypted, int len)+{+ char *result;+ int req;++ result = crypt(key, salt);+ if (result == 0)+ return -1;++ req = strlen(result) + 1;+ if (req > len)+ return req;++ strcpy(encrypted, result);++ return 0;+}
+ src/cbits/crypt.h view
@@ -0,0 +1,2 @@++int crypt_helper(const char *, const char *, char *, int);
+ src/cbits/match.c view
@@ -0,0 +1,93 @@++# include <string.h>+# 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;+}
+ src/cbits/match.h view
@@ -0,0 +1,5 @@++# include <pcre.h>++int match_helper(const pcre *, pcre_extra *, const char *, int, int, int *);+int rmatch_helper(const pcre *, pcre_extra *, const char *, int, int, int *);
src/etamoo.hs view
@@ -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 ++ "'"