implementation module Store import StdString,StdMaybe, StdArray, StdChar, StdClass, StdInt, StdFile, StdList, StdMisc import Directory import Map, Text import GenPrint import GenParse import dynamic_string //Static dynamic serialization :: *Store = { cache :: *Map String (Bool,StoreItem) //Cache for storage items, Bool is used to indicate a value in the cache is 'dirty' , location :: String //Path to the store on disk } :: StoreItem = { format :: StoreFormat , content :: String } :: StoreFormat = SFPlain | SFDynamic | SFBlob /** * Create a store */ createStore :: !String -> *Store createStore location = {Store|cache = newMap, location = location} storeValue :: !String !a !*Store -> *Store | gPrint{|*|}, TC a storeValue key value store = storeValueAs SFPlain key value store storeValueAsBlob :: !String !String !*Store -> *Store storeValueAsBlob key value store=:{cache} = {Store|store & cache = put key (True,{StoreItem|format=SFBlob,content=value}) cache} storeValueAs :: !StoreFormat !String !a !*Store -> *Store | gPrint{|*|}, TC a storeValueAs format key value store=:{cache} = {Store|store & cache = put key (True,{StoreItem|format=format,content=content}) cache} where content = case format of SFPlain = printToString value SFDynamic = dynamic_to_string (dynamic value) loadDynamicValue :: !String !*Store !*World -> (!Maybe Dynamic, !*Store, !*World) loadDynamicValue key store=:{cache,location} world #(mbItem,cache) = getU key cache = case mbItem of Just (dirty,item) = (unpackItem item, {store & cache = cache}, world) Nothing # (mbItem, world) = loadFromDisk key location world = case mbItem of Just item # cache = put key (False,item) cache = (unpackItem item, {store & cache = cache}, world) Nothing = (Nothing, {store & cache = cache}, world) where unpackItem {StoreItem | format=SFPlain, content} = Nothing unpackItem {StoreItem | format=SFDynamic, content} = Just (string_to_dynamic { s \\ s <-: content}) loadValueAsBlob :: !String !*Store !*World -> (!Maybe String, !*Store, !*World) loadValueAsBlob key store=:{cache,location} world #(mbItem,cache) = getU key cache = case mbItem of Just (dirty,item )= (unpackValue item, {store & cache = cache}, world) Nothing # (mbItem, world) = loadFromDisk key location world = case mbItem of Just item # cache = put key (False,item) cache = (unpackValue item, {store & cache = cache}, world) Nothing = (Nothing, {store & cache = cache}, world) where unpackValue {StoreItem|content} = Just content loadValue :: !String !*Store !*World -> (!Maybe a, !*Store, !*World) | gParse{|*|}, TC a loadValue key store=:{cache,location} world #(mbItem,cache) = getU key cache = case mbItem of Just (dirty,item )= (unpackValue item, {store & cache = cache}, world) Nothing # (mbItem, world) = loadFromDisk key location world = case mbItem of Just item # cache = put key (False,item) cache = (unpackValue item, {store & cache = cache}, world) Nothing = (Nothing, {store & cache = cache}, world) where unpackValue {StoreItem|format=SFPlain,content} = parseString content unpackValue {StoreItem|format=SFBlob,content} = Nothing //<- use loadValueAsBlob unpackValue {StoreItem|format=SFDynamic,content} = case string_to_dynamic {s` \\ s` <-: content} of (value :: a^) = Just value _ = Nothing loadFromDisk :: String String !*World -> (Maybe StoreItem, !*World) loadFromDisk key location world //Try plain format first # filename = location +++ "/" +++ key +++ ".txt" # (ok,file,world) = fopen filename FReadData world | ok # (content,file)= freadfile file # (ok,world) = fclose file world = (Just {StoreItem|format = SFPlain, content = content}, world) | otherwise # filename = location +++ "/" +++ key +++ ".bin" # (ok,file,world) = fopen filename FReadData world | ok #(content,file) = freadfile file #(ok,world) = fclose file world =(Just {StoreItem|format = SFDynamic, content = content}, world) | otherwise # filename = location +++ "/" +++ key +++ ".blb" # (ok,file,world) = fopen filename FReadData world | ok #(content,file) = freadfile file #(ok,world) = fclose file world =(Just {StoreItem|format = SFBlob, content = content}, 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) deleteValues :: !String !*Store !*World -> (!*Store, !*World) deleteValues prefix store=:{cache,location} world //Delete items from cache # cache = fromList [(key,item) \\ (key,item) <- toList cache | not (startsWith prefix key)] //Delete items from disk # world = deleteFromDisk prefix location world = ({store & cache = cache},world) where deleteFromDisk prefix location world # ((ok,dir),world) = pd_StringToPath location world | not ok = abort ("Cannot create path to " +++ location) # ((err,files),world) = getDirectoryContents dir world | err <> NoDirError = abort ("Cannot read store directory " +++ location) = unlink prefix dir files world unlink prefix dir [] world = world unlink prefix dir [f:fs] world | startsWith prefix f.fileName # (err,world) = fremove (pathDown dir f.fileName) world = unlink prefix dir fs world | otherwise = unlink prefix dir fs world pathDown (RelativePath steps) step = RelativePath (steps ++ [PathDown step]) pathDown (AbsolutePath dn steps) step = AbsolutePath dn (steps ++ [PathDown step]) copyValues :: !String !String !*Store !*World -> (!*Store, !*World) copyValues fromprefix toprefix store=:{cache,location} world //Copy items in the cache # cache = fromList (flatten [[(key,(dirty,item)): if (startsWith fromprefix key) [(newKey key, (True,item) )] [] ]\\ (key,(dirty,item)) <- toList cache]) //Copy items on disk # world = copyOnDisk fromprefix toprefix location world = ({store & cache = cache},world) where newKey key = toprefix +++ (key % (size fromprefix, size key)) copyOnDisk fromprefix toprefix location world # ((ok,dir),world) = pd_StringToPath location world | not ok = abort ("Cannot create path to " +++ location) # ((err,files),world) = getDirectoryContents dir world | err <> NoDirError = abort ("Cannot read store directory " +++ location) = copy fromprefix toprefix files world copy fromprefix toprefix [] world = world copy fromprefix toprefix [f:fs] world | startsWith fromprefix f.fileName # sfile = (location +++ "/" +++ f.fileName) # dfile = (location +++ "/" +++ toprefix +++ (f.fileName % (size fromprefix, size f.fileName))) # 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) flushCache :: !*Store !*World -> (!*Store,!*World) flushCache store=:{cache,location} world //Check if the location exists and create it otherwise # ((ok,dir),world) = pd_StringToPath location world | not ok = abort ("Cannot create storepath: " +++ location) #(err,world) = case getFileInfo dir world of ((DoesntExist,fileinfo),world) = createDirectory dir world (_,world) = (NoDirError,world) # ok = case err of NoDirError = True; _ = False | not ok = abort ("Cannot create store: " +++ location) //Write the states to disk # (list, world) = flush (toList cache) world = ({store & cache = fromList list}, world) where flush [] world = ([],world) flush [(key,(False,item)):is] world # (is, world) = flush is world = ([(key,(False,item)):is], world) flush [(key,(True,item)):is] world # world = writeToDisk key item location world # (is, world) = flush is world = ([(key,(False,item)):is], world) writeToDisk key {StoreItem|format,content} location world # filename = location +++ "/" +++ key +++ (case format of SFPlain = ".txt" ; SFDynamic = ".bin" ; SFBlob = ".blb") # (ok,file,world) = fopen filename FWriteData world | not ok = abort ("Failed to write value to store: " +++ filename) # file = fwrites content file # (ok,world) = fclose file world = world