Core.icl 5.79 KB
Newer Older
1
implementation module iTasks.SDS.Sources.Core
2 3

import iTasks.SDS.Definition
4 5
import iTasks.Internal.SDS
import iTasks.Internal.IWorld
Bas Lijnse's avatar
Bas Lijnse committed
6
import iTasks.Internal.Serialization
Steffen Michels's avatar
Steffen Michels committed
7
import iTasks.Internal.Util
8
import System.FilePath, System.Directory, System.File
9
import Text, Text.GenJSON
10
import StdFile, StdTuple, StdArray, StdBool, StdList, StdString
Bas Lijnse's avatar
Bas Lijnse committed
11
import qualified Data.Map as DM
12 13

from StdFunc import const
14
from iTasks.Internal.Task import exception
15

16
constShare :: !a -> SDSSource p a ()
17 18
constShare v = createReadOnlySDS (\_ env -> (v, env))

Haye Böhm's avatar
Haye Böhm committed
19
nullShare :: SDSSource p () a
20
nullShare = createReadWriteSDS "_core_" "nullShare" (\_ env -> (Ok (), env)) (\_ _ env -> (Ok (const (const False)), env))
21

22
unitShare :: SimpleSDSSource ()
Bas Lijnse's avatar
Bas Lijnse committed
23 24
unitShare = nullShare

25 26
worldShare :: (p *World -> *(MaybeErrorString r,*World)) (p w *World -> *(MaybeErrorString (),*World)) (p Timespec p -> Bool) -> SDSSource p r w
worldShare read write notify = createReadWriteSDS "_core_" "worldShare" read` write`
27 28 29 30 31 32
where
	read` p iworld=:{IWorld|world} = case read p world of
		(Ok r,world) = (Ok r, {IWorld|iworld & world = world})
		(Error e,world) = (Error (exception e), {IWorld|iworld & world = world})

	write` p w iworld=:{IWorld|world} = case write p w world of
33
		(Ok (),world) = (Ok (notify p), {IWorld|iworld & world = world})
34 35
		(Error e,world) = (Error (exception e), {IWorld|iworld & world = world})

36
// Random source
37
randomInt :: SDSSource () Int ()
38 39 40 41 42
randomInt = createReadOnlySDS randomInt
where
	randomInt () iworld=:{IWorld|random=[i:is]}
		= (i, {IWorld|iworld & random = is})

43
randomString :: SDSSource Int String ()
Steffen Michels's avatar
Steffen Michels committed
44 45
randomString = createReadOnlySDS generateRandomString

46
memoryShare :: SDSSource String (Maybe a) (Maybe a) | TC a
Bas Lijnse's avatar
Bas Lijnse committed
47 48 49 50 51 52 53 54 55
memoryShare = createReadWriteSDS "_core_" "memoryShare" read write
where
	read key iworld=:{IWorld|memoryShares}
		= case 'DM'.get key memoryShares of
			(Just (val :: a^))  = (Ok (Just val),iworld)
			Nothing             = (Ok Nothing, iworld)
			(Just _)            = (Error (exception ("Read shared memory with incorrect type " +++ key)), iworld)

	write key (Just val) iworld=:{IWorld|memoryShares}
56
       = (Ok (const ((===) key)),{IWorld|iworld & memoryShares = 'DM'.put key (dynamic val :: a^) memoryShares})
Bas Lijnse's avatar
Bas Lijnse committed
57
	write key Nothing iworld=:{IWorld|memoryShares}
58
       = (Ok (const ((===) key)),{IWorld|iworld & memoryShares = 'DM'.del key memoryShares})
Bas Lijnse's avatar
Bas Lijnse committed
59

60
fileShare :: SDSSource FilePath (Maybe String) (Maybe String)
Bas Lijnse's avatar
Bas Lijnse committed
61 62 63 64 65 66
fileShare = createReadWriteSDS "_core_" "fileShare" (fileRead fromFile) (fileWrite toFile)
where
	fromFile path content = Ok content

	toFile path content = content

67
jsonFileShare :: SDSSource FilePath (Maybe a) (Maybe a) | JSONEncode{|*|}, JSONDecode{|*|} a
Bas Lijnse's avatar
Bas Lijnse committed
68 69 70 71 72 73 74 75 76
jsonFileShare = createReadWriteSDS "_core_" "jsonFileShare" (fileRead fromFile) (fileWrite toFile)
where
	fromFile path content = case fromJSON (fromString content) of
		(Just value) = Ok value
		Nothing      = Error (exception ("Could not parse json file " +++ path))

	toFile path content = toString (toJSON content)

// Share that maps to a file that holds a serialized graph representation of the value
77
graphFileShare :: SDSSource FilePath (Maybe a) (Maybe a)
Bas Lijnse's avatar
Bas Lijnse committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
graphFileShare = createReadWriteSDS "_core_" "graphFileShare" (fileRead fromFile) (fileWrite toFile)
where
	fromFile path content = case deserialize {c \\ c <-: content} of
	    Ok val  = Ok val
		Error e = Error (exception e)

	toFile path content = serialize content

fileRead fromFile path iworld=:{world}
	# (ok,file,world)			= fopen path FReadData iworld.world
	| not ok					= (Ok Nothing, {IWorld|iworld & world = world})
	# (res,file)				= readAll file
	# (ok,world)				= fclose file world
	| not ok					= (Error (exception CannotClose) ,{IWorld|iworld & world = world})
	= case res of
	   	Error e                 = (Error (exception e), {IWorld|iworld & world = world})
        Ok content = case fromFile path content of
			(Ok value) = (Ok (Just value), {IWorld|iworld & world = world})
			(Error e) = (Error e,{IWorld|iworld & world = world})

fileWrite toFile path (Just content) iworld=:{IWorld|world}
	# (ok,file,world)			= fopen path FWriteData world
	| ok
		= writeContent file {IWorld|iworld & world = world}
	| not ok					
		//Check parent dirs...
		# (ok,world) = ensureParentDirs path world
		| not ok = (Error (exception CannotOpen), {IWorld|iworld & world = world})
		//.. and try again
		# (ok,file,world)			= fopen path FWriteData world
		| ok
			= writeContent file {IWorld|iworld & world = world}
		//Really can't open
			= (Error (exception CannotOpen), {IWorld|iworld & world = world})
	where
		writeContent file iworld=:{IWorld|world}
			# file						= fwrites (toFile path content) file
			# (ok,world)				= fclose file world
			| not ok					= (Error (exception CannotClose) ,{IWorld|iworld & world = world})
117
			= (Ok (const ((==) path)), {IWorld|iworld & world = world})
Bas Lijnse's avatar
Bas Lijnse committed
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136

fileWrite toFile path Nothing iworld
	= (Error (exception "Removing files through fileShare SDS not yet supported"),iworld)

//Create all parent directories of a file if they don't exist
ensureParentDirs :: FilePath *World -> (!Bool,*World)
ensureParentDirs path world = let [b:p] = split {pathSeparator} path in create [b] p world
where
	create _ [] world = (True,world)
	create _ [file] world = (True,world) 
	create base [dir:rest] world
		# next = base ++ [dir]
		# path = join {pathSeparator} next
		# (exists,world) = fileExists path world
		| exists = create next rest world //This part exists, continue
		# (res, world) = createDirectory path world 
		| isError res = (False,world) //Can't create the directory
		= create next rest world //Created the directory, continue

137
directoryListing :: SDSSource FilePath [String] ()
Bas Lijnse's avatar
Bas Lijnse committed
138
directoryListing = createReadOnlySDSError read
139 140
where
	read path iworld = case readDirectory path iworld of
141
		(Ok files,iworld) = (Ok [f \\ f <- files | f <> "." && f <> ".."],iworld)
142 143
		(Error (_,e),iworld) = (Error (exception e),iworld)