rl3/scratch.scm

   1
   2 (import (rnrs base)
   3         (rnrs io simple)
   4         (rl3 aws s3 s3)
   5         (rl3 aws awscredentials)
   6         (rl3 concurrency tasks-with-io))
   7
   8 (define creds (load-credentials "/home/ray/awsaccount.txt"))
   9
  10 (with-tasking-io
  11  (lambda ()
  12    (display (list-buckets creds))))
  13
  14
  15 ;;; S3
  16
  17 (import (rnrs base)
  18         (rnrs bytevectors)
  19         (rl3 env debug)
  20         (rl3 types dates)
  21         (rl3 web uri)
  22         (rl3 web http)
  23         (rl3 aws awscredentials)
  24         (rl3 aws configuration)
  25         (rl3 crypto hash sha1)
  26         (only (rl3 aws s3 s3headers)
  27               date-header host-header)
  28         (rl3 aws awsauth))
  29
  30 ;;;
  31
  32 (import (rnrs base)
  33         ;;(rnrs r5rs)
  34         ;;(rnrs lists)
  35         (rnrs bytevectors)
  36         (rnrs io simple)
  37         (rnrs io ports)
  38         (rnrs unicode)
  39         (rnrs mutable-pairs)
  40         ;;(rnrs mutable-strings)
  41         (rl3 concurrency tasks-with-io)
  42         (rl3 env debug)
  43         (rl3 io net sockets)
  44         (rl3 io print)
  45         (rl3 web http)
  46         (rl3 web pipes htmlprag)
  47         (primitives time))
  48
  49 (define creds  (load-credentials "/home/ray/awsaccount.txt"))
  50
  51 (define base-uri (make-uri "http" #f (s3-configuration 'host) #f "" "" ""))
  52
  53 (define build-rest-uri
  54   (lambda (path)
  55     (make-uri "http" #f (s3-configuration 'host) #f path "" "")))
  56
  57 (define bucket-root-uri (build-rest-uri ""))
  58
  59 (define tstamp (current-time-rfc2822))
  60
  61 (define dheader (date-header tstamp))
  62
  63 (define auth-header
  64   (lambda (creds auth-str)
  65     (string-append "Authorization: AWS " (aws-credentials-access-key credentials)
  66                    ":" (aws-s3-auth-mac (aws-credentials-secret-key credentials) auth-str))))
  67
  68 (define auth-str (aws-s3-auth-str "GET" "" "" tstamp '() "/"))
  69
  70 (define authorization-header
  71   (lambda (credentials auth-str)
  72     (string-append "Authorization: AWS " (aws-credentials-access-key credentials)
  73                    ":" (aws-s3-auth-mac (aws-credentials-secret-key credentials) auth-str))))
  74
  75 (define list-headers (list (host-header (s3-configuration 'host))
  76                            dheader (authorization-header creds auth-str)))
  77
  78 (with-tasking-io
  79  (lambda ()
  80    (let-values (((hdrs hip) (http-invoke 'GET
  81                                          (uri->string bucket-root-uri)
  82                                          list-headers)))
  83      (display hdrs)
  84      (newline)
  85      (let ((tip (http-ascii-port-from-binary-port hip)))
  86        (display (html->sxml tip))
  87        (close-port tip)))))
  88
  89 ;;;
  90 ;;;
  91 ;;;
  92
  93 (import (rnrs base)
  94         ;;(rnrs r5rs)
  95         ;;(rnrs lists)
  96         (rnrs bytevectors)
  97         (rnrs io simple)
  98         (rnrs io ports)
  99         (rnrs unicode)
 100         (rnrs mutable-pairs)
 101         ;;(rnrs mutable-strings)
 102         (rl3 concurrency tasks-with-io)
 103         (rl3 env debug)
 104         (rl3 io net sockets)
 105         (rl3 io print)
 106         (rl3 web http)
 107         (rl3 web pipes htmlprag)
 108         (primitives time))
 109
 110 (let ()
 111   (debug-enable #t)
 112   (with-tasking-io
 113    (lambda ()
 114      (let ((surl "GET /home/will/Larceny/ HTTP/1.1\r\nHost: www.ccs.neu.edu\r\nUser-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.8.1.5) Gecko/20070718 Fedora/2.0.0.5-1.fc7 Firefox/2.0.0.5\r\nAccept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r\nAccept-Language: en-us,en;q=0.5\r\Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n\r\n")
 115            (s (client-socket "www.ccs.neu.edu" 80)))
 116        (let ((op (socket-output-port s))
 117              (ip (socket-input-port s)))
 118          (put-bytevector op (string->utf8 surl))
 119          (flush-output-port op)
 120          (let ((req (http-request ip)))
 121            (let ((hip (http-req-input-port req)))
 122              (let ((tip (http-ascii-port-from-binary-port hip)))
 123                (format #t "Header: ~a Len: ~a~%" (http-req-start-line req) (http-req-size req))
 124                (display (html->sxml tip))))))))))
 125
 126 ;;                (let loop ((ch (get-char tip)) (cnt 0))
 127 ;;                  (if (eof-object? ch)
 128 ;;                      (begin
 129 ;;                        (display "Total Response Bytes: ")
 130 ;;                        (display cnt)
 131 ;;                        (newline)
 132 ;;                        (socket-close s))
 133 ;;                      (begin
 134 ;;                        (display ch)
 135 ;;                        (loop (get-char tip) (+ cnt 1))))))))))))
 136
 137   ;; (require 'tasking-with-io)
 138
 139 ;; (define (do-n thunk n)
 140 ;;   (let loop ((n n))
 141 ;;     (if (> n 0)
 142 ;;         (begin
 143 ;;           (thunk)
 144 ;;           (loop (sub1 n))))))
 145
 146 ;; (define (hi)
 147 ;;   (display 'hi)
 148 ;;   (newline))
 149
 150 ;; (define (hello)
 151 ;;   (display 'hello)
 152 ;;   (newline))
 153
 154 ;; (define (done)
 155 ;;   (display 'done)
 156 ;;   (newline))
 157
 158 ;; (define (main)
 159 ;;   (with-tasking (lambda ()
 160 ;;                   (let ((t1 (spawn (lambda () (do-n hi 100))))
 161 ;;                         (t2 (spawn (lambda () (do-n hello 100)))))
 162 ;;                     (let loop ((ts (all-tasks)))
 163 ;;                       (if (> (length ts) 1)
 164 ;;                           (begin
 165 ;;                             (yield)
 166 ;;                             (loop (all-tasks)))
 167 ;;                           (end-tasking
 168 ;;                            (begin
 169 ;;                              (done)
 170 ;;                              'goodbye))))))))
 171
 172 ;; (main)
 173
 174 ;; (do-n hi 10)
 175
 176 ;; (display "Go\n")
 177
 178 ;; (require 'srfi-0)
 179 ;; (require 'Experimental/webserver/web-server.sch)
 180
 181 (library
 182  (scratch)
 183
 184  (export EPOLLIN);; EPOLLIN EPOLLOUT)
 185
 186  (import
 187   (rnrs base)
 188   (rnrs io simple)
 189   (ffi foreign-ctools))
 190
 191  (c-info (include<> "sys/epoll.h")
 192    ;; EPoll Events
 193    (const EPOLLIN int "EPOLLIN")
 194    (const EPOLLPRI int "EPOLLPRI")
 195    (const EPOLLOUT int "EPOLLOUT")
 196    (const EPOLLRDNORM int "EPOLLRDNORM")
 197    (const EPOLLRDBAND int "EPOLLRDBAND")
 198    (const EPOLLWRNORM int "EPOLLWRNORM")
 199    (const EPOLLWRBAND int "EPOLLWRBAND")
 200    (const EPOLLMSG int "EPOLLMSG")
 201    (const EPOLLERR int "EPOLLERR")
 202    (const EPOLLONESHOT int "EPOLLONESHOT")   ;; no more fixnum?
 203    (const EPOLLET uint "EPOLLET")
 204
 205    ;; EPoll Ops
 206    (const EPOLL-CTL-ADD int "EPOLL_CTL_ADD")
 207    (const EPOLL-CTL-DEL int "EPOLL_CTL_DEL")
 208    (const EPOLL-CTL-MOD int "EPOLL_CTL_MOD")
 209
 210    ;; EPoll Structures
 211    (sizeof EPOLL-SIZEOF-STRUCT-EPOLL-EVENT "struct epoll_event")
 212    (sizeof EPOLL-SIZEOF-EPOLL-DATA "union epoll_data")
 213
 214    (struct "epoll_event"
 215            (EPOLL-EVENT-EVENTS "events")
 216            (EPOLL-EVENT-DATA   "data")))
 217
 218
 219  )
 220
 221   (define run
 222     (lambda (t1 t2)
 223       (lambda ()
 224         (let ((t1 (make-thread t1 "t1"))
 225               (t2 (make-thread t2 "t2")))
 226           (thread-start! t1)
 227           (thread-start! t2)
 228           (thread-join! t1)
 229           (thread-join! t2)
 230           (let loop ((n 10))
 231             (if (zero? n)
 232                 'done))))))
 233
 234  (define athread
 235      (lambda ()
 236        (let loop ((n 100))
 237          (if (<= n 0)
 238              (begin
 239                (newline)
 240                (display "********DONE**********")
 241                (newline)
 242                (flush-output-port)
 243                'done)
 244              (begin
 245                (display n)
 246                (display ", ")
 247                (flush-output-port)
 248                ;;(thread-yield)
 249                (loop
 250                 (- n 1)))))))
 251
 252   ;; (define t1 t2)
 253
 254 (import (rnrs))
 255 (import (rnrs io simple))
 256 (import (rnrs io ports))
 257 (import (rl3 io net sockets))
 258 (import (rl3 io net ipaddress))
 259 (import (rl3 concurrency tasks))
 260 (import (rl3 concurrency tasks-with-io))
 261
 262 (define gurl "GET / HTTP/1.1\r\nHost: www.google.com\r\nUser-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.8.1.5) Gecko/20070718 Fedora/2.0.0.5-1.fc7 Firefox/2.0.0.5\r\nAccept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r\nAccept-Language: en-us,en;q=0.5\r\Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\nKeep-Alive: 300\r\nConnection: keep-alive\r\n\r\n")
 263
 264 (with-tasking-io
 265  (lambda ()
 266    (let ((t (make-task
 267              (lambda ()
 268                (let ()
 269                  (define s (client-socket "www.google.com" 80))
 270
 271                  (define op (socket-output-port s))
 272                  (define ip (socket-input-port s))
 273
 274                  (put-bytevector op (string->utf8 gurl))
 275                  (flush-output-port op)
 276
 277                  (let loop ((b (get-bytevector-n ip 1)))
 278                    (if (or (eof-object? b)
 279                            (zero? (bytevector-length b)))
 280                        (socket-close s)
 281                        (begin
 282                          (display (utf8->string b))
 283                          (newline)
 284                          (flush-output-port (current-output-port))
 285                          (loop (get-bytevector-n ip 1)))))))
 286              "worker")))
 287      (thread-start! t)
 288      (thread-join! t))))
 289
 290
 291
 292 (let ()
 293   (define s (client-socket "www.google.com" 80))
 294
 295   (define op (socket-output-port s #t))
 296   (define ip (socket-input-port s #t))
 297
 298   (put-bytevector op (string->utf8 gurl))
 299   (flush-output-port op)
 300
 301   (let loop ((b (get-bytevector-n ip 1)))
 302     (if (or (eof-object? b)
 303             (zero? (bytevector-length b)))
 304         (socket-close s)
 305         (begin
 306           (display (utf8->string b))
 307           (newline)
 308           (flush-output-port (current-output-port))
 309           (loop (get-bytevector-n ip 1))))))
 310
 311
 312 (socket-error s)
 313 (socket-close s)
 314 (socket-descriptor s)
 315 (define s #f)
 316
 317 (library
 318  (test)
 319
 320  (export doit)
 321
 322  (import
 323   (rnrs)
 324   (rnrs lists)
 325   (rnrs io simple)
 326   (sys system unix)
 327   (sys system process))
 328
 329 (define reduce-r (lambda (pred l)
 330                    (let ((l1 (cdr l)))
 331                      (if (null? l1)
 332                          (car l)
 333                          (pred (car l) (reduce-r pred l1))))))
 334
 335 (define (call-with-input-pipe command pred)
 336   (let* ((results (process (if (string? command)
 337                                command
 338                                (reduce-r (lambda (arg result)
 339                                            (string-append arg " " result))
 340                                          command))))
 341          (result (pred (car results))))
 342     (close-input-port (car results))
 343     (close-output-port (cadr results))
 344     (unix-waitpid (caddr results)) ; important in order to remove process
 345     result))
 346
 347 (define doit
 348   (lambda ()
 349     (call-with-input-pipe '("date" "-I")
 350                           (lambda (ip)
 351                             (utf8->string (get-bytevector-n ip 512))))))
 352 )
 353
 354 ;; START HERE - OK must track length of HTTP header. Content-Length + Header = Total to read.
 355
 356 (let ((buffsz 32))
 357   (get-bytevector-n! (open-bytevector-input-port (make-bytevector 0))
 358                      (make-bytevector 32 0)
 359                      0 16))
 360
 361 (get-bytevector-n (open-bytevector-input-port (make-bytevector 0)) 16)
 362
 363
 364
 365
 366
 367
 368            (haip (http-ascii-port-from-binary-port hip))
 369            (html (html->sxml haip)))
 370       (display html)
 371       'done)))
 372
 373
 374 ;;       (if (chunked-encoding? header)
 375 ;;           (let loop ((chunk (get-chunk ip)))
 376 ;;             (if (eof-object? chunk)
 377 ;;                 (socket-close s)
 378 ;;                 (begin
 379 ;;                   (display "CHUNK -------------")
 380 ;;                   (newline)
 381 ;;                   ;;(display chunk)
 382 ;;                   ;;(newline)
 383 ;;                   (loop (get-chunk ip)))))))))
 384
 385
 386 ;;      (newline)
 387 ;;      (time (display (html->sxml ip)))
 388 ;;      (socket-close s))))
 389
 390 (import (rnrs))
 391
 392 (let ((bip (open-bytevector-input-port (string->utf8 "This is how the world ends, not with a bang, but with a whimper."))))
 393   (display (get-u8 bip))
 394   (let ((tip (html-port bip)))
 395     (display (read-char tip))
 396     (close-input-port tip)))
 397
 398 (define x 0)
 399 (define l '#(1 2 3 4 5 6 7 8))
 400
 401 (define get
 402   (let ((idx 0))
 403     (lambda ()
 404       (let ((n (vector-ref l idx)))
 405         (set! idx (+ idx 1))
 406         n))))
 407
 408 (do ((i 4 (- i 1))
 409      (x (get) (get)))
 410     ((<= i 0))
 411   (display x))