extra/imap/imap-tests.factor

   1 USING: accessors arrays assocs calendar calendar.format calendar.parser
   2 combinators continuations destructors formatting fry grouping.extras imap
   3 imap.private io.streams.duplex kernel math math.parser math.ranges
   4 namespaces random sequences sets sorting uuid multiline
   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
  49 ![[
  50
  51 { t } [
  52     get-test-host <imap4ssl> [ duplex-stream? ] with-disposal
  53 ] unit-test
  54
  55 { t } [
  56     get-test-host <imap4ssl> [ capabilities ] with-stream
  57     { "IMAP4rev1" "UNSELECT" "IDLE" "NAMESPACE" "QUOTA" } swap subset?
  58 ] unit-test
  59
  60 { "NO" } [
  61     [ get-test-host <imap4ssl> [ "dont@exist.com" "foo" login ] with-stream ]
  62     [ ind>> ] recover
  63 ] unit-test
  64
  65 { "BAD" } [
  66     [ get-test-host <imap4ssl> [ f f login ] with-stream ] [ ind>> ] recover
  67 ] unit-test
  68
  69 ! Try to reset test folder before starting tests
  70 { } [
  71     [ "foo/bar/baz/日本語" test-folder delete-folder ] ignore-errors
  72     [ "foo/bar/baz/boo" test-folder delete-folder ] ignore-errors
  73     [ "foo/bar/baz" test-folder delete-folder ] ignore-errors
  74     [ "foo/bar" test-folder delete-folder ] ignore-errors
  75     [ "foo" test-folder delete-folder ] ignore-errors
  76     [ "örjan" test-folder delete-folder ] ignore-errors
  77     [ base-folder delete-folder ] ignore-errors
  78 ] imap-test
  79
  80
  81 { } [ \ imap-settings get-global [ ] with-imap-settings ] unit-test
  82
  83 ! Newly created and then selected folder is empty.
  84 { 0 { } } [
  85     10 random-ascii
  86     [ create-folder ]
  87     [ select-folder ]
  88     [ delete-folder ] tri
  89     "ALL" "" search-mails
  90 ] imap-test
  91
  92 ! Create delete select again.
  93 { 0 } [
  94     "örjan" test-folder
  95     [ create-folder ] [ select-folder ] [ delete-folder ] tri
  96 ] imap-test
  97
  98 ! Test list folders
  99 { t } [
 100     10 random-ascii
 101     [ create-folder "*" list-folders length 0 > ] [ delete-folder ] bi
 102 ] imap-test
 103
 104 ! Generate some mails for searching
 105 { t t f f } [
 106     10 random-ascii {
 107         [ create-folder ]
 108         [
 109             '[ _ "(\\Seen)" now sample-mail append-mail drop ]
 110             10 swap times
 111         ]
 112         [
 113             select-folder drop
 114             "ALL" "" search-mails
 115             5 sample "(RFC822)" fetch-mails
 116             [ [ string? ] all? ] [ length 5 = ] bi
 117             "SUBJECT" "afternoon" search-mails empty?
 118             "(SINCE \"01-Jan-2014\")" "" search-mails empty?
 119         ]
 120         [ delete-folder ]
 121     } cleave
 122 ] imap-test
 123
 124 ! Stat folder
 125 { t } [
 126     10 random-ascii {
 127         [ create-folder ]
 128         [
 129             '[ _ "(\\Seen)" now sample-mail append-mail drop ]
 130             10 swap times
 131         ]
 132         [
 133             { "MESSAGES" "UNSEEN" } status-folder
 134             [ "MESSAGES" of 0 > ] [ "UNSEEN" of 0 >= ] bi and
 135         ]
 136         [ delete-folder ]
 137     } cleave
 138 ] imap-test
 139
 140 ! Rename folder
 141 { } [
 142     "日本語" test-folder [ create-folder ] [
 143         "ascii-name" test-folder
 144         [ rename-folder ] [ delete-folder ] bi
 145     ] bi
 146 ] imap-test
 147
 148 ! Create a folder hierarchy
 149 { t } [
 150     "foo/bar/baz/日本語" test-folder
 151     [ '[ _ delete-folder ] ignore-errors ]
 152     [
 153         "*" test-folder list-folders length
 154         swap create-folder
 155         "*" test-folder list-folders length 4 - =
 156     ]
 157     [ delete-folder ] tri
 158 ] imap-test
 159
 160 ! A gmail compliant way of creating a folder hierarchy.
 161 { } [
 162     "foo/bar/baz/boo" test-folder "/" split
 163     { } [ suffix ] accumulate* [ "/" join ] map
 164     [ [ create-folder ] each ] [ [ delete-folder ] each ] bi
 165 ] imap-test
 166
 167 { } [
 168     "örjan" test-folder {
 169         [ create-folder ]
 170         [ select-folder drop ]
 171         ! Append mail with a seen flag
 172         [ "(\\Seen)" now sample-mail append-mail drop ]
 173         ! And one without
 174         [ "" now sample-mail append-mail drop ]
 175         [ delete-folder ]
 176     } cleave
 177 ] imap-test
 178
 179 ! Exercise store-mail
 180 { 5 } [
 181     "INBOX" select-folder drop "ALL" "" search-mails
 182     5 sample "+FLAGS" "(\\Recent)" store-mail length
 183 ] imap-test
 184
 185 ! Internal date parsing
 186 { "Mon, 19 Aug 2013 23:16:36 GMT" } [
 187     "19-Aug-2013 23:16:36 +0000" internal-date>timestamp timestamp>rfc822
 188 ] unit-test
 189
 190 { "19-Aug-2014 23:16:36 GMT" } [
 191     "Mon, 19 Aug 2014 23:16:36 GMT" rfc822>timestamp timestamp>internal-date
 192 ] unit-test
 193
 194 ! Test parsing an INTERNALDATE from a real mail.
 195 { t } [
 196     "INBOX" select-folder drop
 197     "ALL" "" search-mails
 198     "(INTERNALDATE)" fetch-mails first
 199     "\"([^\"]+)\"" findall first second last
 200     internal-date>timestamp timestamp?
 201 ] imap-test
 202
 203 ! Response parsing
 204 { { 8132 { "\\Seen" } } f } [
 205     "(FLAGS (\\Seen) UID 8132)" parse-store-mail-line
 206     ! Weird non-standard(?) response format gmail uses to indicate the
 207     ! previous mail flags. Just ignore it.
 208     "(UID 1234 FLAGS (\\Seen))" parse-store-mail-line
 209 ] unit-test
 210
 211 ! Just an interesting verb to gmail thread mails. Wonder if you can
 212 ! avoid the double fetch-mails?
 213 : threaded-mailbox ( uids -- threads )
 214     [
 215         "(X-GM-THRID)" fetch-mails [
 216             "\\d+" findall [ first last string>number
 217             ] map
 218         ] map
 219     ] [ "(BODY[HEADER.FIELDS (SUBJECT)])" fetch-mails ] bi zip
 220     [ first first ] [ sort-with ] [ group-by ] bi ;
 221
 222 ]]