extra/crontab/crontab.factor

   1 ! Copyright (C) 2018 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays ascii assocs assocs.extras calendar
   5 calendar.english calendar.format calendar.parser
   6 calendar.private circular combinators combinators.short-circuit
   7 io kernel literals math math.order math.parser prettyprint
   8 random ranges sequences sets sorting splitting ;
   9
  10 IN: crontab
  11
  12 ERROR: invalid-cronentry value ;
  13
  14 TUPLE: cronentry minutes hours days months days-of-week command ;
  15
  16 <PRIVATE
  17
  18 :: parse-range ( from/f to/f quot: ( input -- value ) seq -- from to )
  19     from/f [ seq first ] quot if-empty
  20     to/f [ seq last ] quot if-empty ; inline
  21
  22 :: parse-value ( input quot: ( input -- value ) seq -- value )
  23     input {
  24         { [ dup "*" = ] [ drop seq ] }
  25         { [ CHAR: , over member? ] [
  26             "," split [ quot seq parse-value ] map concat ] }
  27         { [ CHAR: / over member? ] [
  28             "/" split1 [
  29                 quot seq parse-value dup length 1 =
  30                 [ seq swap first seq index seq length ]
  31                 [ 0 over length ] if 1 -
  32             ] dip string>number <range> swap nths ] }
  33         { [ CHAR: - over member? ] [
  34             "-" split1 quot seq parse-range [a..b] ] }
  35         { [ CHAR: ~ over member? ] [
  36             "~" split1 quot seq parse-range [a..b] random 1array ] }
  37         [ quot call 1array ]
  38     } cond members sort ; inline recursive
  39
  40 : parse-day ( str -- n )
  41     [ string>number dup 7 = [ drop 0 ] when ] [
  42         >lower $[ day-abbreviations3 [ >lower ] map ] index
  43     ] ?unless ;
  44
  45 : parse-month ( str -- n )
  46     [ string>number ] [
  47         >lower $[ month-abbreviations [ >lower ] map ] index
  48     ] ?unless ;
  49
  50 CONSTANT: aliases H{
  51     { "@yearly"   "0 0 1 1 *" }
  52     { "@annually" "0 0 1 1 *" }
  53     { "@monthly"  "0 0 1 * *" }
  54     { "@weekly"   "0 0 * * 0" }
  55     { "@daily"    "0 0 * * *" }
  56     { "@midnight" "0 0 * * *" }
  57     { "@hourly"   "0 * * * *" }
  58 }
  59
  60 : check-cronentry ( cronentry -- cronentry )
  61     dup {
  62         [ days-of-week>> [ 0 6 between? ] all? ]
  63         [ months>> [ 1 12 between? ] all? ]
  64         [
  65             [ days>> 1 ] [ months>> ] bi [
  66                 { 0 31 29 31 30 31 30 31 31 30 31 30 31 } nth
  67             ] map maximum [ between? ] 2curry all?
  68         ]
  69         [ minutes>> [ 0 59 between? ] all? ]
  70         [ hours>> [ 0 23 between? ] all? ]
  71     } 1&& [ invalid-cronentry ] unless ;
  72
  73 PRIVATE>
  74
  75 : parse-cronentry ( entry -- cronentry )
  76     " " split1 [ aliases ?at drop ] dip " " glue
  77     " " split1 " " split1 " " split1 " " split1 " " split1 {
  78         [ [ string>number ] T{ range f 0 60 1 } parse-value ]
  79         [ [ string>number ] T{ range f 0 24 1 } parse-value ]
  80         [ [ string>number ] T{ range f 1 31 1 } parse-value ]
  81         [ [ parse-month ] T{ range f 1 12 1 } parse-value ]
  82         [ [ parse-day ] T{ circular f T{ range f 0 7 1 } 1 } parse-value ]
  83         [ ]
  84     } spread cronentry boa check-cronentry ;
  85
  86 <PRIVATE
  87
  88 : ?parse-cronentry ( entry -- cronentry )
  89     dup cronentry? [ parse-cronentry ] unless ;
  90
  91 :: (next-time-after) ( cronentry timestamp -- )
  92
  93     f ! should we keep searching for a matching time
  94
  95     timestamp month>> :> month
  96     cronentry months>> [ month >= ] find nip
  97     dup month = [ drop ] [
  98         [ cronentry months>> first timestamp 1 +year drop ] unless*
  99         timestamp 1 >>day 0 >>hour 0 >>minute month<< drop t
 100     ] if
 101
 102     timestamp day-of-week :> weekday
 103     cronentry days-of-week>> [ weekday >= ] find nip [
 104         cronentry days-of-week>> first 7 +
 105     ] unless* weekday - :> days-to-weekday
 106
 107     timestamp day>> :> day
 108     cronentry days>> [ day >= ] find nip [
 109         cronentry days>> first timestamp days-in-month +
 110     ] unless* day - :> days-to-day
 111
 112     cronentry days-of-week>> length 7 =
 113     cronentry days>> length 31 = 2array
 114     {
 115         { { f t } [ days-to-weekday ] }
 116         { { t f } [ days-to-day ] }
 117         [ drop days-to-weekday days-to-day min ]
 118     } case [
 119         timestamp 0 >>hour 0 >>minute swap +day 2drop t
 120     ] unless-zero
 121
 122     timestamp hour>> :> hour
 123     cronentry hours>> [ hour >= ] find nip
 124     dup hour = [ drop ] [
 125         [ cronentry hours>> first timestamp 1 +day drop ] unless*
 126         timestamp 0 >>minute hour<< drop t
 127     ] if
 128
 129     timestamp minute>> :> minute
 130     cronentry minutes>> [ minute >= ] find nip
 131     dup minute = [ drop ] [
 132         [ cronentry minutes>> first timestamp 1 +hour drop ] unless*
 133         timestamp minute<< drop t
 134     ] if
 135
 136     [ cronentry timestamp (next-time-after) ] when ;
 137
 138 PRIVATE>
 139
 140 : next-time-after ( cronentry timestamp -- timestamp )
 141     [ ?parse-cronentry ] dip 1 minutes time+ 0 >>second
 142     [ (next-time-after) ] keep ;
 143
 144 : next-time ( cronentry -- timestamp )
 145     now next-time-after ;
 146
 147 : next-times-after ( cronentry n timestamp -- timestamps )
 148     swap [ dupd next-time-after dup ] replicate 2nip ;
 149
 150 : next-times-from-until ( cronentry from-timestamp until-timestamp -- timestamps )
 151     [ dup second>> 0 = [ 1 minutes time- ] when ] dip
 152     '[ dupd next-time-after dup dup _ before? ] [ ] produce 3nip ;
 153
 154 : next-times-until ( cronentry timestamp -- timestamps )
 155     [ now start-of-minute ] dip next-times-from-until ;
 156
 157 : next-times ( cronentry n -- timestamps )
 158     now next-times-after ;
 159
 160 : read-crontab ( -- entries )
 161     read-lines harvest [ parse-cronentry ] map ;
 162
 163 : group-crons ( cronstrings from-timestamp until-timestamp -- entries )
 164     '[ _ _ next-times-from-until [ timestamp>unix-time ] map ] zip-with
 165     [ first2 [ 2array ] with map ] map concat
 166     [ nip ] collect-key-by sort-keys ;
 167
 168 : group-crons-for-duration-from ( cronstrings duration from-timestamp -- entries )
 169     tuck time+ group-crons ;
 170
 171 : group-crons-for-duration ( cronstrings duration -- entries )
 172     now group-crons-for-duration-from ;
 173
 174 : crons-for-minute ( cronstrings timestamp -- entries )
 175     start-of-minute dup end-of-minute group-crons ;
 176
 177 : crons-for-hour ( cronstrings timestamp -- entries )
 178     start-of-hour dup end-of-hour group-crons ;
 179
 180 : crons-for-day ( cronstrings timestamp -- entries )
 181     start-of-day dup end-of-day group-crons ;
 182
 183 : crons-for-week ( cronstrings timestamp -- entries )
 184     start-of-week dup end-of-week group-crons ;
 185
 186 : crons-for-month ( cronstrings timestamp -- entries )
 187     start-of-month dup end-of-month group-crons ;
 188
 189 : crons-for-year ( cronstrings timestamp -- entries )
 190     start-of-year dup end-of-year group-crons ;
 191
 192 : crons-for-decade ( cronstrings timestamp -- entries )
 193     start-of-decade dup end-of-decade group-crons ;
 194
 195 : crons-this-minute ( cronstrings -- entries ) now crons-for-minute ;
 196 : crons-this-hour ( cronstrings -- entries ) now crons-for-hour ;
 197 : crons-this-day ( cronstrings -- entries ) now crons-for-day ;
 198 ALIAS: crons-today crons-this-day
 199 : crons-yesterday ( cronstrings -- entries ) 1 days ago crons-for-day ;
 200 : crons-tomorrow ( cronstrings -- entries ) 1 days hence crons-for-day ;
 201 : crons-this-week ( cronstrings -- entries ) now crons-for-week ;
 202 : crons-this-month ( cronstrings -- entries ) now crons-for-month ;
 203 : crons-this-year ( cronstrings -- entries ) now crons-for-year ;
 204 : crons-this-decade ( cronstrings -- entries ) now crons-for-decade ;
 205
 206 : keys-unix-to-rfc822 ( assoc -- assoc' )
 207     [ unix-time>timestamp timestamp>rfc822 ] map-keys ;
 208
 209 : keys-rfc822-to-unix ( assoc -- assoc' )
 210     [ rfc822>timestamp timestamp>unix-time ] map-keys ;
 211
 212 : grouped-crons. ( assoc -- )
 213     keys-unix-to-rfc822 [ first2 [ write bl ] [ ... ] bi* ] each ;