Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
clean-and-itasks
iTasks-SDK
Commits
e0633e14
Commit
e0633e14
authored
Mar 29, 2019
by
Mart Lubbers
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'master' of gitlab.science.ru.nl:clean-and-itasks/iTasks-SDK into onDestroy-io
parents
fe8fa967
0c7ad62e
Pipeline
#20450
failed with stage
in 1 minute and 21 seconds
Changes
14
Pipelines
1
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
14 changed files
with
796 additions
and
305 deletions
+796
-305
Libraries/iTasks/Engine.dcl
Libraries/iTasks/Engine.dcl
+11
-10
Libraries/iTasks/Engine.icl
Libraries/iTasks/Engine.icl
+91
-74
Libraries/iTasks/Extensions/Editors/DynamicEditor.dcl
Libraries/iTasks/Extensions/Editors/DynamicEditor.dcl
+39
-0
Libraries/iTasks/Extensions/Editors/DynamicEditor.icl
Libraries/iTasks/Extensions/Editors/DynamicEditor.icl
+487
-0
Libraries/iTasks/Extensions/TextFile.dcl
Libraries/iTasks/Extensions/TextFile.dcl
+12
-1
Libraries/iTasks/Extensions/TextFile.icl
Libraries/iTasks/Extensions/TextFile.icl
+7
-0
Libraries/iTasks/Internal/Client/RunOnClient.icl
Libraries/iTasks/Internal/Client/RunOnClient.icl
+1
-0
Libraries/iTasks/Internal/EngineTasks.dcl
Libraries/iTasks/Internal/EngineTasks.dcl
+4
-12
Libraries/iTasks/Internal/EngineTasks.icl
Libraries/iTasks/Internal/EngineTasks.icl
+35
-71
Libraries/iTasks/Internal/IWorld.dcl
Libraries/iTasks/Internal/IWorld.dcl
+1
-8
Libraries/iTasks/Internal/IWorld.icl
Libraries/iTasks/Internal/IWorld.icl
+1
-1
Libraries/iTasks/Internal/Task.dcl
Libraries/iTasks/Internal/Task.dcl
+0
-3
Libraries/iTasks/Internal/TaskServer.dcl
Libraries/iTasks/Internal/TaskServer.dcl
+9
-10
Libraries/iTasks/Internal/TaskServer.icl
Libraries/iTasks/Internal/TaskServer.icl
+98
-115
No files found.
Libraries/iTasks/Engine.dcl
View file @
e0633e14
...
...
@@ -58,21 +58,22 @@ instance Startable (a,b) | Startable a & Startable b
::
EngineOptions
=
{
appName
::
String
,
appPath
::
FilePath
// Location of the application's executable
{
appName
::
String
,
appPath
::
FilePath
// Location of the application's executable
,
appVersion
::
String
,
serverPort
::
Int
,
serverUrl
::
String
,
serverPort
::
Int
,
serverUrl
::
String
,
keepaliveTime
::
Timespec
,
sessionTime
::
Timespec
,
persistTasks
::
Bool
,
sessionTime
::
Timespec
,
persistTasks
::
Bool
,
autoLayout
::
Bool
,
maxEvents
::
Int
,
timeout
::
Maybe
Int
// The timeout
,
distributed
::
Bool
,
sdsPort
::
Int
,
webDirPath
::
FilePath
// Location of public files that are served by the iTask webserver
,
storeDirPath
::
FilePath
// Location of the application's persistent data files
,
tempDirPath
::
FilePath
// Location for temporary files used in tasks
,
sdsPort
::
Int
,
webDirPath
::
FilePath
// Location of public files that are served by the iTask webserver
,
storeDirPath
::
FilePath
// Location of the application's persistent data files
,
tempDirPath
::
FilePath
// Location for temporary files used in tasks
,
saplDirPath
::
FilePath
// Location of the application's sapl files (client-side code)
}
...
...
Libraries/iTasks/Engine.icl
View file @
e0633e14
implementation
module
iTasks
.
Engine
import
StdMisc
,
StdArray
,
StdList
,
StdOrdList
,
StdTuple
,
StdChar
,
StdFile
,
StdBool
,
StdEnum
import
Data
.
Func
import
Data
.
Functor
import
Data
.
Queue
import
Internet
.
HTTP
import
StdEnv
import
System
.
CommandLine
import
System
.
Directory
import
System
.
File
import
System
.
FilePath
import
System
.
GetOpt
import
System
.
OS
import
Text
import
iTasks
.
Internal
.
Distributed
.
Symbols
import
iTasks
.
Internal
.
EngineTasks
import
iTasks
.
Internal
.
IWorld
import
iTasks
.
Internal
.
SDS
import
iTasks
.
Internal
.
SDSService
import
iTasks
.
Internal
.
TaskServer
import
iTasks
.
Internal
.
TaskStore
import
iTasks
.
Internal
.
Util
import
iTasks
.
SDS
.
Sources
.
System
import
iTasks
.
WF
.
Combinators
.
Common
import
iTasks
.
WF
.
Definition
import
iTasks
.
WF
.
Tasks
.
SDS
import
iTasks
.
WF
.
Tasks
.
System
import
StdInt
,
StdChar
,
StdString
from
StdFunc
import
o
,
seqList
,
::
St
,
const
,
id
import
tcp
import
Internet
.
HTTP
,
System
.
GetOpt
,
Data
.
Func
,
Data
.
Functor
from
Data
.
Map
import
::
Map
from
Data
.
Queue
import
::
Queue
(..)
from
Data
.
Set
import
::
Set
,
newSet
import
qualified
Data
.
Map
as
DM
from
System
.
OS
import
IF_POSIX_OR_WINDOWS
,
OS_NEWLINE
,
IF_WINDOWS
import
Data
.
List
,
Data
.
Error
,
Data
.
Func
,
Data
.
Tuple
,
Math
.
Random
,
Text
import
System
.
Time
,
System
.
CommandLine
,
System
.
Environment
,
System
.
OSError
,
System
.
File
,
System
.
FilePath
,
System
.
Directory
import
iTasks
.
Internal
.
Util
,
iTasks
.
Internal
.
HtmlUtil
import
iTasks
.
Internal
.
IWorld
,
iTasks
.
Internal
.
WebService
,
iTasks
.
Internal
.
SDSService
import
qualified
iTasks
.
Internal
.
SDS
as
SDS
import
iTasks
.
UI
.
Layout
,
iTasks
.
UI
.
Layout
.
Default
from
iTasks
.
WF
.
Tasks
.
SDS
import
get
from
iTasks
.
WF
.
Combinators
.
Tune
import
class
tune
(..),
instance
tune
ApplyLayout
Task
,
::
ApplyLayout
(..)
from
iTasks
.
SDS
.
Combinators
.
Common
import
sdsFocus
from
iTasks
.
SDS
.
Sources
.
System
import
applicationOptions
import
iTasks
.
Internal
.
IWorld
,
iTasks
.
Internal
.
TaskEval
,
iTasks
.
Internal
.
TaskStore
import
iTasks
.
Internal
.
Util
import
iTasks
.
Internal
.
TaskServer
import
iTasks
.
Internal
.
EngineTasks
import
iTasks
.
Internal
.
Distributed
.
Symbols
from
Sapl
.
Linker
.
LazyLinker
import
generateLoaderState
,
::
LoaderStateExt
from
Sapl
.
Linker
.
SaplLinkerShared
import
::
SkipSet
from
Sapl
.
Target
.
Flavour
import
::
Flavour
,
toFlavour
from
TCPIP
import
::
Timeout
from
StdFunc
import
::
St
,
seqList
MAX_EVENTS
:==
5
...
...
@@ -49,23 +40,30 @@ doTasks startable world = doTasksWithOptions defaultEngineCLIOptions startable w
doTasksWithOptions
::
([
String
]
EngineOptions
->
MaybeError
[
String
]
EngineOptions
)
a
!*
World
->
*
World
|
Startable
a
doTasksWithOptions
initFun
startable
world
#
(
cli
,
world
)
=
getCommandLine
world
#
(
options
,
world
)
=
defaultEngineOptions
world
#
mbOptions
=
initFun
cli
options
|
mbOptions
=:(
Error
_)
=
show
(
fromError
mbOptions
)
world
#
options
=
fromOk
mbOptions
#
iworld
=
createIWorld
options
world
#
(
res
,
iworld
)
=
initJSCompilerState
iworld
|
res
=:(
Error
_)
=
show
[
"Fatal error: "
+++
fromError
res
]
(
destroyIWorld
iworld
)
#
(
symbolsResult
,
iworld
)
=
initSymbolsShare
options
.
distributed
options
.
appName
iworld
#
(
cli
,
world
)
=
getCommandLine
world
#
(
options
,
world
)
=
defaultEngineOptions
world
#
mbOptions
=
initFun
cli
options
|
mbOptions
=:(
Error
_)
=
show
(
fromError
mbOptions
)
world
#
options
=
fromOk
mbOptions
#
iworld
=
createIWorld
options
world
#
(
res
,
iworld
)
=
initJSCompilerState
iworld
|
res
=:(
Error
_)
=
show
[
"Fatal error: "
+++
fromError
res
]
(
destroyIWorld
iworld
)
#
(
symbolsResult
,
iworld
)
=
initSymbolsShare
options
.
distributed
options
.
appName
iworld
|
symbolsResult
=:
(
Error
_)
=
show
[
"Error reading symbols while required: "
+++
fromError
symbolsResult
]
(
destroyIWorld
iworld
)
#
iworld
=
serve
(
startupTasks
options
)
(
tcpTasks
options
.
serverPort
options
.
keepaliveTime
)
engineTasks
(
timeout
options
.
timeout
)
iworld
#
iworld
=
serve
(
startupTasks
options
)
(
tcpTasks
options
.
serverPort
options
.
keepaliveTime
)
(
timeout
options
.
timeout
)
iworld
=
destroyIWorld
iworld
where
webTasks
=
[
t
\\
WebTask
t
<-
toStartable
startable
]
startupTasks
{
distributed
,
sdsPort
}
=
(
if
distributed
[
case
onStartup
(
sdsServiceTask
sdsPort
)
of
StartupTask
t
=
t
;]
[])
++
[
t
\\
StartupTask
t
<-
toStartable
startable
]
hasWebTasks
=
not
(
webTasks
=:
[])
startupTasks
{
distributed
,
sdsPort
}
//If distributed, start sds service task
=
(
if
distributed
[
startTask
(
sdsServiceTask
sdsPort
)]
[])
++
[
startTask
flushWritesWhenIdle
//If there no webtasks, stop when stable, otherwise cleanup old sessions
,
startTask
if
(
webTasks
=:
[])
stopOnStable
removeOutdatedSessions
//Start all startup tasks
:[
t
\\
StartupTask
t
<-
toStartable
startable
]]
startTask
t
=
{
StartupTask
|
attributes
=
defaultValue
,
task
=
TaskWrapper
t
}
initSymbolsShare
False
_
iworld
=
(
Ok
(),
iworld
)
initSymbolsShare
True
appName
iworld
=
case
storeSymbols
(
IF_WINDOWS
(
appName
+++
".exe"
)
appName
)
iworld
of
...
...
@@ -78,16 +76,6 @@ where
|
otherwise
=
[(
serverPort
,
httpServer
serverPort
keepaliveTime
(
engineWebService
webTasks
)
taskOutput
)]
engineTasks
=
[
BackgroundTask
updateClock
,
BackgroundTask
(
processEvents
MAX_EVENTS
)
:
if
(
webTasks
=:
[])
[
BackgroundTask
stopOnStable
]
[
BackgroundTask
removeOutdatedSessions
,
BackgroundTask
flushWritesWhenIdle
]
]
// The iTasks engine consist of a set of HTTP Web services
engineWebService
::
[
WebTask
]
->
[
WebService
(
Map
InstanceNo
TaskOutput
)
(
Map
InstanceNo
TaskOutput
)]
engineWebService
webtasks
=
...
...
@@ -114,7 +102,7 @@ defaultEngineCLIOptions [argv0:argv] defaults
where
opts
::
[
OptDescr
((
Maybe
EngineOptions
)
->
Maybe
EngineOptions
)]
opts
=
[
Option
[
'?'
]
[
"help"
]
(
NoArg
$
const
Nothing
)
[
Option
[
'?'
]
[
"help"
]
(
NoArg
(\_->
Nothing
)
)
"Display this message"
,
Option
[
'p'
]
[
"port"
]
(
ReqArg
(\
p
->
fmap
\
o
->{
o
&
serverPort
=
toInt
p
})
"PORT"
)
(
"Specify the HTTP port (default: "
+++
toString
defaults
.
serverPort
+++
")"
)
...
...
@@ -122,6 +110,8 @@ where
"Specify the timeout in ms (default: 500)
\n
If not given, use an indefinite timeout."
,
Option
[]
[
"keepalive"
]
(
ReqArg
(\
p
->
fmap
\
o
->{
o
&
keepaliveTime
={
tv_sec
=
toInt
p
,
tv_nsec
=
0
}})
"SECONDS"
)
"Specify the keepalive time in seconds (default: 300)"
,
Option
[]
[
"maxevents"
]
(
ReqArg
(\
p
->
fmap
\
o
->{
o
&
maxEvents
=
toInt
p
})
"NUM"
)
"Specify the maximum number of events to process per loop (default: 5)"
,
Option
[]
[
"sessiontime"
]
(
ReqArg
(\
p
->
fmap
\
o
->{
o
&
sessionTime
={
tv_sec
=
toInt
p
,
tv_nsec
=
0
}})
"SECONDS"
)
"Specify the expiry time for a session in seconds (default: 60)"
,
Option
[]
[
"autolayout"
]
(
NoArg
(
fmap
\
o
->{
o
&
autoLayout
=
True
}))
...
...
@@ -208,22 +198,23 @@ defaultEngineOptions world
#
appDir
=
takeDirectory
appPath
#
appName
=
(
dropExtension
o
dropDirectory
)
appPath
#
options
=
{
appName
=
appName
,
appPath
=
appPath
,
appVersion
=
appVersion
,
serverPort
=
IF_POSIX_OR_WINDOWS
8080
80
,
serverUrl
=
"http://localhost/"
,
keepaliveTime
=
{
tv_sec
=
300
,
tv_nsec
=
0
}
// 5 minutes
,
sessionTime
=
{
tv_sec
=
60
,
tv_nsec
=
0
}
// 1 minute, (the client pings every 10 seconds by default)
,
persistTasks
=
False
,
autoLayout
=
True
,
distributed
=
False
,
sdsPort
=
9090
,
timeout
=
Just
500
,
webDirPath
=
appDir
</>
appName
+++
"-www"
,
storeDirPath
=
appDir
</>
appName
+++
"-data"
</>
"stores"
,
tempDirPath
=
appDir
</>
appName
+++
"-data"
</>
"tmp"
,
saplDirPath
=
appDir
</>
appName
+++
"-sapl"
{
appName
=
appName
,
appPath
=
appPath
,
appVersion
=
appVersion
,
serverPort
=
IF_POSIX_OR_WINDOWS
8080
80
,
serverUrl
=
"http://localhost/"
,
keepaliveTime
=
{
tv_sec
=
300
,
tv_nsec
=
0
}
// 5 minutes
,
sessionTime
=
{
tv_sec
=
60
,
tv_nsec
=
0
}
// 1 minute, (the client pings every 10 seconds by default)
,
persistTasks
=
False
,
autoLayout
=
True
,
distributed
=
False
,
maxEvents
=
5
,
sdsPort
=
9090
,
timeout
=
Nothing
//Just 500
,
webDirPath
=
appDir
</>
appName
+++
"-www"
,
storeDirPath
=
appDir
</>
appName
+++
"-data"
</>
"stores"
,
tempDirPath
=
appDir
</>
appName
+++
"-data"
</>
"tmp"
,
saplDirPath
=
appDir
</>
appName
+++
"-sapl"
}
=
(
options
,
world
)
...
...
@@ -256,3 +247,29 @@ determineAppVersion appPath world
#
version
=
strfTime
"%Y%m%d-%H%M%S"
tm
=
(
version
,
world
)
timeout
::
!(
Maybe
Timeout
)
!*
IWorld
->
(!
Maybe
Timeout
,!*
IWorld
)
timeout
mt
iworld
=
case
read
taskEvents
EmptyContext
iworld
of
//No events
(
Ok
(
ReadingDone
(
Queue
[]
[])),
iworld
=:{
sdsNotifyRequests
,
world
})
#
(
ts
,
world
)
=
nsTime
world
=
(
minListBy
lesser
[
mt
:
flatten
(
map
(
getTimeoutFromClock
ts
)
('
DM
'.
elems
sdsNotifyRequests
))]
,
{
iworld
&
world
=
world
})
(
Ok
(
ReadingDone
(
Queue
_
_)),
iworld
)
=
(
Just
0
,
iworld
)
//There are still events, don't wait
(
Error
_,
iworld
)
=
(
Just
500
,
iworld
)
//Keep retrying, but not too fast
where
lesser
(
Just
x
)
(
Just
y
)
=
x
<
y
lesser
(
Just
_)
Nothing
=
True
lesser
Nothing
Nothing
=
False
getTimeoutFromClock
::
Timespec
(
Map
SDSNotifyRequest
Timespec
)
->
[
Maybe
Timeout
]
getTimeoutFromClock
now
requests
=
map
getTimeoutFromClock`
('
DM
'.
toList
requests
)
where
getTimeoutFromClock`
::
(!
SDSNotifyRequest
,
!
Timespec
)
->
Maybe
Timeout
getTimeoutFromClock`
(
snr
=:{
cmpParam
=(
ts
::
ClockParameter
Timespec
)},
reqTimespec
)
|
startsWith
"$IWorld:timespec$"
snr
.
reqSDSId
&&
ts
.
interval
<>
zero
#
fire
=
iworldTimespecNextFire
now
reqTimespec
ts
=
Just
(
max
0
(
toMs
fire
-
toMs
now
))
=
mt
getTimeoutFromClock`
_
=
mt
toMs
x
=
x
.
tv_sec
*
1000
+
x
.
tv_nsec
/
1000000
Libraries/iTasks/Extensions/Editors/DynamicEditor.dcl
0 → 100644
View file @
e0633e14
definition
module
iTasks
.
Extensions
.
Editors
.
DynamicEditors
import
iTasks
::
DynamicEditor
a
=:
DynamicEditor
[
DynamicEditorElement
]
// phantom type only needed for top level
::
DynamicEditorValue
a
=
DynamicEditorValue
!
DynamicConsId
!
DEVal
|
Undefined
// TODO: Undefined can be removed once we have parametrised editors
::
DEVal
=
DEApplication
![(!
DynamicConsId
,
!
DEVal
)]
|
DEJSONValue
!
JSONNode
derive
class
iTask
DynamicEditorValue
::
DynamicEditorElement
=
DynamicCons
!
DynamicCons
|
DynamicConsGroup
!
String
![
DynamicCons
]
::
DynamicCons
::
DynamicConsOption
=
HideIfOnlyChoice
|
UseAsDefault
(<<@@@)
infixl
2
::
!
DynamicCons
!
DynamicConsOption
->
DynamicCons
(@@@>>)
infixr
2
::
!
DynamicConsOption
!
DynamicCons
->
DynamicCons
::
DynamicConsId
:==
String
::
DynamicConsBuilder
=
FunctionCons
!
Dynamic
|
E
.
a
:
CustomEditorCons
!(
Editor
a
)
&
JSONEncode
{|*|},
JSONDecode
{|*|},
gText
{|*|},
TC
a
|
ListCons
!
Dynamic
//* must contain a value of type [a] -> b
functionCons
::
!
String
!
String
!
a
->
DynamicCons
|
TC
a
listCons
::
!
String
!
String
!([
a
]
->
b
)
->
DynamicCons
|
TC
a
&
TC
b
customEditorCons
::
!
String
!
String
!(
Editor
a
)
->
DynamicCons
|
TC
,
JSONEncode
{|*|},
JSONDecode
{|*|},
gText
{|*|}
a
// dynamic variants are required because this is the only way to use quantified type variables
functionConsDyn
::
!
String
!
String
!
Dynamic
->
DynamicCons
listConsDyn
::
!
String
!
String
!
Dynamic
->
DynamicCons
dynamicEditor
::
!(
DynamicEditor
a
)
->
Editor
(
DynamicEditorValue
a
)
|
TC
a
parametrisedDynamicEditor
::
!(
p
->
DynamicEditor
a
)
->
Editor
(!
p
,
!
DynamicEditorValue
a
)
|
TC
a
&
gEq
{|*|},
JSONEncode
{|*|},
JSONDecode
{|*|}
p
toValue
::
!(
DynamicEditor
a
)
!(
DynamicEditorValue
a
)
->
a
|
TC
a
dynEditorValToString
::
!(
DynamicEditor
a
)
!(
DynamicEditorValue
a
)
->
String
Libraries/iTasks/Extensions/Editors/DynamicEditor.icl
0 → 100644
View file @
e0633e14
This diff is collapsed.
Click to expand it.
Libraries/iTasks/Extensions/TextFile.dcl
View file @
e0633e14
definition
module
iTasks
.
Extensions
.
TextFile
import
iTasks
from
System
.
FilePath
import
::
FilePath
from
System
.
FilePath
import
::
FilePath
from
iTasks
.
Extensions
.
Document
import
::
Document
/**
* Import the content of a text file on the server's filesystem.
...
...
@@ -15,6 +16,16 @@ from System.FilePath import :: FilePath
*/
importTextFile
::
!
FilePath
->
Task
String
/**
* Import the content of a text file document.
*
* @param Document: The document to import
*
* @return The imported content
* @throws FileException
*/
importTextDocument
::
!
Document
->
Task
String
/**
* Export a string as text file to the server's filesystem.
*
...
...
Libraries/iTasks/Extensions/TextFile.icl
View file @
e0633e14
...
...
@@ -9,6 +9,13 @@ importTextFile :: !FilePath -> Task String
importTextFile
filename
=
mkInstantTask
eval
where
eval
taskId
iworld
=
fileTaskRead
taskId
filename
readAll
iworld
importTextDocument
::
!
Document
->
Task
String
importTextDocument
{
Document
|
documentId
}
=
mkInstantTask
eval
where
eval
taskId
iworld
#
(
filename
,
iworld
)
=
documentLocation
documentId
iworld
=
fileTaskRead
taskId
filename
readAll
iworld
exportTextFile
::
!
FilePath
!
String
->
Task
String
exportTextFile
filename
content
=
mkInstantTask
eval
...
...
Libraries/iTasks/Internal/Client/RunOnClient.icl
View file @
e0633e14
...
...
@@ -132,6 +132,7 @@ createClientIWorld serverURL currentInstance
,
autoLayout
=
True
,
timeout
=
Just
100
,
distributed
=
False
,
maxEvents
=
5
,
sdsPort
=
9090
,
webDirPath
=
locundef
"webDirectory"
,
storeDirPath
=
locundef
"dataDirectory"
...
...
Libraries/iTasks/Internal/EngineTasks.dcl
View file @
e0633e14
...
...
@@ -2,18 +2,10 @@ definition module iTasks.Internal.EngineTasks
/**
* This module defines the separate system tasks that the iTasks engine performs
*/
from
iTasks
.
Internal
.
IWorld
import
::
IWorld
from
iTasks
.
WF
.
Definition
import
::
TaskException
from
Data
.
Error
import
::
MaybeError
from
Data
.
Maybe
import
::
Maybe
from
TCPIP
import
::
Timeout
from
iTasks
.
WF
.
Definition
import
::
Task
timeout
::
!(
Maybe
Timeout
)
!*
IWorld
->
(!
Maybe
Timeout
,!*
IWorld
)
removeOutdatedSessions
::
Task
(
)
updateClock
::
!*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
)
flushWritesWhenIdle
::
Task
(
)
removeOutdatedSessions
::
!*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
)
flushWritesWhenIdle
::
!*
IWorld
->
(!
MaybeError
TaskException
(),
!*
IWorld
)
stopOnStable
::
!*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
)
stopOnStable
::
Task
()
Libraries/iTasks/Internal/EngineTasks.icl
View file @
e0633e14
implementation
module
iTasks
.
Internal
.
EngineTasks
import
StdBool
,
StdOverloaded
,
StdList
,
StdOrdList
import
qualified
Data
.
Map
as
DM
import
qualified
Data
.
Set
as
DS
import
Data
.
List
import
Data
.
Functor
,
Data
.
Func
import
Data
.
Error
import
Data
.
Queue
import
StdEnv
import
iTasks
.
Engine
import
iTasks
.
Internal
.
IWorld
import
iTasks
.
WF
.
Definition
import
iTasks
.
Internal
.
Util
import
iTasks
.
Internal
.
SDS
import
iTasks
.
Internal
.
TaskEval
import
iTasks
.
Internal
.
TaskServer
import
iTasks
.
Internal
.
TaskState
import
iTasks
.
Internal
.
TaskStore
import
iTasks
.
SDS
.
Definition
import
iTasks
.
SDS
.
Combinators
.
Common
import
iTasks
.
UI
.
Definition
import
iTasks
.
WF
.
Definition
from
iTasks
.
Extensions
.
DateTime
import
toDate
,
toTime
,
instance
==
Date
,
instance
==
Time
from
System
.
Time
import
time
import
Text
.
GenJSON
from
TCPIP
import
::
Timeout
import
Data
.
Queue
import
Text
from
Data
.
Map
import
newMap
timeout
::
!(
Maybe
Timeout
)
!*
IWorld
->
(!
Maybe
Timeout
,!*
IWorld
)
timeout
mt
iworld
=
case
read
taskEvents
EmptyContext
iworld
of
//No events
(
Ok
(
ReadingDone
(
Queue
[]
[])),
iworld
=:{
sdsNotifyRequests
,
world
})
#
(
ts
,
world
)
=
nsTime
world
=
(
minListBy
lesser
[
mt
:
flatten
$
map
(
getTimeoutFromClock
ts
)
$
'
DM
'.
elems
sdsNotifyRequests
]
,
{
iworld
&
world
=
world
})
(
Ok
(
ReadingDone
(
Queue
_
_)),
iworld
)
=
(
Just
0
,
iworld
)
//There are still events, don't wait
(
Error
_,
iworld
)
=
(
Just
500
,
iworld
)
//Keep retrying, but not too fast
everyTick
::
(*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
))
->
Task
()
everyTick
f
=
Task
eval
where
lesser
(
Just
x
)
(
Just
y
)
=
x
<
y
lesser
(
Just
_)
Nothing
=
True
lesser
Nothing
Nothing
=
False
getTimeoutFromClock
::
Timespec
(
Map
SDSNotifyRequest
Timespec
)
->
[
Maybe
Timeout
]
getTimeoutFromClock
now
requests
=
getTimeoutFromClock`
<$>
'
DM
'.
toList
requests
where
getTimeoutFromClock`
::
(!
SDSNotifyRequest
,
!
Timespec
)
->
Maybe
Timeout
getTimeoutFromClock`
(
snr
=:{
cmpParam
=(
ts
::
ClockParameter
Timespec
)},
reqTimespec
)
|
startsWith
"$IWorld:timespec$"
snr
.
reqSDSId
&&
ts
.
interval
<>
zero
#
fire
=
iworldTimespecNextFire
now
reqTimespec
ts
=
Just
(
max
0
(
toMs
fire
-
toMs
now
))
=
mt
getTimeoutFromClock`
_
=
mt
toMs
x
=
x
.
tv_sec
*
1000
+
x
.
tv_nsec
/
1000000
updateClock
::
!*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
)
updateClock
iworld
=:{
IWorld
|
clock
,
world
}
//Determine current date and time
#
(
timespec
,
world
)
=
nsTime
world
#
iworld
=
{
iworld
&
world
=
world
}
//Write SDS if necessary
#
(
mbe
,
iworld
)
=
write
timespec
(
sdsFocus
{
start
=
zero
,
interval
=
zero
}
iworldTimespec
)
EmptyContext
iworld
=
case
mbe
of
(
Error
e
)
->
(
Error
e
,
iworld
)
(_)
->
(
Ok
(),
iworld
)
eval
event
evalOpts
tree
=:(
TCInit
taskId
ts
)
iworld
#
(
merr
,
iworld
)
=
f
iworld
|
isError
merr
=
(
ExceptionResult
(
fromError
merr
),
iworld
)
#
(
merr
,
iworld
)
=
readRegister
taskId
tick
iworld
|
isError
merr
=
(
ExceptionResult
(
fromError
merr
),
iworld
)
=
(
ValueResult
NoValue
{
TaskEvalInfo
|
lastEvent
=
ts
,
removedTasks
=[],
attributes
=
newMap
}
NoChange
(
TCInit
taskId
ts
)
,
iworld
)
//When we run the built-in HTTP server we need to do active garbage collection of instances that were created for sessions
removeOutdatedSessions
::
!*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
)
removeOutdatedSessions
iworld
=:{
IWorld
|
options
}
#
(
mbIndex
,
iworld
)
=
read
(
sdsFocus
{
InstanceFilter
|
defaultValue
&
onlySession
=
Just
True
}
filteredInstanceIndex
)
EmptyContext
iworld
=
case
mbIndex
of
Ok
(
ReadingDone
index
)
=
checkAll
removeIfOutdated
index
iworld
Error
e
=
(
Error
e
,
iworld
)
removeOutdatedSessions
::
Task
()
removeOutdatedSessions
=
everyTick
\
iworld
=:{
IWorld
|
options
}->
case
read
(
sdsFocus
{
InstanceFilter
|
defaultValue
&
onlySession
=
Just
True
}
filteredInstanceIndex
)
EmptyContext
iworld
of
(
Ok
(
ReadingDone
index
),
iworld
)
=
checkAll
(
removeIfOutdated
options
)
index
iworld
(
Error
e
,
iworld
)
=
(
Error
e
,
iworld
)
where
checkAll
f
[]
iworld
=
(
Ok
(),
iworld
)
checkAll
f
[
x
:
xs
]
iworld
=
case
f
x
iworld
of
(
Ok
(),
iworld
)
=
checkAll
f
xs
iworld
(
Error
e
,
iworld
)
=
(
Error
e
,
iworld
)
removeIfOutdated
(
instanceNo
,_,_,_)
iworld
=:{
options
={
appVersion
},
clock
=
tNow
}
removeIfOutdated
options
(
instanceNo
,_,_,_)
iworld
=:{
options
={
appVersion
},
clock
=
tNow
}
#
(
remove
,
iworld
)
=
case
read
(
sdsFocus
instanceNo
taskInstanceIO
)
EmptyContext
iworld
of
//If there is I/O information, we check that age first
(
Ok
(
ReadingDone
(
Just
(
client
,
tInstance
))),
iworld
)
//No IO for too long, clean up
...
...
@@ -103,27 +71,23 @@ where
=
(
Error
e
,
iworld
)
//When the event queue is empty, write deferred SDS's
flushWritesWhenIdle
::
!*
IWorld
->
(!
MaybeError
TaskException
(),
!*
IWorld
)
flushWritesWhenIdle
iworld
=
case
read
taskEvents
EmptyContext
iworld
of
flushWritesWhenIdle
::
Task
(
)
flushWritesWhenIdle
=
everyTick
\
iworld
->
case
read
taskEvents
EmptyContext
iworld
of
(
Error
e
,
iworld
)
=
(
Error
e
,
iworld
)
(
Ok
(
ReadingDone
(
Queue
[]
[])),
iworld
)
=
flushDeferredSDSWrites
iworld
(
Ok
_,
iworld
)
=
(
Ok
(),
iworld
)
//When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop
//once all tasks are stable
stopOnStable
::
!*
IWorld
->
*(!
MaybeError
TaskException
(),
!*
IWorld
)
stopOnStable
iworld
=:{
IWorld
|
shutdown
}
#
(
mbIndex
,
iworld
)
=
read
(
sdsFocus
{
InstanceFilter
|
defaultValue
&
includeProgress
=
True
}
filteredInstanceIndex
)
EmptyContext
iworld
=
case
mbIndex
of
Ok
(
ReadingDone
index
)
stopOnStable
::
Task
()
stopOnStable
=
everyTick
\
iworld
=:{
IWorld
|
shutdown
}->
case
read
(
sdsFocus
{
InstanceFilter
|
defaultValue
&
includeProgress
=
True
}
filteredInstanceIndex
)
EmptyContext
iworld
of
(
Ok
(
ReadingDone
index
),
iworld
)
#
shutdown
=
case
shutdown
of
Nothing
=
if
(
allStable
index
)
(
Just
(
if
(
exceptionOccurred
index
)
1
0
))
Nothing
_
=
shutdown
=
(
Ok
(),
{
IWorld
|
iworld
&
shutdown
=
shutdown
})
Error
e
=
(
Error
e
,
iworld
)
(
Error
e
,
iworld
)
=
(
Error
e
,
iworld
)
where
allStable
instances
=
all
(\
v
->
v
=:
Stable
||
v
=:
(
Exception
_))
(
values
instances
)
exceptionOccurred
instances
=
any
(\
v
->
v
=:
(
Exception
_))
(
values
instances
)
values
instances
=
[
value
\\
(_,_,
Just
{
InstanceProgress
|
value
},_)
<-
instances
]
Libraries/iTasks/Internal/IWorld.dcl
View file @
e0633e14
...
...
@@ -12,7 +12,7 @@ from Text.GenJSON import :: JSONNode
from
iTasks
.
Engine
import
::
EngineOptions
from
iTasks
.
UI
.
Definition
import
::
UI
,
::
UIType
from
iTasks
.
Internal
.
TaskState
import
::
ParallelTaskState
,
::
TIMeta
,
::
DeferredJSON
from
iTasks
.
Internal
.
Task
import
::
ConnectionTask
,
::
BackgroundTask
from
iTasks
.
Internal
.
Task
import
::
ConnectionTask
from
iTasks
.
Internal
.
TaskEval
import
::
TaskTime
from
iTasks
.
WF
.
Definition
import
::
TaskValue
,
::
Event
,
::
TaskId
,
::
InstanceNo
,
::
TaskNo
,
::
TaskException
...
...
@@ -78,7 +78,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
::
*
IOTaskInstance
=
ListenerInstance
!
ListenerInstanceOpts
!*
TCP_Listener
|
ConnectionInstance
!
ConnectionInstanceOpts
!*
TCP_DuplexChannel
|
BackgroundInstance
!
BackgroundInstanceOpts
!
BackgroundTask
::
ListenerInstanceOpts
=
{
taskId
::
!
TaskId
//Reference to the task that created the listener
...
...
@@ -96,12 +95,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
::
ConnectionId
:==
Int
::
BackgroundInstanceOpts
=
{
bgInstId
::
!
BackgroundTaskId
}
::
BackgroundTaskId
:==
Int
::
IOStates
:==
Map
TaskId
IOState
::
IOState
=
IOActive
!(
Map
ConnectionId
(!
Dynamic
,!
Bool
))
// Bool: stability
...
...
Libraries/iTasks/Internal/IWorld.icl
View file @
e0633e14
...
...
@@ -195,4 +195,4 @@ where
=
(
x
,
{
IWorld
|
iworld
&
world
=
world
})
appFiles
appfun
iworld
=:{
IWorld
|
world
}
#
world
=
appFiles
appfun
world
=
{
IWorld
|
iworld
&
world
=
world
}
\ No newline at end of file
=
{
IWorld
|
iworld
&
world
=
world
}
Libraries/iTasks/Internal/Task.dcl
View file @
e0633e14
...
...
@@ -37,9 +37,6 @@ derive gEq Task
,
onDestroy
::
!(
l
*
IWorld
->
*(!
MaybeErrorString
l
,
![
String
],
!*
IWorld
))
}