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