REBOL [
    Title: "Amazon S3 Protocol"
    Author: "Christopher Ross-Gill"
    Date: 30-Aug-2011
    File: %s3.r
    Version: 0.2.1
    License: 'BSD
    Purpose: {Basic retrieve and upload protocol for Amazon S3.}
    Example: [
        do/args http://reb4.me/r/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: true ; optional
    ]
]

do http://reb4.me/r/http-custom

context bind [
    port-flags: system/standard/port-flags/pass-thru

    init: use [chars url][
        chars: ; charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "-_!+%.,"]
        #[bitset! 64#{AAAAACJ4/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]

        url: [
            "s3://" [
                copy user some chars #":"
                copy pass some chars #"@"
                | (user: none pass: none)
            ]
            copy host some chars #"/"
            copy path any [some chars #"/"]
            copy target any chars
            end

            (
                path: all [path to-file path]
                target: all [target to-file target]
                user: any [user settings/awsaccesskeyid]
                pass: any [pass settings/awssecretaccesskey]
                url: rejoin [s3:// host "/" any [path ""] any [target ""]]
            )
        ]

        func [port spec][
            unless all [
                url? spec
                parse/all spec bind url port
            ][make error! "Invalid S3 Spec"]

            spec: rejoin [
                either settings/secure [https://][http://]
                port/host ".s3.amazonaws.com/"
                any [all [port/target port/path] ""] any [port/target ""]
            ]

            port/sub-port: make port! spec
        ]
    ]

    open: use [options][
        options: context [
            options: modes: type: md5: access: prefix: none
        ]

        func [port][
            port/state/flags: port/state/flags or port-flags

            port/locals: make options [
                modes: make block! 3

                if port/state/flags and 1 > 0 [append modes 'read]
                if port/state/flags and 2 > 0 [append modes 'write]
                if port/state/flags and 32 > 0 [append modes 'binary]

                options: any [port/state/custom make block! []]

                if all [port/path not port/target][
                    repend options ['prefix port/path]
                ]

                parse options [
                    any [
                          'md5 set md5 string!
                        | 'type set type path! (type: form type)
                        | 'read (access: "public-read")
                        | 'write (access: "public-read-write")
                        | 'prefix set prefix [string! | file!] (
                            unless port/target [
                                port/sub-port/path: join "?prefix=" prefix
                            ]
                        )
                        | skip
                    ]
                ]
            ]
        ]
    ]

    copy: func [port][send "GET" port none]

    insert: func [port data][
        unless port/target [make error! "Not a valid S3 key"]

        case [
            none? data [send "DELETE" port data]
            any [string? data binary? data][send "PUT" port data]
            data [send "PUT" port form data]
        ]
    ]

    close: does []

    query: func [port][
        port/locals: [modes [read]]

        send "HEAD" port none

        port/size: attempt [to-integer port/sub-port/locals/headers/content-length]
        port/date: port/sub-port/date
        port/status: either port/target ['file]['directory]
    ]

    unless in system/schemes 's3 [system/schemes: make system/schemes [s3: none]]

    system/schemes/s3: make system/standard/port compose [
        scheme: 's3
        port-id: 0
        handler: (self)
        passive: none
        cache-size: 5
        proxy: context [host: port-id: user: pass: type: bypass: none]
    ]

] context [
    settings: make context [
        awsaccesskeyid: awssecretaccesskey: ""
        secure: true
    ] any [
        system/script/args
        system/script/header/settings
    ]

    get-http-response: func [port][
        reform next parse do bind [response-line] last second get in port/handler 'open none
    ]

    send: use [timestamp detect-mime sign compose-request][
        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! none!]][
                if file [
                    file: any [find types suffix? file next types]
                    form first find/reverse file path!
                ]
            ]
        ]

        sign: func [verb [string!] port [port!] request [object!]][
            rejoin [
                "AWS " port/user ":" enbase/base checksum/secure/key rejoin [
                    form verb newline
                    newline ; any [port/locals/md5 ""] newline
                    any [request/type ""] newline
                    timestamp newline
                    either request/auth [join "x-amz-acl:" [request/auth "^/"]][""]
                    "/" port/host "/" any [all [port/target port/path] ""] any [port/target ""]
                ] port/pass 64
            ]
        ]

        compose-request: func [verb [string!] port [port!] data [series! none!]][
            data: context [
                body: any [data ""]
                size: all [data length? data]
                type: all [data any [port/locals/type detect-mime port/target]]
                auth: all [data port/locals/access]
            ]

            reduce [
                to-word verb data/body
                foreach [header value][
                    "Date" [timestamp]
                    "Content-Type" [data/type]
                    "Content-Length" [data/size]
                    "Authorization" [sign verb port data]
                    "x-amz-acl" [data/auth]
                    "Pragma" ["no-cache"]
                    "Cache-Control" ["no-cache"]
                ][
                    if value: all :value [
                        repend [] [to-set-word header form value]
                    ]
                ]
            ]
        ]

        send: func [[catch] method [string!] port [port!] data [any-type!]][
            either error? data: try [
                open/mode/custom port/sub-port port/locals/modes compose-request method port data
            ][
                net-error rejoin ["Target url " port/url " could not be retrieved (" get-http-response port/sub-port ")."]
            ][
                data: copy port/sub-port
                either port/target [
                    data
                ][
                    unless method = "HEAD" [
                        data: load/markup data
                        parse data [
                            copy data any [
                                data: <key> (remove data change data to-file data/1) | skip (remove data) :data
                            ]
                        ]
                        data
                    ]
                ]
            ]
        ]
    ]
]