Skip to content

Instantly share code, notes, and snippets.

@GiuseppeChillemi
Forked from greggirwin/scheduler.r
Created March 11, 2019 09:10
Show Gist options
  • Save GiuseppeChillemi/3f8c69bab18073fab0ef9aff1b9e31ab to your computer and use it in GitHub Desktop.
Save GiuseppeChillemi/3f8c69bab18073fab0ef9aff1b9e31ab to your computer and use it in GitHub Desktop.
Rebol scheduler dialect
REBOL [
Title: "Scheduler"
File: %scheduler.r
Purpose: "Dialected task scheduling library"
Author: ["SOFTINNOV / Nenad Rakocevic" "Pointillistic / Gregg Irwin"]
Copyright: ["2009 SOFTINNOV" "2013 SOFTINNOV/POINTILLISTIC"]
Email: [[email protected] [email protected]]
Date: 28-Oct-2013
Version: 0.9.5
License: "BSD - see %LICENCE.txt file"
Comments: {
Scheduler DSL quickstart
------------------------
Legend:
- <value> means that the value is optional
- CAPITALIZED words are dialect keywords
o Event with a precise point in time :
<name:> AT time! DO action
or
<name:> ON date! AT time! DO action
o Event with a delay :
<name:> IN n <unit> DO action
o Recurring event :
<name:> EVERY
<n> <unit> ; recurring unit
<allowed> ; specific point(s) in time or duration(s) allowed
<NOT forbidden> ; specific point(s) in time or duration(s) forbidden
<OFFSET amount> ; date/time offset amount from unit
<AT moment> ; fixed time for each event (only the date changes)
<count TIMES> ; limit the number of event occurences
<USER-DATA value> ; any value you want to associate with the job
DO action ; action to execute
with
<name:>: set-word! value for naming a task (for future access using the API).
<n>: integer! value for unit multiplying.
<unit>: any of
s|sec|second|seconds
mn|min|minute|minutes
h|hr|hour|hours
d|day|days
w|wk|week|weeks
m|mo|month|months
<allowed>: any time (00:00:00), calendar day (#dd), weekday (mon|monday),
month (jan|january), range of time|calendar-days or block of any
of theses options.
<forbidden>: same options as <allowed>.
<moment>: date! or time! value.
<t>: integer! value.
action: file!|url!|block!|function!|word! value to be evaluated when
event is fired.
Syntactic sugar
---------------
The default dialect is parsed in BLOCK! mode. That means that only REBOL values
are accepted, but some people may want to write calendar dates like: 1st, 2nd,...
instead or #1, #2,... So a preprocessor is included, allowing tasks to be passed
as string! values, extending the accepted syntax for the following cases :
1st, 2nd, 3rd,..nth : accepted
12s, 12mn, 12h, 12d,... : accepted
Scheduler API
-------------
scheduler/plan [spec] ; Add one or more tasks to the scheduler
scheduler/plan/new [spec] ; Same as above, but removes all previous tasks
scheduler/delete 'name ; Removes the named task from the scheduler
scheduler/wait ; Provides a global event loop
Examples
--------
scheduler/plan [
at 18:30 do http://domain.com/update.r
every 3 days not [#2 - #9 #12 sat sun] at 00:30 do %batch.r
smk: every friday at 13:00 do %test.r
cc: every 12 hours do %backup.r
every [sat sun] at 12:00 do %beep.r
every month on #01 do %check.r
]
scheduler/wait
(See %test-scheduler.r for more examples)
}
Gregg's-notes: {
Dialect production rule names now all end with = as a naming convention.
It's BNF-like, and helps distinguish them from other words.
I know 'times matches the N TIMES dialect syntax, but to have a count
value called 'times where time values are heavily used, seems confusing.
It is now called 'count. 'Count is also used in iCal. I also changed
the 'repeat field name to 'count, to match it. 'Count also seems clearer
there.
Added [on date! at time!] support to the dialect.
Added user-data field to jobs.
Code reorganization, to group things contextually, and comments.
Added events-up-to, to get a list of upcoming events.
Added error trap and log for actions.
}
]
scheduler: context [
name: mult: unit: n: allow: forbid: on-day: at-time: offset: count: action: user-data: err:
type:
_start: _end: ; Where the event starts and ends in the dialected plan
s: e: ; start/end values for restricted ranges
value: ; Most recently parsed day, time, day-num, etc.
none
error-log: %scheduler-errors.log
last-error: none
last-exec-result: none ; not sure we'll want to keep this. Just experimenting.
; Jobs is a block of date!/spec pairs, where the date value is the
; next time that job/task should run, and the spec block is the spec
; for that task as it was parsed from the dialected plan.
jobs: make block! 8
; The queue contains only specs (? only one spec at a time, ever?)
queue: make block! 1
; Shortcut name (? is it worth it?)
wait-list: system/ports/wait-list
reset: does [
clear jobs
clear queue
remove find wait-list time!
]
; Return the current date/time with no timezone information
get-now: has [n] [n: now n/zone: 00:00 n]
; Some tests set NOW to a specific date, which makes sense, but that
; breaks /precise. Hence, sys-now and precise-now
;get-now: has [n] [n: now/precise n/zone: 00:00 n]
sys-now: :now
precise-now: has [n] [n: sys-now/precise n/zone: 00:00 n]
; Execute the action for a given task
exec: func [task-spec /local action res] [
last-error: none
if error? set/any 'res try [
;print mold task-spec
action: select task-spec 'action
;?? Do we really need to switch on action type? Or can we just DO them
; (once we de-reference word actions)?
if word? :action [action: get :action]
either file? :action [
call action
][
set/any 'res do :action :task-spec
]
; switch type?/word :action [
; url! [read action] ;?? READ, not DO?
; block! [do action]
; file! [do action]
; function! [do :action task-spec]
; word! [do get :action task-spec]
; ]
last-exec-result: either value? 'res [:res] [none]
][
last-error: disarm res
;TBD: What should go in the error log?
write/append error-log reform [
newline now/precise remold [task-spec/source third last-error]
]
]
]
; Call on-timer when the job timer goes off for the next job. It works closely
; with update-sys-timer. On-timer is called when a timer expires, takes the next
; task spec from the queue, runs it, and updates the job list with the next time
; that task should run. If the job was set to run only once, it's removed from
; the job list.
on-timer: has [task job] [
task: take queue
job: back find/only jobs task
; Set the time for the task running now, which is used by next-event?.
task/last: get-now
; Run the actual action for the task.
exec task
; Remove jobs that don't need to execute again.
if any [
; Have to confirm this. If task/at is a date, we want to bail,
; but if it's a time, we only want to bail if 'every hasn't been
; used in the spec.
date? task/at
all [task/at not task/unit]
all [task/count zero? task/count: task/count - 1]
none? job/1: next-event? task
][
;print ["SCHEDULER" "on-timer" "Removing task from job list:" mold job/2]
remove/part job 2
]
; Set up the next task timer
update-sys-timer
]
; Schedule a timer for the next task to execute, and put its spec in the queue.
update-sys-timer: does [
; Jobs are pairs of next-task-time/spec values. Sort them to put
; the next upcoming task first.
sort/skip jobs 2
; Update our public interface copy of jobs.
job-list: copy/deep jobs
; Take the current timer out of the system port wait-list, if we find one.
remove find wait-list time!
; Jobs have been sorted, so the next upcoming time is first, followed by
; its spec. Put the spec in the queue for on-timer to use and put the
; time we want it to trigger in the system port wait-list (offset from
; the current system time).
; It's possible that there was no next event for the first job, meaning
; it will be NONE. That won't work for setting a timer, but we can just
; remove all expired jobs at the head of the job list before trying.
while [all [not empty? jobs none? jobs/1]] [remove/part jobs 2]
if not empty? jobs [
append/only queue jobs/2
; If we don't use /precise, milliseconds creep up over time. An offset
; of 0.04. Task exec time doesn't seem to be the value though.
; By using /precise, our events are within a few ms of the target second.
; !! But if our intervals are longer (e.g. 5 minutes), using /precise can
; cause the even to trigger up to a full second early.
; The MAX is here because I was getting some errors in calling code that
; had WAITs in it. e.g. id: 'invalid-arg arg1: -0:00:03. My guess was that
; very close timing on things could cause a negative result to get into
; the list when other WAIT calls were used. I haven't seen one of those
; errors since I added MAX here.
;append wait-list difference jobs/1 get-now
append wait-list max 0:0:0 difference jobs/1 get-now
]
]
allowed?: func [spec [block!] time [time!]] [
foreach v spec [
either time? v [
if v = time [return yes]
][
; v is a block of two time values [start end].
either v/1 <= v/2 [
; Start is less than end.
if all [v/1 <= time time <= v/2] [return yes]
][
; Midnight rollover logic (start is greater than end).
if any [
all [time >= v/1 time <= 24:00] ; 23:59:59.999
all [time <= v/2 time >= 00:00]
] [return yes]
]
]
]
no
]
; This returns NONE if there is no next event for the spec.
next-event?: func [spec [block!] /local new time mult] [
; If they set a count for the event (number of times to exec), and
; it has reached zero, there is no next event for it.
if spec/count = 0 [return none]
; If the spec gave a relative time, make it an absolute time.
if spec/at = 'in [
spec/at: search-event/short spec get-now
]
either any [date? spec/at none? spec/unit] [
;-- AT --
new: set-datetime spec/at get-now
][
;-- EVERY --
new: any [spec/last get-now]
; This logic for setting /offset isn't elegant, but the original
; logic just set the entire time value to the offset, which wasn't
; correct for some cases, and could cause plan failures.
;!! TBD: We may miss the first event if there's an offset, because
; we are adding the mult, which may put us past the next time.
; e.g., start plan at 6:05 with a 15 minute step and offset of
; 0:0, and it thinks we should start searching at 6:15, making
; the first event 6:30.
; search-event calls next-new before checking, which is
; part of this. It steps by spec/multiple.
; It looks like setting mult to 0 when the new time unit is
; less than the mult takes care of it.
if all [not spec/last spec/offset] [
; new is set to NOW, and we have an offset to apply.
time: new/time
mult: any [spec/multiple 0] ; any [spec/multiple 1]
switch spec/unit [
hour [
;print 'HOUR
if time/hour <= mult [mult: 0]
time/hour: spec/offset/hour + mult
time/minute: spec/offset/minute
time/second: spec/offset/second
]
minute [
;print 'MINUTE
if time/minute <= mult [mult: 0]
time/minute: spec/offset/minute + mult
time/second: spec/offset/second
]
second [
;print 'SECOND
if time/second <= mult [mult: 0]
time/second: spec/offset/second + mult
]
]
new/time: time
]
if spec/at [
; If it's our first time setting the event, and /at is not a
; full date, but just a time, and since /last isn't set, we
; know new/day=now/day, then, finally, if /at comes later in
; the day than the current time, we want to step the day back
; one because search-event will always step it forward at least
; one day, which means we miss the event for today, which should
; happen later in this day, not tomorrow.
if all [none? spec/last time? spec/at now/time <= spec/at] [
new/day: new/day - 1
]
new/time: spec/at
]
if spec/unit = 'month [
new/day: any [
spec/on
all [date? spec/offset spec/offset/day]
1 ; Default to the first of the month if they didn't spec a day.
]
]
new: search-event spec new
]
new
]
search-event: func [
"Find the next date-time for the event, given a starting point in time."
spec [block!]
new [date!] "Where to start searching"
/short "Only create an absolute event time from a relative time. Do no contstraint checking."
/local tests step next-new sa sf u list
t-dbg-start t-dbg-end n-dbg-ct ;<< Used to test search timing
][
u: spec/unit
step: any [spec/multiple 1]
next-new: either find [day month] u [
[new/:u: new/:u + step]
][
step: step * select [hour 1:0 minute 0:1 second 0:0:1] u
[new/time: new/time + step]
]
;-- Shortcut exit
if short [do next-new return new]
tests: clear []
sa: spec/allow
sf: spec/forbid
;-- Constraints compilation --
foreach [cond test] [
[sa select sa 'cal-days] [find sa/cal-days new/day]
[sa select sa 'week-days] [find sa/week-days new/weekday]
[sa select sa 'months] [find sa/months new/month]
[sa select sa 'time] [allowed? sa/time new/time]
[sf select sf 'cal-days] [not find sf/cal-days new/day]
[sf select sf 'week-days] [not find sf/week-days new/weekday]
[sf select sf 'months] [not find sf/months new/month]
[sf select sf 'time] [not allowed? sf/time new/time]
][
if all cond [append tests test]
]
;?? Is this the correct way to ensure that we don't trigger a timer
;!! event right away, which then messes up the other timer events
; so they don't honor the offset? This only happens if we start up
; at a time that is within the allowed range. That's a real problem
; if timers run 24 hours a day.
insert tests [new >= get-now]
;-- evaluation --
;!! This will fail to find the next event if it's too far out, based
;!! on the unit type. e.g., more than 60 minutes away if your unit
;!! is 1 minute. That can easily happen if your allowed hours are over
;!! for the day when you schedule the plan.
; The STEP value comes into play, because we increment by that each
; time through our loop. e.g., a step of 30 minutes will let you have
; a gap of 30 hours to the next event, a step of 15 minutes works up
; to 15 hours, 5 minutes = 5 hours, etc. This might be where a NOT
; rule should be used, so we don't have to increase our loop counts
; too much. To support a 24 hour period, with a 5 minute step, we
; need to loop 288 times. A 1 minute step = 1440 loops max.
; Using 3600 for the seconds loop lets us go a day at 30 sec steps.
n-dbg-ct: 0
t-dbg-start: precise-now
loop select [
second 86'400 ; 3600 ; 60 86'400 = 1 day takes ~0.6 sec on my machine
minute 1'440 ; 288 ; 60 1'440 = 1 day
hour 24
day 366 ; account for leap years
month 12
] u [
n-dbg-ct: n-dbg-ct + 1
do next-new
if all tests [
t-dbg-end: precise-now
;print ["DEBUG search-event FOUND" "count:" n-dbg-ct "time:" difference t-dbg-end t-dbg-start]
return new
]
]
t-dbg-end: precise-now
;print ["DEBUG search-event NOT FOUND" "count:" n-dbg-ct "time:" difference t-dbg-end t-dbg-start]
;?? TBD: Should this error out, or return NONE, if we want to have some kind of trace?
;print "Debug info:"
;print ["new:" new "step:" step "next-new:" mold next-new "spec:" mold spec "tests:" mold tests]
;make error! rejoin ["Can't find next event for rule " mold spec/source]
;print rejoin ["Can't find next event for rule " mold spec/source]
return none
]
; Set the dest date/time values in place, from the source value.
set-datetime: func [src [date! time!] dst [date!]] [
if date? src [
dst/date: src/date
; If no source time is set, dest/time will not be set.
if src/time [dst/time: src/time]
; Timezones are not accounted for in this library.
dst/zone: 00:00
]
if time? src [dst/time: src]
dst
]
;-- Dialect support
; TBD: There is some type/name confusion throughout the module. In the
; parse rules, 'type is used for allow/forbid, but it's called
; 'name in the blockify/expand/store funcs. In the parse rules,
; 'type is set to units like 'week-days or 'month.
blockify: func [
name [word!] "'allow or 'forbid"
type [word!]
/local blk
][
if not find [allow forbid] name [
make error! join "Blockify called with bad type:" type
]
if not block? get name [set name make block! 1]
name: get name
if not blk: select name type [
repend name [type blk: make block! 1]
]
blk
]
expand: func [
name [word!] "'allow or 'forbid"
type [word!]
start
end
/local list
][
if not find [allow forbid] name [
make error! join "Expand called with bad type:" type
]
list: blockify name type
start: -1 + to integer! form start
end: 1 + to integer! form end
repeat c min end - start 60 [insert list end - c]
]
; This is used when starting to parse a dialected spec.
reset-locals: has [list] [
clear next find list: first self 'value
set next bind list self err: none
]
; Unused at this time
;reset-series: func [s [series!] len [integer!]] [head clear skip s len]
; Store an allow or forbid value
store: func [
name [word!] "'allow or 'forbid"
type [word!]
value
/only
/local list
][
if not find [allow forbid] name [
make error! join "Store called with bad type:" type
]
list: blockify name type
if issue? value [value: to integer! form value]
either only [append/only list value] [append list value]
]
; Put a job, that we parsed from a plan, into the jobs list
store-job: has [record al src] [
src: copy/part _start _end
if all [
block? allow
block? forbid
not empty? intersect allow forbid
][
make error! rejoin ["Bad specification for task (allow and forbid values intersect):" mold src]
]
record: reduce [
'name all [name to word! name]
'multiple mult
'unit unit ; = ical FREQ
'allow allow
'forbid forbid
'on on-day
'at at-time
'offset offset ; = ical BY ?
'count count ; = ical COUNT
'action :action ; get-word! to allow funcs
'last none ; The last time the event occurred
'log? yes
'debug? no
'source src
'user-data user-data
]
;probe new-line/all copy/part record 20 off
repend jobs [next-event? record record]
]
;-------------------------------------------------------------------------------
;-- Block Dialect
digits=: charset "0123456789"
; Not used at this time
;cal-days=: [set n integer!]
week-days=: [
['Monday | 'Mon] (n: 1)
| ['Tuesday | 'Tue] (n: 2)
| ['Wednesday | 'Wed] (n: 3)
| ['Thursday | 'Thu] (n: 4)
| ['Friday | 'Fri] (n: 5)
| ['Saturday | 'Sat] (n: 6)
| ['Sunday | 'Sun] (n: 7)
]
months=: [
['January | 'Jan] (n: 1)
| ['February | 'Feb] (n: 2)
| ['March | 'Mar] (n: 3)
| ['April | 'Apr] (n: 4)
| ['May | 'May] (n: 5)
| ['June | 'Jun] (n: 6)
| ['July | 'Jul] (n: 7)
| ['August | 'Aug] (n: 8)
| ['September | 'Sep] (n: 9)
| ['October | 'Oct] (n: 10)
| ['November | 'Nov] (n: 11)
| ['December | 'Dec] (n: 12)
]
delays=: [
['seconds | 'second | 'sec | 's] (unit: 'second)
| ['minutes | 'minute | 'min | 'mn] (unit: 'minute)
| ['hours | 'hour | 'hr | 'h] (unit: 'hour)
| ['days | 'day | 'd] (unit: 'day)
| ['weeks | 'week | 'wk | 'w] (unit: 'day mult: 7 * any [mult 1])
| ['months | 'month | 'mo] (unit: 'month) opt on-day=
;| 'last-day-of-month (unit: 'ldom) ; unsupported use every -1, -2...??
;| 'day-of-year (unit: 'doy) ; unsupported
]
on-day=: ['on set value issue! (unit: 'day store 'allow 'cal-days value)]
week-months=: [
week-days= (unit: 'day store type 'week-days n)
| months= (unit: any [unit 'month] store type 'months n)
opt on-day=
]
restriction=: [
opt 'from set s issue! ['- | 'to] set e issue! (expand type 'cal-days s e)
| opt 'from set s time! ['- | 'to] set e time! (store/only type 'time reduce [s e])
| set value time! (store type 'time value)
| set value issue! (unit: 'day store type 'cal-days value)
| week-months=
]
restrictions=: [restriction= | into [some restriction=]]
count=: [set count integer! ['times | 'time]]
at-time=: [
'on set at-time date! 'at set value time! (at-time/time: value)
| 'at set at-time [date! | time!]
]
every-rule=: [
; Changed integer! to number! for mult, to allow for partial intervals
; e.g., sub-second timers. Need to test for regression errors.
opt [set mult number!]
[
(type: 'allow) restrictions= opt on-day=
| [delays= | (type: 'allow) week-months=] opt [(type: 'allow) restrictions=]
]
1 4 [
opt ['not (type: 'forbid) restrictions=]
opt ['offset set offset [date! | time!]]
opt at-time=
opt count=
]
]
; 'With is a nicer word if user-data comes after the action.
user-data=: [['user-data | 'with] set user-data any-type!]
action=: [
'do set action [file! | url! | block! | word! | function! | paren!]
]
dialect=: [
any [
(reset-locals)
err: _start:
opt [set name set-word!]
[
at-time=
| 'in set mult integer! delays= (at-time: 'in)
| 'every every-rule=
]
; User-data can come before or after the action.
opt user-data=
action=
opt user-data=
_end:
(store-job)
]
]
;-- End Block Dialect
;-------------------------------------------------------------------------------
;-- String Dialect
; This is for internal use. It's not a public interface.
pre-process: func [src [string!] /local s e v fix out] [
fix: [e: (s: change/part s v e) :s]
parse/all src [
any [
s: "1st" (v: "#1") fix
| "2nd" (v: "#2") fix
| "3rd" (v: "#3") fix
| "21st" (v: "#21") fix
| "22nd" (v: "#22") fix
| "23rd" (v: "#23") fix
| "31st" (v: "#31") fix
| copy v 1 3 digits= [
"th" (v: join "#" v) fix
| "s" (v: join v " s") fix
| "mn" (v: join v " mn") fix
| "h" (v: join v " h") fix
| "w" (v: join v " w") fix
| "m" (v: join v " m") fix
]
| skip
]
]
if none? out: attempt [load/all src] [
make error! join "Scheduler input syntax error in: " src
]
out
]
;-- End String Dialect
;-------------------------------------------------------------------------------
;-- Public Interface
delete: func [name [word!] /local job] [
job: jobs
forskip job 2 [
if job/2/name = name [
remove/part job 2
return true
]
]
make error! reform ["job" mold name "not found!"]
]
;!! Be careful calling this if you have events with very low intervals.
; E.g., getting all events that happen every second for the next year
; has to find a lot of events.
events-up-to: func [
"Return a block of upcoming events"
end [date!] "Return events that occur up to this point in time"
/local job-blk task next-evt res
][
sort/skip job-blk: copy/deep job-list 2 ;!! copy/deep is important here!
if empty? job-blk [return copy []]
res: copy []
while [
all [
not empty? job-blk
next-evt: job-blk/1: job-blk/2/last: next-event? job-blk/2
next-evt <= end
next-evt >= get-now
]
][
task: job-blk/2
if next-evt [
repend res [next-evt new-line/all copy task off]
]
; Remove jobs that don't need to execute again.
if any [
; Have to confirm this. If task/at is a date, we want to bail,
; but if it's a time, we only want to bail if 'every hasn't been
; used in the spec. I think task/unit is the best way to check that.
date? task/at
all [task/at not task/unit]
all [task/count zero? task/count: task/count - 1]
none? next-evt
][
;print [next-evt end task/last next-evt <= end]
;print "*** Removing task"
remove/part job-blk 2
]
sort/skip job-blk 2
]
new-line/skip res on 2
]
; Encourage people to use this, rather than 'jobs, so they can't screw
; things up by modifying it. It will be a deep copy of 'jobs.
job-list: copy/deep jobs
;?? Would plan-events be a better name?
plan: func [
spec [block! string!]
/new "Clear the current plan before setting up the new one."
][
if new [reset]
if string? spec [spec: pre-process spec]
if not parse copy/deep spec dialect= [
print ["Error parsing schedule plan at rule:" mold copy/part err 10]
]
update-sys-timer
]
;TBD: Make sure this doesn't set any vars during the parse that would mess
; up a running plan, or one about to be scheduled.
plan-ok?: func [
"See if a plan can be parsed successfully"
spec [block! string!]
][
if string? spec [spec: pre-process spec]
parse copy/deep spec dialect=
; Use scheduler/err to see the where the parse failed.
]
;!! Use this in place of REBOL's standard WAIT func when using a scheduler.
wait: does [
; If (system) WAIT returns none, it means our next job timer went off.
while [none? system/words/wait []] [
on-timer
if empty? jobs [exit]
]
]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment