implementation module Store import StdString, StdArray, StdChar, StdClass, StdInt, StdFile, StdList, StdTuple, StdMisc, Void import File, Directory, OSError, Maybe, Map, Text, JSON, Functor, FilePath from Config import :: Config from IWorld import :: IWorld(..), :: ProcessId, :: Control from SystemTypes import :: DateTime, :: User from Time import :: Timestamp(..), instance < Timestamp, instance toInt Timestamp from iTasks import serialize, deserialize, defaultStoreFormat :: Store = { location :: !String //Path to the store on disk } :: StoreItem = { format :: !StoreFormat , content :: !String , timestamp :: !Timestamp } :: StoreFormat = SFPlain | SFDynamic | SFBlob storeValue :: !String !a !*IWorld -> *IWorld | JSONEncode{|*|}, TC a storeValue key value iworld = storeValueAs defaultStoreFormat key value iworld storeValueAs :: !StoreFormat !String !a !*IWorld -> *IWorld | JSONEncode{|*|}, TC a storeValueAs format key value iworld=:{IWorld|timestamp,world,storeDirectory} # world = writeToDisk key {StoreItem|format=format,content=content,timestamp=timestamp} storeDirectory world = {iworld & world = world} where content = case format of SFPlain = toString (toJSON value) SFDynamic = serialize value writeToDisk :: !String !StoreItem !String !*World -> *World writeToDisk key {StoreItem|format,content,timestamp} location world //Check if the location exists and create it otherwise # (exists,world) = fileExists location world # world = if exists world ( case createDirectory location world of (Ok Void, world) = world (Error e, world) = abort ("Cannot create store: " +++ location +++ ": " +++ snd e) ) //Write the value # filename = addExtension (location key) (case format of SFPlain = "txt" ; SFDynamic = "bin" ; SFBlob = "blb") # (ok,file,world) = fopen filename (case format of SFPlain = FWriteText; _ = FWriteData) world | not ok = abort ("Failed to write value to store: " +++ filename) # file = fwritei (toInt timestamp) file # file = case format of SFPlain = fwritec ' ' file; _ = file // for txt files write space to indicate end of timestamp # file = fwrites content file # (ok,world) = fclose file world = world loadValue :: !String !*IWorld -> (!Maybe a,!*IWorld) | JSONDecode{|*|}, TC a loadValue key iworld # (mbItem,iworld) = loadStoreItem key iworld = case mbItem of Just item = case unpackValue item of Just v = (Just v,iworld) Nothing = (Nothing,iworld) Nothing = (Nothing,iworld) getStoreTimestamp :: !String !*IWorld -> (!Maybe Timestamp,!*IWorld) getStoreTimestamp key iworld # (mbItem,iworld) = loadStoreItem key iworld = case mbItem of Just item = (Just item.StoreItem.timestamp,iworld) Nothing = (Nothing,iworld) loadValueAndTimestamp :: !String !*IWorld -> (!Maybe (a,Timestamp),!*IWorld) | JSONDecode{|*|}, TC a loadValueAndTimestamp key iworld # (mbItem,iworld) = loadStoreItem key iworld = case mbItem of Just item = case unpackValue item of Just v = (Just (v,item.StoreItem.timestamp),iworld) Nothing = (Nothing,iworld) Nothing = (Nothing,iworld) unpackValue :: !StoreItem -> (Maybe a) | JSONDecode{|*|}, TC a unpackValue {StoreItem|format=SFPlain,content} = case fromJSON (fromString content) of Nothing = Nothing Just v = Just v unpackValue {StoreItem|format=SFBlob,content} = abort "use loadValueAsBlob" unpackValue {StoreItem|format=SFDynamic,content,timestamp} = case deserialize {s` \\ s` <-: content} of Ok value = Just value Error _ = Nothing loadStoreItem :: !String !*IWorld -> (!Maybe StoreItem,!*IWorld) loadStoreItem key iworld=:{storeDirectory} = accWorld (loadFromDisk key storeDirectory) iworld loadFromDisk :: !String !String !*World -> (Maybe StoreItem, !*World) loadFromDisk key location world //Try plain format first # filename = addExtension (location key) "txt" # (ok,file,world) = fopen filename FReadText world | ok # (ok,time,file) = freadi file # (ok,_,file) = freadc file // read char indicating the end of the timestamp # (content,file) = freadfile file # (ok,world) = fclose file world = (Just {StoreItem|format = SFPlain, content = content, timestamp = Timestamp time}, world) | otherwise # filename = addExtension (location key) "bin" # (ok,file,world) = fopen filename FReadData world | ok # (ok,time,file) = freadi file # (content,file) = freadfile file #( ok,world) = fclose file world =(Just {StoreItem|format = SFDynamic, content = content, timestamp = Timestamp time}, world) | otherwise # filename = addExtension (location key) "blb" # (ok,file,world) = fopen filename FReadData world | ok # (ok,time,file) = freadi file # (content,file) = freadfile file # (ok,world) = fclose file world =(Just {StoreItem|format = SFBlob, content = content, timestamp = Timestamp time}, world) | otherwise = (Nothing, world) where freadfile file = rec file "" where rec :: *File String -> (String, *File) rec file acc # (string, file) = freads file 102400 | string == "" = (acc, file) | otherwise = rec file (acc +++ string) deleteValue :: !String !*IWorld -> *IWorld deleteValue delKey iworld = deleteValues` delKey (==) filterFuncDisk iworld where // compare key with filename without extension filterFuncDisk delKey key = (subString 0 (size key - 4) key) == delKey deleteValues :: !String !*IWorld -> *IWorld deleteValues delKey iworld = deleteValues` delKey startsWith startsWith iworld deleteValues` :: !String !(String String -> Bool) !(String String -> Bool) !*IWorld -> *IWorld deleteValues` delKey filterFuncCache filterFuncDisk iworld=:{storeDirectory} //Delete items from disk # iworld = appWorld deleteFromDisk iworld = iworld where deleteFromDisk world # (res, world) = readDirectory storeDirectory world | isError res = abort ("Cannot read store directory " +++ storeDirectory +++ ": " +++ snd (fromError res)) = unlink storeDirectory (fromOk res) world where unlink _ [] world = world unlink dir [f:fs] world | filterFuncDisk delKey f # (err,world) = deleteFile (dir f) world = unlink dir fs world | otherwise = unlink dir fs world copyValues :: !String !String !*IWorld -> *IWorld copyValues fromprefix toprefix iworld=:{storeDirectory} //Copy items on disk # iworld = appWorld (copyOnDisk fromprefix toprefix storeDirectory) iworld = iworld where newKey key = toprefix +++ (key % (size fromprefix, size key)) copyOnDisk fromprefix toprefix location world # (res,world) = readDirectory location world | isError res = abort ("Cannot read store directory " +++ location +++ ": " +++ snd (fromError res)) = copy fromprefix toprefix (fromOk res) world copy fromprefix toprefix [] world = world copy fromprefix toprefix [f:fs] world | startsWith fromprefix f # sfile = storeDirectory f # dfile = storeDirectory toprefix +++ (f % (size fromprefix, size f)) # world = fcopy sfile dfile world = copy fromprefix toprefix fs world | otherwise = copy fromprefix toprefix fs world fcopy sfilename dfilename world # (ok,sfile,world) = fopen sfilename FReadData world | not ok = abort ("fcopy: Could not open " +++ sfilename +++ " for reading") # (ok,dfile,world) = fopen dfilename FWriteData world | not ok = abort ("fcopy: Could not open " +++ dfilename +++ " for writing") # (sfile,dfile) = transfer sfile dfile # (ok,world) = fclose sfile world | not ok = abort ("fcopy: Could not close " +++ sfilename) # (ok,world) = fclose dfile world | not ok = abort ("fcopy: Could not close " +++ dfilename) = world where transfer sfile dfile # (ok,c,sfile) = freadc sfile | ok # dfile = fwritec c dfile = transfer sfile dfile | otherwise # (err,sfile)= ferror sfile | err = abort "fcopy: read error during copy" | otherwise = (sfile,dfile) isValueChanged :: !String !Timestamp !*IWorld -> (!Maybe Bool,!*IWorld) isValueChanged key ts0 iworld # (mbTimestamp,iworld) = getStoreTimestamp key iworld = (fmap ((<) ts0) mbTimestamp,iworld) appWorld :: !.(*World -> *World) !*IWorld -> *IWorld appWorld f iworld=:{world} = {iworld & world = f world} accWorld :: !.(*World -> *(.a,*World)) !*IWorld -> (.a,!*IWorld) accWorld f iworld=:{world} # (a,world) = f world = (a,{iworld & world = world})