implementation module iTasks.Framework.Store

import StdEnv
import Data.Void
import Data.Maybe, Data.Map, Data.Functor
import System.File, System.Directory, System.OSError, System.FilePath
import Text, Text.JSON

import iTasks.Framework.Client.JSStore
import iTasks.Framework.SDS

from iTasks.Framework.IWorld		import :: IWorld {onClient,server,world}, :: ServerInfo(..), :: SystemPaths(..), :: Resource
from iTasks.Framework.UIDefinition	import :: UIDef, :: UIControl, :: UIEditletOpts
from iTasks.Framework.UIDiff		import :: UIUpdate, :: UIEditletDiffs
from iTasks.Framework.TaskState		import :: TaskListEntry
from iTasks.API.Core.Types	        import :: DateTime, :: User, :: Config, :: TaskId, :: TaskNo, :: InstanceNo, :: TaskListItem, :: TaskTime, :: SessionId
from iTasks							import serialize, deserialize, defaultStoreFormat, functionFree
from System.Time 					import :: Timestamp(..), instance < Timestamp, instance toInt Timestamp

:: StoreItem =
	{ format		:: !StoreFormat
	, content		:: !String
	}

:: StoreFormat = SFPlain | SFDynamic

storeAccess :: !StoreNamespace !StoreKey !(Maybe a) -> Shared a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
storeAccess namespace storeId defaultV = createReadWriteSDS namespace storeId read write
where
	read Void iworld
		# (mbV,iworld) = loadValue namespace storeId iworld
		= (maybe (maybe (Error ("Can't read " +++ storeId)) Ok defaultV) Ok mbV, iworld)
	write Void v iworld
		= (Ok (const True),storeValue namespace storeId v iworld)

storePath :: !FilePath !String -> FilePath
storePath dataDir buildID = dataDir </> "store-" +++ buildID

safeName :: !String -> String
safeName s = copy 0 (createArray len '\0') 
where
	len = size s
	copy :: !Int !*String -> String
	copy i n
		| i == len	= n
		| isAlphanum s.[i] || s.[i] == '-'  = copy (i + 1) {n & [i] = s.[i]}
							                = copy (i + 1) {n & [i] = '_'} 

storeValue :: !StoreNamespace !StoreKey !a !*IWorld -> *IWorld | JSONEncode{|*|}, TC a
storeValue namespace key value iworld 
	= storeValueAs defaultStoreFormat namespace key value iworld

storeValueAs :: !StoreFormat !StoreNamespace !StoreKey !a !*IWorld -> *IWorld | JSONEncode{|*|}, TC a
storeValueAs format namespace key value iworld=:{IWorld|onClient=True}
	= jsStoreValue namespace key value iworld

storeValueAs format namespace key value iworld=:{IWorld|server={buildID,paths={dataDirectory}}}
	= writeToDisk namespace key {StoreItem|format=format,content=content} (storePath dataDirectory buildID) iworld
where
	content = case format of	
		SFPlain		= toString (toJSON value)
		SFDynamic	= serialize value

storeBlob :: !StoreNamespace !StoreKey !{#Char}		!*IWorld -> *IWorld
storeBlob namespace key blob iworld=:{IWorld|onClient=True}
	= jsStoreValue namespace key blob iworld
	
storeBlob namespace key blob iworld=:{IWorld|server={buildID,paths={dataDirectory}}}
	= writeToDisk namespace key {StoreItem|format=SFDynamic,content=blob} (storePath dataDirectory buildID) iworld

writeToDisk :: !StoreNamespace !StoreKey !StoreItem !String !*IWorld -> *IWorld
writeToDisk namespace key {StoreItem|format,content} location iworld=:{IWorld|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)
							)
	//Check if the namespace exists and create it otherwise
	# (exists,world)	= fileExists (location </> namespace) world
	# world				= if exists world
							( case createDirectory (location </> namespace) world of
								(Ok Void, world) = world
								(Error e, world) = abort ("Cannot create namespace " +++ namespace +++ ": " +++ snd e)
							)
	//Write the value
	# filename 			= addExtension (location </> namespace </> safeName key) (case format of SFPlain = "txt" ; SFDynamic = "bin")
	# (ok,file,world)	= fopen filename (case format of SFPlain = FWriteText; _ = FWriteData) world
	| not ok			= abort ("Failed to write value to store: " +++ filename +++ "\n")
	# file				= fwrites content file
	# (ok,world)		= fclose file world
	= {IWorld|iworld & world = world}
	
loadValue :: !StoreNamespace !StoreKey !*IWorld -> (!Maybe a,!*IWorld) | JSONDecode{|*|}, TC a
loadValue namespace key iworld=:{IWorld|onClient=True}
	= jsLoadValue namespace key iworld
	
loadValue namespace key iworld=:{IWorld|server={buildID,paths={dataDirectory}}}
	# (mbItem,old,iworld) = loadStoreItem namespace key iworld
	= case mbItem of
		Just item = case unpackValue (not old) item of
			Just v	= (Just v, if old (writeToDisk namespace key item (storePath dataDirectory buildID) iworld) iworld)
			Nothing	= (Nothing,iworld)
		Nothing 	= (Nothing,iworld)
		
unpackValue :: !Bool !StoreItem -> (Maybe a) | JSONDecode{|*|}, TC a
unpackValue allowFunctions {StoreItem|format=SFPlain,content}
	# json = fromString content
	| allowFunctions || functionFree json
		= case fromJSON (fromString content) of
			Nothing		= Nothing
			Just v		= Just v
	| otherwise
		= Nothing
unpackValue allowFunctions {StoreItem|format=SFDynamic,content}
	= case deserialize {s` \\ s` <-: content} of
		Ok value = Just value
		Error _  = Nothing

loadStoreItem :: !StoreNamespace !StoreKey !*IWorld -> (!Maybe StoreItem,!Bool,!*IWorld)
loadStoreItem namespace key iworld=:{server={buildID,paths={dataDirectory}},world}
	= case loadFromDisk namespace key (storePath dataDirectory buildID) world of
		(Just item,world)	= (Just item,False,{iworld & world = world})
		(Nothing,world)	
			| namespace == NS_APPLICATION_SHARES
				# (mbItem,iworld) = findOldStoreItem namespace key {iworld & world = world}
				= (mbItem,True,iworld)
			| otherwise
				= (Nothing,False,{iworld & world = world})

loadBlob :: !StoreNamespace !StoreKey !*IWorld -> (!Maybe {#Char}, !*IWorld)
loadBlob namespace key iworld=:{onClient=True}
	= jsLoadValue namespace key iworld

loadBlob namespace key iworld=:{server={buildID,paths={dataDirectory}},world}
	= case loadFromDisk namespace key (storePath dataDirectory buildID) world of
		(Just {StoreItem|content},world)	= (Just content, {IWorld|iworld & world = world})
		(Nothing,world)						= (Nothing, {IWorld|iworld & world = world})
	
//Look in stores of previous builds for a version of the store that can be migrated
findOldStoreItem :: !StoreNamespace !StoreKey !*IWorld -> (!Maybe StoreItem,!*IWorld)
findOldStoreItem namespace key iworld=:{server={serverName,paths={appDirectory,dataDirectory}},world}
	# (builds,world) = readBuilds dataDirectory world
	  //Also Look in 'old' data directory
	# (deprBuilds,world) = readBuilds (appDirectory </> serverName) world
	#  builds = builds ++ deprBuilds
	# (mbItem,world) = searchStoreItem (sortBy (\x y -> x > y) builds) world
	= (mbItem,{IWorld|iworld & world = world})
where
	readBuilds dir world		
		# (mbBuilds,world)	= readDirectory dir world
		= case mbBuilds of
			Ok dirs	= ([dir </> d \\ d <- dirs | startsWith "store-" d],world)
			Error _	= ([],world)
			
	searchStoreItem [] world = (Nothing,world)
	searchStoreItem [d:ds] world
		= case loadFromDisk namespace key d world of
			(Just item, world)		
				= (Just item,world)
			(Nothing, world)
				= searchStoreItem ds world

loadFromDisk :: !StoreNamespace !StoreKey !FilePath !*World -> (Maybe StoreItem, !*World)	
loadFromDisk namespace key storeDir world		
		//Try plain format first
		# filename			= addExtension (storeDir </> namespace </> safeName key) "txt"
		# (ok,file,world)	= fopen filename FReadText world
		| ok
			# (content,file)	= freadfile file
			# (ok,world)		= fclose file world
			= (Just {StoreItem|format = SFPlain, content = content}, world)
		| otherwise
			# filename			= addExtension (storeDir </> namespace </> safeName 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
				= (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 :: !StoreNamespace !StoreKey !*IWorld -> *IWorld
deleteValue namespace delKey iworld=:{onClient=True}
	= jsDeleteValue namespace delKey iworld

deleteValue namespace delKey iworld = deleteValues` namespace delKey (==) filterFuncDisk iworld
where
	// compare key with filename without extension
	filterFuncDisk delKey key = dropExtension key == delKey

deleteValues :: !StoreNamespace !StorePrefix !*IWorld -> *IWorld
deleteValues namespace delKey iworld = deleteValues` namespace delKey startsWith startsWith iworld

deleteValues` :: !String !String !(String String -> Bool) !(String String -> Bool) !*IWorld -> *IWorld
deleteValues` namespace delKey filterFuncCache filterFuncDisk iworld=:{server={buildID,paths={dataDirectory}},world}
	//Delete items from disk
	# world = deleteFromDisk world
	= {iworld & world = world}
where
	deleteFromDisk world
		# storeDir		= storePath dataDirectory buildID </> namespace
		# (res, world)	= readDirectory storeDir world
		| isError res = abort ("Cannot read store directory " +++ storeDir +++ ": " +++ snd (fromError res))
		= unlink storeDir (fromOk res) world
		where
			unlink _ [] world
				= world
			unlink dir [f:fs] world
				| filterFuncDisk (safeName delKey) f
					# (err,world) = deleteFile (dir </> f) world 
					= unlink dir fs world
				| otherwise
					= unlink dir fs world

listKeys :: !StoreNamespace !*IWorld -> (![StoreKey], !*IWorld)
listKeys namespace iworld=:{server={buildID,paths={dataDirectory}},world}
    # storeDir		= storePath dataDirectory buildID </> namespace
    # (res,world)   = readDirectory storeDir world
    = case res of
        Error e     = ([], {iworld & world = world})
        Ok keys     = ([dropExtension k \\ k <- keys | not (k == "." || k == "..")], {iworld & world = world})