Commit 127a2d41 authored by Bas Lijnse's avatar Bas Lijnse

Centralized itasks engine options in an EngineOptions record that you can...

Centralized itasks engine options in an EngineOptions record that you can customize using startEngineWithOptions
parent 89dd8f56
......@@ -5,7 +5,7 @@ definition module iTasks
*/
import
// iTasks engine
iTasks.Internal.Engine
iTasks.Engine
// iTasks API
, iTasks.SDS.Definition
, iTasks.SDS.Sources.Core
......
definition module iTasks.Internal.Engine
definition module iTasks.Engine
/**
* This module provides the iTasks engine.
* This is the primary function that creates the complete
......@@ -6,37 +6,26 @@ definition module iTasks.Internal.Engine
*/
from StdList import ++, iterate, take
from System.FilePath import </>
from Data.Maybe import :: Maybe
from System.FilePath import :: FilePath
from System.OS import IF_POSIX_OR_WINDOWS
import iTasks.Internal.Task
from Internet.HTTP import :: HTTPRequest
from Internet.HTTP import :: HTTPRequest
import iTasks.WF.Definition
//* Configuration defaults
DEFAULT_PORT :== IF_POSIX_OR_WINDOWS 8080 80
DEFAULT_KEEPALIVE_TIME :== 300 // 5 minutes
SESSION_TIMEOUT :== 600 //Seconds (10 minutes)
MAX_EVENTS :== 5
:: PublishedTask =
{ url :: String
, task :: WebTaskWrapper
}
:: ServerOptions =
:: EngineOptions =
{ appName :: String
, appPath :: FilePath
, appPath :: FilePath // Location of the application's executable
, appVersion :: String
, serverPort :: Int
, keepalive :: Int
, serverUrl :: String
, keepaliveTime :: Int
, sessionTime :: Int
, persistTasks :: Bool
, webDirPath :: Maybe FilePath
, storeDirPath :: Maybe FilePath
, saplDirPath :: Maybe FilePath
, webDirPath :: FilePath // Location of public files that are served by the iTask webserver
, storeDirPath :: FilePath // Location of the application's persistent data files
, tempDirPath :: FilePath // Location for temporary files used in tasks
, saplDirPath :: FilePath // Location of the application's sapl files (client-side code)
}
:: WebTaskWrapper = E.a: WebTaskWrapper (HTTPRequest -> Task a) & iTask a
:: TaskWrapper = E.a: TaskWrapper (Task a) & iTask a
/**
* Starts the task engine with a list of published task definitions.
......@@ -51,11 +40,51 @@ startEngine :: a !*World -> *World | Publishable a
* Starts the task engine with options and a list of published task definitions.
*
* @param Tasks to start
* @param Options to use like port and server paths.
* @param An initialization function to set the engine options with:
@param The command line arguments
@param The default options
@return Maybe the engine options, in case of Nothing, the engine is not started
@return A message that is printed to the console when the engine is started
* @param The world
* @return The world
*/
startEngineWithOptions :: a ServerOptions !*World -> *World | Publishable a
startEngineWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Publishable a
/**
* The function that takes the 'standard' command line options of an itask engine and
* shows the default help and startup message
*
* Essentially: startEngine = startEngineWithOptions defaultEngineCLIOptions
* @param The command line arguments
* @param The default options
* @return Maybe the engine options, in case of Nothing, the engine is not started
* @return A message that is printed to the console when the engine is started
*/
defaultEngineCLIOptions :: [String] EngineOptions -> (!Maybe EngineOptions,![String])
/**
* Determines the default options for an application
*/
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
/**
* Start a stripped task engine (without an HTTP server) with a list of tasks to be created
*/
runTasks :: a !*World -> *World | Runnable a
runTasksWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Runnable a
// === Wrapping interactive tasks for use with the builtin iTask webserver ===
:: PublishedTask =
{ url :: String
, task :: WebTaskWrapper
}
:: WebTaskWrapper = E.a: WebTaskWrapper (HTTPRequest -> Task a) & iTask a
:: TaskWrapper = E.a: TaskWrapper (Task a) & iTask a
/**
* Wraps a task together with a url to make it publishable by the engine
......@@ -76,20 +105,11 @@ instance Publishable (Task a) | iTask a
instance Publishable (HTTPRequest -> Task a) | iTask a
instance Publishable [PublishedTask]
determineAppName :: !*World -> (!String,!*World)
// === Wrapping non-interactive tasks for running on the command line ===
/**
* Start a stripped task engine (without an HTTP server) with a list of tasks to be created
*/
class Runnable a
where
toRunnable :: !a -> [TaskWrapper]
instance Runnable (Task a) | iTask a
instance Runnable [TaskWrapper]
runTasks :: a !*World -> *World | Runnable a
//HACK FOR RUNNING BACKGROUND TASKS ON A CLIENT
background :: !*IWorld -> *IWorld
implementation module iTasks.Extensions.Admin.StoreAdmin
import iTasks
import qualified iTasks.Internal.Store
import qualified iTasks.Internal.Task
import Data.Error
manageStore :: Task ()
......@@ -20,7 +21,7 @@ selectStore
//Low-level access
deleteStore :: (String,String) -> Task ()
deleteStore (namespace,storename) = mkInstantTask eval
deleteStore (namespace,storename) = 'iTasks.Internal.Task'.mkInstantTask eval
where
eval _ iworld = case 'iTasks.Internal.Store'.deleteValue namespace storename iworld of
(Ok (),iworld) = (Ok (),iworld)
......
......@@ -2,7 +2,7 @@ definition module iTasks.Extensions.Admin.TonicAdmin
import iTasks
from iTasks.Internal.Tonic.Images import :: TaskAppRenderer, :: ModelTy, :: ClickMeta, :: TonicImageState, :: ActionState, :: TClickAction
from iTasks.Internal.Tonic.Types import :: AllBlueprints, :: TonicModule, :: TonicFunc, :: FuncName, :: ModuleName, :: NavStack, :: BlueprintIdent
from iTasks.Internal.Tonic.Types import :: AllBlueprints, :: TonicModule, :: TonicFunc, :: FuncName, :: ModuleName, :: NavStack, :: BlueprintIdent, :: ExprId
from Graphics.Scalable import :: TagSource, :: TagRef, :: Image, :: ImageTag
tonicDashboard :: [TaskAppRenderer] -> Task ()
......
......@@ -9,6 +9,7 @@ import iTasks.Internal.Tonic.Types
import iTasks.Internal.Tonic.AbsSyn
import iTasks.Internal.Tonic.Pretty
import iTasks.Internal.Tonic.Images
import iTasks.Internal.Task
import iTasks.UI.Definition
import iTasks.Extensions.DateTime
from StdFunc import seq
......
......@@ -2,6 +2,7 @@ implementation module iTasks.Extensions.Development.Tools
import iTasks
import iTasks.Internal.IWorld, iTasks.Internal.SDS
import System.Environment
import System.OS
CPM_EXE :== IF_POSIX_OR_WINDOWS "bin/cpm" "Tools\\cpm.exe"
......
implementation module iTasks.Extensions.SQLDatabase
import iTasks, Database.SQL, Database.SQL.MySQL, Database.SQL.SQLite, Data.Error, Data.Func, System.FilePath
import iTasks.Internal.IWorld, iTasks.Internal.SDS
import iTasks.Internal.Task, iTasks.Internal.IWorld, iTasks.Internal.SDS
import qualified Data.Map
//Extend Resource type for mysql resources
......@@ -249,8 +249,8 @@ openSQLiteDB :: !SQLDatabase !*IWorld -> (MaybeErrorString (!*SQLiteCursor, !*SQ
openSQLiteDB db iworld=:{IWorld|resources=Just (SQLiteResource con)}
= (Ok con, {IWorld|iworld & resources=Nothing})
openSQLiteDB db iworld=:{IWorld|resources=Nothing}
# iworld=:{IWorld|world,server={paths={dataDirectory}}} = {IWorld|iworld & resources = Nothing}
# db = {db & database = dataDirectory </> db.database}
# iworld=:{IWorld|world,options={storeDirPath}} = {IWorld|iworld & resources = Nothing}
# db = {db & database = storeDirPath </> db.database}
# (err,mbContext,world) = openContext world
| isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world})
# (err,mbConn,context) = openConnection db (fromJust mbContext)
......
......@@ -13,7 +13,6 @@ from Data.Set import :: Set, newSet
from iTasks.UI.JS.Interface import :: JSWorld, :: JSEvent, :: JSObj, :: JSObject, :: JSVal
from iTasks.Internal.Client.RunOnClient import createClientIWorld, getUIUpdates
from iTasks.Internal.Engine import background
import iTasks.Internal.IWorld
import Sapl.Target.JS.CodeGeneratorJS, Sapl.Linker.LazyLinker, Sapl.SaplParser
......
......@@ -122,16 +122,18 @@ createClientIWorld serverURL currentInstance
# world = newWorld
# (timestamp=:(Timestamp seed),world) = time world
= {IWorld
|server =
{serverName = "application"
,serverURL = serverURL
,buildID = "build"
,paths = {appDirectory = locundef "appDirectory"
,dataDirectory = locundef "dataDirectory"
,webDirectory = locundef "webDirectory"
,saplDirectory = locundef "saplDirectory"}
}
,config = {sessionTime = 3600, smtpServer = locundef "smtpServer", persistTasks = True}
|options = { appName = "application"
, appPath = locundef "appDirectory"
, appVersion = locundef "appVersion"
, serverPort = 80
, serverUrl = locundef "serverUrl"
, keepaliveTime = locundef "keepaliveTime"
, sessionTime = locundef "sessionTime"
, persistTasks = False
, webDirPath = locundef "webDirectory"
, storeDirPath = locundef "dataDirectory"
, tempDirPath = locundef "tempDirectory"
, saplDirPath = locundef "saplDirectory"}
,clocks =
{ timestamp = timestamp
, localDate = {Date|day = 1, mon = 1, year = 1977}
......
......@@ -10,6 +10,7 @@ from StdFile import class FileSystem
from System.Time import :: Timestamp
from Text.JSON import :: JSONNode
from System.Process import :: ProcessHandle, :: ProcessIO
from iTasks.Engine import :: EngineOptions
from iTasks.UI.Definition import :: UI, :: UINodeType
from iTasks.Internal.TaskState import :: ParallelTaskState, :: TIMeta, :: DeferredJSON
from iTasks.Internal.Task import :: ExternalProcessTask, :: ConnectionTask, :: BackgroundTask
......@@ -29,8 +30,7 @@ from TCPIP import :: TCP_Listener, :: TCP_Listener_, :: TCP_RChannel_, :: TCP_SC
CLEAN_HOME_VAR :== "CLEAN_HOME"
:: *IWorld = { server :: !ServerInfo // Static server info, initialized at startup
, config :: !Config // Server configuration
:: *IWorld = { options :: !EngineOptions // Engine configuration
, clocks :: !SystemClocks // Server side clocks
, current :: !TaskEvalState // Shared state during task evaluation
......@@ -54,26 +54,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
, shutdown :: !Maybe Int // Signals the server function to shut down, the int will be set as exit code
}
:: Config =
{ sessionTime :: !Int //* Time (in seconds) before inactive sessions are garbage collected. Default is 3600 (one hour).
, smtpServer :: !String //* The smtp server to use for sending e-mails
, persistTasks :: !Bool //* Persist the task state to disk
}
:: ServerInfo =
{ serverName :: !String // The name of the server application
, serverURL :: !String // URL of the server like "//any.com:80"
, buildID :: !String // The date/time identifier of the server's build
, paths :: !SystemPaths // Filesystem paths that are used by iTasks
}
:: SystemPaths =
{ appDirectory :: !FilePath // Location of the application's executable
, dataDirectory :: !FilePath // Location of the application's data files
, webDirectory :: !FilePath // List of directories that contain files that are served publicly by the iTask webserver
, saplDirectory :: !FilePath // Location of the application's sapl files
}
:: SystemClocks =
{ timestamp :: !Timestamp
, localDate :: !Date
......@@ -139,7 +119,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
:: BackgroundTaskId :== Int
:: IOStates :== Map TaskId IOState
:: IOState
= IOActive !(Map ConnectionId (!Dynamic,!Bool)) // Bool: stability
......@@ -156,17 +135,12 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
/**
* Creates and initializes the IWorld state
*
* @param The application's name
* @param The application's path (e.g. to executable).
* @param Persist task administration
* @param The path where static web assets can be found (optional)
* @param The path where the iTasks data store is located (optional)
* @param Path to where the applications's SAPL files are stored (optional)
* @param The engine options
* @param The world
*
* @return An initialized iworld
*/
createIWorld :: !String FilePath !Bool !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
createIWorld :: !EngineOptions !*World -> *IWorld
/**
* Initialize the SAPL->JS compiler state
......
......@@ -9,8 +9,8 @@ from Text.JSON import :: JSONNode
from iTasks.WF.Definition import :: TaskId, :: InstanceNo, :: TaskNo
from iTasks.WF.Combinators.Core import :: TaskListItem, :: ParallelTaskType
from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime, toTime, toDate
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Internal.IWorld import :: Config
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Engine import :: EngineOptions(..)
from System.Process import :: ProcessHandle, :: ProcessIO
from StdFile import class FileSystem(..)
......@@ -55,35 +55,13 @@ JS_COMPILER_EXCLUDES :==
,"System.Directory"
]
createIWorld :: !String FilePath !Bool !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
createIWorld appName appPath persistTasks mbWebdirPath mbStorePath mbSaplPath world
# appDir = takeDirectory appPath
# dataDir = fromMaybe (appDir </> appName +++ "-data") mbStorePath
# webDir = fromMaybe (appDir </> appName +++ "-www") mbWebdirPath
# saplDir = fromMaybe (appDir </> appName +++ "-sapl") mbSaplPath
# (saplDir,world) = fallBackSaplDir appDir saplDir world
# (res,world) = getFileInfo appPath world
| isError res = abort "Cannot get executable info."
# tm = (fromOk res).lastModifiedTime
# build = strfTime "%Y%m%d-%H%M%S" tm
createIWorld :: !EngineOptions !*World -> *IWorld
createIWorld options world
# (local,world) = currentLocalDateTimeWorld world
# (utc,world) = currentUTCDateTimeWorld world
# tmpDir = dataDir </> "tmp"
# storeDir = dataDir </> "stores"
# (timestamp=:(Timestamp seed), world) = time world
= {IWorld
|server =
{serverName = appName
,serverURL = "//127.0.0.1:80"
,buildID = build
,paths =
{appDirectory = appDir
,dataDirectory = dataDir
,webDirectory = webDir
,saplDirectory = saplDir
}
}
,config = initialConfig persistTasks
|options = options
,clocks =
{SystemClocks
|timestamp=timestamp
......@@ -114,25 +92,10 @@ createIWorld appName appPath persistTasks mbWebdirPath mbStorePath mbSaplPath wo
,random = genRandInt seed
,onClient = False
}
where
initialConfig persistTasks =
{ sessionTime = 3600
, smtpServer = "localhost"
, persistTasks = persistTasks
}
//Temporary fallback to use "sapl" instead of "<Application name>-sapl".
//Once everybody uses an upgraded sapl-collector-linker that creates the proper
//directory name it can be removed
fallBackSaplDir appDir saplDir world
# (exists, world) = fileExists saplDir world
| exists = (saplDir,world)
= (appDir </> "sapl",world)
initJSCompilerState :: *IWorld -> *(!MaybeErrorString (), !*IWorld)
initJSCompilerState iworld=:{IWorld|world,server={paths={appDirectory,saplDirectory}}}
# ((lst, ftmap, _), world) = generateLoaderState [saplDirectory] [] JS_COMPILER_EXCLUDES world
initJSCompilerState iworld=:{IWorld|world,options={EngineOptions|saplDirPath}}
# ((lst, ftmap, _), world) = generateLoaderState [saplDirPath] [] JS_COMPILER_EXCLUDES world
# jsCompilerState = { loaderState = lst, functionMap = ftmap, flavour = cleanFlavour, parserState = Nothing, skipMap = 'DM'.newMap}
= (Ok (), {iworld & jsCompilerState = Just jsCompilerState, world = world})
......
......@@ -3,6 +3,7 @@ implementation module iTasks.Internal.RemoteAccess
import StdString, StdMisc, StdFile, StdBool, StdArray
import Text
import iTasks.Engine
import iTasks.WF.Definition
import iTasks.Internal.Task
import iTasks.Internal.IWorld
......@@ -41,10 +42,10 @@ closeException s
= Error (dynamic e, toString e)
httpRequest_server :: !HTTPMethod !URI !String !*IWorld -> *(!HTTPResponse, !*IWorld)
httpRequest_server method uri request iworld=:{IWorld|current={taskTime},server={buildID,paths={dataDirectory}},world}
# infile = dataDirectory </> "tmp-" +++ buildID </> (mkFileName "request")
# outfile = dataDirectory </> "tmp-" +++ buildID </> (mkFileName "response")
# hfile = dataDirectory </> "tmp-" +++ buildID </> (mkFileName "response-header")
httpRequest_server method uri request iworld=:{IWorld|current={taskTime},options={tempDirPath},world}
# infile = tempDirPath </> (mkFileName "request")
# outfile = tempDirPath </> (mkFileName "response")
# hfile = tempDirPath </> (mkFileName "response-header")
# (res,world) = writeFile infile request world
| isError res
= abort "httpRequest_server: infile creation error"
......
......@@ -6,6 +6,7 @@ from Data.Map import :: Map
import qualified Data.Map as DM
import Data.Error, Data.Func, Data.Tuple, System.Time, Text, Text.JSON
import qualified Data.Set as Set
import iTasks.Engine
import iTasks.Internal.IWorld
import iTasks.Internal.Task, iTasks.Internal.TaskStore, iTasks.Internal.TaskEval
......@@ -423,12 +424,12 @@ newSDSId iworld=:{IWorld|random}
= (toString (take 32 [toChar (97 + abs (i rem 26)) \\ i <- random]) , {IWorld|iworld&random = drop 32 random})
newURL :: !*IWorld -> (!String, !*IWorld)
newURL iworld=:{IWorld|server={serverURL},random}
newURL iworld=:{IWorld|options={serverUrl},random}
# (sdsId, iworld) = newSDSId iworld
= getURLbyId sdsId iworld
// TODO: different URL for clients
getURLbyId :: !String !*IWorld -> (!String, !*IWorld)
getURLbyId sdsId iworld=:{IWorld|server={serverURL},random}
= ("sds:" +++ serverURL +++ "/" +++ sdsId, iworld)
getURLbyId sdsId iworld=:{IWorld|options={serverUrl},random}
= ("sds:" +++ serverUrl +++ "/" +++ sdsId, iworld)
......@@ -10,11 +10,11 @@ import Text, Text.JSON, iTasks.Internal.Serialization
import iTasks.Internal.Client.JSStore
import iTasks.Internal.SDS
from iTasks.Internal.IWorld import :: IWorld {config,onClient,server,memoryShares,world}, :: ServerInfo(..), :: SystemPaths(..), :: Resource
from iTasks.Engine import :: EngineOptions(..)
from iTasks.Internal.IWorld import :: IWorld {options,onClient,memoryShares,world}, :: Resource
from iTasks.Internal.Task import exception
from iTasks.Internal.TaskState import :: DeferredJSON(..)
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Internal.IWorld import :: Config(..)
from iTasks.WF.Definition import class iTask
from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat(..), toMultiLineText
......@@ -46,89 +46,6 @@ memoryStore namespace defaultV = storeShare namespace False InMemory defaultV
jsonFileStore :: !StoreNamespace !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
jsonFileStore namespace check reset defaultV = storeShare namespace True InJSONFile defaultV
blobStoreWrite :: !StoreNamespace !StoreName !{#Char} !*IWorld -> *IWorld //TODO: Propagate error up
blobStoreWrite namespace key blob iworld=:{IWorld|onClient=True}
= jsStoreValue namespace key blob iworld
blobStoreWrite namespace key blob iworld
# (_,iworld) = writeToDisk namespace key blob iworld
= iworld
blobStoreRead :: !StoreNamespace !StoreName !*IWorld -> (!MaybeError StoreReadError {#Char}, !*IWorld)
blobStoreRead namespace key iworld=:{onClient=True}
# (mbBlob,iworld) =jsLoadValue namespace key iworld
= (maybe (Error (StoreReadMissingError (namespace +++ "/" +++ key))) Ok mbBlob, iworld)
blobStoreRead namespace key iworld
= case readFromDisk namespace key iworld of
(Ok (_,content),iworld) = (Ok content,iworld)
(Error e,iworld) = (Error e,iworld)
writeToDisk :: !StoreNamespace !StoreName !String !*IWorld -> (MaybeErrorString (), *IWorld)
writeToDisk namespace key content iworld=:{server={buildID,paths={dataDirectory}},world}
# location = dataDirectory </> "stores"
//Check if the location exists and create it otherwise
# (exists,world) = fileExists location world
# (res,world) = if exists (Ok (),world)
( case createDirectory location world of
(Ok (), world) = (Ok (),world)
(Error e, world) = (Error ("Cannot create store: " +++ location +++ ": " +++ snd e), world)
)
| res =: (Error _)
= (res,{IWorld|iworld & world = world})
//Check if the namespace exists and create it otherwise
# (exists,world) = fileExists (location </> namespace) world
# (res,world) = if exists (Ok (),world)
( case createDirectory (location </> namespace) world of
(Ok (), world) = (Ok (), world)
(Error e, world) = (Error ("Cannot create namespace " +++ namespace +++ ": " +++ snd e), world)
)
| res =: (Error _)
= (res,{IWorld|iworld & world = world})
//Write the value
# filename = addExtension (location </> namespace </> safeName key) "txt"
# (ok,file,world) = fopen filename FWriteData world
| not ok = (Error ("Failed to write value to store: " +++ filename),{IWorld|iworld & world = world})
//Write build ID
# file = fwrites buildID file
//Write content
# file = fwrites content file
# (ok,world) = fclose file world
= (Ok (),{IWorld|iworld & world = world})
readFromDisk :: !StoreNamespace !StoreName !*IWorld -> (MaybeError StoreReadError (!BuildID,!String), !*IWorld)
readFromDisk namespace key iworld=:{server={paths={dataDirectory}},world}
# filename = addExtension (dataDirectory </> "stores" </> namespace </> safeName key) "txt"
# (ok,file,world) = fopen filename FReadData world
| ok
# (maybe_build_id_and_content,file) = read_file storeDesc file
# (ok,world) = fclose file world
| ok
= (maybe_build_id_and_content,{iworld & world = world})
= (Error (StoreReadDataError storeDesc),{iworld & world = world})
| otherwise
= (Error (StoreReadMissingError storeDesc), {iworld & world = world})
where
read_file :: !String !*File -> (!MaybeError StoreReadError (BuildID,String), !*File)
read_file desc file
# (buildId,file) = freads file 15
| size buildId<15
= (Ok (buildId,""),file)
# (ok,file) = fseek file 0 FSeekEnd
| not ok
= (Error (StoreReadDataError desc),file)
# (file_size,file) = fposition file
| file_size<15
= (Error (StoreReadDataError desc),file)
# (ok,file) = fseek file 15 FSeekSet
| not ok
= (Error (StoreReadDataError desc),file)
# content_size = file_size - 15;
# (content,file) = freads file content_size;
| size content<>content_size
= (Error (StoreReadDataError desc),file)
= (Ok (buildId,content),file)
storeDesc = namespace +++ "/" +++ key
deleteValue :: !StoreNamespace !StoreName !*IWorld -> *(MaybeErrorString (),*IWorld)
deleteValue namespace delKey iworld=:{onClient=True}
= (Ok (), jsDeleteValue namespace delKey iworld)
......@@ -141,13 +58,13 @@ deleteValues :: !StoreNamespace !StorePrefix !*IWorld -> *(MaybeErrorString (),*
deleteValues namespace delKey iworld = deleteValues` namespace delKey startsWith startsWith iworld
deleteValues` :: !String !String !(String String -> Bool) !(String String -> Bool) !*IWorld -> *(MaybeErrorString (),*IWorld)
deleteValues` namespace delKey filterFuncCache filterFuncDisk iworld=:{server={buildID,paths={dataDirectory}},world}
deleteValues` namespace delKey filterFuncCache filterFuncDisk iworld=:{options={storeDirPath},world}
//Delete items from disk
# (res,world) = deleteFromDisk world
= (res,{iworld & world = world})
where
deleteFromDisk world
# storeDir = dataDirectory </>"store"</> namespace
# storeDir = storeDirPath</> namespace
# (res, world) = readDirectory storeDir world
= case res of
(Ok _) = deleteFiles storeDir (fromOk res) world
......@@ -184,19 +101,19 @@ where
= copy (i + 1) {n & [i] = '_'}
listStoreNamespaces :: !*IWorld -> (![StoreNamespace], !*IWorld)
listStoreNamespaces iworld=:{server={buildID,paths={dataDirectory}},world}
# (res,world) = readDirectory (dataDirectory</>"stores") world
listStoreNamespaces iworld=:{options={storeDirPath},world}
# (res,world) = readDirectory storeDirPath world
= case res of
Error e = ([], {iworld & world = world})
Ok files = ([f \\ f <- files | not (f == "." || f == "..")], {iworld & world = world})