rl3/scratch.scm

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