extra/imap/imap-tests.factor

   1 USING: accessors arrays assocs calendar calendar.format
   2 combinators continuations destructors formatting fry grouping.extras imap
   3 imap.private io.streams.duplex kernel math math.parser math.ranges
   4 math.statistics namespaces random sequences sets sorting uuid
   5 splitting strings system tools.test memoize combinators.smart ;
   6 FROM: pcre => findall ;
   7 IN: imap.tests
   8
   9 : random-ascii ( n -- str )
  10     [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
  11
  12 : make-mail ( from -- mail )
  13     now timestamp>rfc822 swap 10000 random
  14     3array {
  15         "Date: %s"
  16         "From: %s"
  17         "Subject: afternoon meeting"
  18         "To: mooch@owatagu.siam.edu"
  19         "Message-Id: <%08d@Blurdybloop.COM>"
  20         "MIME-Version: 1.0"
  21         "Content-Type: TEXT/PLAIN; CHARSET=US-ASCII"
  22         ""
  23         "Hello Joe, do you think we can meet at 3:30 tomorrow?"
  24     } "\r\n" join vsprintf ;
  25
  26 : sample-mail ( -- mail )
  27     "Fred Foobar <foobar@Blurdybloop.COM>" make-mail ;
  28
  29 ERROR: no-imap-test-host ;
  30
  31 : get-test-host ( -- host )
  32     \ imap-settings get-global host>> [ no-imap-test-host ] unless* ;
  33
  34 : imap-test ( result quot -- )
  35     '[ \ imap-settings get-global _ with-imap-settings ] unit-test ; inline
  36
  37 : base-folder ( -- s )
  38     os name>> cpu name>> "-" glue ;
  39
  40 MEMO: my-uuid ( -- str )
  41     uuid1 ;
  42
  43 : test-folder ( s -- s )
  44     '[
  45         base-folder "/" my-uuid "/" _
  46     ] "" append-outputs-as ;
  47
  48 { t } [
  49     get-test-host <imap4ssl> [ duplex-stream? ] with-disposal
  50 ] unit-test
  51
  52 { t } [
  53     get-test-host <imap4ssl> [ capabilities ] with-stream
  54     { "IMAP4rev1" "UNSELECT" "IDLE" "NAMESPACE" "QUOTA" } swap subset?
  55 ] unit-test
  56
  57 { "NO" } [
  58     [ get-test-host <imap4ssl> [ "dont@exist.com" "foo" login ] with-stream ]
  59     [ ind>> ] recover
  60 ] unit-test
  61
  62 { "BAD" } [
  63     [ get-test-host <imap4ssl> [ f f login ] with-stream ] [ ind>> ] recover
  64 ] unit-test
  65
  66 ! Try to reset test folder before starting tests
  67 [ ] [
  68     [ "foo/bar/baz/日本語" test-folder delete-folder ] ignore-errors
  69     [ "foo/bar/baz/boo" test-folder delete-folder ] ignore-errors
  70     [ "foo/bar/baz" test-folder delete-folder ] ignore-errors
  71     [ "foo/bar" test-folder delete-folder ] ignore-errors
  72     [ "foo" test-folder delete-folder ] ignore-errors
  73     [ "örjan" test-folder delete-folder ] ignore-errors
  74     [ base-folder delete-folder ] ignore-errors
  75 ] imap-test
  76
  77
  78 { } [ \ imap-settings get-global [ ] with-imap-settings ] unit-test
  79
  80 ! Newly created and then selected folder is empty.
  81 [ 0 { } ] [
  82     10 random-ascii
  83     [ create-folder ]
  84     [ select-folder ]
  85     [ delete-folder ] tri
  86     "ALL" "" search-mails
  87 ] imap-test
  88
  89 ! Create delete select again.
  90 [ 0 ] [
  91     "örjan" test-folder
  92     [ create-folder ] [ select-folder ] [ delete-folder ] tri
  93 ] imap-test
  94
  95 ! Test list folders
  96 [ t ] [
  97     10 random-ascii
  98     [ create-folder "*" list-folders length 0 > ] [ delete-folder ] bi
  99 ] imap-test
 100
 101 ! Generate some mails for searching
 102 [ t t f f ] [
 103     10 random-ascii {
 104         [ create-folder ]
 105         [
 106             '[ _ "(\\Seen)" now sample-mail append-mail drop ]
 107             10 swap times
 108         ]
 109         [
 110             select-folder drop
 111             "ALL" "" search-mails
 112             5 sample "(RFC822)" fetch-mails
 113             [ [ string? ] all? ] [ length 5 = ] bi
 114             "SUBJECT" "afternoon" search-mails empty?
 115             "(SINCE \"01-Jan-2014\")" "" search-mails empty?
 116         ]
 117         [ delete-folder ]
 118     } cleave
 119 ] imap-test
 120
 121 ! Stat folder
 122 [ t ] [
 123     10 random-ascii {
 124         [ create-folder ]
 125         [
 126             '[ _ "(\\Seen)" now sample-mail append-mail drop ]
 127             10 swap times
 128         ]
 129         [
 130             { "MESSAGES" "UNSEEN" } status-folder
 131             [ "MESSAGES" of 0 > ] [ "UNSEEN" of 0 >= ] bi and
 132         ]
 133         [ delete-folder ]
 134     } cleave
 135 ] imap-test
 136
 137 ! Rename folder
 138 [ ] [
 139     "日本語" test-folder [ create-folder ] [
 140         "ascii-name" test-folder
 141         [ rename-folder ] [ delete-folder ] bi
 142     ] bi
 143 ] imap-test
 144
 145 ! Create a folder hierarchy
 146 [ t ] [
 147     "foo/bar/baz/日本語" test-folder
 148     [ '[ _ delete-folder ] ignore-errors ]
 149     [
 150         "*" test-folder list-folders length
 151         swap create-folder
 152         "*" test-folder list-folders length 4 - =
 153     ]
 154     [ delete-folder ] tri
 155 ] imap-test
 156
 157 ! A gmail compliant way of creating a folder hierarchy.
 158 [ ] [
 159     "foo/bar/baz/boo" test-folder "/" split
 160     { } [ suffix ] cum-map [ "/" join ] map
 161     [ [ create-folder ] each ] [ [ delete-folder ] each ] bi
 162 ] imap-test
 163
 164 [ ] [
 165     "örjan" test-folder {
 166         [ create-folder ]
 167         [ select-folder drop ]
 168         ! Append mail with a seen flag
 169         [ "(\\Seen)" now sample-mail append-mail drop ]
 170         ! And one without
 171         [ "" now sample-mail append-mail drop ]
 172         [ delete-folder ]
 173     } cleave
 174 ] imap-test
 175
 176 ! Exercise store-mail
 177 [ 5 ] [
 178     "INBOX" select-folder drop "ALL" "" search-mails
 179     5 sample "+FLAGS" "(\\Recent)" store-mail length
 180 ] imap-test
 181
 182 ! Internal date parsing
 183 { "Mon, 19 Aug 2013 23:16:36 GMT" } [
 184     "19-Aug-2013 23:16:36 +0000" internal-date>timestamp timestamp>rfc822
 185 ] unit-test
 186
 187 { "19-Aug-2014 23:16:36 GMT" } [
 188     "Mon, 19 Aug 2014 23:16:36 GMT" rfc822>timestamp timestamp>internal-date
 189 ] unit-test
 190
 191 ! Test parsing an INTERNALDATE from a real mail.
 192 [ t ] [
 193     "INBOX" select-folder drop
 194     "ALL" "" search-mails
 195     "(INTERNALDATE)" fetch-mails first
 196     "\"([^\"]+)\"" findall first second last
 197     internal-date>timestamp timestamp?
 198 ] imap-test
 199
 200 ! Response parsing
 201 { { 8132 { "\\Seen" } } f } [
 202     "(FLAGS (\\Seen) UID 8132)" parse-store-mail-line
 203     ! Weird non-standard(?) response format gmail uses to indicate the
 204     ! previous mail flags. Just ignore it.
 205     "(UID 1234 FLAGS (\\Seen))" parse-store-mail-line
 206 ] unit-test
 207
 208 ! Just an interesting verb to gmail thread mails. Wonder if you can
 209 ! avoid the double fetch-mails?
 210 : threaded-mailbox ( uids -- threads )
 211     [
 212         "(X-GM-THRID)" fetch-mails [
 213             "\\d+" findall [ first last string>number
 214             ] map
 215         ] map
 216     ] [ "(BODY[HEADER.FIELDS (SUBJECT)])" fetch-mails ] bi zip
 217     [ first first ] [ sort-with ] [ group-by ] bi ;