Commit 89dd8f56 authored by Bas Lijnse's avatar Bas Lijnse

MAJOR CHANGE

Completely changed the way the store works. It is now fully built on top of the core SDS sources and combinators. Before the store existed as part of the engine although you could access it using some SDS's.
To make this possible I added a generic caching combinator for SDS's such that caching is no longer limited to files in the store, but can be applied to any shared source.

This change removes *a lot* of unnecessary I/O and makes iTask apps feel more responsive.
parent bdbc3f34
......@@ -69,13 +69,13 @@ where
moduleDefinition :: SDS (FilePath,ModuleName) [String] [String]
moduleDefinition = mapReadWrite mapToLines (sdsTranslate "moduleDefinition" (\(p,m) -> modulePath p m "dcl") externalFile)
moduleDefinition = mapReadWrite mapToLines (sdsTranslate "moduleDefinition" (\(p,m) -> modulePath p m "dcl") (removeMaybe (Just "") fileShare))
moduleImplementation :: SDS (FilePath,ModuleName) [String] [String]
moduleImplementation = mapReadWrite mapToLines (sdsTranslate "moduleImplementation" (\(p,m) -> modulePath p m "icl") externalFile)
moduleImplementation = mapReadWrite mapToLines (sdsTranslate "moduleImplementation" (\(p,m) -> modulePath p m "icl") (removeMaybe (Just "") fileShare))
moduleDocumentation :: SDS (FilePath,ModuleName) [String] [String]
moduleDocumentation = mapReadWrite mapToLines (sdsTranslate "moduleDocumentation" (\(p,m) -> modulePath p m "md") externalFile)
moduleDocumentation = mapReadWrite mapToLines (sdsTranslate "moduleDocumentation" (\(p,m) -> modulePath p m "md") (removeMaybe (Just "") fileShare))
mapToLines = (split "\n",\w _ -> Just (join "\n" w))
......
implementation module iTasks.Extensions.User
import iTasks
import Text
import Data.Functor
import Data.Functor, Data.Either
import qualified Data.Map as DM
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Combinators
import iTasks.UI.Layout.Default
......@@ -186,7 +186,11 @@ where
taskInstancesForCurrentUser :: ROShared () [TaskInstance]
taskInstancesForCurrentUser
= sdsSequence "taskInstancesForCurrentUser" (\() u -> u) snd (SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ _ -> Ok Nothing)) currentUser taskInstancesForUser
= sdsSequence "taskInstancesForCurrentUser"
id
(\() u -> u)
(\_ _ -> Right snd)
(SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ _ -> Ok Nothing)) currentUser taskInstancesForUser
workOn :: !t -> Task AttachmentStatus | toInstanceNo t
workOn t
......
......@@ -148,7 +148,8 @@ createClientIWorld serverURL currentInstance
}
,sdsNotifyRequests = []
,memoryShares = 'Data.Map'.newMap
,cachedShares = 'Data.Map'.newMap
,readCache = 'Data.Map'.newMap
,writeCache = 'Data.Map'.newMap
,exposedShares = 'Data.Map'.newMap
,jsCompilerState = locundef "jsCompilerState"
,shutdown = Nothing
......
......@@ -119,7 +119,8 @@ where
systemTasks =
[BackgroundTask updateClocks
,BackgroundTask (processEvents MAX_EVENTS)
,BackgroundTask removeOutdatedSessions]
,BackgroundTask removeOutdatedSessions
,BackgroundTask flushWritesWhenIdle]
runTasks :: a !*World -> *World | Runnable a
runTasks tasks world
......@@ -214,6 +215,14 @@ where
where
(Timestamp tNow) = timestamp
//When the event queue is empty, write deferred SDS's
flushWritesWhenIdle:: !*IWorld -> (!MaybeError TaskException (), !*IWorld)
flushWritesWhenIdle iworld = case read taskEvents iworld of
(Error e,iworld) = (Error e,iworld)
(Ok (Queue [] []),iworld) = flushDeferredSDSWrites iworld
(Ok _,iworld) = (Ok (),iworld)
//When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop
//once all tasks are stable
stopOnStable :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
......
......@@ -5,6 +5,7 @@ from Data.Map import :: Map
from Data.Maybe import :: Maybe
from Data.Error import :: MaybeError(..), :: MaybeErrorString(..)
from Data.Set import :: Set
from Data.Queue import :: Queue
from StdFile import class FileSystem
from System.Time import :: Timestamp
from Text.JSON import :: JSONNode
......@@ -17,7 +18,7 @@ from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.WF.Definition import :: TaskValue, :: Event, :: TaskId, :: InstanceNo, :: TaskNo
from iTasks.WF.Combinators.Core import :: ParallelTaskType, :: TaskListItem
from iTasks.SDS.Definition import :: SDS, :: RWShared, :: ReadWriteShared, :: Shared
from iTasks.Internal.SDS import :: SDSNotifyRequest, :: JSONShared
from iTasks.Internal.SDS import :: SDSNotifyRequest, :: JSONShared, :: DeferredWrite
from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime
from Sapl.Linker.LazyLinker import :: LoaderState
......@@ -28,23 +29,24 @@ 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
, clocks :: !SystemClocks // Server side clocks
, current :: !TaskEvalState // Shared state during task evaluation
:: *IWorld = { server :: !ServerInfo // Static server info, initialized at startup
, config :: !Config // Server configuration
, clocks :: !SystemClocks // Server side clocks
, current :: !TaskEvalState // Shared state during task evaluation
, random :: [Int] // Infinite random stream
, random :: [Int] // Infinite random stream
, sdsNotifyRequests :: ![SDSNotifyRequest] // Notification requests from previously read sds's
, memoryShares :: !Map (String,String) Dynamic // Run-time memory shares
, cachedShares :: !ShareCache // Cached json file shares
, exposedShares :: !Map String (Dynamic, JSONShared) // Shared source
, jsCompilerState :: !Maybe JSCompilerState // Sapl to Javascript compiler state
, sdsNotifyRequests :: ![SDSNotifyRequest] // Notification requests from previously read sds's
, memoryShares :: !Map String Dynamic // Run-time memory shares
, readCache :: !Map (String,String) Dynamic // Cached share reads
, writeCache :: !Map (String,String) (Dynamic,DeferredWrite) // Cached deferred writes
, exposedShares :: !Map String (Dynamic, JSONShared) // Shared source
, jsCompilerState :: !Maybe JSCompilerState // Sapl to Javascript compiler state
, ioTasks :: !*IOTasks // The low-level input/output tasks
, ioStates :: !IOStates // Results of low-level io tasks, indexed by the high-level taskid that it is linked to
, ioTasks :: !*IOTasks // The low-level input/output tasks
, ioStates :: !IOStates // Results of low-level io tasks, indexed by the high-level taskid that it is linked to
, world :: !*World // The outside world
, world :: !*World // The outside world
//Experimental database connection cache
, resources :: !*(Maybe *Resource)
......@@ -55,7 +57,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
:: 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
}
......@@ -81,10 +82,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
, utcTime :: !Time
}
// share cached used for json stores (Store.cachedJSONFileStore) and dynamic string stores (Store.cachedDynamicStringFileStore)
:: ShareCache :== Map (String, String) (Dynamic, Bool, Maybe CachedValue)
:: CachedValue = CachedJSONValue DeferredJSON | CachedDynamicValue
:: JSCompilerState =
{ loaderState :: !LoaderState // State of the lazy loader
, functionMap :: !FuncTypeMap // Function name -> source code mapping
......
......@@ -68,11 +68,8 @@ createIWorld appName appPath persistTasks mbWebdirPath mbStorePath mbSaplPath wo
# build = strfTime "%Y%m%d-%H%M%S" tm
# (local,world) = currentLocalDateTimeWorld world
# (utc,world) = currentUTCDateTimeWorld world
# (_,world) = ensureDir "data" dataDir world
# tmpDir = dataDir </> "tmp"
# (_,world) = ensureDir "tmp" tmpDir world
# storeDir = dataDir </> "stores"
# (exists,world) = ensureDir "stores" storeDir world
# (timestamp=:(Timestamp seed), world) = time world
= {IWorld
|server =
......@@ -105,7 +102,8 @@ createIWorld appName appPath persistTasks mbWebdirPath mbStorePath mbSaplPath wo
}
,sdsNotifyRequests = []
,memoryShares = 'DM'.newMap
,cachedShares = 'DM'.newMap
,readCache = 'DM'.newMap
,writeCache = 'DM'.newMap
,exposedShares = 'DM'.newMap
,jsCompilerState = Nothing
,shutdown = Nothing
......@@ -123,14 +121,6 @@ where
, persistTasks = persistTasks
}
ensureDir :: !String !FilePath *World -> (!Bool,!*World)
ensureDir name path world
# (exists, world) = fileExists path world
| exists = (True,world)
# (res, world) = createDirectory path world
| isError res = abort ("Cannot create " +++ name +++ " directory" +++ path +++ " : " +++ snd (fromError res))
= (False,world)
//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
......
......@@ -21,7 +21,7 @@ import iTasks.SDS.Definition
}
:: SDSIdentity :== String
//:: WriteShare p = E.r w: Write !w !(RWShared p r w)
:: DeferredWrite = E. p r w: DeferredWrite !p !w !(SDS p r w) & iTask p & TC r & TC w
//Internal creation functions:
......@@ -46,13 +46,13 @@ createReadOnlySDSError ::
//Internal access functions
//Just read an SDS
read :: !(RWShared () r w) !*IWorld -> (!MaybeError TaskException r, !*IWorld)
read :: !(RWShared () r w) !*IWorld -> (!MaybeError TaskException r, !*IWorld) | TC r
//Read an SDS and register a taskId to be notified when it is written
readRegister :: !TaskId !(RWShared () r w) !*IWorld -> (!MaybeError TaskException r, !*IWorld)
readRegister :: !TaskId !(RWShared () r w) !*IWorld -> (!MaybeError TaskException r, !*IWorld) | TC r
//Write an SDS (and queue evaluation of those task instances which contained tasks that registered for notification)
write :: !w !(RWShared () r w) !*IWorld -> (!MaybeError TaskException (), !*IWorld)
write :: !w !(RWShared () r w) !*IWorld -> (!MaybeError TaskException (), !*IWorld) | TC r & TC w
//Read followed by write. The 'a' typed value is a result that is returned
modify :: !(r -> (!a,!w)) !(RWShared () r w) !*IWorld -> (!MaybeError TaskException a, !*IWorld)
modify :: !(r -> (!a,!w)) !(RWShared () r w) !*IWorld -> (!MaybeError TaskException a, !*IWorld) | TC r & TC w
//Force notify (queue evaluation of task instances that registered for notification)
notify :: !(RWShared () r w) !*IWorld -> (!MaybeError TaskException (), !*IWorld)
......@@ -66,10 +66,13 @@ clearInstanceSDSRegistrations :: ![InstanceNo] !*IWorld -> *IWorld
listAllSDSRegistrations :: *IWorld -> (![(InstanceNo,[(TaskId,SDSIdentity)])],!*IWorld)
formatSDSRegistrationsList :: [(InstanceNo,[(TaskId,SDSIdentity)])] -> String
//Flush all deffered/cached writes of
flushDeferredSDSWrites :: !*IWorld -> (!MaybeError TaskException (), !*IWorld)
:: JSONShared :== RWShared JSONNode JSONNode JSONNode
//Exposing shares for external nodes
toJSONShared :: (RWShared p r w) -> JSONShared | JSONDecode{|*|} p & JSONEncode{|*|} r & JSONDecode{|*|} w & iTask p
toJSONShared :: (RWShared p r w) -> JSONShared | JSONDecode{|*|} p & JSONEncode{|*|} r & JSONDecode{|*|} w & iTask p & TC r & TC w
fromJSONShared :: JSONShared -> RWShared p r w | JSONEncode{|*|} p & JSONDecode{|*|} r & JSONEncode{|*|} w
newURL :: !*IWorld -> (!String, !*IWorld)
getURLbyId :: !String !*IWorld -> (!String, !*IWorld)
......
This diff is collapsed.
......@@ -32,7 +32,6 @@ from GenEq import generic gEq
NS_TASK_INSTANCES :== "task-instances"
NS_DOCUMENT_CONTENT :== "document-data"
NS_APPLICATION_SHARES :== "application-data"
NS_JAVASCRIPT_CACHE :== "js-cache"
:: StoreReadError
= StoreReadMissingError !StoreName //When there is no file on disk for this
......@@ -43,41 +42,13 @@ NS_JAVASCRIPT_CACHE :== "js-cache"
instance toString StoreReadError
derive class iTask StoreReadError
//For system stores, the server configuration determines if and when data is written to disk
//This storage preference type is used to indicate
:: StoragePreference
= StoreInMemory //When the data is disposable. It will be gone when the application shuts down
| StoreInJSONFile //When the data should be persisted between different versions of an application
| StoreInDynamicFile //When the data contains functions, dynamics or otherwise
/**
* Creates a store in memory. Values in this store are lost when the server shuts down.
*
* @param The namespace in the store
* @param Optionally a default content to be used on first read. If nothing is given an error will occur when reading before writing.
*/
memoryStore :: !StoreNamespace !(Maybe a) -> RWShared StoreName a a | TC a
/**
* Creates a 'raw' store which keeps values in multiple files indexed by a store name
* The application's build ID is automatically stored with the content, and returned when reading
*
* @param The namespace in the store
* @param Automatically reset the the store if an error occurs
* @param Optionally a default content to be used on first read. If nothing is given an error will occur when reading before writing.
*/
fullFileStore :: !StoreNamespace !Bool !(Maybe {#Char}) -> RWShared StoreName (!BuildID,!{#Char}) {#Char}
/**
* Creates a store that is either in-memory, or persisted to disk depending on the global configuation option
*
* @param The namespace in the store
* @param Check the build version
* @param Automatically reset the the store if an error occurs
* @param Cache the value
* @param Optionally a default content to be used on first read. If nothing is given an error will occur when reading before writing.
*/
systemStore :: !StoreNamespace !StoragePreference !Bool !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
memoryStore :: !StoreNamespace !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
/**
* Extends a fullFileStore with JSON encoding/decoding such that arbitrary values can be stored.
......@@ -91,50 +62,6 @@ systemStore :: !StoreNamespace !StoragePreference !Bool !Bool !Bool !(Maybe a) -
*/
jsonFileStore :: !StoreNamespace !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
/**
* Optimized caching version of the jsonFileStore.
* During the evaluation of a task instance, the shares that are read from disk are kept in memory,
* writes are applied to the in-memory version, and json encoding and writing to disk is deferred.
*
* @param The namespace in the store
* @param Check the build versions to protect against deserializing outdated functions stored by older versions
* @param Automatically reset the the store if an error occurs
* @param Keep the value in the cache between evaluations
* @param Optionally a default content to be used on first read. If nothing is given an error will occur when reading before writing.
*/
cachedJSONFileStore :: !StoreNamespace !Bool !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
/**
* Extends a fullFileStore with dynamic string encoding such that arbitrary values can be stored.
* This encoding can be significantly more efficient for storing large functions.
* Additionally, caching is applied as for cachedJSONFileStore.
* During the evaluation of a task instance, the shares that are read from disk are kept in memory,
* writes are applied to the in-memory version, and encoding and writing to disk is deferred.
*
* @param The namespace in the store
* @param Check the build versions to protect against deserializing outdated functions stored by older versions
* @param Automatically reset the the store if an error occurs
* @param Keep the value in the cache between evaluations
* @param Optionally a default content to be used on first read. If nothing is given an error will occur when reading before writing.
*/
cachedDynamicStringFileStore :: !StoreNamespace !Bool !Bool !Bool !(Maybe a) -> RWShared StoreName a a | TC a
/**
* This function is called at the very end of the evaluation of a task instance.
* It writes all pending writes to disk and clears values that are no longer needed from memory.
*/
flushShareCache :: *IWorld -> *IWorld
/**
* Store a binary blob
*/
blobStoreWrite :: !StoreNamespace !StoreName !{#Char} !*IWorld -> *IWorld
/**
* Load a binary blob
*/
blobStoreRead :: !StoreNamespace !StoreName !*IWorld -> (!MaybeError StoreReadError {#Char}, !*IWorld)
/**
* Deletes the value with given key from the store
*/
......@@ -158,8 +85,3 @@ listStoreNames :: !StoreNamespace !*IWorld ->
* Delete all values in the store
*/
emptyStore :: !*IWorld -> *IWorld
//writeToDisk :: !StoreNamespace !StoreName !String !*IWorld -> *IWorld
writeToDisk :: !StoreNamespace !StoreName !String !*IWorld -> (MaybeErrorString (), *IWorld)
readFromDisk :: !StoreNamespace !StoreName !*IWorld -> (MaybeError StoreReadError (!BuildID, !String), !*IWorld)
This diff is collapsed.
......@@ -144,7 +144,6 @@ where
NoChange = (Ok value,iworld)
change
# iworld = queueUIChange instanceNo change iworld
# iworld = flushShareCache iworld
= (Ok value, iworld)
(ExceptionResult (e,msg))
= (Error msg, iworld)
......
......@@ -509,7 +509,7 @@ where
# ioStates = 'DM'.put taskId (IOActive taskStates) ioStates
= closeIO (ioChannels, iworld)//{iworld & ioStates = ioStates})
writeShareIfNeeded :: !(RWShared () r w) !(Maybe w) !*IWorld -> (!MaybeError TaskException (), !*IWorld)
writeShareIfNeeded :: !(RWShared () r w) !(Maybe w) !*IWorld -> (!MaybeError TaskException (), !*IWorld) | TC r & TC w
writeShareIfNeeded sds Nothing iworld = (Ok (), iworld)
writeShareIfNeeded sds (Just w) iworld = 'SDS'.write w sds iworld
......
......@@ -2,7 +2,7 @@ implementation module iTasks.Internal.TaskStore
import StdOverloaded, StdBool, StdArray, StdTuple
from StdFunc import const, id, o
import Data.Maybe, Text, System.Time, Math.Random, Text.JSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath, Data.Functor
import Data.Maybe, Data.Either, Text, System.Time, Math.Random, Text.JSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath, Data.Functor
import iTasks.Internal.IWorld, iTasks.Internal.TaskState, iTasks.Internal.Task, iTasks.Internal.Store
import iTasks.Internal.TaskEval, iTasks.Internal.Util, iTasks.UI.Definition
......@@ -13,6 +13,7 @@ import iTasks.Internal.Generic.Visualization
import qualified iTasks.Internal.SDS as SDS
from iTasks.SDS.Definition import :: SDSLensRead(..), :: SDSLensWrite(..), :: SDSLensNotify(..), :: SDS(SDSDynamic)
import iTasks.SDS.Combinators.Core, iTasks.SDS.Combinators.Common
import iTasks.SDS.Sources.Store
import iTasks.Internal.SDSService
import iTasks.Internal.Client.Override
import iTasks.WF.Combinators.Core
......@@ -34,20 +35,18 @@ derive gEq ParallelTaskChange
derive gText ParallelTaskChange
derive class iTask InstanceFilter
//Unfiltered administration
rawTaskIndex = storeShare NS_TASK_INSTANCES False InJSONFile (Just [])
rawTaskNoCounter = storeShare NS_TASK_INSTANCES False InJSONFile (Just 1)
rawTaskIndex = systemStore NS_TASK_INSTANCES StoreInJSONFile False False True (Just [])
rawTaskNoCounter = systemStore NS_TASK_INSTANCES StoreInJSONFile False False True (Just 1)
rawInstanceIO = systemStore NS_TASK_INSTANCES StoreInMemory False False False (Just 'DM'.newMap)
rawInstanceEvents = systemStore NS_TASK_INSTANCES StoreInJSONFile False False True (Just 'DQ'.newQueue)
rawInstanceUIChanges = systemStore NS_TASK_INSTANCES StoreInMemory False False False (Just 'DM'.newMap)
rawInstanceIO = storeShare NS_TASK_INSTANCES False InMemory (Just 'DM'.newMap)
rawInstanceEvents = storeShare NS_TASK_INSTANCES False InMemory (Just 'DQ'.newQueue)
rawInstanceUIChanges = storeShare NS_TASK_INSTANCES False InMemory (Just 'DM'.newMap)
rawInstanceReduct = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False Nothing
rawInstanceValue = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False Nothing
rawInstanceShares = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False (Just 'DM'.newMap)
rawInstanceParallels = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False (Just 'DM'.newMap)
rawInstanceReduct = storeShare NS_TASK_INSTANCES True InDynamicFile Nothing
rawInstanceValue = storeShare NS_TASK_INSTANCES True InDynamicFile Nothing
rawInstanceShares = storeShare NS_TASK_INSTANCES True InDynamicFile (Just 'DM'.newMap)
rawInstanceParallels = storeShare NS_TASK_INSTANCES True InDynamicFile (Just 'DM'.newMap)
//Master instance index
taskInstanceIndex :: RWShared () [TIMeta] [TIMeta]
......@@ -418,7 +417,7 @@ where
parallelTaskList :: RWShared (!TaskId,!TaskId,!TaskListFilter) (!TaskId,![TaskListItem a]) [(!TaskId,!TaskAttributes)] | iTask a
parallelTaskList
= sdsSequence "parallelTaskList" param2 read (SDSWriteConst write1) (SDSWriteConst write2) filteredTaskStates filteredInstanceIndex
= sdsSequence "parallelTaskList" id param2 (\_ _ -> Right read) (SDSWriteConst write1) (SDSWriteConst write2) filteredTaskStates filteredInstanceIndex
where
filteredTaskStates
= sdsLens "parallelTaskListStates" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) taskInstanceParallelTaskList
......@@ -516,17 +515,20 @@ detachViewport instanceNo iworld
# iworld = clearEvents instanceNo iworld
= iworld
documentContent :: SDS String String String
documentContent = sdsTranslate "documentContent" (\docId -> docId +++ "-content") (blobStoreShare NS_DOCUMENT_CONTENT False Nothing)
createDocument :: !String !String !String !*IWorld -> (!MaybeError FileError Document, !*IWorld)
createDocument name mime content iworld
# (documentId, iworld) = newDocumentId iworld
# document = {Document|documentId = documentId, contentUrl = "/download/"+++documentId, name = name, mime = mime, size = size content}
# iworld = blobStoreWrite NS_DOCUMENT_CONTENT (documentId +++ "-data") content iworld
# (_,iworld) = 'SDS'.write content (sdsFocus documentId documentContent) iworld
# (_,iworld) = 'SDS'.write document (sdsFocus documentId (sdsTranslate "document_meta" (\d -> d +++ "-meta") (jsonFileStore NS_DOCUMENT_CONTENT False False Nothing))) iworld
= (Ok document,iworld)
loadDocumentContent :: !DocumentId !*IWorld -> (!Maybe String, !*IWorld)
loadDocumentContent documentId iworld
= case blobStoreRead NS_DOCUMENT_CONTENT (documentId +++ "-data") iworld of
= case 'SDS'.read (sdsFocus documentId documentContent) iworld of
(Ok content,iworld) = (Just content,iworld)
(Error e,iworld) = (Nothing,iworld)
......
......@@ -12,7 +12,7 @@ import Data.Func, Data.Either, Data.Error
from iTasks.Internal.IWorld import createIWorld, destroyIWorld, initJSCompilerState, ::IWorld{server}, :: ServerInfo(..), :: SystemPaths(..)
from iTasks.Internal.TaskStore import createTaskInstance, taskInstanceUIChanges
from iTasks.Internal.TaskEval import evalTaskInstance
from iTasks.Internal.Store import flushShareCache, emptyStore
from iTasks.Internal.Store import emptyStore
from iTasks.Internal.Util import toCanonicalPath
import iTasks.Internal.Serialization
import iTasks.Internal.IWorld
......@@ -101,7 +101,7 @@ where
//UTILITY TASKS
testEditor :: (Editor a) a EditMode -> Task a | iTask a
testEditor editor model mode
= (interact "Editor test" mode nullShare (const ((),model)) (\v l _ -> (l,v,Nothing)) (\_ l v -> (l,v,Nothing)) (Just editor) @ snd
= (interact "Editor test" mode unitShare (const ((),model)) (\v l _ -> (l,v,Nothing)) (\_ l v -> (l,v,Nothing)) (Just editor) @ snd
>&> viewSharedInformation "Editor value" [ViewAs (toString o toJSON)] @? tvFromMaybe
) <<@ ApplyLayout (setUIAttributes (directionAttr Horizontal) )
......@@ -132,7 +132,7 @@ where
test world
# (argv,world) = getCommandLine world
# (appPath,world) = toCanonicalPath (hd argv) world
# iworld = createIWorld "TEST" appPath Nothing Nothing Nothing world
# iworld = createIWorld "TEST" appPath False Nothing Nothing Nothing world
//Initialize JS compiler support
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _)
......
......@@ -13,10 +13,10 @@ toStubIWorld world
= {IWorld
|server = {serverName = "STUB",serverURL = "//127.0.0.1:80",buildID = "STUB"
,paths = {appDirectory = "./STUB/",dataDirectory = "./STUB/",webDirectory = "./STUB/",saplDirectory = "./STUB/"}}
,config = {sessionTime = 3600, smtpServer = "localhost"}
,config = {sessionTime = 3600, smtpServer = "localhost",persistTasks = True}
,clocks = {SystemClocks |timestamp = Timestamp 0,localDate=defaultValue,localTime=defaultValue,utcDate=defaultValue,utcTime=defaultValue}
,current ={TaskEvalState|taskTime= 0,taskInstance= 0,sessionInstance = Nothing,attachmentChain = [] ,nextTaskNo = 0}
,sdsNotifyRequests = [], memoryShares = 'DM'.newMap, cachedShares = 'DM'.newMap, exposedShares = 'DM'.newMap
,sdsNotifyRequests = [], memoryShares = 'DM'.newMap, readCache = 'DM'.newMap, writeCache = 'DM'.newMap, exposedShares = 'DM'.newMap
,jsCompilerState = Nothing ,shutdown = Nothing ,ioTasks = {done = [], todo = []},ioStates = 'DM'.newMap
,world = world
,resources = Nothing,random = [],onClient = False }
......
......@@ -10,21 +10,21 @@ import StdMisc
NS_TONIC_INSTANCES :== "tonic-instances"
sdsUnsafeRead :: (RWShared () a b) *IWorld -> *(a, *IWorld)
sdsUnsafeRead :: (RWShared () a b) *IWorld -> *(a, *IWorld) | TC a
sdsUnsafeRead focus iworld
# (res, iworld) = 'DSDS'.read focus iworld
= case res of
Ok x -> (x, iworld)
selectedBlueprint :: RWShared () (Maybe ClickMeta) (Maybe ClickMeta)
selectedBlueprint = sdsFocus "selectedBlueprint" (memoryStore NS_TONIC_INSTANCES (Just Nothing))
selectedBlueprint = sdsFocus "selectedBlueprint" (removeMaybe (Just Nothing) memoryShare)
selectedDetail :: RWShared () (Maybe (Either ClickMeta (ModuleName, FuncName, ComputationId, Int))) (Maybe (Either ClickMeta (ModuleName, FuncName, ComputationId, Int)))
selectedDetail = sdsFocus "selectedDetail" (memoryStore NS_TONIC_INSTANCES (Just Nothing))
selectedDetail = sdsFocus "selectedDetail" (removeMaybe (Just Nothing) memoryShare)
storedOutputEditors :: RWShared () (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)) (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability))
storedOutputEditors = sdsTranslate "storedOutputEditors" (\t -> t +++> "-storedOutputEditors")
(memoryStore NS_TONIC_INSTANCES (Just 'DM'.newMap))
(removeMaybe (Just 'DM'.newMap) memoryShare)
outputForTaskId :: RWShared (TaskId, ExprId) (TaskId, Int, Task (), TStability) (TaskId, Int, Task (), TStability)
outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) storedOutputEditors
......@@ -128,18 +128,18 @@ tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ())
_ -> False
staticDisplaySettings :: RWShared () StaticDisplaySettings StaticDisplaySettings
staticDisplaySettings = sdsFocus "staticDisplaySettings" (memoryStore NS_TONIC_INSTANCES (Just
staticDisplaySettings = sdsFocus "staticDisplaySettings" (removeMaybe (Just
{ StaticDisplaySettings
| unfold_depth = 0
, display_compact = False
, show_comments = True
}))
}) memoryShare)
queryShare :: RWShared () (Maybe BlueprintQuery) (Maybe BlueprintQuery)
queryShare = sdsFocus "queryShare" (memoryStore NS_TONIC_INSTANCES (Just Nothing))
queryShare = sdsFocus "queryShare" (removeMaybe (Just Nothing) memoryShare)
dynamicDisplaySettings :: RWShared () DynamicDisplaySettings DynamicDisplaySettings
dynamicDisplaySettings = sdsFocus "dynamicDisplaySettings" (memoryStore NS_TONIC_INSTANCES (Just
dynamicDisplaySettings = sdsFocus "dynamicDisplaySettings" (removeMaybe (Just
{ DynamicDisplaySettings
| unfold_depth = 0
, display_compact = False
......@@ -147,7 +147,7 @@ dynamicDisplaySettings = sdsFocus "dynamicDisplaySettings" (memoryStore NS_TONIC
, show_task_value = False
, show_comments = False
, show_all_child_tasks = False
}))
}) memoryShare)
paramsForTaskInstance :: RWShared (ModuleName, FuncName, TaskId) [(VarName, Int, Task ())] [(VarName, Int, Task ())]
......
......@@ -253,6 +253,7 @@ where
:: ChangeQueues :== Map InstanceNo (Queue UIChange)
import StdMisc
taskUIService :: ![PublishedTask] -> WebService ChangeQueues ChangeQueues
taskUIService taskUrls = { urlMatchPred = matchFun [url \\ {PublishedTask|url} <-taskUrls]
, completeRequest = True
......@@ -305,8 +306,10 @@ where
(JSONArray [JSONInt reqId,JSONString "new"])
= case createTaskInstance` req taskUrls iworld of
(Error (_,err), iworld)
# json = JSONArray [JSONInt reqId,JSONString "ERROR",JSONString err]
= (wsockTextMsg (toString json),False, instances,iworld)
= abort err
// # json = JSONArray [JSONInt reqId,JSONString "ERROR",JSONString err]
// = (wsockTextMsg (toString json),False, instances,iworld)
(Ok (instanceNo,instanceKey),iworld)
# json = JSONArray [JSONInt reqId, JSONObject [("instanceNo",JSONInt instanceNo),("instanceKey",JSONString instanceKey)]]
= (wsockTextMsg (toString json),False, instances, iworld)
......
......@@ -15,6 +15,7 @@ from Data.Error import :: MaybeError, :: MaybeErrorString
from Data.Map import :: Map
from Data.IntMap.Strict import :: IntMap
from StdOverloaded import class <
from System.FilePath import :: FilePath
from Text.JSON import :: JSONNode, generic JSONEncode, generic JSONDecode
......@@ -28,16 +29,20 @@ from Text.JSON import :: JSONNode, generic JSONEncode, generic JSONDecode
| SDSNoWrite
// Fix a focus parameter
sdsFocus :: !p !(RWShared p r w) -> (RWShared p` r w) | iTask p
sdsFocus :: !p !(RWShared p r w) -> (RWShared p` r w) | iTask p & TC r & TC w
// Projection of the domain with a lens
sdsProject :: !(SDSReadProjection rs r) !(SDSWriteProjection rs ws w) !(RWShared p rs ws) -> RWShared p r w | iTask p
sdsProject :: !(SDSReadProjection rs r) !(SDSWriteProjection rs ws w) !(RWShared p rs ws) -> RWShared p r w | iTask p & TC rs & TC ws
// Translate the parameter space
sdsTranslate :: !String !(p -> ps) !(RWShared ps r w) -> RWShared p r w | iTask ps
sdsTranslate :: !String !(p -> ps) !(RWShared ps r w) -> RWShared p r w | iTask ps & TC r & TC w
// Introduce a new parameter
sdsSplit :: !String !(p -> (ps,pn)) !(pn rs -> r) !(pn rs w -> (ws,SDSNotifyPred pn)) !(RWShared ps rs ws) -> RWShared p r w | iTask ps & iTask pn
sdsSplit :: !String !(p -> (ps,pn)) !(pn rs -> r) !(pn rs w -> (ws,SDSNotifyPred pn)) !(RWShared ps rs ws) -> RWShared p r w | iTask ps & iTask pn & TC rs & TC ws
// Treat symmetric sources with optional values as if they always have a value.
// You can provide a default value, if you don't it will trigger a read error
removeMaybe :: !(Maybe a) !(SDS p (Maybe a) (Maybe a)) -> SDS p a a | iTask p & TC a
/**
* Maps the read type, the write type or both of a shared reference to another one using a functional mapping.
......@@ -48,34 +53,35 @@ sdsSplit :: !String !(p -> (ps,pn)) !(pn rs -> r) !(pn rs w -> (ws,SDSNotifyPred
* @param A reference to shared data
* @return A reference to shared data of another type
*/
mapRead :: !(r -> r`) !(RWShared p r w) -> RWShared p r` w | iTask p
mapWrite :: !(w` r -> Maybe w) !(RWShared p r w) -> RWShared p r w` | iTask p
mapReadWrite :: !(!r -> r`,!w` r -> Maybe w) !(RWShared p r w) -> RWShared p r` w` | iTask p
mapRead :: !(r -> r`) !(RWShared p r w) -> RWShared p r` w | iTask p & TC r & TC w
mapWrite :: !(w` r -> Maybe w) !(RWShared p r w) -> RWShared p r w` | iTask p & TC r & TC w
mapReadWrite :: !(!r -> r`,!w` r -> Maybe w) !(RWShared p r w) -> RWShared p r` w` | iTask p & TC r & TC w
mapReadError :: !(r -> MaybeError TaskException r`) !(RWShared p r w) -> RWShared p r` w | iTask p & TC r & TC w
mapWriteError :: !(w` r -> MaybeError TaskException (Maybe w)) !(RWShared p r w) -> RWShared p r w` | iTask p & TC r & TC w
mapReadWriteError :: !(!r -> MaybeError TaskException r`,!w` r -> MaybeError TaskException (Maybe w)) !(RWShared p r w) -> RWShared p r` w` | iTask p & TC r & TC w
mapReadError :: !(r -> MaybeError TaskException r`) !(RWShared p r w) -> RWShared p r` w | iTask p
mapWriteError :: !(w` r -> MaybeError TaskException (Maybe w)) !(RWShared p r w) -> RWShared p r w` | iTask p
mapReadWriteError :: !(!r -> MaybeError TaskException r`,!w` r -> MaybeError TaskException (Maybe w)) !(RWShared p r w) -> RWShared p r` w` | iTask p
toReadOnly :: !(RWShared p r w) -> ROShared p r | iTask p & TC r & TC w
toReadOnly :: !(RWShared p r w) -> ROShared p r | iTask p
toDynamic :: !(RWShared p r w) -> (RWShared p Dynamic Dynamic) | iTask p & TC r & TC w
toDynamic :: !(RWShared p r w) -> (RWShared p Dynamic Dynamic) | iTask p & TC r & TC w
//Map a list SDS of one element to the element itsel
mapSingle :: !(RWShared p [r] [w]) -> (RWShared p r w) | iTask p
//Map a list SDS of one element to the element itself
mapSingle :: !(RWShared p [r] [w]) -> (RWShared p r w) | iTask p & TC r & TC w
// Composition of two shared references.
// The read type is a tuple of both types.
// The write type can either be a tuple of both write types, only one of them or it is written to none of them (result is a read-only shared).
// START DEPRECATED
(>+<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) (wx,wy) | iTask p
(>+|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wx | iTask p
(|+<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wy | iTask p
(|+|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) () | iTask p
(>+<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) (wx,wy) | iTask p & TC rx & TC ry & TC wx & TC wy
(>+|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wx | iTask p & TC rx & TC ry & TC wx & TC wy
(|+<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wy | iTask p & TC rx & TC ry & TC wx & TC wy
(|+|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) () | iTask p & TC rx & TC ry & TC wx & TC wy
// END DEPRECATED
(>*<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) (wx,wy) | iTask p
(>*|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wx | iTask p
(|*<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wy | iTask p
(|*|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) () | iTask p
(>*<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) (wx,wy) | iTask p & TC rx & TC ry & TC wx & TC wy
(>*|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wx | iTask p & TC rx & TC ry & TC wx & TC wy
(|*<) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) wy | iTask p & TC rx & TC ry & TC wx & TC wy
(|*|) infixl 6 :: !(RWShared p rx wx) !(RWShared p ry wy) -> RWShared p (rx,ry) () | iTask p & TC rx & TC ry & TC wx & TC wy
/**
* Puts a symmetric lens between two symmetric shared data sources.
......@@ -87,55 +93,55 @@ mapSingle :: !(RWShared p [r] [w]) -> (RWShared p r w) | iTask p
* @param SymmetricShared b
* @param RWShared references of the same type with symmetric lens between them
*/
symmetricLens :: !(a b -> b) !(b a -> a) !(RWShared p a a) !(RWShared p b b) -> (!RWShared p a a, !RWShared p b b) | iTask p
symmetricLens :: !(a b -> b) !(b a -> a) !(RWShared p a a) !(RWShared p b b) -> (!RWShared p a a, !RWShared p b b) | iTask p & TC a & TC b
//Derived versions of tasks lists
/**
* Get the shared state of a task list
*/
taskListState :: !(SharedTaskList a) -> ReadOnlyShared [TaskValue a]
taskListState :: !(SharedTaskList a) -> ReadOnlyShared [TaskValue a] | TC a
/**
* Get the meta data sds of a task list
*/
taskListMeta :: !(SharedTaskList a) -> ReadWriteShared [TaskListItem a] [(TaskId,TaskAttributes)]
taskListMeta :: !(SharedTaskList a) -> ReadWriteShared [TaskListItem a] [(TaskId,TaskAttributes)] | TC a
/**
* Get the list of task id's in a task list
*/
taskListIds :: !(SharedTaskList a) -> ROShared () [TaskId]
taskListIds :: !(SharedTaskList a) -> ROShared () [TaskId] | TC a
/**
* Get the meta data sds for a specific entry in a task list
*/
taskListEntryMeta :: !(SharedTaskList a) -> RWShared TaskId (TaskListItem a) TaskAttributes
taskListEntryMeta :: !(SharedTaskList a) -> RWShared TaskId (TaskListItem a) TaskAttributes | TC a
/*
* Get the id of the entry in the list the current task is part of
*/
taskListSelfId :: !(SharedTaskList a) -> ReadOnlyShared TaskId
taskListSelfId :: !(SharedTaskList a) -> ReadOnlyShared TaskId | TC a
/**
* Get the current tasks management meta data share
*/
taskListSelfManagement :: !(SharedTaskList a) -> Shared TaskAttributes
taskListSelfManagement :: !(SharedTaskList a) -> Shared TaskAttributes | TC a
/**
* Get the value of a specific task in the list
* The paramater is either the index in the list or a specific task id
*/
taskListItemValue :: !(SharedTaskList a) -> ROShared (Either Int TaskId) (TaskValue a)
taskListItemValue :: !(SharedTaskList a) -> ROShared (Either Int TaskId) (TaskValue a) | TC a
/**
* Get the progress of a specific task in the list
* The paramater is either the index in the list or a specific task id
*/
taskListItemProgress :: !(SharedTaskList a) -> ROShared (Either Int TaskId) InstanceProgress
taskListItemProgress :: !(SharedTaskList a) -> ROShared (Either Int TaskId) InstanceProgress | TC a
/**
* Convenience lens for lookups in Maps. Returns Nothing on a missing key.
*/
mapMaybeLens :: !String !(RWShared () (Map a b) (Map a b)) -> RWShared a (Maybe b) b | < a & == a
mapMaybeLens :: !String !(RWShared () (Map a b) (Map a b)) -> RWShared a (Maybe b) b | < a & == a & TC a & TC b
/**
* Convenience lens for lookups in Maps. Can use a default value on a missing key, gives an error if no default is supplied.
*/
mapLens :: !String !(RWShared () (Map a b) (Map a b)) !(Maybe b) -> RWShared a b b | < a & == a
mapLens :: !String !(RWShared () (Map a b) (Map a b)) !(Maybe b) -> RWShared a b b | < a & == a & TC a & TC b
/**
* Convenience lens for lookups in IntMaps. Can use a default value on a missing key, gives an error if no default is supplied.
*/
intMapLens :: !String !(RWShared () (IntMap a) (IntMap a)) !(Maybe a) -> RWShared Int a a
intMapLens :: !String !(RWShared () (IntMap a) (IntMap a)) !(Maybe a) -> RWShared Int a a | TC a
This diff is collapsed.
......@@ -2,7 +2,8 @@ definition module iTasks.SDS.Combinators.Core
/**
* This module provides the core builtin combinators for composing shared data sources.
*/
from iTasks.SDS.Definition import :: SDS, :: SDSLensRead, :: SDSLensWrite, :: SDSLensNotify, :: SDSNotifyPred
from iTasks.SDS.Definition import :: SDS, :: SDSLensRead, :: SDSLensWrite, :: SDSLensNotify, :: SDSNotifyPred, :: SDSCacheWrite
from iTasks.Internal.IWorld import :: IWorld
from Data.Either import :: Either
from Data.Maybe import :: Maybe
from Text.JSON import :: JSONNode
......@@ -13,17 +14,21 @@ from iTasks.WF.Definition import generic gEditor, generic gEq, generic gDefault,
from iTasks.UI.Editor import :: Editor
from iTasks.Internal.Generic.Visualization import :: TextFormat
//Apply a parametric lens
sdsLens :: !String (p -> ps) (SDSLensRead p r rs) (SDSLensWrite p w rs ws) (SDSLensNotify p w rs) !(SDS ps rs ws) -> SDS p r w | iTask ps
// Apply a parametric lens
sdsLens :: !String (p -> ps) (SDSLensRead p r rs) (SDSLensWrite p w rs ws) (SDSLensNotify p p w rs) !(SDS ps rs ws) -> SDS p r w | iTask ps & TC rs & TC ws
// Choose between two SDS's based on the parameter.
// Because there may be overlap in the parameter spaces of the two SDS's
// a write to the merged SDS can invalidate both SDS's even though only one is chosen to write to.
sdsSelect :: !String !(p -> Either p1 p2) !(p1 r w -> SDSNotifyPred p2) !(p2 r w -> SDSNotifyPred p1) !(SDS p1 r w) !(SDS p2 r w) -> SDS p r w | iTask p1 & iTask p2
sdsSelect :: !String (p -> Either p1 p2) (SDSLensNotify p1 p2 w r) (SDSLensNotify p2 p1 w r) !(SDS p1 r w) !(SDS p2 r w) -> SDS p r w | iTask p1 & iTask p2 & TC r & TC w
// Create a new SDS by simultaneous access to two independent SDS's
sdsParallel :: !String !(p -> (p1,p2)) !((r1,r2) -> r) !(SDSLensWrite p w r1 w1) !(SDSLensWrite p w r2 w2) !(SDS p1 r1 w1) !(SDS p2 r2 w2) -> SDS p r w | iTask p1 & iTask p2
sdsParallel :: !String !(p -> (p1,p2)) !((r1,r2) -> r) !(SDSLensWrite p w r1 w1) !(SDSLensWrite p w r2 w2) !(SDS p1 r1 w1) !(SDS p2 r2 w2) -> SDS p r w | iTask p1 & iTask p2 & TC r1 & TC r2 & TC w1 & TC w2
// Create a new SDS by sequential access to two dependent SDS's
sdsSequence :: !String !(p r1 -> p2) !((r1,r2) -> r) !(SDSLensWrite p w r1 w1) !(SDSLensWrite p w r2 w2) !(SDS p r1 w1) !(SDS p2 r2 w2) -> SDS p r w | iTask p2
sdsSequence :: !String !(p -> p1) !(p r1 -> p2) (p r1 -> Either r ((r1,r2) -> r)) !(SDSLensWrite p w r1 w1) !(SDSLensWrite p w r2 w2) !(SDS p1 r1 w1) !(SDS p2 r2 w2) -> SDS p r w | iTask p1 & iTask p2 & TC r1 & TC r2 & TC w1 & TC w2
// Create a cached version of an SDS
sdsCache:: (p (Maybe r) (Maybe w) w -> (Maybe r, SDSCacheWrite)) (SDS p r w) -> SDS p r w | iTask p & TC r & TC w