Rebol [
    Title: "Amazon S3 Protocol"
    Author: "Christopher Ross-Gill"
    Date: 20-Mar-2013
    File: %s3.r
    Version: 0.1.0
    License: 'BSD
    Purpose: {Basic retrieve and upload protocol for Amazon S3.}
    Example: [
        do/args http://reb4.me/r3/s3 [args (see settings)]
        write s3://<bucket>/file/foo.txt "Foo"
        read s3://<bucket>/file/foo.txt
    ]
    History: [
        23-Nov-2008 ["Graham Chiu" "Maarten Koopmans" "Gregg Irwin"]
    ]
    Settings: [
        AWSAccessKeyId: <AWSAccessKeyId>
        AWSSecretAccessKey: <AWSSecretAccessKey>
        Secure: false ; optional
    ]
]

sys/make-scheme bind [
    title: "Amazon S3 Protocol"
    name: 's3

    actor: [
        open: funct [port [port!]] [
            port/spec/path: any [port/spec/path "/"]

            subport: make port! rejoin [
                either settings/secure [https://][http://]
                any [select port/spec 'user settings/awsaccesskeyid] ":"
                any [select port/spec 'pass settings/awssecretaccesskey] "@"
                port/spec/host ".s3.amazonaws.com" port/spec/path
            ]

            subport/locals: context [
                parent: port
                response: none
            ]

            port/locals: context compose [
                subport: (subport)
                response: none
            ]

            port
        ]

        open?: func [port [port!]][
            all [
                port/locals
                open? port/locals/subport
            ]
        ]

        read: func [port [port!]][
            open port
            send "GET" port/locals/subport none
        ]

        write: func [port [port!] content [none! string! binary! block!]][
            case/all [
                none? content [content: #{}]
                not block? content [content: join [body:] content]
                block? content [content: make request content]
            ]

            open port
            send "PUT" port/locals/subport content
        ]

        delete: func [port [port!]][
            open port
            send "DELETE" port/locals/subport none
        ]

        query: func [port /local headers][
            open port

            if headers: send "HEAD" port/locals/subport none [
                context [
                    name: port/spec/ref
                    size: any [headers/content-length 0]
                    date: headers/last-modified
                    type: either dir? port/spec/ref ['dir]['file]
                    content-type: headers/content-type
                ]
            ]
        ]

        close: func [port][
            close port/locals/subport
        ]
    ]
] context [
    settings: make context [
        awsaccesskeyid: awssecretaccesskey: ""
        secure: false
    ] any [
        system/script/args
        bind system/script/header/settings system/contexts/user
    ]

    request: context [body: size: type: md5: access: none]

    send: use [timestamp detect-mime sign compose-request response][
        timestamp: func [/for date [date!]][
            date: any [date now]
            date/time: date/time - date/zone

            rejoin [
                copy/part pick system/locale/days date/weekday 3 
                ", " next form 100 + date/day " " 
                copy/part pick system/locale/months date/month 3 
                " " date/year " "
                next form 100 + date/time/hour ":"
                next form 100 + date/time/minute ":"
                next form 100 + to-integer date/time/second " GMT" 
            ]
        ]

        detect-mime: use [types][
            types: [
                application/octet-stream
                text/html %.html %.htm
                image/jpeg %.jpg %.jpeg
                image/png %.png
                image/tiff %.tif %.tiff
                application/pdf %.pdf
                text/plain %.txt %.r
                application/xml %.xml
                video/mpeg %.mpg %.mpeg
                video/x-m4v %.m4v
            ]

            func [file [file! url! string! none!]][
                if file [
                    file: any [find types suffix? file next types]
                    first find/reverse file path!
                ]
            ]
        ]

        sign: func [verb [string!] spec [object!] request [object!]][
            rejoin [
                "AWS " spec/user ":" enbase/base checksum/secure/key rejoin [
                    #{} verb newline
                    newline ; any [port/locals/md5 ""] newline
                    any [request/type ""] newline
                    timestamp newline
                    either request/access [join "x-amz-acl:" [request/access "^/"]][""]
                    "/" copy/part spec/host find/last spec/host ".s3.amazonaws.com" spec/path
                ] spec/pass 64
            ]
        ]

        compose-request: func [
            method [string!] port [port!] content [object! none!]
            /local prefix
        ][
            content: any [content make request []]

            content/size: all [content/body length? content/body]
            content/type: all [content/body form any [content/type detect-mime port/spec/path]]
            content/access: all [
                content/body switch/default content/access [
                    read ["public-read"] write ["public-read-write"]
                ][content/access]
            ]

            port/spec/method: method
            port/spec/content: content/body

            if parse port/spec/path [skip thru #"/"][
                prefix: remove port/spec/path
                port/spec/path: copy "/"
            ]

            port/spec/headers: collect [
                foreach [header value][
                    Date: [timestamp]
                    Content-Type: [content/type]
                    Content-Length: [content/size]
                    Authorization: [sign method port/spec content]
                    x-amz-acl: [content/access]
                    Pragma: ["no-cache"]
                    Cache-Control: ["no-cache"]
                ][
                    if value: all :value [
                        keep header
                        keep form value
                    ]
                ]
            ]

            if prefix [append port/spec/path join "?prefix=" prefix]
        ]

        send: func [[catch] method [string!] port [port!] content [any-type!]][
            compose-request method port content

            port/awake: func [event][
                switch event/type [
                    connect [read event/port false]
                    done [true]
                ]
            ]

            open port
            response: query port

            ; unless port?
            wait [port 1]
            ; [make error! "No Response from Port"]

            port/locals/parent/data: switch/default response/response-parsed [
                ok [
                    switch method [
                        "GET" [
                            either dir? response/name [
                                collect [
                                    parse decode 'markup port/data use [name][
                                        [any [thru <key> copy name string! (keep to file! name)]]
                                    ]
                                ]
                            ][port/data]
                        ]
                        "PUT" [content/body]
                        "HEAD" [response/headers]
                    ]
                ]
                no-content [port/locals/parent] ; DELETE
            ][
                make error! rejoin collect [
                    parse decode 'markup port/data use [message][
                        [
                            thru <Error> thru <Message> set message string!
                            (keep [message " (" skip response/response-line 9 ")"])
                        ]
                    ]
                ]
            ]
        ]
    ]
]