implementation module iTasks.Framework.TaskStore import StdEnv import Data.Maybe, Text, System.Time, Math.Random, Text.JSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath import iTasks.Framework.IWorld, iTasks.Framework.TaskState, iTasks.Framework.Task, iTasks.Framework.Store import iTasks.Framework.TaskEval, iTasks.Framework.Util, iTasks.Framework.UIDefinition import iTasks.API.Core.SDSCombinators, iTasks.API.Common.SDSCombinators from iTasks.Framework.SDS as SDS import qualified read, write, createReadWriteSDS import iTasks.Framework.SerializationGraphCopy //TODO: Make switchable from within iTasks module import qualified Data.Map derive gEq TIType //Derives required for storage of UI definitions derive JSONEncode TaskResult, TaskInfo, TaskRep, TIValue derive JSONEncode UIDef, UIContent, UIAction, UIViewport, UIWindow, UIControl, UIFSizeOpts, UISizeOpts, UIHSizeOpts, UIViewOpts, UIEditOpts, UIActionOpts, UIChoiceOpts, UIItemsOpts derive JSONEncode UIProgressOpts, UISliderOpts, UIGridOpts, UITreeOpts, UIIconOpts, UILabelOpts, UITreeNode derive JSONEncode UIControlStack, UISubUI, UISubUIStack derive JSONEncode UIMenuButtonOpts, UIButtonOpts, UIPanelOpts, UIFieldSetOpts, UIWindowOpts, UIViewportOpts, UITabSetOpts, UITab, UITabOpts derive JSONEncode UISize, UIBound, UIDirection, UIHAlign, UIVAlign, UISideSizes, UIMenuItem derive JSONEncode UITaskletOpts, UIEditletOpts, UIEmbeddingOpts derive JSONDecode TaskResult, TaskInfo, TaskRep, TIValue derive JSONDecode UIDef, UIContent, UIAction, UIViewport, UIWindow, UIControl, UIFSizeOpts, UISizeOpts, UIHSizeOpts, UIViewOpts, UIEditOpts, UIActionOpts, UIChoiceOpts, UIItemsOpts derive JSONDecode UIProgressOpts, UISliderOpts, UIGridOpts, UITreeOpts, UIIconOpts, UILabelOpts, UITreeNode derive JSONDecode UIControlStack, UISubUI, UISubUIStack derive JSONDecode UIMenuButtonOpts, UIButtonOpts, UIPanelOpts, UIFieldSetOpts, UIWindowOpts, UIViewportOpts, UITabSetOpts, UITab, UITabOpts derive JSONDecode UISize, UIBound, UIDirection, UIHAlign, UIVAlign, UISideSizes, UIMenuItem derive JSONDecode UITaskletOpts, UIEditletOpts, UIEmbeddingOpts INCREMENT :== "increment" SHARE_REGISTRATIONS :== "share-registrations" meta_index = "instances" rep_store t = toString t +++ "-rep" value_store t = toString t +++ "-value" reduct_store t = toString t +++ "-reduct" newInstanceNo :: !*IWorld -> (!InstanceNo,!*IWorld) newInstanceNo iworld # (mbNewTid,iworld) = loadValue NS_TASK_INSTANCES INCREMENT iworld = case mbNewTid of Just tid # iworld = storeValue NS_TASK_INSTANCES INCREMENT (tid+1) iworld = (tid,iworld) Nothing # iworld = storeValue NS_TASK_INSTANCES INCREMENT 2 iworld //store the next value (2) = (1,iworld) //return the first value (1) maxInstanceNo :: !*IWorld -> (!InstanceNo, !*IWorld) maxInstanceNo iworld # (mbNewTid,iworld) = loadValue NS_TASK_INSTANCES INCREMENT iworld = case mbNewTid of Just tid = (tid-1,iworld) Nothing = (0,iworld) newInstanceKey :: !*IWorld -> (!InstanceKey, !*IWorld) newInstanceKey iworld=:{IWorld|random} = (toString (take 32 [toChar (97 + abs (i rem 26)) \\ i <- random]) , {IWorld|iworld & random = drop 32 random}) newDocumentId :: !*IWorld -> (!DocumentId, !*IWorld) newDocumentId iworld=:{IWorld|random} = (toString (take 32 [toChar (97 + abs (i rem 26)) \\ i <- random]) , {IWorld|iworld & random = drop 32 random}) deleteInstance :: !InstanceNo !*IWorld -> *IWorld deleteInstance instanceNo iworld //Delete all states # iworld = deleteValue NS_TASK_INSTANCES (reduct_store instanceNo) iworld # iworld = deleteValue NS_TASK_INSTANCES (value_store instanceNo) iworld # iworld=:{ti} = deleteValue NS_TASK_INSTANCES (rep_store instanceNo) iworld = {iworld & ti = [m \\ m <- ti | m.TIMeta.instanceNo <> instanceNo]} initInstanceMeta :: !*IWorld -> *IWorld initInstanceMeta iworld # (mbIndex,iworld) = loadValue NS_TASK_INSTANCES meta_index iworld = {iworld & ti = fromMaybe [] mbIndex} fullInstanceMeta :: RWShared Void [TIMeta] [TIMeta] fullInstanceMeta = 'SDS'.createReadWriteSDS NS_TASK_INSTANCES "tiindex" read write where read Void iworld=:{IWorld|ti} = (Ok ti, iworld) write Void ti iworld # iworld = {iworld & ti = ti} # iworld = storeValue NS_TASK_INSTANCES meta_index ti iworld //Sync to disk to enable server restarts = (Ok (const True),iworld) filteredInstanceMeta :: RWShared InstanceFilter [TIMeta] [TIMeta] filteredInstanceMeta = sdsSplit (\p -> (Void,p)) read write fullInstanceMeta where read tfilter is = filter (filterFun tfilter) is write tfilter is ws = let (ds,us) = splitWith (filterFun tfilter) is in (us ++ ws, notifyFun (ds ++ ws)) filterFun {InstanceFilter|instanceNo,session} i = (maybe True (\m -> i.TIMeta.instanceNo == m) instanceNo) && (maybe True (\m -> i.TIMeta.session == m) session) notifyFun ws qfilter = any (filterFun qfilter) ws //The instance meta data is stored directly in the iworld taskInstanceMeta :: RWShared InstanceNo TIMeta TIMeta taskInstanceMeta = mapSingle (sdsTranslate (\no -> {InstanceFilter|instanceNo=Just no, session = Nothing}) filteredInstanceMeta) //The remaining instance parts are stored on disk taskInstanceReduct :: !InstanceNo -> RWShared Void TIReduct TIReduct taskInstanceReduct instanceNo = storeAccess NS_TASK_INSTANCES (reduct_store instanceNo) Nothing taskInstanceValue :: !InstanceNo -> RWShared Void TIValue TIValue taskInstanceValue instanceNo = storeAccess NS_TASK_INSTANCES (value_store instanceNo) Nothing taskInstanceRep :: !InstanceNo -> RWShared Void TaskRep TaskRep taskInstanceRep instanceNo = storeAccess NS_TASK_INSTANCES (rep_store instanceNo) 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 = storeBlob NS_DOCUMENT_CONTENT (documentId +++ "-data") content iworld # iworld = storeValue NS_DOCUMENT_CONTENT (documentId +++ "-meta") document iworld = (Ok document,iworld) createDocumentWith :: !String !String (*File -> *File) !*IWorld -> (!MaybeError FileError Document, !*IWorld) createDocumentWith name mime f iworld = createDocument name mime "FIXME" iworld //TODO make it possible to apply the function during creation loadDocumentContent :: !DocumentId !*IWorld -> (!Maybe String, !*IWorld) loadDocumentContent documentId iworld = loadBlob NS_DOCUMENT_CONTENT (documentId +++ "-data") iworld loadDocumentMeta :: !DocumentId !*IWorld -> (!Maybe Document, !*IWorld) loadDocumentMeta documentId iworld = loadValue NS_DOCUMENT_CONTENT (documentId +++ "-meta") iworld documentLocation :: !DocumentId !*IWorld -> (!FilePath,!*IWorld) documentLocation documentId iworld=:{server={buildID,paths={dataDirectory}}} = (storePath dataDirectory buildID NS_DOCUMENT_CONTENT (documentId +++ "_data.bin"),iworld)