├── .gitignore ├── get-rebol.red ├── format.red ├── tests ├── send-request.red ├── xml.red └── graphql-tests.red ├── file-tools.red ├── README.md ├── sancrypt.red ├── set.red ├── paf.red ├── mailgun.red ├── make-response.md ├── transform.red ├── users.red ├── apache-log.red ├── github-tools.red ├── apis ├── cloudflare.red ├── github-v4.red └── github-v3.red ├── codecs ├── json.red ├── bson.red ├── xml.red ├── csv.red └── graphql.red ├── html-tools.red ├── nsource.red ├── bivi.red ├── barbucha.red ├── send-request.md ├── ansi-seq.red ├── js.red ├── qobom.red ├── bson.red ├── packers ├── zip.red ├── tar.red └── zip-debug.red └── func-tools.red /.gitignore: -------------------------------------------------------------------------------- 1 | delme.* 2 | console 3 | notes 4 | *options* 5 | issues.red 6 | -------------------------------------------------------------------------------- /get-rebol.red: -------------------------------------------------------------------------------- 1 | Red[] 2 | 3 | #include %packers/tar.red 4 | #include %../castr/http-scheme.red 5 | 6 | get-rebol: func [ 7 | /local links 8 | ] [ 9 | links: [ 10 | Linux http://www.rebol.com/downloads/v278/rebol-core-278-4-3.tar.gz 11 | Windows http://www.rebol.com/downloads/v278/rebol-core-278-3-1.exe 12 | OSX http://www.rebol.com/downloads/v278/rebol-core-278-2-5.tar.gz 13 | ] 14 | paths: [ 15 | Linux "releases/rebol-core/rebol" 16 | OSX 17 | ] 18 | 19 | link: select links system/platform 20 | path: select paths system/platform 21 | 22 | ; TODO this section must be platform specific 23 | data: load-tar read link 24 | data: select data path 25 | write/binary %rebol data 26 | call "chmod +x rebol" 27 | ; -- return something 28 | true 29 | ] 30 | -------------------------------------------------------------------------------- /format.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "Formating functions" 3 | Author: "Boleslav Březovský" 4 | ] 5 | 6 | 7 | context [ 8 | tabs: func [ 9 | "Return required number of tabs" 10 | count [integer!] 11 | ][ 12 | append/dup copy {} tab count 13 | ] 14 | 15 | spaces: func [ 16 | "Return required number of spaces" 17 | count [integer!] 18 | ][ 19 | append/dup copy {} space count 20 | ] 21 | 22 | set 'entab func [ 23 | "Convert spaces to tabs (modifies)" 24 | value [string!] "Script to convert" 25 | /count "Number of spaces in tab /default is 4)" 26 | cnt [integer!] 27 | ][ 28 | cnt: any [cnt 4] 29 | parse value [ 30 | some [ 31 | opt [change copy indent some space (tabs (length? indent) / cnt)] 32 | thru newline 33 | ] 34 | ] 35 | value 36 | ] 37 | 38 | set 'detab func [ 39 | "Convert tabs to spaces (modifies)" 40 | value [string!] "Script to convert" 41 | /count "Number of spaces in tab /default is 4)" 42 | cnt [integer!] 43 | ][ 44 | cnt: any [cnt 4] 45 | parse value [ 46 | some [ 47 | opt [change copy indent some tab (spaces (length? indent) * cnt)] 48 | thru newline 49 | ] 50 | ] 51 | value 52 | ] 53 | ] 54 | -------------------------------------------------------------------------------- /tests/send-request.red: -------------------------------------------------------------------------------- 1 | Red[] 2 | 3 | context [ 4 | passed: failed: log: none 5 | 6 | set 'assert func [ 7 | result [logic!] 8 | ][ 9 | unless log [init-test] 10 | either result [ 11 | passed: passed + 1 12 | ][ 13 | failed: failed + 1 14 | ] 15 | ] 16 | 17 | set 'init-test does [ 18 | passed: failed: 0 19 | log: copy [] 20 | ] 21 | 22 | set 'test func [ 23 | name [string!] 24 | code [block!] 25 | ][ 26 | result: do code 27 | message: rejoin ["TEST: " name " - " either result ["passed"]["failed"]] 28 | repend log [now message] 29 | print message 30 | ] 31 | ] 32 | 33 | httpbin: https://httpbin.org/ 34 | 35 | test "GET: basic request" [ 36 | ret: send-request httpbin/get 'GET 37 | assert 200 = ret/code 38 | ] 39 | 40 | test "GET: basic form" [ 41 | ret: send-request/data httpbin/get 'GET [x: 1 y: 2] 42 | assert 200 = ret/code 43 | assert ret/data/args = #(x: "1" y: "2") 44 | ] 45 | 46 | test "GET: basic form with spaces" [ 47 | ret: send-request/data httpbin/get 'GET [x: "hello world"] 48 | assert 200 = ret/code 49 | assert ret/data/args = #(x: "hello world") 50 | ] 51 | 52 | test "POST: basic request" [ 53 | ret: send-request/data httpbin/post 'POST [x: 1 y: 2] 54 | assert 200 = ret/code 55 | assert ret/data/form = #(x: "1" y: "2") 56 | ] 57 | -------------------------------------------------------------------------------- /file-tools.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "File tools" 3 | Author: "Boleslav Březovský" 4 | ] 5 | 6 | match: func [ 7 | "Match string to given wildcard pattern (supports ? and *)" 8 | ;TODO: escaping for * and ? 9 | value [any-string!] 10 | pattern [any-string!] 11 | /local forward 12 | ][ 13 | forward: func [][ 14 | value: next value 15 | pattern: next pattern 16 | ] 17 | value: to string! value 18 | pattern: to string! pattern 19 | until [ 20 | switch/default pattern/1 [ 21 | #"?" [forward] 22 | #"*" [ 23 | unless value: find value first pattern: next pattern [ 24 | return false 25 | ] 26 | ] 27 | ][ 28 | either equal? value/1 pattern/1 [forward][return false] 29 | ] 30 | 31 | tail? pattern 32 | ] 33 | unless empty? value [return false] 34 | true 35 | ] 36 | 37 | foreach-file: func [ 38 | "Evaluate body for each file in a path" 39 | 'file [word!] 40 | path [file!] 41 | body [block!] 42 | /with "Wildcard based pattern file has to confort to" 43 | pattern [any-string!] 44 | /local files f 45 | ][ 46 | files: read path 47 | foreach f files [ 48 | f: rejoin [path f] 49 | either dir? f [ 50 | either with [ 51 | foreach-file/with :file f body pattern 52 | ][ 53 | foreach-file :file f body 54 | ] 55 | ][ 56 | if any [ 57 | not with 58 | all [with match second split-path f pattern] 59 | ][ 60 | set :file f 61 | do body 62 | ] 63 | ] 64 | ] 65 | ] 66 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # IMPORTANT NOTICE 2 | 3 | All HTTP and HTML related stuff has been moved to the [CASTR](https://gitlab.com/rebolek/castr/) repository. Go there for updated and fixed version of 4 | 5 | * `SEND-REQUEST` 6 | * `XML/HTML` parser 7 | * The `HUB` web server 8 | * codepages handling functions 9 | 10 | and other amazing stuff. Versions here will be deleted eventually. 11 | 12 | # red-tools 13 | Various Red tools, encoders/decoders and APIs 14 | 15 | ## Encoders/decoders 16 | 17 | ### CSV 18 | 19 | Load and save [CSV](https://www.wikiwand.com/en/Comma-separated_values) files. 20 | 21 | ### JSON 22 | 23 | Load and save JSON files. 24 | 25 | ### GraphQL 26 | 27 | Load and save GraphQL files. 28 | 29 | ## APIs 30 | 31 | ### Github-v3 32 | 33 | Github REST API. 34 | 35 | ### Github-v4 36 | 37 | Github GraphQL API. 38 | 39 | ## Tools 40 | 41 | ### HTTP-TOOLS 42 | 43 | Various client and server side HTTP tools. HTTP headers parsing for use with CGI and other stuff. 44 | 45 | ### HTML-TOOLS 46 | 47 | Various tools for working with HTML files that simplfy parsing and data retrieval. 48 | 49 | ### PAF 50 | 51 | *PAF* (parse files) is [grep](https://www.wikiwand.com/en/Grep)-like tool for Red that uses `parse` rules instead of `regex`. 52 | 53 | ### UFCS 54 | 55 | [Uniform Function Call Syntax](https://en.wikipedia.org/wiki/Uniform_Function_Call_Syntax) implementation for Red. 56 | 57 | ### NSOURCE 58 | 59 | Show source for `native!` functions. 60 | -------------------------------------------------------------------------------- /sancrypt.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "SANSCrypt - Simple And Naive Symmetric Crypto" 3 | Author: "Boleslav Březovský" 4 | Purpose: "Placeholder symmetric cryptography until Red gets real thing" 5 | ] 6 | 7 | context [ 8 | 9 | binc: func [ 10 | "Binary increase" 11 | value [binary!] 12 | ][ 13 | len: length? value 14 | value/:len: value/:len + 1 15 | repeat i len [ 16 | i: len - i + 1 17 | either zero? value/:i [ 18 | value/(i - 1): value/(i - 1) + 1 19 | ][ 20 | break 21 | ] 22 | ] 23 | value 24 | ] 25 | 26 | make-nonce: func [ 27 | "Return random binary. Default is 256 bits" 28 | /size 29 | length "Size in bits" 30 | ][ 31 | length: any [length 256] 32 | collect/into [ 33 | loop length / 8 [keep (random/secure 256) - 1] 34 | ] copy #{} 35 | ] 36 | 37 | crypt: func [ 38 | value [string! binary!] 39 | password [string!] 40 | nonce [binary!] 41 | ][ 42 | data: copy #{} 43 | until [ 44 | block: copy/part value 32 45 | value: skip value 32 46 | key: checksum rejoin [#{} password form nonce] 'sha256 47 | block: key xor to binary! block 48 | append data block 49 | binc nonce 50 | tail? value 51 | ] 52 | data 53 | ] 54 | 55 | set 'encrypt func [ 56 | value [string! binary!] 57 | password [string!] 58 | ][ 59 | nonce: make-nonce 60 | orig: copy nonce 61 | value: crypt value password nonce 62 | reduce [orig value] 63 | ] 64 | 65 | set 'decrypt func [ 66 | value [string! binary!] 67 | password [string!] 68 | nonce [binary!] 69 | ][ 70 | crypt value password nonce 71 | ] 72 | 73 | ; -- end of context 74 | ] 75 | -------------------------------------------------------------------------------- /set.red: -------------------------------------------------------------------------------- 1 | Red[] 2 | 3 | set!: object [ 4 | data: [] 5 | 6 | on-deep-change*: func [ 7 | owner word target action new index part 8 | /local mark 9 | ][ 10 | all [ 11 | word = 'data 12 | find [poke insert append] action 13 | mark: find data new 14 | remove mark 15 | ] 16 | ] 17 | ] 18 | 19 | sorted-set!: object [ 20 | data: [] 21 | steps: 0 22 | internal?: no 23 | 24 | on-deep-change*: func [ 25 | owner word target action new index part 26 | /local mark 27 | ][ 28 | probe action 29 | if word = 'data [ 30 | switch action [ 31 | insert append [ 32 | if any [ 33 | not block? new 34 | odd? length? new 35 | ][ 36 | do make error! "Invalid data" 37 | ] 38 | if mark: find data new/1 [ 39 | owner/internal?: true 40 | remove mark 41 | ] 42 | ] 43 | inserted appended [ 44 | sort/skip/compare data 2 1 ; sort lexicographically first 45 | sort/skip/compare data 2 2 ; then sort by score 46 | ] 47 | remove [ 48 | if zero? steps [owner/steps: part * 2] 49 | ] 50 | removed [ 51 | unless zero? owner/steps [ 52 | remove data 53 | owner/steps: owner/steps - 1 54 | ] 55 | ] 56 | poke [ 57 | ; do make error! "Action not supported" 58 | print [#poke index new] 59 | ] 60 | ] 61 | ] 62 | ] 63 | ] 64 | 65 | make-set: func [/local value][ 66 | value: make set! [] 67 | value/data 68 | ] 69 | 70 | make-sorted-set: func [/local value][ 71 | value: make sorted-set! [] 72 | value/data 73 | ] 74 | 75 | 76 | test: [ 77 | s: make-sorted-set 78 | append s [a 5] 79 | append s [b 3] 80 | append s [c 1] 81 | append s [d 4] 82 | ] 83 | -------------------------------------------------------------------------------- /paf.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "PAF - parse files" 3 | Author: "Boleslav Březovský" 4 | ] 5 | 6 | paf: function [ 7 | path 8 | pattern 9 | /quiet "Do not print any output" 10 | /only "Return only logic! value to indicate match" 11 | ] [ 12 | matches: make block! 100 13 | lines: 1 14 | found?: false 15 | line-start: none 16 | mark: none 17 | dir: none 18 | filepath: none 19 | unless dir? path [append path #"/"] 20 | dirs: reduce copy [path] 21 | find-line-end: function [ 22 | text 23 | ] [ 24 | unless mark: find text newline [mark: tail text] 25 | mark 26 | ] 27 | pattern: compose/deep [ 28 | some [ 29 | (either block? pattern [append/only copy [] pattern] [pattern]) 30 | mark: 31 | (quote ( 32 | found?: true 33 | unless only [append last matches mark] 34 | unless quiet [ 35 | print rejoin [ 36 | filepath #"@" lines ": " 37 | copy/part line-start find-line-end mark 38 | ] 39 | ] 40 | )) 41 | ; to end 42 | | #"^/" line-start: (quote (lines: lines + 1)) 43 | | skip 44 | ] 45 | ] 46 | scan-file: func [ 47 | path 48 | ] [ 49 | lines: 1 50 | unless error? try [file: read path] [ 51 | unless only [repend matches [path make block! 100]] 52 | parse file pattern 53 | all [ 54 | not only empty? 55 | last matches 56 | remove/part skip tail matches -2 2 57 | ] 58 | ] 59 | ] 60 | scan-dir: func [ 61 | path 62 | ] [ 63 | dir: read path 64 | foreach file dir [ 65 | either dir? file [ 66 | append dirs file 67 | scan-dir to file! dirs 68 | take/last dirs 69 | ] [ 70 | scan-file filepath: append to file! dirs file 71 | ] 72 | ] 73 | ] 74 | scan-dir path 75 | either only [found?] [matches] 76 | ] 77 | -------------------------------------------------------------------------------- /mailgun.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "Mailgun API" 3 | Author: "Boleslav Březovský" 4 | Usage: { 5 | Make your own `mailgun` object like this: 6 | 7 | ``` 8 | my-mailgun: make mailgun! [ 9 | api: 10 | domain: 11 | from: 12 | ] 13 | ``` 14 | } 15 | API: https://documentation.mailgun.com/en/latest 16 | ] 17 | 18 | ;sony@deli:~/Code/temp$ curl -s --user 'api:key-3c3fad7221f6f700b13724fab19cfd0c' \ 19 | ;> https://api.mailgun.net/v3/sandbox915666ebdc3a47ddaff441ebff290da1.mailgun.org/messages \ 20 | ;> -F from='Mailgun Sandbox ' \ 21 | ;> -F to='Ivan Vrah ' \ 22 | ;> -F subject='Hello Ivan Vrah' \ 23 | ;> -F text='Congratulations Ivan Vrah, you just sent an email with Mailgun! You are truly awesome!' 24 | 25 | do %http-tools.red 26 | 27 | mailgun!: context [ 28 | api: none ; put your API key here 29 | 30 | base-url: https://api.mailgun.net/v3/ 31 | domain: none ; put your domain here 32 | from: none ; put your email address here 33 | 34 | send: func [ 35 | recepients 36 | subject ; TODO: get subject from body as first line? 37 | body 38 | /local ret link method 39 | ][ 40 | link: rejoin [base-url self/domain /messages] 41 | method: 'POST 42 | data: "" 43 | headers: make map! compose [ 44 | from: (self/from) 45 | to: (recepients) ; TODO: conversion to comma separated format 46 | ; TODO: CC, BCC 47 | subject: (subject) 48 | text: (body) 49 | ; TODO: Attachment and other headers 50 | ] 51 | ret: send-request/auth/data/with link method 'basic reduce ["api" self/api] data headers 52 | load-json ret 53 | ; TODO: Error handling 54 | ] 55 | ] 56 | -------------------------------------------------------------------------------- /make-response.md: -------------------------------------------------------------------------------- 1 | # MAKE-RESPONSE 2 | 3 | `make-response` is a Red function that creates HTTP response string from input 4 | string or dialect. It can set status code and `Content-Type` header field 5 | based on type of the input data. 6 | 7 | ## modes of operation 8 | 9 | There are two basic modes of operation - automatic and dialected. Automatic 10 | mode sets `Content-Type` based on type of data, while dialected mode offers 11 | fine control over the HTTP response using simple dialect. 12 | 13 | ## Automatic mode 14 | 15 | Automatic mode just sets `Content-Type` header field according to the type 16 | of deta: 17 | 18 | ### string 19 | 20 | When VALUE is a `string!`, Content-Type is determined by first character: 21 | 22 | "<" - text/html 23 | "{" or "[" - application/json 24 | else text/plain 25 | 26 | More types may be supported in the future. 27 | 28 | ### map and object 29 | 30 | If VALUE is `map!` or `object!`, it's converted to JSON and Content-Type 31 | is set accordingly. 32 | 33 | ## dialect 34 | 35 | Dialect offers finer control over the HTTP response. It allows user to set 36 | status code and various header fields. 37 | 38 | ### status code 39 | 40 | Status code is optional. It consist of an `integer!` for a status code and 41 | an optional `string!` for the reason message. 42 | 43 | Examples: 44 | 45 | ``` 46 | make-response [200 "content"] 47 | 48 | make-response [200 "OK" "content"] 49 | ``` 50 | 51 | ### content type 52 | 53 | Content type is optional and overrides auto-detection mechanism. It can be 54 | either `word!` for predefined types or `path!` for other types. Predefined 55 | types are: 56 | 57 | - html - text/html 58 | - text - text/plain 59 | - json - application/json 60 | - csv - text/csv 61 | - xml - text/xml 62 | - jpeg - image/jpeg 63 | - png - image/png 64 | 65 | Other types may be supported in future. 66 | 67 | If no type is set, dialected mode uses same autodetection mechanism as 68 | automatic mode. 69 | 70 | Examples: 71 | 72 | ``` 73 | make-response [json {{"key": "value"}}] 74 | 75 | make-response [text/html {hello world}] 76 | 77 | make-response [200 "hello"] 78 | ``` 79 | 80 | In the last example, `make-response` can detect that the string is content 81 | and not areason message for the status code. 82 | 83 | ### content 84 | 85 | Content is last value in dialect and is the only value that **MUST** be 86 | present in the dialect block. It's type can be `string!` or `file!`. 87 | If no `Content-Type` was set, auto-detection is used for `string!` content 88 | and `application/octet-stream` type is used for `file!.` 89 | -------------------------------------------------------------------------------- /transform.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "Transform" 3 | Author: "Boleslav Březovský" 4 | Purpose: "Translate received JSON object to Red function call" 5 | Notes: { 6 | Maps received JSON object into Red function call. 7 | Finds matching sequence of required keys and calls related function with keys' 8 | values as arguments. 9 | } 10 | To-Do: [ 11 | error-handling: 12 | "nothing matched when NONE option is not present" 13 | "check for required fields" 14 | [required "user" "pass" ["required fields missing"]] 15 | {block is executed and returned, it can be just a string for an 16 | error message, or some function} 17 | "this boils down to two options of handling required fields:" 18 | #1 [ 19 | "user" "pass" [login "user" "pass"] 20 | ] 21 | {on fail it returns something like "nothing matched" or NONE} 22 | 23 | #2 [ 24 | required "user" "pass" ["required fields missing"] 25 | "user" "pass" [login "user" "pass"] 26 | ] 27 | 28 | "There is also third option, provide optional error message:" 29 | #3 [ 30 | "user" "pass" [login "user" "pass"]["required fields missing"] 31 | ] 32 | ] 33 | ] 34 | 35 | 36 | mapping: [ 37 | #none [list] 38 | state [list/only state] 39 | location [list/codes location] 40 | state location [list/only/codes state location] 41 | scraper [list/with scraper] 42 | scraper state [list/only/with state scraper] 43 | scraper location [list/codes/with location scraper] 44 | scraper state location [list/only/codes/with state location scraper] 45 | ] 46 | 47 | request: #(state: "CA" location: "Los Angeles") 48 | 49 | #call [transform mapping request] 50 | #result [list/only/codes "CA" "Los" "Angleles"] 51 | 52 | transform: func [ 53 | "Map JSON request to a function call" 54 | mapping [block!] 55 | request [string! map!] "JSON object or converted map!" 56 | /local key keys value break? rule word words action 57 | ][ 58 | unless map? request [request: load-json request] 59 | keys: sort keys-of request 60 | 61 | all-words: unique parse mapping [ 62 | collect [some [#none | keep word! | skip]] 63 | ] 64 | remove-each key keys [not find all-words key] 65 | 66 | break?: false 67 | rule: [ 68 | (words: clear []) 69 | some [set word word! (append words word)] 70 | set action block! 71 | (if equal? sort words keys [break?: true]) 72 | ] 73 | parse mapping [ 74 | some [ 75 | if (break?) break 76 | | 'none set action block! (if empty? keys [break?: true]) 77 | | rule 78 | ] 79 | ] 80 | unless break? [action: none] 81 | foreach key keys [replace/all action key request/:key] 82 | action 83 | ] 84 | -------------------------------------------------------------------------------- /users.red: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/red 2 | Red [ 3 | Note: "need enbase64url from http-tools" 4 | ] 5 | 6 | users-file: %/var/www/data/users.red 7 | tokens-file: %/var/www/data/tokens.red 8 | 9 | users: none 10 | tokens: none 11 | 12 | ; -- user management -------------------------------------------------------- 13 | 14 | load-users: func [][ 15 | users: either any [ 16 | not exists? users-file 17 | zero? size? users-file 18 | ][ 19 | copy #() 20 | ][ 21 | load users-file 22 | ] 23 | ] 24 | 25 | save-users: func [][ 26 | save users-file users 27 | ] 28 | 29 | make-user: func [ 30 | "Returns FALSE when user exists, TOKEN when not and is created" 31 | name [string!] 32 | password [string!] 33 | /local user 34 | ][ 35 | if select users name [return false] 36 | user: compose [ 37 | name: none 38 | password: none 39 | salt: none 40 | version: 1 41 | created: now/precise 42 | ] 43 | user/name: name 44 | user/salt: checksum form now/time/precise 'SHA256 45 | user/password: checksum rejoin [user/salt password] 'SHA256 46 | users/:name: user 47 | save-users 48 | make-token name 49 | ] 50 | 51 | login-user: func [ 52 | "Return NONE when user not exists, FALSE when password is wrong or TOKEN" 53 | name [string!] 54 | password [string!] 55 | /local user 56 | ][ 57 | user: select users name 58 | unless user [return none] 59 | password: checksum rejoin [user/salt password] 'SHA256 60 | unless equal? password user/password [return false] 61 | make-token name 62 | ] 63 | 64 | ; -- token management ------------------------------------------------------- 65 | 66 | load-tokens: func [][ 67 | tokens: either any [ 68 | not exists? tokens-file 69 | zero? size? tokens-file 70 | ][ 71 | copy #() 72 | ][ 73 | load tokens-file 74 | ] 75 | check-tokens 76 | ] 77 | 78 | save-tokens: func [][ 79 | save tokens-file tokens 80 | ] 81 | 82 | check-tokens: func [][ 83 | foreach [token data] tokens [ 84 | if data/expires < now/precise [ 85 | remove/key tokens token 86 | save-tokens 87 | ] 88 | ] 89 | ] 90 | 91 | make-token: func [name /refresh data /local token][ 92 | data: any [ 93 | data 94 | enbase64url checksum form now/precise 'sha256 95 | ] 96 | token: compose [ 97 | name: none 98 | value: (data) 99 | expires: (now/precise + 01:00:00) ; TODO: move expiration to settings 100 | ] 101 | token/name: name 102 | tokens/:name: token 103 | save-tokens 104 | make map! token 105 | ] 106 | 107 | match-token: func [value][ 108 | foreach [user token] tokens [ 109 | if equal? value token/value [ 110 | make-token/refresh user value 111 | return user 112 | ] 113 | ] 114 | return false 115 | ] 116 | 117 | ; -- initalization 118 | 119 | load-users 120 | load-tokens 121 | -------------------------------------------------------------------------------- /tests/xml.red: -------------------------------------------------------------------------------- 1 | Red [] 2 | 3 | ; TODO: conversion of map keys to word! if possible 4 | 5 | ;rl: read-thru http://red-lang.org 6 | 7 | ; for content see page/html/body/20 8 | 9 | test: {bleble} 10 | xx: {^/^/^/^/^/} 11 | xy: { 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | } 22 | 23 | xz: { 24 | 25 | 26 | 27 | 28 | } 29 | 30 | google: https://www.google.cz/search?q=bullerbyne 31 | malf-scr: {} ; google uses this... 32 | chip: https://en.wikipedia.org/wiki/CHIP-8 33 | 34 | chipp: { 35 | 36 | 37 | 38 | 39 | CHIP-8 - Wikipedia 40 | 41 | 42 | } 43 | 44 | ; TODO: move tests to separate file 45 | 46 | tests: [ 47 | ; 48 | ; FORMAT: source result 49 | ; 50 | ; comments 51 | {} [] 52 | { } [] 53 | ; 54 | ; single tags 55 | {} [img #()] 56 | {} [img none #("src" "http://www.image.com/image.jpg")] 57 | {} [img none #("src" "http://www.image.com/image.jpg")] 58 | {} [img none #("src" "http://www.image.com/image.jpg") img none #("src" "http://www.image.com/image.jpg")] 59 | { } [img none #("src" "http://www.image.com/image.jpg") img none #("src" "http://www.image.com/image.jpg")] 60 | {} [img none #("src" "http://www.image.com/image.jpg")] 61 | ]yes 62 | 63 | run-tests: function [ 64 | tests 65 | ] [ 66 | output: clear {} 67 | index: 1 68 | foreach [test result] tests [ 69 | repend output either equal? xml-lite/decode test result [ 70 | ["Test #" index " passed." newline] 71 | ] [ 72 | ["Test #" index " failed." newline] 73 | ] 74 | index: index + 1 75 | ] 76 | copy output 77 | ] 78 | 79 | -------------------------------------------------------------------------------- /apache-log.red: -------------------------------------------------------------------------------- 1 | Red[] 2 | 3 | map-from: func [ 4 | words 5 | /local result 6 | ][ 7 | result: make map! [] 8 | foreach word words [ 9 | result/:word: get word 10 | ] 11 | result 12 | ] 13 | 14 | parse-apache-time: func [ 15 | data 16 | /local sign tz tz-hour tz-min value 17 | ][ 18 | ; NOTE: Expects English names in system/locale 19 | get-month: func [month][ 20 | months: system/locale/months 21 | forall months [ 22 | if equal? month copy/part first months 3 [ 23 | return index? months 24 | ] 25 | ] 26 | ] 27 | date: now ; prefill with something 28 | date/timezone: 0 29 | parse data [ 30 | #"[" 31 | copy value to slash skip (date/day: load value) 32 | copy value to slash skip (date/month: get-month value) 33 | copy value to #":" skip (date/year: load value) 34 | copy value to #":" skip (date/hour: load value) 35 | copy value to #":" skip (date/minute: load value) 36 | copy value to space skip (date/second: load value) 37 | set sign skip 38 | copy tz-hour 2 skip 39 | copy tz-min 2 skip ( 40 | tz: to time! reduce [load tz-hour load tz-min] 41 | if equal? #"-" sign [tz: negate tz] 42 | date/timezone: tz 43 | ) 44 | #"]" 45 | ] 46 | date 47 | ] 48 | 49 | parse-logs: func [ 50 | dir 51 | ; /local result file files maximum id data 52 | ][ 53 | result: copy [] 54 | files: read dir 55 | ; get rid of non-interesting files 56 | remove-each file files [ 57 | any [ 58 | not find file %access 59 | equal? file %other_vhosts_access.log 60 | ] 61 | ] 62 | sort files 63 | maximum: 0 64 | ; find max ID 65 | foreach file files [ 66 | all [ 67 | id: third split file dot 68 | id: try [to integer! id] 69 | if id > maximum [maximum: id] 70 | ] 71 | ] 72 | until [ 73 | data: to string! decompress read/binary rejoin [dir %access.log. maximum %.gz] 74 | append result parse-log data 75 | maximum: maximum - 1 76 | 1 = maximum 77 | ] 78 | append result parse-log read rejoin [dir %access.log.1] 79 | append result parse-log read rejoin [dir %access.log] 80 | result 81 | ] 82 | 83 | parse-log: func [ 84 | log [string!] 85 | /local result 86 | ][ 87 | result: copy [] 88 | log: split log newline 89 | foreach line log [ 90 | append result parse-line line 91 | ] 92 | result 93 | ] 94 | 95 | parse-line: func [ 96 | line [string!] 97 | /local ip identd userid date status size referrer agent 98 | ][ 99 | parse line [ 100 | copy ip to space skip (ip: to tuple! ip) 101 | copy identd to space skip (identd: load identd) 102 | copy userid to space skip (userid: load userid) 103 | copy date thru #"]" skip (date: parse-apache-time date) 104 | skip copy request to {" } 2 skip ; TODO: split request to [method address version] or smt like that 105 | copy status to space skip (status: to integer! status) 106 | copy size to space skip (size: to integer! size) 107 | copy referrer to space skip (referrer: load referrer) 108 | copy agent to end (agent: load agent) 109 | ] 110 | map-from [ip identd userid date request status size referrer agent] 111 | ] 112 | 113 | ; test 114 | 115 | test-line: {162.158.75.158 - - [04/Jun/2018:07:01:36 +0000] "GET / HTTP/1.1" 301 562 "-" "Mozilla/5.0 (Linux; Android 6.0.1; Nexus 5X Build/MMB29P) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/41.0.2272.96 Mobile Safari/537.36 (compatible; Googlebot/2.1; +http://www.google.com/bot.html)"} 116 | -------------------------------------------------------------------------------- /github-tools.red: -------------------------------------------------------------------------------- 1 | Red[] 2 | 3 | #include %apis/github-v3.red 4 | ;#include %github-options.red 5 | #include %qobom.red 6 | #include %packers/zip.red 7 | #include %../castr/http-scheme.red 8 | 9 | ; --- support 10 | 11 | numbers: charset "0123456789" 12 | 13 | ; --- loading functions 14 | 15 | init: does [ 16 | issues: get-issues 17 | commits: get-commits 18 | ; Cache downloaded data 19 | save %issues.red issues 20 | save %commits.red commits 21 | ] 22 | 23 | get-issues: func [ 24 | /local page issues repo 25 | ] [ 26 | issues: copy [] 27 | repo: 'red/red 28 | ; get last 30 issues 29 | page: github/get-issues/repo/with repo [state: 'all] 30 | ; get total page count 31 | print ["Downloading" page/1/number "issues."] 32 | pages: page/1/number / 30 33 | append issues page 34 | repeat page pages [ 35 | print ["Issues - page" page #"/" pages] 36 | append issues github/get-issues/repo/page/with repo page + 1 [state: 'all] 37 | ] 38 | issues 39 | ] 40 | 41 | get-commits: func [ 42 | /local page commits repo 43 | ][ 44 | commits: copy [] 45 | page: 1 46 | repo: 'red/red 47 | until [ 48 | data: github/get-commits/page repo page 49 | print ["Commits - page" page] 50 | append commits data 51 | page: page + 1 52 | empty? data 53 | ] 54 | commits 55 | ] 56 | 57 | ; --- functions working on downloaded data 58 | 59 | get-column: func [ 60 | data 61 | column 62 | /local line result value 63 | ][ 64 | result: copy [] 65 | foreach line data [ 66 | value: pick line column 67 | unless find result value [append result value] 68 | ] 69 | result 70 | ] 71 | 72 | get-authors: func [ 73 | issues 74 | /local 75 | ][ 76 | authors: make map! [] 77 | foreach issue issues [ 78 | author: issue/user/login 79 | either authors/:author [authors/:author: authors/:author + 1][authors/:author: 1] 80 | ] 81 | authors 82 | ] 83 | 84 | get-fixes: func [ 85 | "Return commits that are fixes to issues (message contains #XXXX)" 86 | commits 87 | /local fixes 88 | ][ 89 | fixes: copy [] 90 | foreach commit commits [ 91 | issue: none 92 | parse commit/commit/message [thru #"#" copy issue some numbers] 93 | if issue [repend fixes [issue commit]] 94 | ] 95 | fixes 96 | ] 97 | 98 | qget-fixes: func [ 99 | "Return commits that are fixes to issues (message contains #XXXX)" 100 | commits 101 | ][ 102 | qobom commits ['commit/message matches [thru #"#" some numbers to end]] 103 | ] 104 | 105 | get-issue-by-number: func [ 106 | issues 107 | number 108 | ][ 109 | foreach issue issues [ 110 | if equal? issue/number number [return issue] 111 | ] 112 | none 113 | ] 114 | 115 | get-aoiltf: func [ 116 | "get authors of issues leading to fixes" 117 | commits 118 | issues 119 | ][ 120 | authors: make map! [] 121 | fixes: get-fixes commits 122 | foreach [id commit] fixes [ 123 | id: to integer! id 124 | if issue: get-issue-by-number issues id [ 125 | ; NOTE: some messages may point to non-existent issue (because they point to something different, see commit "bc6d27c1d0ae89237ce9cbddb7fe593924d482e8") 126 | author: issue/user/login 127 | either authors/:author [ 128 | append authors/:author id ;TODO: or issue directly, let's see 129 | ][ 130 | authors/:author: reduce [id] 131 | ] 132 | ] 133 | ] 134 | authors 135 | ] 136 | 137 | clone: func [ 138 | repo [path!] 139 | /branch 140 | name 141 | /local data file content 142 | ] [ 143 | name: any [name "master"] 144 | ; download ZIP archive 145 | repo: rejoin [https://codeload.github.com/ repo %/zip/refs/heads/ name] 146 | data: load-zip read/binary repo 147 | ; save files 148 | foreach [file content] data [ 149 | append out file 150 | either dir? file [ 151 | make-dir/deep file 152 | ][ 153 | write/binary file content 154 | ] 155 | ] 156 | ] 157 | -------------------------------------------------------------------------------- /apis/cloudflare.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "Cloudflare API" 3 | Author: "Boleslav Březovský" 4 | Url: https://api.cloudflare.com 5 | 6 | Options: [ 7 | api-key: "your-api-key-here" 8 | email: your@email.here 9 | ] 10 | 11 | Usage: [ 12 | do %cloudflare.red 13 | opt: load %cloudflare-options.red 14 | cf: make cloudflare! opt 15 | ] 16 | ] 17 | 18 | base-url: https://api.cloudflare.com/client/v4/ 19 | 20 | do %../http-tools.red 21 | 22 | cloudflare!: context [ 23 | ; user settings 24 | token: none 25 | email: none 26 | 27 | ; support 28 | reply: none ; reply from server 29 | zone-cache: none 30 | dns-cache: #() 31 | 32 | ; main function 33 | send: func [ 34 | link 35 | /with method data 36 | /local header 37 | ][ 38 | link: rejoin [base-url link] 39 | method: any [method 'GET] 40 | header: make map! compose [ 41 | Content-Type: "application/json" 42 | ] 43 | reply: either equal? method 'get [ 44 | send-request/with/auth link method header 'Bearer token 45 | ] [ 46 | send-request/with/data/auth link method header data 'Bearer token 47 | ] 48 | ; TODO: error handling 49 | either reply/code = 200 [ 50 | reply/data 51 | ][ 52 | make error! rejoin [ 53 | reply/data/errors/1/code ": " reply/data/errors/1/message 54 | ] 55 | ] 56 | ] 57 | 58 | ; --- support functions 59 | 60 | id?: func [ 61 | "Return TRUE when string is ID" 62 | string 63 | /local hexa 64 | ][ 65 | hexa: charset [#"a" - #"f" #"0" - #"9"] 66 | parse string [32 hexa] 67 | ] 68 | 69 | get-zone-id: func [ 70 | name 71 | ][ 72 | either id? name [ 73 | return name 74 | ][ 75 | if empty? zone-cache [get-zones] 76 | foreach zone zone-cache [ 77 | if equal? name zone/name [return zone/id] 78 | ] 79 | ] 80 | none 81 | ] 82 | 83 | get-zone-name: func [zone-id][ 84 | foreach zone zone-cache [ 85 | if equal? zone-id zone/id [return zone/name] 86 | ] 87 | ] 88 | 89 | get-dns-record-id: func [ 90 | zone 91 | name 92 | /local zone-name records 93 | ][ 94 | ; prepare caches 95 | zone: get-zone-id zone 96 | zone-name: get-zone-name zone 97 | if empty? words-of dns-cache [list-dns-records zone] 98 | ; make sure that name contains zone name 99 | unless find name zone-name [name: rejoin [name dot zone-name]] 100 | ; find record ID 101 | records: select dns-cache zone 102 | foreach record records [ 103 | if equal? name record/name [return record/id] 104 | ] 105 | none 106 | ] 107 | 108 | ; --- API implementation 109 | 110 | verify: func [] [ 111 | send %user/tokens/verify 112 | copy reply/data/result 113 | ] 114 | 115 | get-zones: func [][ 116 | ; TODO: Pagination 117 | send %zones 118 | zone-cache: copy reply/data/result 119 | ] 120 | 121 | list-dns-records: func [ 122 | zone 123 | ][ 124 | zone: get-zone-id zone 125 | send rejoin [%zones/ zone "/dns_records"] 126 | dns-cache/:zone: reply/data/result 127 | ] 128 | 129 | make-dns-record: func [ 130 | zone 131 | type 132 | name 133 | content 134 | ; TODO: optional args 135 | ][ 136 | zone: get-zone-id zone 137 | send/with rejoin [%zones/ zone "/dns_records"] 'POST json/encode make map! compose [ 138 | type: (type) 139 | name: (name) 140 | content: (content) 141 | ] 142 | ] 143 | 144 | update-dns-record: func [ 145 | zone 146 | type 147 | name 148 | content 149 | ; TODO: optional args 150 | /local id 151 | ][ 152 | id: get-dns-record-id zone name 153 | zone: get-zone-id zone 154 | send/with rejoin [%zones/ zone "/dns_records/" :id] 'PUT json/encode make map! compose [ 155 | type: (type) 156 | name: (name) 157 | content: (content) 158 | ] 159 | ] 160 | 161 | delete-dns-record: func [ 162 | zone 163 | name 164 | ][ 165 | ; DELETE zones/:zone_identifier/dns_records/:identifier 166 | id: get-dns-record-id zone name 167 | zone: get-zone-id zone 168 | send/with rejoin [%zones/ zone "/dns_records/" :id] 'DELETE [] 169 | ] 170 | ] 171 | 172 | test: [ 173 | opt: load %cloudflare-options.red 174 | cf: make cloudflare! opt 175 | cf/get-zones 176 | ] 177 | -------------------------------------------------------------------------------- /codecs/json.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "JSON parser" 3 | File: %json.red 4 | Author: "Nenad Rakocevic, Qingtian Xie, Boleslav Březovský" 5 | License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt" 6 | ] 7 | 8 | json: context [ 9 | quoted-char: charset {"\/bfnrt} 10 | exponent: charset "eE" 11 | sign: charset "+-" 12 | digit-nz: charset "123456789" 13 | digit: charset [#"0" - #"9"] 14 | hexa: union digit charset "ABCDEFabcdef" 15 | blank: charset " ^(09)^(0A)^(0D)" 16 | ws: [any blank] 17 | dbl-quote: #"^"" 18 | s: e: none 19 | list: none 20 | 21 | null-value: none ; NOTE: Change this, if you prefer something else than NONE 22 | conversion?: no ; EXPERIMENTAL: For numbers in quotes, load them 23 | pretify?: yes 24 | 25 | load-str: func [ 26 | "Return word if possible, leave untouched when not" 27 | str 28 | /local out 29 | ] [ 30 | if error? try [out: load str] [out: str] 31 | out 32 | ] 33 | 34 | decode-str: func [start end /local new rule s t loaded][ 35 | new: copy/part start back end ;-- exclude ending quote 36 | rule: [ 37 | any [ 38 | s: remove #"\" [ 39 | #"^"" (s/1: #"^"") 40 | | #"/" (s/1: #"/") 41 | | #"\" (s/1: #"\") 42 | | #"b" (s/1: #"^H") 43 | | #"f" (s/1: #"^(0C)") 44 | | #"n" (s/1: #"^/") 45 | | #"r" (s/1: #"^M") 46 | | #"t" (s/1: #"^-") 47 | | #"u" copy t 4 hexa ( 48 | change/part s load rejoin [{#"^^(} t {)"}] 5 49 | s: skip s -4 50 | ) :s 51 | ] 52 | | skip 53 | ] 54 | ] 55 | parse new rule 56 | all [ 57 | conversion? 58 | not error? loaded: try [load new] 59 | new: loaded 60 | ] 61 | new 62 | ] 63 | 64 | encode-str: func [str [string!] buffer [string!] /local start rule s][ 65 | append buffer #"^"" 66 | start: tail buffer 67 | append buffer str 68 | rule: [ 69 | any [ 70 | change #"^H" "\b" 71 | | change #"^(0C)" "\f" 72 | | change #"^/" "\n" 73 | | change #"^M" "\r" 74 | | change #"\" "\\" 75 | | change #"^-" "\t" 76 | | change #"^"" {\"} 77 | | skip 78 | ] 79 | ] 80 | parse start rule 81 | append buffer #"^"" 82 | ] 83 | 84 | value: [ 85 | string keep (decode-str s e) 86 | | number keep (load copy/part s e) 87 | | "true" keep (true) 88 | | "false" keep (false) 89 | | "null" keep (null-value) 90 | | object-rule 91 | | array 92 | ] 93 | 94 | number: [ 95 | s: opt #"-" 96 | some digit 97 | opt [dot some digit] 98 | opt [exponent opt sign 1 3 digit] 99 | e: 100 | ] 101 | 102 | string: [ 103 | dbl-quote 104 | ; TODO: check if any unicode conversion needs to be done here 105 | s: any [#"\" [quoted-char | #"u" 4 hexa] | dbl-quote break | skip] 106 | e: 107 | ] 108 | 109 | couple: [ws string keep (load-str decode-str s e) ws #":" ws value ws] 110 | 111 | object-rule: [ 112 | #"{" 113 | collect set list opt [any [couple #","] couple] ws #"}" 114 | keep (make map! list) 115 | ] 116 | 117 | array: [#"[" collect opt [ws value any [ws #"," ws value]] ws #"]"] 118 | 119 | decode: function [ 120 | data [string!] 121 | return: [block! object!] 122 | ][ 123 | output: parse data [collect any [blank | object-rule | array | value]] 124 | either equal? 1 length? output [first output] [output] 125 | ] 126 | 127 | encode-into: function [ 128 | data [any-type!] 129 | buffer [string!] 130 | ][ 131 | case [ 132 | any [map? data object? data] [ 133 | append buffer #"{" 134 | either zero? length? words-of data [ 135 | append buffer #"}" 136 | ][ 137 | foreach word words-of data [ 138 | encode-into word buffer 139 | append buffer #":" 140 | encode-into data/:word buffer 141 | append buffer #"," 142 | ] 143 | change back tail buffer #"}" 144 | ] 145 | ] 146 | block? data [ 147 | append buffer #"[" 148 | either empty? data [ 149 | append buffer #"]" 150 | ][ 151 | foreach v data [ 152 | encode-into v buffer 153 | append buffer #"," 154 | ] 155 | change back tail buffer #"]" 156 | ] 157 | ] 158 | string? data [ 159 | encode-str data buffer 160 | ] 161 | any [logic? data number? data][ 162 | append buffer mold data 163 | ] 164 | true [ 165 | encode-into mold data buffer 166 | ] 167 | ] 168 | ] 169 | 170 | encode: function [ 171 | data 172 | return: [string!] 173 | ][ 174 | buffer: make string! 1000 175 | encode-into data buffer 176 | buffer 177 | ] 178 | ] 179 | -------------------------------------------------------------------------------- /html-tools.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "HTML Tools" 3 | Author: "Boleslav Březovský" 4 | 5 | ] 6 | 7 | #include %xml.red 8 | 9 | probe-xml: func [ 10 | data 11 | ] [ 12 | foreach [tag content attributes] data [ 13 | print [tag length? content length? attributes] 14 | ] 15 | ] 16 | 17 | foreach-node: func [ 18 | data 19 | code 20 | /local tag content attributes 21 | ] [ 22 | z: data 23 | ; FN takes three parameters: [tag content attribute] 24 | foreach [tag content attributes] data [ 25 | do bind code 'tag 26 | if block? content [ 27 | foreach-node content code 28 | ] 29 | ] 30 | ] 31 | 32 | 33 | select-by: func [ 34 | data 35 | type ; tag, class, content, attribute name 36 | value 37 | ; TODO: How to support /only ? There some binding problems 38 | /local action ret 39 | ] [ 40 | action: probe compose switch/default type [ 41 | tag [[equal? tag (to lit-word! value)]] 42 | class [[find select attributes "class" (value)]] 43 | content [[all [string? content find content (value)]]] 44 | ] [[equal? (value) select attributes (type)]] 45 | ret: copy [] 46 | foreach-node data compose [ 47 | if (action) [ 48 | append ret reduce [tag content attributes] 49 | ] 50 | ] 51 | ret 52 | ] 53 | 54 | context [ 55 | parent: none ; TODO: make a closure 56 | set 'parent? func [ 57 | data 58 | value 59 | /inner 60 | /local tag content attributes 61 | ] [ 62 | unless inner [parent: none] 63 | foreach [tag content attributes] data [ 64 | if equal? value reduce [tag content attributes] [ 65 | return parent 66 | ] 67 | if block? content [ 68 | parent: reduce [tag content attributes] 69 | if parent?/inner content value [return parent] 70 | ] 71 | ] 72 | none 73 | ] 74 | ] 75 | 76 | children?: func [ 77 | "Return children tag names" 78 | data 79 | /local tag content attributes 80 | ] [ 81 | collect [foreach [tag content attributes] data [keep tag]] 82 | ] 83 | 84 | get-text: function [ 85 | data 86 | ] [ 87 | if any [not data string? data char? data] [return data] 88 | ret: copy {} 89 | foreach-node data compose/deep [ 90 | all [ 91 | string? content 92 | append (ret) content 93 | ] 94 | ] 95 | ret 96 | ] 97 | 98 | show-h: does [ 99 | page: xml/decode read http://www.red-lang.org 100 | headings: select-by page "post-title" 'class 101 | foreach [t c a] headings [print c/a/2] 102 | ] 103 | 104 | google: func [value] [ 105 | debug "Loading page" 106 | page: rejoin [http://www.google.cz/search?q= replace/all value space #"+"] 107 | page: read/binary probe page 108 | write %goog.html page 109 | debug "Decoding page" 110 | page: load-non-utf page 111 | debug "Page read" 112 | page: xml/decode page 113 | results: select-by page 'h3 'tag 114 | result: collect [ 115 | foreach [t c a] results [keep reduce [get-text c/a rejoin [http://www.google.com select c/3 "href"]]] 116 | ] 117 | new-line/all/skip result true 2 118 | ] 119 | 120 | get-table: func [ 121 | "Convert to block! of block!s" 122 | table 123 | /trim 124 | /header "Get headers and return them as first row" 125 | ] [ 126 | table: any [table/table table] 127 | if header [ 128 | headers: any [table/thead/tr (also remove/part table 3 table/tr)] 129 | headers: collect [ 130 | foreach [t col a] headers [ 131 | col: get-text col 132 | if trim [col: system/words/trim/lines form col] 133 | keep col 134 | ] 135 | ] 136 | ] 137 | table: any [table/tbody table] 138 | data: collect/into [ 139 | foreach [t row a] table [ ; row 140 | keep/only collect [ 141 | foreach [t cell a] row [ 142 | if cell: get-text cell [ 143 | if trim [cell: system/words/trim/lines form cell] 144 | keep cell 145 | ] 146 | ] 147 | ] 148 | ] 149 | ] clear [] 150 | if header [insert/only data headers] 151 | new-line/all/skip data true 1 152 | copy data 153 | ] 154 | 155 | ; Using `get-table`: 156 | ; 157 | ; page: xml/decode read https://coinmarketcap.com/ 158 | ; table: select-by page 'table 'tag 159 | ; t: get-table/trim table/table/tbody ; TODO: `get-table` should find this automatically 160 | ; probe copy/part t 5 161 | ; 162 | ; >> 163 | ; [ 164 | ; ["1" "Bitcoin" "$46,856,630,435" "$2843.13" "16,480,650 BTC" "$748,864,000" "3.85%" "" ""] 165 | ; ["2" "Ethereum" "$18,906,132,157" "$201.78" "93,695,367 ETH" "$522,577,000" "0.44%" "" ""] 166 | ; ["3" "Ripple" "$6,482,777,296" "$0.169117" "38,333,090,674 XRP *" "$52,118,400" "1.42%" "" ""] 167 | ; ["4" "Litecoin" "$2,248,733,073" "$43.03" "52,255,407 LTC" "$211,233,000" "5.29%" "" ""] 168 | ; ["5" "NEM" "$1,499,805,000" "$0.166645" "8,999,999,999 XEM *" "$2,905,890" "1.11%" "" ""] 169 | ; ] 170 | -------------------------------------------------------------------------------- /nsource.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Nsource - native source" 3 | Purpose: "Print source for native functions" 4 | Author: "Boleslav Březovský" 5 | Date: "9-2-2018" 6 | ] 7 | 8 | indent: func [ 9 | "(Un)indent text by tab" 10 | string [string!] "Text to (un)indent" 11 | value [integer!] "Positive vales indent, negative unindent" 12 | /space "Use spaces instead of tabs (default is 4)" 13 | /size "Tab size in spaces" 14 | sz [integer!] 15 | ; NOTE: Unindent automaticaly detects tabs/spaces, but for different size than 4, 16 | ; /size refinement must be used (TODO: autodetect space size?) 17 | ; 18 | ; Zero value does automatic unindentation based on first line 19 | ] [ 20 | out: make string! length? string 21 | indent?: positive? value ; indent or unindent? 22 | ending?: equal? newline back tail string ; is there newline on end? 23 | unless size [sz: 4] 24 | tab: either any [space not positive? value] [append/dup copy "" #" " sz] [#"^-"] 25 | if zero? value [ 26 | parse string [ 27 | ; NOTE: The rule will accept comination of tabs and spaces. 28 | ; Probably not a good thing, maybe it can be detected somehow. 29 | some [ 30 | tab (value: value - 1) 31 | | #"^-" (value: value - 1) 32 | | break 33 | ] 34 | to end 35 | ] 36 | ] 37 | data: split string newline 38 | foreach line data [ 39 | loop absolute value [ 40 | case [ 41 | ; indent 42 | indent? [insert line tab] 43 | ; unindent 44 | all [not indent? equal? first line #"^-"] [remove line] 45 | all [not indent? equal? copy/part line sz tab] [remove/part line sz] 46 | ] 47 | ] 48 | ; process output 49 | append out line 50 | append out newline 51 | ] 52 | unless ending? [remove back tail out] ; there wasn't newline on end, remove current 53 | out 54 | ] 55 | 56 | entab: function [ 57 | "Replace spaces at line start with tabs (default size is 4)" 58 | string [string!] 59 | /size "Number of spaces per tab" 60 | sz [integer!] 61 | ] [ 62 | sz: max 1 any [sz 4] 63 | spaces: append/dup clear "" #" " sz 64 | sz: sz - 1 65 | parse string [some [some [not spaces change 1 sz space "" | change spaces tab] thru newline]] 66 | string 67 | ] 68 | 69 | detab: function [ 70 | "Replace tabs at line start with spaces (default size is 4)" 71 | string [string!] 72 | /size "Number of spaces per tab" 73 | sz [integer!] 74 | ] [ 75 | sz: max 1 any [sz 4] 76 | spaces: append/dup clear "" #" " sz 77 | sz: sz - 1 78 | parse string [some [some [spaces | change [0 sz space tab] spaces] thru newline]] 79 | string 80 | ] 81 | 82 | match-bracket: function [ 83 | string [string!] 84 | ] [ 85 | mark: none 86 | level: 0 87 | slevel: 0 88 | subrule: [fail] 89 | string-char: complement charset [#"^""] 90 | mstring-char: complement charset [#"{" #"}"] 91 | string-rule: [ 92 | #"^"" 93 | some [ 94 | {^^"} 95 | | [#"^"" break] 96 | | string-char 97 | ] 98 | ] 99 | mstring-rule: [ ; multiline string 100 | #"{" (slevel: slevel + 1) 101 | some [ 102 | #"{" (slevel: slevel + 1) 103 | | [#"}" (slevel: slevel - 1 subrule: either zero? slevel [[break]] [[fail]]) subrule] 104 | | mstring-char 105 | ] 106 | ] 107 | parse string [ 108 | some [ 109 | {#"["} ; ignore char! 110 | | {#"]"} ; ignore char! 111 | | #"[" (level: level + 1) 112 | | #"]" (level: level - 1 subrule: either zero? level [[break]] [[fail]]) subrule 113 | | string-rule 114 | | mstring-rule 115 | | skip 116 | ] 117 | mark: 118 | ] 119 | mark 120 | ] 121 | 122 | nsource: func [ 123 | 'word 124 | ] [ 125 | if native? get word [ 126 | runtime-link: https://raw.githubusercontent.com/red/red/master/runtime/natives.reds 127 | env-link: https://raw.githubusercontent.com/red/red/master/environment/natives.red 128 | 129 | ; Red/System source 130 | sources: read runtime-link 131 | run-word: append form word #"*" 132 | src: next find/reverse find sources run-word newline ; find source and go back to line start 133 | spec: match-bracket find src #"[" ; skip spec 134 | end: match-bracket find spec #"[" ; skip body 135 | src: copy/part src end ; copy func source 136 | 137 | ; Red header 138 | headers: read env-link 139 | hdr: find headers head append form word #":" 140 | end: back match-bracket spec: next find hdr #"[" ; get spec 141 | spec: copy/part next spec end ; copy func source 142 | if equal? newline spec/1 [remove spec] 143 | 144 | 145 | ; output 146 | print [ 147 | uppercase form word "is native! so source is not available." newline 148 | newline 149 | "Here is latest version of Red/System source code" newline 150 | "which may or may not be same version as you are using" newline 151 | newline 152 | "Native specs:" newline 153 | newline 154 | indent spec 0 155 | newline 156 | "Native Red/System source:" newline 157 | newline 158 | indent src 0 159 | newline 160 | ] 161 | ] 162 | ] -------------------------------------------------------------------------------- /bivi.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Name: "BiVi - binary viewer" 3 | Author: "Boleslav Březovský" 4 | To-Do: [ 5 | "Clear internal console history on exit" 6 | ] 7 | ] 8 | 9 | ;do https://rebolek.com/redquire 10 | ;redquire 'ansi-seq 11 | 12 | bivi!: context [ 13 | data: none 14 | lines-per-page: 8 ; how many lines per page 15 | line: 0 16 | addout: [] 17 | mark-start: 0 18 | mark-end: 0 19 | last-match: none 20 | pattern: none 21 | numbers: charset "1234567890" 22 | hex: charset "1234567890abcdefABCDEF" 23 | 24 | trim-zeroes: func [value][first parse value [collect [some #"0" keep to end]]] 25 | 26 | print-page: func [ 27 | line 28 | /local value ret count infoline length 29 | ][ 30 | length: length? data 31 | infoline: reduce [ 32 | 'cls 33 | 'at 1x1 "Data length: " 34 | 'bold form length " (" trim-zeroes form to-hex length ")" 'reset 35 | " | Page: " form line / lines-per-page "/" form length / lines-per-page / 16 - 1 space 36 | ] 37 | append infoline addout 38 | append infoline "^/" 39 | ansi/do infoline 40 | repeat j lines-per-page [ 41 | ansi/do print-line data line - 1 + j * 16 42 | ] 43 | ret: line 44 | count: 1 45 | count-rule: [ 46 | (count: 1 value: none) 47 | copy value any numbers 48 | (unless empty? value [count: to integer! value]) 49 | ] 50 | main-rule: [ 51 | #"q" (ret: none) 52 | | #"e" count-rule (ret: line + count) ; NEXT LINE ; TODO - check max value 53 | | #"y" count-rule (ret: max 0 line - count) ; PREV LINE 54 | | #"f" count-rule (ret: lines-per-page * count + line) ; TODO: limit at maximum ; NEXT PAGE - default action 55 | | #"b" count-rule (ret: max 0 line - (count * lines-per-page)) ; PREV PAGE - line was already updated, so subtract it twice 56 | | #"/" copy pattern to end (last-match: none ret: find-pattern) ; FIND 57 | | #"n" (ret: find-pattern) ; FIND NEXT 58 | | #"l" copy value some numbers (lines-per-page: to integer! value) ; SET LINES PER PAGE 59 | | copy value 4 hex (ret: (to integer! debase/base value 16) / 16) 60 | | #"h" (print-help) 61 | | (ret: lines-per-page * count + line) 62 | ] 63 | parse ask ":" main-rule 64 | if ret [ret: min ret length / 16 - 8] 65 | ret 66 | ] 67 | print-line: func [ 68 | "return line of 16 values" 69 | data position 70 | /local line hilite? 71 | ][ 72 | hilite?: false 73 | line: copy/part at data position 16 74 | bin-part: copy [] 75 | char-part: copy [] 76 | repeat i 16 [ 77 | char: to integer! line/:i 78 | ; -- highlight mark 79 | if all [ 80 | not zero? mark-start 81 | (position + i - 1) >= mark-start 82 | (position + i - 1) <= mark-end 83 | ][ 84 | ; TODO: turn on hilite only on mark start 85 | hilite?: true 86 | append bin-part 'inverse 87 | append char-part 'inverse 88 | ] 89 | ; -- add character 90 | append bin-part rejoin [form to-hex/size char 2 space] 91 | append char-part case [ 92 | all [char > 31 char < 128][form to char! char] 93 | any [char = 10 char = 13]["↵"] 94 | char = 9 ["⇥"] 95 | 'default [dot] 96 | ] 97 | ; -- end highlighting 98 | if hilite? [ 99 | ; TODO: turn off hilite only after mark end 100 | append bin-part 'reset 101 | append char-part 'reset 102 | hilite?: false 103 | ] 104 | if i = 8 [ 105 | append bin-part space 106 | append char-part space 107 | ] 108 | ] 109 | compose [(form to-hex/size position 4) " | " (bin-part) "| " (char-part)] 110 | ] 111 | find-pattern: func [ 112 | ][ 113 | index: line + 1 114 | unless last-match [last-match: data] 115 | either mark: find last-match pattern [ 116 | last-match: next mark 117 | mark-start: index? mark 118 | mark-end: -1 + (index? mark) + length? pattern 119 | print "in find" 120 | index: (index? mark) / 16 121 | addout: reduce ['bold pattern 'reset space "found at line" space 'bold form index 'reset] 122 | ][ 123 | index: line 124 | if pattern [addout: reduce ['bold pattern 'reset space "not found." 'reset]] 125 | ] 126 | index 127 | ] 128 | print-help: does [ 129 | ansi/do [ 130 | cls 131 | at 1x1 132 | bold "^-NAVIGATION^/^/" reset 133 | "Navigation commands can be followed by numbers to skip more lines/pages.^/^/" 134 | bold "f^-ENTER" reset "^-next page^/" 135 | bold "b" reset "^-^-previous page^/" 136 | bold "e" reset "^-^-next line^/" 137 | bold "y" reset "^-^-previous line^/^/" 138 | bold "/" reset "" "^-search for ^/" 139 | bold "n" reset "^-^-repeat previous search^/^/" 140 | bold "XXXX " reset italic "hex chars" reset "^-go to given offset^/" 141 | "^/^/Press ENTER to continue^/" 142 | ] 143 | input 144 | ] 145 | history-mark: none 146 | set 'bivi func [file][ 147 | history-mark: length? system/console/history 148 | line: 0 149 | data: file 150 | if file? data [data: read/binary data] ; TODO: support url! also? 151 | pages: (length? data) / lines-per-page 152 | unless zero? (length? data) // lines-per-page [pages: pages + 1] 153 | until [ 154 | none? line: print-page line 155 | ] 156 | remove/part system/console/history (length? system/console/history) - history-mark 157 | true 158 | ] 159 | ] 160 | -------------------------------------------------------------------------------- /barbucha.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "Barbucha - collection of tools for fuzzy testing" 3 | Author: "Boleslav Březovsky" 4 | ] 5 | 6 | 7 | comment { 8 | Dialect specs: 9 | 10 | opt [integer!] ; repeat following type X times 11 | opt RANDOM ; return random value 12 | [word!] ; value type 13 | opt ; 14 | 15 | Supported options: 16 | 17 | integer!: 18 | NEGATIVE ; return negative integer 19 | 20 | string!: 21 | LENGTH integer! ; set string length 22 | 23 | 24 | } 25 | 26 | type-templates: [ 27 | datatype! [ 28 | reduce [ 29 | datatype! 30 | first random collect [ 31 | foreach word words-of system/words [ 32 | if datatype? get/any word [keep word] 33 | ] 34 | ] 35 | ] 36 | ] 37 | unset! [[] []] 38 | none! [none] 39 | logic! [[true] [first random [true false]]] 40 | block! [[[foo #bar "baz"]] [collect [loop length [keep random-string length]]]] 41 | paren! [[quote (foo #bar "baz")] []] 42 | string! [["foo"] [random-string length]] 43 | file! [[%foo.bar]] 44 | url! [[http://foo.bar]] 45 | char! [[#"x"] [random 1FFFFFh]] 46 | integer! [[0] [random 2147483647]] ; TODO: also negative integers and switch in dialect for it 47 | float! [[0.0] [random 1.797693134862315e308]] 48 | word! [['foo] [to word! random-string length]] 49 | set-word! [[quote foo:] [to set-word! random-string length]] 50 | lit-word! [[quote 'foo] [to lit-word! random-string length]] 51 | get-word! [[quote :foo] [to get-word! random-string length]] 52 | refinement! [[/foo] [to refinement! random-string length]] 53 | issue! [[#foo] [to issue! random-string length]] 54 | native! [] 55 | action! [] 56 | op! [] 57 | function! [] 58 | path! [[quote foo/bar/baz]] 59 | lit-path! [[quote 'foo/bar/baz]] 60 | set-path! [[quote foo/bar/baz:]] 61 | get-path! [quote :foo/bar/baz] 62 | routine! [] 63 | bitset! [[charset "bar"] [charset random-string length]] 64 | point! [] 65 | object! [] 66 | typeset! [] 67 | error! [] 68 | vector! [[make vector! [integer! 8 10]]] 69 | hash! [[make hash! [foo bar baz]]] 70 | pair! [[0x0] [random 2147483647x2147483647]] 71 | percent! [[0%] [random 1.797693134862315e308%]] 72 | tuple! [[0.0.0] [random 255.255.255]] ; TODO: support different length 73 | map! [[#(foo: bar)]] 74 | binary! [[#{deadcafe}]] 75 | time! [[11:22:33]] 76 | tag! [[]] 77 | email! [[foo@bar.baz]] 78 | handle! [] 79 | date! [[27-2-2011]] 80 | ] 81 | 82 | random-string: func [ 83 | "Return random string" 84 | length 85 | ; TODO: support description dialect 86 | ][ 87 | unless length [length: 8] 88 | collect/into [loop length [keep #"`" + random 26]] copy {} 89 | ] 90 | 91 | random-map: func [ 92 | "Return random map" 93 | size 94 | /depth 95 | level 96 | /local 97 | make-map map maps out key 98 | ][ 99 | ; currently creates random map with words as keys and strings as values. 100 | make-map: func [size][ 101 | to map! make-type collect [ 102 | loop size [ 103 | keep compose [ 104 | random word! 105 | random string! length (random 1000) 106 | ] 107 | ] 108 | ] 109 | ] 110 | either level [ 111 | maps: collect [ 112 | loop level [ 113 | keep make-map size 114 | ] 115 | ] 116 | map: out: take maps 117 | until [ 118 | key: to word! random-string 8 119 | map/:key: take maps 120 | map: map/:key 121 | empty? maps 122 | ] 123 | out 124 | ][ 125 | make-map size 126 | ] 127 | ] 128 | 129 | context [ 130 | action: none 131 | length: 8 132 | 133 | rules: [ 134 | float! integer! pair! percent! [['negative (action: [negate value])]] 135 | string! word! set-word! get-word! lit-word! [[ 136 | 'length set value integer! (pre-action: compose [length: (value)]) 137 | ]] 138 | ] 139 | 140 | 141 | set 'make-type func [ 142 | "Return default value of given type" 143 | type [datatype! block!] "Type of value or dialect specs" 144 | /random "Return random value of given type" 145 | /local 146 | species values results 147 | repetition 148 | ][ 149 | if datatype? type [type: reduce [type]] 150 | species: 1 ; 1 - default, 2 - random 151 | length: 8 ; default length for random strings 152 | repetition: 1 153 | values: copy [] ; internal "dialect": [type random? options] 154 | results: copy [] 155 | 156 | parse type [ 157 | some [ 158 | (species: repetition: 1) 159 | (pre-action: action: none) 160 | (length: 8) 161 | opt [set repetition integer!] 162 | opt ['random (species: 2)] 163 | set type skip 164 | (opt-rule: switch to word! type rules) 165 | opt opt-rule 166 | ( 167 | loop repetition [ 168 | repend values [to word! type species pre-action action] 169 | ] 170 | ) 171 | ] 172 | ] 173 | 174 | foreach [type species pre-act act] values [ 175 | ; NOTE: This is bit crazy, but when binding length directly, 176 | ; code not using length somehow stops working 177 | length: 8 178 | do pre-act 179 | value: select type-templates type 180 | value: any [pick value species first value] 181 | value: func [length] value 182 | value: value length 183 | if action [value: do action] 184 | append/only results value 185 | ] 186 | results 187 | ] 188 | ] 189 | -------------------------------------------------------------------------------- /send-request.md: -------------------------------------------------------------------------------- 1 | # SEND-REQUEST 2 | 3 | Simplifies sending HTTP requests: 4 | 5 | * Automaticaly translates data from Red values to url-encoded strings and JSON. 6 | * Handles authentication. 7 | * Makes handling HTTP headers easier. 8 | * Translates response to Red values based on MIME type. 9 | 10 | ## Usage 11 | 12 | `SEND-REQUEST link method` 13 | 14 | * `link [url!]` is HTTP(S) address 15 | * `method [word!]` is one of HTTP methods (`GET`, `HEAD`, `POST`, `PUT`, 16 | `DELETE`, `CONNECT`, `OPTIONS`, `TRACE`). 17 | 18 | ## Data handling 19 | 20 | With most requests, user wants to send some data. This is handled with 21 | `/data` refinement which accepts `content` value that can be of multiple 22 | datatypes: 23 | 24 | ### string! 25 | 26 | The most basic type is `string!` which is passed as is. 27 | 28 | ``` 29 | send-request/data server 'POST "key1=val1&key2=val2" 30 | ``` 31 | 32 | ### map! and object! 33 | 34 | `map!` and `object!` are converted to JSON and `Content-Type` is set to 35 | `application/json` 36 | 37 | ``` 38 | send-request/data server 'POST #(key1: "val1" key2: 2) 39 | 40 | send-request/data server 'POST context [key1: "val1" key2: 2] 41 | ``` 42 | 43 | ### block! 44 | 45 | `block!` can be used as multi-puropse dialect. Simplest variant are pairs 46 | of `set-word!` keys and values that are represented as `application/x-www-form-urlencoded`: 47 | 48 | ``` 49 | send-request/data server 'POST [key1: "val1" key2 2] 50 | ``` 51 | 52 | `block!` can be used with `GET` method also, in that case it's translated to 53 | URL: 54 | 55 | ``` 56 | send-request/data http://www.example.com 'GET [key: "val1" key2 2] 57 | == http://www.example.com?key1=val1&key2=2 58 | ``` 59 | 60 | It's possible to send JSON array using `block!`. In such case use `#json` 61 | as first value in block, everything else is treated as values in JSON array: 62 | 63 | ``` 64 | send-request/data server 'POST [#JSON this is json array] 65 | == (...) {["this", "is", "json", "array"]} 66 | ``` 67 | 68 | `block!` can also be used to send `multipart/form-data`. Use `#multi` as a 69 | first value to specify that what follows are form data. They use same format 70 | as plain form, `set-word!` followed by value with two extensions: 71 | 72 | 1. it's possible to specify `Content-Type` by adding `path!` after value: 73 | 74 | ``` 75 | send-request/data server 'POST [ 76 | #multi 77 | key0: "plain text without MIME type" 78 | key1: "plain text with MIME type" text/plain 79 | key2: {{"jsonkey": "json value"}} application/json 80 | ] 81 | ``` 82 | 83 | 2. you can upload files also by having `file!` value: 84 | 85 | ``` 86 | send-request/data server 'POST [#multi upload-file: %some.file] 87 | ``` 88 | 89 | `send-request` tries to auto-detect wheter file is binary or text, you can 90 | specify it manually by `text`, `bin` or `binary` postfix: 91 | 92 | ``` 93 | send-request/data server 'POST [ 94 | #multi 95 | file1: %text-file.txt text 96 | file2: %picture.jpg bin 97 | file3: %song.mp3 binary 98 | ] 99 | ``` 100 | 101 | it's not possible to specify MIME type of file, it's either `text/plain` or 102 | `application/octet-stream`. 103 | 104 | ### Refinements 105 | 106 | #### /only 107 | 108 | Return reply only without headers. 109 | 110 | #### /with headers 111 | 112 | Headers to send with requests. Should be `map!` or `block!` of key/value 113 | pairs. 114 | 115 | #### /auth auth-type auth-data 116 | 117 | Authentication method and data. 118 | 119 | Supported methods: `basic`, `bearer`. 120 | 121 | * `basic` method expects data to be `block!` with two values, **user** and 122 | **password**. 123 | 124 | * `bearer` method expects data to be `string!` with token. 125 | 126 | #### /raw 127 | 128 | Return raw data and do not try to decode them. Useful for debugging purposes. 129 | 130 | #### /verbose 131 | 132 | Print request informations. Useful for debugging purposes. 133 | 134 | #### /debug 135 | 136 | Set debug words: 137 | 138 | * `req` - block with two values: `link` and `data`. Link is address of HTTP 139 | request, in case of `GET` method with url-encoded data. `data` is block of 140 | headers and encoded data. 141 | 142 | * `raw-reply` - binary reply returned from server 143 | 144 | * `loaded-reply` - reply converted to `string!`. Unlike Red, `send-request` 145 | tries to convert also non-UTF8 strings using very naive method (no codepage 146 | conversion), so the results may vary. 147 | 148 | ## Examples 149 | 150 | #### GET request 151 | 152 | Simple request with no data (in such case, use just `read http://example.org` 153 | instead): 154 | 155 | `send-request http://example.org 'GET` 156 | 157 | GET request with FORM data: 158 | 159 | `send-request/data http://example.org 'GET [name: "Albert Einstein" age: 140]` 160 | 161 | GET request with headers: 162 | 163 | `send-request/with http://example.org 'GET [Accept-Charset: utf-8]` 164 | 165 | GET request with basic authentication: 166 | 167 | `send-request/auth http://example.org 'GET 'basic ["username" "my-secret-passw0rd"]` 168 | 169 | GET request with bearer token: 170 | 171 | `send-request/auth http://example.org 'GET 'bearer "abcd1234cdef5678"` 172 | 173 | #### POST request 174 | 175 | POST request with HTTP FORM data: 176 | 177 | `send-request/data http://example.org 'POST [name: "Albert Einstein" age: 140]` 178 | 179 | POST request with JSON data: 180 | 181 | `send-request/data http://example.org 'POST #(name: "Albert Einstein" age: 140)` 182 | 183 | POST request with multiple form data: 184 | 185 | ``` 186 | send-request/data http://example.org 'POST [ 187 | #multi 188 | name: "Albert Einstein" 189 | age: 140 text/plain 190 | json: #(first-name: "Albert" last-name: "Einstein") 191 | image: %albert.jpg 192 | ] 193 | ``` 194 | -------------------------------------------------------------------------------- /tests/graphql-tests.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "GraphQL tests" 3 | Author: "Boleslav Březovský" 4 | Usage: { 5 | 6 | Load tests with `do %graphql-tests.red` 7 | 8 | ### Validate test 9 | 10 | `graphql/validate tests/` 11 | 12 | Where `index` is test id. 13 | 14 | Validation will return TRUE if the test unit can be parsed. 15 | 16 | ### Check test 17 | 18 | check-test 19 | 20 | Converts GraphQL test unit to Red format and then back to GraphQL. 21 | Then it compares minified version of both units to see if the conversion went 22 | right. Units are minified so the whitespaces don’t matter in the comparison. 23 | 24 | compare-test 25 | 26 | Prints original minified test unit and converted version on separate 27 | lines. 28 | } 29 | Links: [ 30 | https://graphql.org/ 31 | Tests: https://github.com/graphql/graphql-js/tree/main/src/__tests__ 32 | ] 33 | ] 34 | 35 | check-test: func [index /local qgl results] [ 36 | results: copy [] 37 | if integer? index [index: reduce [index]] 38 | if equal? true index [ 39 | index: collect [ 40 | repeat local length? tests [keep local] 41 | ] 42 | ] 43 | foreach test index [ 44 | test: pick tests test 45 | gql: graphql/decode test 46 | append results equal? graphql/minify test graphql/encode gql 47 | ] 48 | results 49 | ] 50 | 51 | compare-test: func [index] [ 52 | print [ 53 | mold graphql/minify tests/:index 54 | newline 55 | mold graphql/encode graphql/decode tests/:index 56 | ] 57 | ] 58 | 59 | tests: [ 60 | ; ---[1] 61 | { 62 | mutation { 63 | likeStory(storyID: 12345) { 64 | story { 65 | likeCount 66 | } 67 | } 68 | } 69 | } 70 | ; ---[2] 71 | { 72 | { 73 | me { 74 | id 75 | firstName 76 | lastName 77 | birthday { 78 | month 79 | day 80 | } 81 | friends { 82 | name 83 | } 84 | } 85 | } 86 | } 87 | ; ---[3] 88 | { 89 | # `me` could represent the currently logged in viewer. 90 | { 91 | me { 92 | name 93 | } 94 | } 95 | } 96 | ; ---[4] 97 | { 98 | # `user` represents one of many users in a graph of data, referred to by a 99 | # unique identifier. 100 | { 101 | user(id: 4) { 102 | name 103 | } 104 | } 105 | } 106 | ; ---[5] 107 | { 108 | { 109 | user(id: 4) { 110 | id 111 | name 112 | profilePic(size: 100) 113 | } 114 | } 115 | } 116 | ; ---[6] 117 | { 118 | { 119 | user(id: 4) { 120 | id 121 | name 122 | profilePic(width: 100, height: 50) 123 | } 124 | } 125 | } 126 | ; ---[7] 127 | { 128 | { 129 | user(id: 4) { 130 | id 131 | name 132 | smallPic: profilePic(size: 64) 133 | bigPic: profilePic(size: 1024) 134 | } 135 | } 136 | } 137 | ; ---[8] 138 | { 139 | query noFragments { 140 | user(id: 4) { 141 | friends(first: 10) { 142 | id 143 | name 144 | profilePic(size: 50) 145 | } 146 | mutualFriends(first: 10) { 147 | id 148 | name 149 | profilePic(size: 50) 150 | } 151 | } 152 | } 153 | } 154 | ; ---[9] 155 | { 156 | query withFragments { 157 | user(id: 4) { 158 | friends(first: 10) { 159 | ...friendFields 160 | } 161 | mutualFriends(first: 10) { 162 | ...friendFields 163 | } 164 | } 165 | } 166 | 167 | fragment friendFields on User { 168 | id 169 | name 170 | profilePic(size: 50) 171 | } 172 | } 173 | ; ---[10] 174 | { 175 | query withNestedFragments { 176 | user(id: 4) { 177 | friends(first: 10) { 178 | ...friendFields 179 | } 180 | mutualFriends(first: 10) { 181 | ...friendFields 182 | } 183 | } 184 | } 185 | 186 | fragment friendFields on User { 187 | id 188 | name 189 | ...standardProfilePic 190 | } 191 | 192 | fragment standardProfilePic on User { 193 | profilePic(size: 50) 194 | } 195 | } 196 | ; ---[11] 197 | { 198 | query FragmentTyping { 199 | profiles(handles: ["zuck", "cocacola"]) { 200 | handle 201 | ...userFragment 202 | ...pageFragment 203 | } 204 | } 205 | 206 | fragment userFragment on User { 207 | friends { 208 | count 209 | } 210 | } 211 | 212 | fragment pageFragment on Page { 213 | likers { 214 | count 215 | } 216 | } 217 | } 218 | ; ---[12] 219 | { 220 | query inlineFragmentTyping { 221 | profiles(handles: ["zuck", "cocacola"]) { 222 | handle 223 | ... on User { 224 | friends { 225 | count 226 | } 227 | } 228 | ... on Page { 229 | likers { 230 | count 231 | } 232 | } 233 | } 234 | } 235 | } 236 | ; ---[13] 237 | { 238 | query inlineFragmentNoType($expandedInfo: Boolean) { 239 | user(handle: "zuck") { 240 | id 241 | name 242 | ... @include(if: $expandedInfo) { 243 | firstName 244 | lastName 245 | birthday 246 | } 247 | } 248 | } 249 | } 250 | ; ---[14] 251 | { 252 | { 253 | entity { 254 | name 255 | ... on Person { 256 | age 257 | } 258 | }, 259 | phoneNumber 260 | } 261 | } 262 | ] 263 | 264 | more-tests: [ 265 | ; ---[15] 266 | { 267 | { 268 | "profiles": [ 269 | { 270 | "handle": "zuck", 271 | "friends": { "count" : 1234 } 272 | }, 273 | { 274 | "handle": "cocacola", 275 | "likers": { "count" : 90234512 } 276 | } 277 | ] 278 | } 279 | } 280 | ] 281 | 282 | test-query.graphql: { 283 | query { 284 | repository(owner:"octocat", name:"Hello-World") { 285 | issues(last:20, states:CLOSED) { 286 | edges { 287 | node { 288 | title 289 | url 290 | labels(first:5) { 291 | edges { 292 | node { 293 | name 294 | } 295 | } 296 | } 297 | } 298 | } 299 | } 300 | } 301 | } 302 | } 303 | 304 | test-query: [ 305 | repository (owner: "octocat" name: "Hello-World") [ 306 | issues (last: 20 states: CLOSED) [ 307 | edges [ 308 | node [ 309 | title 310 | url 311 | labels (first: 5) [ 312 | edges [ 313 | node [ 314 | name 315 | ] 316 | ] 317 | ] 318 | ] 319 | ] 320 | ] 321 | ] 322 | ] 323 | -------------------------------------------------------------------------------- /ansi-seq.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "Ansi sequence dialect" 3 | Author: "Boleslav Březovský" 4 | Usage: { 5 | # Function 6 | 7 | ANSI/DO block! - print dialect 8 | ANSI/TRANS block! - convert dialect to string! 9 | 10 | # Dialect 11 | 12 | CLS - clear screen 13 | CLEAR - clear screen 14 | CLEAR LINE - clear whole line 15 | CLEAR LINE LEFT - clear line from cursor to line start 16 | CLEAR LINE RIGHT - clear line from cursor to line end 17 | CLEAR SCREEN - clear screen 18 | CLEAR SCREEN UP - clear screen from cursor to top of screen 19 | CLEAR SCREEN DOWN - clear screen from cursor to bottom of screen 20 | AT pair! - put curspor at position 21 | FG word! - set foregroud to color 22 | BG word! - set background to color 23 | BOLD - set bold style 24 | ITALIC - set italic style 25 | UNDERLINE - set underline style 26 | UP - move cursor up 27 | DOWN - move cursor down 28 | LEFT - move cursor left 29 | RIGHT - move cursor right 30 | RESET - reset all styles 31 | } 32 | ] 33 | 34 | ansi: context [ 35 | 36 | win?: system/platform = 'Windows 37 | 38 | esc-main: "^[[" 39 | clear-screen: append copy esc-main "2J" 40 | set-position: func [position][ 41 | rejoin [esc-main form position/y #";" form position/x #"H"] 42 | ] 43 | 44 | demo: does [ 45 | do [cls at 1x1 fg red "Welcome to " fg black bg white "A" bg yellow "N" bg red "S" bg magenta "I" reset bold space underline fg bright green "con" reset fg green italic "sole" reset] 46 | ] 47 | 48 | colors: [black red green yellow blue magenta cyan white none default] 49 | 50 | as-rule: func [block][ 51 | block: collect [ 52 | foreach value block [keep reduce [to lit-word! value '|]] 53 | ] 54 | also block take/last block 55 | ] 56 | 57 | colors-list: as-rule colors 58 | color-rule: [ 59 | set type ['fg | 'bg] 60 | (bright?: false) 61 | opt ['bright (bright?: true)] 62 | set value colors-list 63 | keep ( 64 | type: pick [3 4] equal? 'fg type 65 | if bright? [type: type + 6] 66 | value: -1 + index? find colors value 67 | either win? [""][ 68 | rejoin [esc-main form type value #"m"] 69 | ] 70 | ) 71 | ] 72 | move-rule: [ 73 | (value: 1) 74 | set type ['up | 'down | 'left | 'right] 75 | opt [set value integer!] 76 | keep (rejoin [esc-main form value #"@" + index? find [up down left right] type]) 77 | ] 78 | style-rule: [ 79 | set type ['bold | 'italic | 'underline | 'inverse] 80 | keep ( 81 | either win? [""][ 82 | rejoin [esc-main form select [bold 1 italic 3 underline 4 inverse 7] type #"m"] 83 | ] 84 | ) 85 | ] 86 | clear-rule: [ 87 | (type: value: none) 88 | 'clear 89 | opt [ 90 | set type [ 91 | 'line opt [set value ['left | 'right]] 92 | | 'screen opt [set value ['up | 'down]] 93 | ] 94 | ] 95 | keep ( 96 | case [ 97 | not type (rejoin [esc-main "2J"]) 98 | type = 'line [ 99 | rejoin [ 100 | esc-main 101 | switch/default value [left "1" right "0"]["2"] 102 | #"K" 103 | ] 104 | ] 105 | type = 'screen [ 106 | rejoin [ 107 | esc-main 108 | switch/default value [up "1" down "0"]["2"] 109 | #"J" 110 | ] 111 | ] 112 | ] 113 | ) 114 | ] 115 | type: value: bright?: none 116 | 117 | trans: func [ 118 | data 119 | ][ 120 | parse data [ 121 | collect [ 122 | some [ 123 | 'reset keep (either win? [""][rejoin [esc-main "0m"]]) 124 | | 'cls keep (clear-screen) 125 | | clear-rule 126 | | style-rule 127 | | move-rule 128 | | color-rule 129 | | 'at set value pair! keep (set-position value) 130 | | keep [word! | string! | char!] 131 | ] 132 | ] 133 | ] 134 | ] 135 | 136 | do: func [data][ 137 | if block? data [data: trans data] 138 | print rejoin data 139 | ] 140 | 141 | vline: func [ 142 | pos 143 | height 144 | ][ 145 | collect [ 146 | repeat i height [ 147 | keep reduce ['at pos + (i * 0x1) "│"] 148 | ] 149 | ] 150 | ] 151 | 152 | tui: func [ 153 | data 154 | /local cmd value stack 155 | box-rule 156 | ][ 157 | stack: [] 158 | dialect: clear [] 159 | box-rule: [ 160 | (clear stack) 161 | 'box 162 | set value pair! (append stack value) 163 | set value pair! (append stack value) 164 | ( 165 | width: stack/2/x - stack/1/x - 1 166 | height: stack/2/y - stack/1/y - 1 167 | repend dialect ['at stack/1 + 1x0 append/dup copy "" #"─" width] ; top line 168 | repend dialect ['at stack/1 + (height + 1 * 0x1) + 1x0 append/dup copy "" #"─" width] ; bottom line 169 | append dialect vline stack/1 height 170 | append dialect vline stack/1 + 1x0 + (width * 1x0) height 171 | repend dialect ['at stack/1 "┌"] ; top-left copner 172 | repend dialect ['at stack/1 + (width + 1 * 1x0) "┐"] ; top-right corner 173 | repend dialect ['at stack/1 + (height + 1 * 0x1) "└"] ; bottom-left copner 174 | repend dialect ['at stack/2 "┘"] ; bottom-right copner 175 | ) 176 | ] 177 | pass-rule: [ 178 | set value skip (append dialect value) 179 | ] 180 | parse data [ 181 | some [ 182 | box-rule 183 | | pass-rule 184 | ] 185 | ] 186 | dialect 187 | ] 188 | 189 | ; --- DECODER 190 | 191 | octet: charset "01234567" 192 | m: #"m" 193 | 194 | set-color: func [color][ 195 | if char? color [color: to integer! color - 48] 196 | pick colors color + 1 197 | ] 198 | 199 | ansi-seqs: [ 200 | "2J" ; clear screen 201 | | #"3" set value octet m (cmd: reduce ['fg set-color value] emit) ; foreground 202 | | #"4" set value octet m (cmd: reduce ['bg set-color value] emit) ; background 203 | | "0m" (cmd: 'reset emit) 204 | | "1m" (cmd: 'bold emit) 205 | | "3m" (cmd: 'italic emit) 206 | | "4m" (cmd: 'underline emit) 207 | ] 208 | 209 | decode-rules: [ 210 | some [ 211 | esc-main ansi-seqs 212 | | set value skip (append str value) 213 | ] 214 | ] 215 | 216 | emit: does [ 217 | append result copy str 218 | if cmd [append result cmd] 219 | clear str 220 | cmd: none 221 | ] 222 | 223 | result: [] 224 | str: "" 225 | cmd: none 226 | 227 | decode: func [ 228 | string 229 | ][ 230 | clear str 231 | clear result 232 | parse string decode-rules 233 | emit 234 | result 235 | ] 236 | 237 | ; -- end of context 238 | ] 239 | -------------------------------------------------------------------------------- /apis/github-v4.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "GitHub API v4" 3 | Author: "Boleslav Březovský" 4 | ] 5 | 6 | do %../graphql.red 7 | do %../http-tools.red 8 | 9 | github: context [ 10 | 11 | token: none 12 | result: none 13 | 14 | ; === Query ================================================================== 15 | 16 | ; type description (taken from https://developer.github.com/v4/reference/query/) 17 | 18 | connections: [ 19 | first [integer!] ; Returns the first n elements from the list. 20 | after [string!] ; Returns the elements in the list that come after the specified global ID. 21 | last [integer!] ; Returns the last n elements from the list. 22 | before [string!] ; Returns the elements in the list that come before the specified global ID. 23 | query [string!] ; The search string to look for. 24 | type [search-type!] ; The types of search items to search within. 25 | ] 26 | 27 | fields: [ 28 | codeOfConduct [ 29 | "Look up a code of conduct by its key" 30 | key [string!] "The code of conduct's key" 31 | ] 32 | codesOfConduct [ 33 | "Look up a code of conduct by its key" 34 | ] 35 | node [ 36 | "Fetches an object given its ID" 37 | id [id!] "ID of the object" 38 | ] 39 | nodes [ 40 | "Lookup nodes by a list of IDs" 41 | ids [some id!] "The list of node IDs" 42 | ] 43 | organization [ 44 | "Lookup a organization by login" 45 | login [string!] "The organization's login" 46 | ] 47 | rateLimit [ 48 | "The client's rate limit information" 49 | ] 50 | relay [ 51 | "Hack to workaround https://github.com/facebook/relay/issues/112 re-exposing the root query object" 52 | ] 53 | repository [ 54 | "Lookup a given repository by the owner and repository name" 55 | owner [string!] "The login field of a user or organization" 56 | name [string!] "The name of the repository" 57 | ] 58 | repositoryOwner [ 59 | "Lookup a repository owner (ie. either a User or an Organization) by login" 60 | login [string!] "The username to lookup the owner by" 61 | ] 62 | resource [ 63 | "Lookup resource by a URL" 64 | url [url!] "The URL" 65 | ] 66 | topic [ 67 | "Lookup a topic by name" 68 | name [string!] "The topic's name" 69 | ] 70 | user [ 71 | "Lookup a user by login" 72 | login [string!] "The user's login" 73 | ] 74 | viewer [ 75 | "The currently authenticated user" 76 | ] 77 | ] 78 | 79 | sanitize: func [ 80 | "Perform some escaping and optimization" 81 | string [string!] 82 | ] [ 83 | parse string [ 84 | some [ 85 | change #"^"" {\"} 86 | | change #"^/" {} ; TODO: change to escaping? 87 | | skip 88 | ] 89 | ] 90 | string 91 | ] 92 | 93 | ; === main function ========================================================== 94 | 95 | send: func [ 96 | query 97 | /var 98 | vars 99 | ] [ 100 | if block? query [query: graphql/encode query] 101 | if all [var not string? vars] [vars: json/encode vars] 102 | query: rejoin [{^{"query": "} sanitize query {"^}}] 103 | if vars [ 104 | insert back tail query rejoin [{, "variables": } trim/lines vars] 105 | ] 106 | result: send-request/data/auth https://api.github.com/graphql 'POST probe query 'Bearer token 107 | result/data 108 | ] 109 | ] 110 | 111 | 112 | ; Testing: 113 | ; 114 | ; (set TOKEN in global context (temporary)) 115 | ; 116 | ; ret: github graphql/encode test-query 117 | ; 118 | ; var example: 119 | ; 120 | ; ret: github/var graphql/encode [query ('number_of_repos Int!) [viewer [name repositories (last: :number_of_repos) [nodes [name]]]]] json/encode #(number_of_repos 3) 121 | ; 122 | ; 123 | ; --- 124 | ; 125 | ; d: {{"query":"query { viewer { login}}"}} 126 | ; r: send-request/data/auth https://api.github.com/graphql 'POST d 'Bearer token 127 | 128 | 129 | ; Usage 130 | ; 131 | ; get repository: 132 | ; 133 | ;query { 134 | ; organization(login: "red") { 135 | ; name 136 | ; url 137 | ; repository(name: "red") { 138 | ; name 139 | ; } 140 | ; } 141 | ;} 142 | ; 143 | ; query [organization (login: "red") [name url repository (name: "red") [name]]] 144 | ; 145 | ; get last 10 issues (title): 146 | ; 147 | ;query { 148 | ; organization(login: "red") { 149 | ; name ; not required 150 | ; url ; not required 151 | ; repository(name: "red") { 152 | ; name 153 | ; issues (last: 10) {edges {node {title}}} 154 | ; } 155 | ; } 156 | ;} 157 | ; 158 | ; query [organization (login: "red") [repository (name: "red") [issues (last: 10) [edges [node [title]]]]]] 159 | 160 | 161 | ; add comment to issue: 162 | ;query FindIssueID { 163 | ; repository(owner:"rebolek", name:"red-tools") { 164 | ; id 165 | ; issue(number:1) { 166 | ; id 167 | ; } 168 | ; } 169 | ;} 170 | ; 171 | ; NOTE: subjectId is (issue) id from above query, clientMutationId is (repository) id 172 | ; 173 | ;mutation AddCommentToIssue { 174 | ; addComment(input: {subjectId: "MDU6SXNzdWUyMzEzOTE1NTE=", body: "testing comment", clientMutationId: "MDEwOlJlcG9zaXRvcnk3OTM5MjA0OA=="}) { 175 | ; clientMutationId 176 | ; } 177 | ;} 178 | ; 179 | ; red version: 180 | ; 181 | ; query FindIssueId [repository (owner: "rebolek" name: "red-tools") [issue (number: 1) [id]]] 182 | ; mutation AddCommentToIssue [ 183 | ; addComment (input: [subjectId: "MDU6SXNzdWUyMzEzOTE1NTE=" clientMutationId: "MDEwOlJlcG9zaXRvcnk3OTM5MjA0OA==" body: "it works!"]) [ 184 | ; clientMutationId 185 | ; ] 186 | ; ] 187 | 188 | comment-issue: function [ 189 | repo 190 | issue-id 191 | text 192 | ; usage: comment-issue 'owner/repo 123 "blablabla" 193 | ] [ 194 | reply: github/send reduce [ 195 | 'query 'FindIssueId reduce [ 196 | 'repository to paren! compose [ 197 | owner: (form repo/1) name: (form repo/2) 198 | ] 199 | reduce ['id 'issue to paren! compose [number: (issue-id)] [id]] 200 | ] 201 | ] 202 | if equal? "Bad credentials" reply/message [ 203 | ; TODO: Use `cause-error` here, once I understand it 204 | return make error! "Bad credentials" 205 | ] 206 | input: make map! compose [ 207 | subjectId: (reply/data/repository/issue/id) 208 | clientMutationId: (reply/data/repository/id) 209 | body: (text) 210 | ] 211 | reply: github/send reduce [ 212 | 'mutation 'AddCommentToIssue reduce [ 213 | 'addComment to paren! compose/deep [input: (input)] [clientMutationId] 214 | ] 215 | ] 216 | ; return mutation-id (or something else? who knows...) 217 | reply/data/addComment/clientMutationId 218 | ] 219 | -------------------------------------------------------------------------------- /codecs/bson.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Notes: [ 3 | "INT64, UINT64 and DEC128 are kept as binary!" 4 | ] 5 | Todo: [ 6 | "Test #10 - regex" 7 | "Test #24 - binary data" 8 | "Test #25 (and some others) - 06 - deprecated" 9 | "Test #40 (and some others) - error" 10 | "Test #52 - empty (shouldn't be)" 11 | "Test #55 - Invalid UTF8" 12 | ] 13 | ] 14 | 15 | as-bin: func [value] [lowercase enbase/base value 16] 16 | char: func [value] [ 17 | case [ 18 | not value [""] 19 | all [value > 31 value < 128] [to char! value] 20 | 'else [#"."] 21 | ] 22 | ] 23 | 24 | xxd: func [value /local index line out text] [ 25 | value: copy value 26 | index: 0 27 | until [ 28 | line: take/part value 16 29 | out: rejoin [ 30 | as-bin to binary! index 31 | ": " 32 | ] 33 | text: clear "" 34 | until [ 35 | append text char line/1 36 | append text char line/2 37 | append out as-bin take/part line 2 38 | append out space 39 | empty? line 40 | ] 41 | append/dup out space 51 - length? out 42 | print [out text] 43 | index: index + 16 44 | empty? value 45 | ] 46 | exit 47 | ] 48 | 49 | 50 | 51 | path: %../libbson/tests/binary/ 52 | 53 | bson: context [ 54 | 55 | doc: 56 | output: 57 | target: none 58 | stack: copy [] 59 | name-stack: copy [] 60 | 61 | name: key: value: none 62 | length: doc-length: 0 63 | 64 | emit: none 65 | emit-red: quote (put target name value) 66 | ; TODO: Is this a proper way to decode date? 67 | load-date: quote (value: to date! to integer! copy/part value 4) 68 | load-array: quote (value: values-of value) 69 | 70 | byte: [copy value skip] 71 | i32: [copy value 4 skip (value: to integer! reverse value)] 72 | i64: [copy value 8 skip] 73 | u64: [copy value 8 skip] 74 | double: [copy value 8 skip (value: to float! reverse value)] 75 | decimal128: [copy value 16 skip] 76 | 77 | null: #"^@" 78 | char: charset reduce ['not null] 79 | c_string: [copy value to null skip] 80 | string: [ 81 | i32 (length: value - 1) 82 | copy value length skip 83 | null 84 | (value: to string! value) 85 | ] 86 | binary: [ 87 | i32 (length: value) 88 | subtype 89 | copy value length skip 90 | ] 91 | subtype: [ 92 | #"^(00)" (bin-type: 'generic) 93 | | #"^(01)" (bin-type: 'function) 94 | | #"^(02)" (bin-type: 'binary-old) 95 | | #"^(03)" (bin-type: 'uuid-old) 96 | | #"^(04)" (bin-type: 'uuid) 97 | | #"^(05)" (bin-type: 'md5) 98 | | #"^(06)" (bin-type: 'encrypted-bson-value) 99 | ] 100 | 101 | ; FIXME: This naive set-word conversion may fail on more complicated keys 102 | ; e_name: [c_string (name: probe to set-word! to string! value)] 103 | e_name: [c_string (name: to string! value)] 104 | 105 | document: [ 106 | i32 (doc-length: value) 107 | (print ["DOC LEN:" doc-length]) 108 | any [t: (probe t) element] 109 | null 110 | ] 111 | 112 | sub-doc: [ 113 | (insert stack target) 114 | (target: copy #()) 115 | e_name 116 | (insert name-stack name) 117 | document 118 | (name: take name-stack) 119 | (value: target) 120 | (target: take stack) 121 | ; emit 122 | ] 123 | 124 | element: [ 125 | #"^(01)" e_name double emit ; 64bit float 126 | | #"^(02)" e_name string emit ; UTF-8 string 127 | | #"^(03)" sub-doc emit ; embedded doc 128 | | #"^(04)" sub-doc load-array emit ; array 129 | | #"^(05)" e_name binary emit ; binary data 130 | ; #"^(06)" - deprecated 131 | | #"^(07)" e_name copy value 12 skip emit ; object-id 132 | | #"^(08)" e_name #"^(00)" (value: false) emit ; logic TRUE 133 | | #"^(08)" e_name #"^(01)" (value: true) emit ; logic FALSE 134 | | #"^(09)" e_name i64 load-date emit ; UTC datetime 135 | | #"^(0A)" e_name (value: none) emit ; null value 136 | | #"^(0B)" e_name 137 | c_string (pattern: value) 138 | c_string (options: value) 139 | ; TODO: emit 140 | ; #"^(0C)" - deprecated 141 | | #"^(0D)" e_name string emit ; JS code 142 | ; #"^(0E)" - deprecated 143 | ; #"^(0F)" - deprecated 144 | | #"^(10)" e_name i32 emit ; 32bit integer 145 | | #"^(11)" e_name u64 emit ; timestamp 146 | | #"^(12)" e_name i64 emit ; 64bit integer 147 | | #"^(13)" e_name decimal128 emit ; 128bit decimal FP 148 | | #"^(FF)" e_name ; min key - TODO: emit 149 | | #"^(7F)" e_name ; max key - TODO: emit 150 | 151 | ] 152 | 153 | init-loader: does [ 154 | output: copy #() 155 | target: output 156 | stack: copy [] 157 | emit: :emit-red 158 | ] 159 | 160 | set 'load-bson func [data [binary! file!]] [ 161 | if file? data [data: read/binary data] 162 | init-loader 163 | parse data document 164 | output 165 | ] 166 | 167 | init-emitter: does [ 168 | output: copy #{} 169 | ] 170 | 171 | emit-bson: func [value] [ 172 | append output value 173 | ] 174 | 175 | emit-string: func [value] [ 176 | append output value 177 | append output null 178 | ] 179 | 180 | emit-number: func [value] [ 181 | append output reverse to binary! value 182 | ] 183 | 184 | emit-key: does [emit-string form key] 185 | 186 | make-array: func [data /local array index value] [ 187 | array: copy #() 188 | index: 0 189 | foreach value data [ 190 | put array index value 191 | index: index + 1 192 | ] 193 | array 194 | ] 195 | 196 | emit-doc: func [data [map! object!]] [ 197 | insert stack output 198 | init-emitter 199 | foreach key keys-of data [ 200 | value: data/:key 201 | switch type?/word value [ 202 | float! [ 203 | emit #{01} 204 | emit-string form key 205 | emit-number value 206 | ] 207 | string! file! url! tag! email! ref! [ 208 | emit #{02} 209 | emit-key 210 | emit-string value 211 | ] 212 | map! object! [ 213 | emit #{03} 214 | emit-key 215 | emit-doc value 216 | ] 217 | block! [ 218 | emit #{04} 219 | emit-key 220 | ; TODO: this is not very efficient as it makes temporary 221 | ; MAP! that is thrown away. Adding directly 222 | ; would be better but it would need some changes 223 | ; in the emitter's architecture. 224 | emit-doc make-array value 225 | ] 226 | binary! [ 227 | emit #{0500} ; TODO: Be able to select subtype 228 | emit-key 229 | emit value 230 | ] 231 | logic! [ 232 | emit #{08} 233 | emit-key 234 | emit pick #{0100} value 235 | ] 236 | integer! [ 237 | emit #{10} 238 | emit-key 239 | emit-number value 240 | ] 241 | ] 242 | ] 243 | append output null 244 | insert output reverse to binary! 4 + length? output 245 | print ["EMIT:" as-bin output] 246 | output: append take stack output 247 | output 248 | ] 249 | 250 | set 'to-bson func [data [map! object!]] [ 251 | emit: :emit-bson 252 | doc: copy #{} 253 | stack: copy [] 254 | output: doc 255 | emit-doc data 256 | output 257 | ] 258 | ] 259 | -------------------------------------------------------------------------------- /js.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "GraphQL" 3 | Author: "Boleslav Březovský" 4 | Link: https://facebook.github.io/graphql/ 5 | To-Do: [ 6 | "List! rule is not recursive" 7 | ] 8 | ] 9 | 10 | js: context [ 11 | 12 | ; various values 13 | 14 | null-value: none ; change this, if you do not want NONE in place of NULL 15 | 16 | output: [] 17 | mark: none 18 | stack: [] 19 | type!: none 20 | s: e: none 21 | 22 | op-type=: value=: type=: selection=: object=: list=: path=: paren=: 23 | none 24 | 25 | js-types: [ 26 | integer! "Int" float! "Float" string! "String" logic! "Boolean" 27 | none! "Null" enum! "Enum" list! "List" object! "Object" 28 | ] 29 | red-types: reverse copy js-types 30 | 31 | ; === Rules ============================================================= 32 | 33 | bracket-start: [ws #"[" ws] 34 | bracket-end: [ws #"]" ws] 35 | brace-start: [ws #"{" ws] 36 | brace-end: [ws #"}" ws] 37 | paren-start: [ws #"(" ws] 38 | paren-end: [ws #")" ws] 39 | 40 | ; source text 41 | source-char: charset reduce [tab cr lf #" " '- #"^(FFFF)"] 42 | unicode-bom: #"^(FEFF)" 43 | whitespace: charset reduce [space tab] 44 | ws: [any ignored] 45 | line-terminator: charset reduce [cr lf] ; [crlf | cr | lf] 46 | comment: ["//" ws some comment-char ws] 47 | comment-char: difference source-char line-terminator 48 | comma*: [ws comma ws] 49 | token: [punctuator | name | int-value | float-value | string-value] 50 | ignored: [unicode-bom | whitespace | line-terminator | comment] 51 | punctuator-chars: charset "!$():=@[]{|}" 52 | punctuator: [punctuator-chars | "..."] 53 | name*: [start-name-char any name-char] 54 | start-name-char: charset [#"_" #"A" - #"Z" #"a" - #"z"] 55 | name-char: union start-name-char charset [#"0" - #"9"] 56 | 57 | ; values and types 58 | value*: [ 59 | ws 60 | [ 61 | ; variable* (type!: 'variable!) keep (to get-word! copy/part s e) 62 | int-value* (type!: 'integer!) keep (load copy/part s e) 63 | | float-value* (type!: 'float!) keep (load copy/part s e) 64 | | boolean-value* (type!: 'logic!) keep (copy/part s e) 65 | | string-value* (type!: 'string!) keep (copy/part s e) 66 | | null-value* (type!: 'none!) keep (null-value) 67 | ; | enum-value* (type!: 'enum!) (print "--type enum") 68 | | list-value* (type!: 'list!) ; handled in list-value* 69 | | object-value* (type!: 'object!) 70 | | s: name* e: keep (to word! copy/part s e) 71 | ] 72 | ws 73 | ] 74 | int-value*: [s: integer-part e:] 75 | integer-part: [ 76 | opt negative-sign #"0" 77 | | opt negative-sign non-zero-digit any digit 78 | ] 79 | negative-sign: #"-" 80 | digit: charset [#"0" - #"9"] 81 | non-zero-digit: difference digit charset #"0" 82 | 83 | float-value*: [ 84 | s: [ 85 | integer-part fractional-part exponent-part 86 | | integer-part fractional-part 87 | | integer-part exponent-part 88 | ] 89 | e: 90 | ] 91 | fractional-part: [#"." some digit] 92 | exponent-part: [exponent-indicator opt sign some digit] 93 | exponent-indicator: charset "eE" 94 | sign: charset "+-" 95 | 96 | boolean-value*: [s: ["true" | "false"] e:] 97 | 98 | string-value*: [#"^"" s: e: #"^"" | #"^"" s: some string-char e: #"^""] 99 | string-char: [ 100 | ahead not [#"^"" | #"\" | line-terminator] source-char 101 | | {\u} escaped-unicode 102 | | #"\" escaped-char 103 | ] 104 | hex-char: charset [#"0" - #"9" #"a" - #"f" #"A" - #"F"] 105 | escaped-unicode: [4 hex-char] 106 | escaped-char: charset "^"\/bfnrt" 107 | 108 | null-value*: "null" 109 | enum-value*: [ahead not ["true" | "false" | "null"] name] 110 | list-value*: [ ; NOTE: This is * rule 111 | ; TODO: list= must be recursive 112 | "[]" keep ([]) 113 | | [ 114 | bracket-start 115 | (print "list") 116 | collect set list= 117 | [ 118 | value* 119 | any [comma* value*] 120 | ] 121 | bracket-end 122 | keep (list=) 123 | ] 124 | ] 125 | object-value*: [ 126 | brace-start brace-end keep (#()) 127 | | brace-start collect set object= object-fields keep (make map! object=) brace-end 128 | ] 129 | object-fields: [ 130 | object-field 131 | any object-field 132 | ws 133 | ] 134 | object-field: [ 135 | ws s: name* e: 136 | #":" ws 137 | keep (to set-word! copy/part s e) 138 | value* 139 | ] 140 | 141 | ; query document 142 | 143 | semicolon*: [ws #";" ws] 144 | 145 | document*: [ 146 | some [ 147 | path* 148 | | set-var* 149 | | call-func* 150 | | set-func* 151 | | value* 152 | ] 153 | ] 154 | 155 | set-var*: [ 156 | ws "var" ws s: name* e: ws #"=" ws 157 | ; TODO: set name and keep only when whole rule passed 158 | keep ('var) ; TODO: keep only 159 | keep (to set-word! copy/part s e) 160 | [ 161 | [ 162 | ws "new" ws 163 | keep ('new) 164 | s: name* e: ; type 165 | ; keep (to word! copy/part s e) 166 | value* 167 | ] 168 | | value* 169 | ] 170 | opt semicolon* 171 | ] 172 | 173 | call-func*: [ 174 | s: name* e: 175 | paren-start 176 | keep (to word! copy/part s e) 177 | args* 178 | paren-end 179 | ] 180 | 181 | set-func*: [ 182 | "function" ws 183 | s: name* e: 184 | ws paren-start ws 185 | keep (to set-word! copy/part s e) 186 | keep ('function) 187 | args* 188 | paren-end 189 | func-body* 190 | ] 191 | 192 | func-body*: [ 193 | brace-start 194 | collect some value* 195 | brace-end 196 | ] 197 | 198 | args*: [ 199 | (paren=: make paren! []) 200 | collect into paren= [ 201 | opt arg* 202 | any [comma* arg*] 203 | ws 204 | ] 205 | keep (paren=) 206 | ] 207 | 208 | arg*: [ 209 | ; TODO: move NAME to VALUE* 210 | s: name* e: keep (to word! copy/part s e) 211 | | value* 212 | ] 213 | 214 | path*: [ 215 | (path=: make block! 10) 216 | s: name* e: 217 | some [ 218 | #"." 219 | (print "path") 220 | (append path= to word! copy/part s e) 221 | s: name* e: 222 | ] 223 | (append path= to word! copy/part s e) 224 | keep (to path! path=) 225 | ] 226 | 227 | ; === Support ============================================================ 228 | 229 | push-stack: func [ 230 | value 231 | ] [ 232 | append/only mark copy value 233 | append/only stack tail mark 234 | mark: last mark 235 | ] 236 | 237 | load-value: does [ 238 | switch/default type! [ 239 | integer! [load value=] 240 | string! [load value=] 241 | variable! [to get-word! head remove value=] 242 | list! [list=] 243 | ] [value=] 244 | ] 245 | 246 | block-to-list: function [ 247 | block 248 | ] [ 249 | list: copy {} 250 | foreach value block [ 251 | append list rejoin [mold value #","] 252 | ] 253 | remove back tail list 254 | rejoin [#"[" list #"]"] 255 | ] 256 | map-to-obj: function [ 257 | data 258 | ] [ 259 | obj: copy {} 260 | foreach [key value] body-of data [ 261 | repend obj [mold key space mold value #"," space] 262 | ] 263 | remove back tail obj 264 | rejoin [#"{" obj #"}"] 265 | ] 266 | 267 | ; === JS parser ===================================================== 268 | 269 | validate: func [ 270 | "checks GraphQL validity" 271 | data 272 | ] [ 273 | parse data document* 274 | ] 275 | 276 | ; === ;r ============================================================ 277 | 278 | decode: func [ 279 | data 280 | ] [ 281 | parse data [collect document*] 282 | ] 283 | 284 | ; === Encoder ============================================================ 285 | 286 | encode: function [ 287 | dialect [block!] 288 | ] [ 289 | print "TBD" 290 | ] 291 | ] -------------------------------------------------------------------------------- /qobom.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "QOBOM - Query over block of maps" 3 | Author: "Boleslav Březovský" 4 | Usage: { 5 | ``` 6 | keep [ or * ] where 7 | is 8 | [ = < > <= >= ] 9 | contains 10 | matches 11 | ``` 12 | 13 | can be `paren!` and then is evaluated first 14 | can be `block!` and then is interpred as list of values that can match 15 | 16 | Support for expressions in count - see following example: 17 | 18 | >> qobom messages [keep ['author 'text] as map where 'sent > (now - 6:0:0) count by 'author (length? text)] 19 | == #( 20 | "pekr" 1999 21 | "9214" 116 22 | "BeardPower" 69 23 | ) 24 | 25 | NOTE: expression must return number to be counted (probably should add some checks) 26 | 27 | 28 | } 29 | ] 30 | 31 | qobom!: context [ 32 | time: none 33 | select-deep: func [ 34 | series 35 | value 36 | ][ 37 | either word? value [ 38 | select series value 39 | ][ 40 | ; path 41 | foreach elem value [ 42 | series: select series elem 43 | ] 44 | ] 45 | ] 46 | 47 | sort-by: func [ 48 | "Sort block of maps" 49 | data 50 | match-key 51 | ; keep-key ; TODO: support * for keeping everything 52 | ; TODO: sorting order 53 | /local result value 54 | ][ 55 | ; NOTE: How expensive is map!->block!->map! ? Is there other way? 56 | result: clear #() 57 | foreach item data [ 58 | value: item/:match-key 59 | result/:value: either result/:value [ 60 | result/:value + 1 61 | ][ 62 | 1 63 | ] 64 | ] 65 | to map! sort/skip/compare/reverse to block! result 2 2 66 | ] 67 | 68 | do-conditions: func [ 69 | data conditions selector type 70 | /local value 71 | ][ 72 | type: equal? map! type 73 | collect [ 74 | foreach item data [ 75 | if any conditions [ 76 | case [ 77 | equal? '* selector [keep/only either type [item][values-of item]] 78 | block? selector [ 79 | value: to map! collect [foreach s selector [keep reduce [s select-key item to lit-word! s]]] 80 | keep/only either type [value][values-of value] 81 | ] 82 | 'default [ 83 | value: select-key item selector 84 | keep either type [to map! reduce [selector value]][value] 85 | ] 86 | ] 87 | ] 88 | ] 89 | ] 90 | ] 91 | 92 | select-key: func [item selector][ 93 | switch type?/word selector [ 94 | none! [item] 95 | lit-word! lit-path! [select-deep item to path! selector] 96 | block! [ 97 | collect [ 98 | foreach key selector [keep select-deep item to path! key] 99 | ] 100 | ] 101 | ] 102 | ] 103 | 104 | count-values: func [ 105 | "Count occurences of each value in DATA. Return map! with values as keys and count as values" 106 | data 107 | /key 108 | name "Key to match" 109 | action 110 | ; TODO: support some refinement to return block! instead (or make it default?) 111 | /local result act-result 112 | ][ 113 | result: copy #() 114 | foreach value data [ 115 | either key [ 116 | ; NOTE: I'm doing some black magic here to simplify the dialect 117 | ; It's certainly not the fastest way and should be redone 118 | act-result: do bind as block! action make object! to block! value 119 | key-name: value/:name 120 | result/:key-name: either result/:key-name [result/:key-name + act-result][act-result] 121 | ][ 122 | result/:value: either result/:value [result/:value + 1][1] 123 | ] 124 | ] 125 | to map! sort/skip/compare/reverse to block! result 2 2 126 | ] 127 | select-key: func [ 128 | "Deep select key" 129 | value 130 | key 131 | /local item elem 132 | ][ 133 | item: either lit-path? key [ 134 | item: value 135 | foreach elem key [item: select item elem] 136 | item 137 | ][select value key] 138 | ] 139 | clean-word: func [ 140 | "Remove punctuation from a word" 141 | word 142 | ][ 143 | ; TODO clean punctuation only if it's last letter? 144 | parse word [ 145 | some [ 146 | change #"." "" 147 | | change #"," "" 148 | | change #"?" "" 149 | | change #"." "" 150 | | skip 151 | ] 152 | ] 153 | word 154 | ] 155 | count-frequency: func [ 156 | "Count frequency of keys or words in keys" 157 | type "BY for counting keys, IN for counting words in keys" 158 | key 159 | /local result 160 | ][ 161 | result: #() 162 | switch type [ 163 | by [ 164 | foreach value data-block [ 165 | item: select-key value key 166 | result/:item: either result/:item [ 167 | result/:item + 1 168 | ][1] 169 | ] 170 | ] 171 | in [ 172 | foreach value data-block [ 173 | set 'v value 174 | item: select-key value key 175 | foreach word split item space [ 176 | word: clean-word word 177 | result/:word: either result/:word [ 178 | result/:word + 1 179 | ][1] 180 | ] 181 | ] 182 | ] 183 | ] 184 | result: make map! sort/skip/compare/reverse to block! result 2 2 185 | ] 186 | add-condition: func [ 187 | condition 188 | ][ 189 | append group condition 190 | ] 191 | 192 | lits: [lit-word! | lit-path!] 193 | value-rule: [ 194 | set value skip ( 195 | if paren? value [value: compose value] 196 | ) 197 | ] 198 | reflector-rule: [ 199 | (reflector: none) 200 | set value skip 'in ( 201 | reflector: value 202 | ) 203 | ] 204 | col-rule: [ 205 | opt reflector-rule 206 | set key lits 207 | [ 208 | 'is 'from set value block! ( 209 | add-condition compose/deep [ 210 | find [(value)] select-deep item (key) 211 | ] 212 | ) 213 | | ['is | '=] value-rule ( 214 | either reflector [ 215 | add-condition compose [ 216 | equal? (to paren! compose [t: select-deep item (key)]) (value) 217 | ] 218 | ][ 219 | add-condition compose [ 220 | equal? select-deep item (key) (value) 221 | ] 222 | ] 223 | ) 224 | | set symbol ['< | '> | '<= | '>=] value-rule ( 225 | add-condition compose [ 226 | (to paren! reduce ['select-deep 'item key]) (symbol) (value) 227 | ] 228 | ) 229 | ] 230 | ] 231 | find-rule: [ 232 | set key lits 233 | 'contains 234 | value-rule ( 235 | add-condition compose [ 236 | find select-deep item (key) (value) 237 | ] 238 | ) 239 | ] 240 | match-rule: [ 241 | set key lits 242 | 'matches 243 | value-rule ( 244 | append value [to end] 245 | add-condition compose/deep [ 246 | parse select-deep item (key) [(value)] 247 | ] 248 | ) 249 | ] 250 | keep-rule: [ 251 | (keep-type: block!) 252 | 'keep 253 | set selector ['* | block! | lit-word! | lit-path!] 254 | opt ['as 'map (keep-type: map!)] 255 | 'where 256 | ] 257 | sort-rule: [ 258 | 'sort 'by set value skip ( 259 | sort-by result value 260 | ) 261 | ] 262 | count-rule: [ 263 | 'count (count-by?: no) 264 | opt [ 265 | 'by (count-by?: yes) 266 | set key lit-word! 267 | set value paren! 268 | ] 269 | ( 270 | result: either count-by? [ 271 | count-values/key result key value 272 | ][ 273 | count-values result 274 | ] 275 | ) 276 | ] 277 | conditions-rule: [col-rule | find-rule | match-rule] 278 | do-cond-rule: [( 279 | repend conditions ['all group] 280 | result: do-conditions data-block conditions selector keep-type 281 | )] 282 | basic-rule: [ 283 | keep-rule 284 | conditions-rule 285 | any [ 286 | ['and conditions-rule] 287 | | [ 288 | 'or ( 289 | repend conditions ['all group] 290 | group: copy [] 291 | ) 292 | conditions-rule 293 | ] 294 | ] 295 | do-cond-rule 296 | opt count-rule 297 | ] 298 | frequency-rule: [ 299 | 'frequency [ 300 | set type ['by | 'in] 301 | set key lits 302 | ] 303 | (count-frequency type key) 304 | ] 305 | main-rule: [ 306 | frequency-rule 307 | | basic-rule 308 | ] 309 | conditions: [] 310 | group: none 311 | data-block: none 312 | result: none 313 | value: none 314 | key: none 315 | type: none 316 | reflector: none 317 | t: none 318 | 319 | set 'qobom func [ 320 | "Simple query dialect for filtering messages" 321 | data 322 | dialect 323 | /local 324 | selector 325 | keep-type count-by? 326 | t 327 | ][ 328 | t: now/time/precise 329 | data-block: data 330 | clear conditions 331 | value: result: none 332 | group: copy [] 333 | 334 | parse dialect main-rule 335 | time: now/time/precise - t 336 | result 337 | ] 338 | ; -- end of context 339 | ] 340 | -------------------------------------------------------------------------------- /bson.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "BSON" 3 | Author: "Boleslav Březovský" 4 | Note: [ 5 | "test31.bson fails - key is out of range. how to handle it?" 6 | ] 7 | Links: [ 8 | http://bsonspec.org/ 9 | https://github.com/mongodb/libbson/tree/master/tests/binary 10 | ] 11 | ] 12 | 13 | path: %../libbson/tests/binary/ 14 | 15 | 16 | ; Types: 17 | 18 | ; byte 1 byte (8-bits) 19 | ; int32 4 bytes (32-bit signed integer, two's complement) 20 | ; int64 8 bytes (64-bit signed integer, two's complement) 21 | ; uint64 8 bytes (64-bit unsigned integer) 22 | ; double 8 bytes (64-bit IEEE 754-2008 binary floating point) 23 | ; decimal128 16 bytes (128-bit IEEE 754-2008 decimal floating point) 24 | 25 | ; document ::= int32 e_list "\x00" BSON Document. int32 is the total number of bytes comprising the document. 26 | 27 | load-int: func [s e] [to integer! reverse copy/part s e] 28 | 29 | debug?: true 30 | debug: func [value] [if debug? [print value]] 31 | 32 | bson: context [ 33 | 34 | name=: value=: none 35 | 36 | length: 1 37 | byte: [skip] 38 | int32: [s: 4 byte e:] 39 | int64: [s: 8 byte e:] 40 | uint64: [s: 8 byte e:] 41 | double: [s: 8 byte e:] 42 | decimal128: [16 byte] 43 | 44 | null-byte: copy [#"^(00)"] 45 | string-byte: complement charset null-byte 46 | append null-byte [(print "null-byte")] 47 | 48 | document: [ 49 | s: int32 e: 50 | (print ["doc length" load-int s e]) 51 | collect e-list null-byte 52 | ] 53 | 54 | e-list: [ 55 | some [ 56 | (print "check-elem>>") 57 | (name=: value=: none) 58 | p: (print mold p/1) 59 | not ahead null-byte 60 | (print "passed non-null-byte") 61 | element 62 | (print "<>") 63 | ; TODO: why is the check needed? 64 | if (any [name= value=]) [ 65 | ; TODO: Naive conversion to set-word! which may fail 66 | ; Keep string if it can't be converted 67 | keep (to set-word! to string! name=) 68 | keep (value=) 69 | (print ["elem:" name= value=]) 70 | ] 71 | ] 72 | ] 73 | 74 | probe-rule: [p: (print mold p)] 75 | 76 | element: [ 77 | #"^(01)" (debug "float64") e-name double 78 | (value=: to float! reverse copy/part s e) ; 64-bit binary FP 79 | | #"^(02)" (debug "string") e-name string 80 | (value=: to string! copy/part s e) ; UTF-8 string 81 | | #"^(03)" (debug "document") e-name keep 82 | (to string! name=) document ; Embedded document 83 | | #"^(04)" (debug "array") e-name keep 84 | (to string! name=) document ; Array 85 | | #"^(05)" (debug "binary") 86 | e-name binary ; Binary data 87 | | #"^(06)" (debug "undefined") e-name 88 | (value=: ) ; Deprecated 89 | | #"^(07)" (debug "objectid") e-name s: 12 byte e: 90 | (value=: to integer! copy/part s e) ; ObjectId 91 | | #"^(08)" (debug "false") e-name #"^(00)" 92 | (value=: false) ; Boolean "false" 93 | | #"^(08)" (debug "true") e-name #"^(01)" 94 | (value=: true) ; Boolean "true" 95 | | #"^(09)" (debug "datetime") e-name (debug "dt1") int64 96 | (probe "datatype+" value=: to date! probe load-int s e) ; UTC datetime 97 | | #"^(0A)" (debug "null") e-name 98 | (value=: none) ; Null value 99 | | #"^(0B)" (debug "regexp") e-name (regex=: copy []) 100 | cstring (append regex= to string! copy/part s e) 101 | cstring (append regex= to string! copy/part s e) 102 | (value=: regex=) ; Regular expression 103 | ; The first cstring is the regex pattern, the second is the regex 104 | ; options string. Options are identified by characters, which must 105 | ; be stored in alphabetical order. Valid options are 'i' for case 106 | ; insensitive matching, 'm' ;for multiline matching, 'x' for 107 | ; verbose mode, 'l' to make \w, \W, etc. locale dependent, 108 | ; 's' for dotall mode ('.' matches everything), and ;'u' to make 109 | ; \w, \W, etc. match unicode. 110 | | #"^(0C)" (debug "dbpointer") e-name string s: 12 byte e: 111 | (value=: probe to integer! copy/part s e) ; DBPointer (Deprecated) 112 | | #"^(0D)" (debug "jscode") e-name string 113 | (value=: to string! copy/part s e) ; JavaScript code 114 | | #"^(0E)" (debug "symbol") e-name string 115 | (value=: to string! copy/part s e) ; Symbol. Deprecated 116 | | #"^(10)" (debug "integer32") e-name int32 117 | (print "val" value=: load-int s e) probe-rule ; 32-bit integer 118 | | #"^(11)" (debug "timestamp") e-name s: uint64 e: 119 | (print "val" value=: load-int s e) ; Timestamp 120 | | #"^(12)" (debug "integer64") e-name int64 121 | (value=: load-int s e) ; 64-bit integer 122 | | #"^(13)" (debug "decimal128") e-name decimal128 123 | ; 128-bit decimal 124 | | #"^(FF)" (debug "minkey") e-name ; Min key 125 | | #"^(7F)" (debug "maxkey") e-name ; Max key 126 | ] 127 | 128 | ; TODO: where length is set, use that length in rule instead of SOME 129 | 130 | e-name: [cstring (name=: copy/part s e)] ; Key name 131 | string: [ 132 | int32 133 | (print ["length:" load-int s e] length: -1 + load-int s e) 134 | s: length byte e: null-byte 135 | ] ; String 136 | ; The int32 is the number bytes in the (byte*) + 1 (for the trailing '\x00'). 137 | ; The (byte*) is zero or more UTF-8 encoded characters. 138 | cstring: [ 139 | s: some string-byte e: null-byte 140 | (print ["cstring" mold to string! copy/part s e]) 141 | ] 142 | ; Zero or more modified UTF-8 encoded characters followed by '\x00'. 143 | ; The (byte*) MUST NOT contain '\x00', hence it is not full UTF-8. 144 | binary: [ 145 | int32 subtype s: some byte e: 146 | (value=: copy/part s e) 147 | ] ; Binary 148 | ; The int32 is the number of bytes in the (byte*). 149 | subtype: [ 150 | #"^(00)" ; Generic binary subtype 151 | | #"^(01)" ; Function 152 | | #"^(02)" ; Binary (Old) 153 | | #"^(03)" ; UUID (Old) 154 | | #"^(04)" ; UUID 155 | | #"^(05)" ; MD5 156 | | #"^(80)" ; User defined 157 | ] 158 | code-w-s: [int32 string document] ; Code w/ scope 159 | 160 | decode: func [data] [ 161 | value=: none 162 | parse data document 163 | ] 164 | 165 | ; === encoder ============================================================= 166 | 167 | name: value: none 168 | 169 | keep-value: func [data] [ 170 | append output probe to binary! probe reduce data 171 | ] 172 | c-name: func [] [rejoin [form name #"^@"]] 173 | num: func [value] [reverse to binary! value] 174 | 175 | int-rule: [ 176 | set name set-word! 177 | set value integer! 178 | (keep-value [#"^(10)" c-name num value]) 179 | ] 180 | float-rule: [ 181 | set name set-word! 182 | set value float! 183 | (keep-value [#"^(01)" c-name num value]) 184 | ] 185 | logic-rule: [ 186 | set name set-word! 187 | set value logic! 188 | (keep-value [#"^(08)" c-name to char! make integer! value]) 189 | ] 190 | none-rule: [ 191 | set name set-word! 192 | none! 193 | (keep-value [#"^(0A)" c-name]) 194 | ] 195 | string-rule: [ 196 | set name set-word! 197 | set value string! 198 | (keep-value [#"^(02)" c-name num 1 + length? value value #"^@"]) 199 | ] 200 | datetime-rule: [ 201 | set name set-word! 202 | set value date! 203 | (keep-value [#"^(09)" c-name to binary! TODO: to-64-bit-integer-here! value]) 204 | ] 205 | regex-rule: [ 206 | set name set-word! 207 | TODO: 208 | ] 209 | code-rule: [ 210 | TODO: "how to recognize js code?" 211 | ] 212 | deep-rule: [ 213 | set-name set-word! 214 | t: 215 | change only set value map! (body-of value) 216 | :t 217 | ; TODO 218 | (keep-value [#"^(03)" c-name ...]) 219 | into rules 220 | ] 221 | rules: [ 222 | some [ 223 | int-rule 224 | | float-rule 225 | | logic-rule 226 | | none-rule 227 | | string-rule 228 | ; | datetime-rule 229 | ; | regex-rule 230 | ; | code-rule 231 | ; | deep-rule 232 | ] 233 | ] 234 | 235 | output: #{} 236 | 237 | init-output: does [ 238 | clear output 239 | append output #{00000000} 240 | ] 241 | 242 | set 'to-bson func [data] [ 243 | init-output 244 | unless block? data [data: body-of data] 245 | parse data rules 246 | head change/part output num length? output 4 247 | ] 248 | 249 | set 'load-bson func [data] [ 250 | to map! parse data document 251 | ] 252 | ] 253 | -------------------------------------------------------------------------------- /packers/zip.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "ZIP packer and unpacker" 3 | Author: "Boleslav Březovský" 4 | 5 | ] 6 | 7 | context [ 8 | ; -- support functions ------------------------------------------------------------ 9 | 10 | ; FIXME: Remove once proper CLEAN-PATH is implemented in Red 11 | strip-path: func [ 12 | "Remove tarting %./ when present" 13 | value [file!] 14 | ][ 15 | value: clean-path/only value 16 | if equal? %./ copy/part value 2 [ 17 | remove/part value 2 18 | ] 19 | value 20 | ] 21 | 22 | to-ilong: func [ 23 | "Converts an integer to a little-endian long" 24 | value [integer!] "Value to convert" 25 | ][ 26 | reverse to binary! value 27 | ] 28 | 29 | to-ishort: func [ 30 | "Converts an integer to a little-endian short" 31 | value [integer!] "Value to convert" 32 | ][ 33 | reverse skip to binary! value 2 34 | ] 35 | 36 | load-ishort: func [ 37 | "Converts little-endian short to integer" 38 | value [binary!] "Value to convert" 39 | ][ 40 | to integer! reverse value 41 | ] 42 | 43 | load-number: func [data][to integer! reverse data] 44 | 45 | to-msdos-date: func [ 46 | "Converts to a msdos date" 47 | value [date!] "Value to convert" 48 | ][ 49 | to-ishort 512 * (max 0 value/year - 1980) or (value/month * 32) or value/day 50 | ] 51 | 52 | to-msdos-time: func [ 53 | "Converts to a msdos time." 54 | value [time!] "Value to convert" 55 | ][ 56 | to-ishort (value/hour * 2048) or (value/minute * 32) or (to integer! value/second / 2) 57 | ] 58 | 59 | load-msdos-time: func [ 60 | "Converts from a msdos time" 61 | value [binary!] "Value to convert" 62 | ][ 63 | value: load-ishort value 64 | to time! reduce [ 65 | 63488 and value / 2048 66 | 2016 and value / 32 67 | 31 and value * 2 68 | ] 69 | ] 70 | 71 | load-msdos-date: func [ 72 | "Converts from a msdos date" 73 | value [binary!] "Value to convert" 74 | ][ 75 | value: load-ishort value 76 | to date! reduce [ 77 | 65024 and value / 512 + 1980 78 | 480 and value / 32 79 | 31 and value 80 | ] 81 | ] 82 | 83 | global-signature: #{504B0102} 84 | local-signature: #{504B0304} 85 | central-signature: #{504B0506} 86 | 87 | ; -- internal functions ----------------------------------------------------------- 88 | 89 | gp-bitflag: func [][ 90 | ; bit 0 - encryption 91 | ; bit 1&2 - method: normal, maximum, fast, super fast 92 | ; bit 3 - are crc&sizes in local header? 93 | ; bit 4 - enhanced deflating(?) 94 | ; bit 5 - compressed pached data 95 | ; bit 6 - strong encryption 96 | ; bit 7-11 - unused 97 | ; bit 12 - 15 - reserved 98 | 99 | flag: make bitset! 16 100 | to binary! flag 101 | ] 102 | 103 | make-entry: func [ 104 | "Make Zip archive entry" 105 | filename [file!] 106 | /local local-header global-header data crc 107 | orig-size comp-size name-size filedate 108 | ][ 109 | either dir? filename [ 110 | data: #{} 111 | crc: 112 | orig-size: 113 | comp-size: #{00000000} 114 | ][ 115 | data: read/binary filename 116 | crc: to-ilong checksum data 'crc32 117 | orig-size: to-ilong length? data 118 | data: compress data 'deflate 119 | comp-size: to-ilong length? data 120 | ] 121 | name-size: to-ishort length? to binary! filename 122 | filedate: query filename 123 | 124 | ; -- make header 125 | local-header: rejoin [ 126 | local-signature 127 | #{0000} ; version needed to extract 128 | gp-bitflag ; bitflag 129 | #{0800} ; compression method - DEFLATE 130 | to-msdos-time filedate/time 131 | to-msdos-date filedate/date 132 | crc 133 | comp-size 134 | orig-size 135 | name-size 136 | #{0000} ; extra field length 137 | filename 138 | #{} ; no extra field 139 | ] 140 | append local-header data 141 | global-header: rejoin [ 142 | global-signature 143 | #{0000} ; source version 144 | #{0000} ; version needed to extract 145 | gp-bitflag ; bitflag 146 | #{0800} ; compression method - DEFLATE 147 | to-msdos-time filedate/time 148 | to-msdos-date filedate/date 149 | crc 150 | comp-size 151 | orig-size 152 | name-size 153 | #{0000} ; extra field length 154 | #{0000} ; file comment length 155 | #{0000} ; disk number start 156 | #{0000} ; internal attributes 157 | #{00000000} ; external attributes 158 | #{00000000} ; header offset 159 | filename 160 | #{} ; extrafield 161 | #{} ; comment 162 | ] 163 | reduce [local-header global-header] 164 | ] 165 | 166 | grab-files: func [path out /local file files][ 167 | either dir? path [ 168 | files: read path 169 | append out path 170 | foreach file files [ 171 | grab-files rejoin [path file] out 172 | ] 173 | ][ 174 | append out path 175 | ] 176 | ] 177 | 178 | ; -- in-Red functions ------------------------------------------------------------- 179 | 180 | set 'make-zip func [ 181 | "Make ZIP archive from file or block of files. Returns binary!" 182 | files [block! file!] "File(s) to archive" 183 | /local length archive central-directory arc-size entry 184 | ][ 185 | files: append clear [] files 186 | length: to-ishort length? files 187 | archive: copy #{} 188 | central-directory: copy #{} 189 | arc-size: 0 190 | foreach file files [ 191 | entry: make-entry strip-path file 192 | ; write file offset in archive 193 | change skip entry/2 42 to-ilong arc-size 194 | ; directory entry 195 | append central-directory entry/2 196 | ; compressed file + header 197 | append archive entry/1 198 | arc-size: arc-size + length? entry/1 199 | ] 200 | rejoin [ 201 | archive 202 | central-directory 203 | central-signature 204 | #{0000} ; disk number 205 | #{0000} ; disk central directory 206 | length ; entries 207 | length ; entries disk 208 | to-ilong length? central-directory 209 | to-ilong arc-size 210 | #{0000} ; comment length 211 | #{} ; comment 212 | ] 213 | ] 214 | 215 | set 'load-zip func [ 216 | "Extract ZIP archive to block of Red values" 217 | data [binary!] "ZIP archive data" 218 | /meta "Include metadata also" 219 | /local files metadata start mark time date comp 220 | comp-size orig-size name-size extra-size comment-size 221 | offset filename extrafield comment 222 | ][ 223 | files: copy #() 224 | metadata: copy #() 225 | parse data [ 226 | start: 227 | some [to local-signature] 228 | to global-signature 229 | some [ 230 | global-signature 231 | 4 skip ; versions 232 | 2 skip ; flags 233 | copy method 2 skip 234 | ( 235 | method: select [0 store 8 deflate] load-ishort method 236 | ; TODO: add error handling for unsupported methods 237 | ) 238 | copy time 2 skip 239 | copy date 2 skip 240 | 4 skip ; crc 241 | copy comp-size 4 skip (comp-size: load-number comp-size) 242 | copy orig-size 4 skip (orig-size: load-number orig-size) 243 | copy name-size 2 skip (name-size: load-number name-size) 244 | copy extra-size 2 skip (extra-size: load-number extra-size) 245 | copy comment-size 2 skip (comment-size: load-number comment-size) 246 | 8 skip ; various attributes 247 | copy offset 4 skip (offset: load-number offset) 248 | copy filename name-size skip (filename: to file! filename) 249 | copy extrafield extra-size skip 250 | copy comment comment-size skip 251 | mark: 252 | (start: skip head start offset) 253 | :start 254 | local-signature 255 | 22 skip ; mandatory fields 256 | copy name-size 2 skip (name-size: load-number name-size) 257 | copy extra-size 2 skip (extra-size: load-number extra-size) 258 | name-size skip 259 | extra-size skip 260 | copy comp comp-size skip 261 | ( 262 | ; print [filename method offset comp-size] 263 | files/:filename: switch method [ 264 | store [comp] 265 | deflate [decompress/size comp 'deflate orig-size] 266 | ] 267 | date: load-msdos-date date 268 | date/time: load-msdos-time time 269 | metadata/:filename: context compose [ 270 | date: (date) 271 | size: (orig-size) 272 | packed: (comp-size) 273 | ratio: ( 274 | either zero? orig-size [0%] [ 275 | to percent! comp-size / orig-size 276 | ] 277 | ) 278 | comment: (comment) 279 | ] 280 | ) 281 | :mark 282 | ] 283 | ] 284 | either meta [reduce [files metadata]][files] 285 | ] 286 | 287 | ; -- file functions --------------------------------------------------------------- 288 | 289 | set 'zip func [ 290 | "Save ZIP archive created from given files or paths" 291 | where [file!] "Where to save" 292 | files [file! block!] "File(s) and/or path(s) to archive" 293 | /local out 294 | ][ 295 | files: append copy [] files 296 | out: copy [] 297 | foreach file files [grab-files file out] 298 | write/binary where make-zip out 299 | out 300 | ] 301 | 302 | set 'unzip func [ 303 | "Extract files from ZIP archive" 304 | value [file!] "ZIP archive to extract" 305 | /local data file content out 306 | ][ 307 | out: copy [] 308 | data: load-zip read/binary value 309 | foreach [file content] data [ 310 | append out file 311 | either dir? file [ 312 | make-dir/deep file 313 | ][ 314 | write/binary file content 315 | ] 316 | ] 317 | out 318 | ] 319 | 320 | ; -- end of context 321 | ] 322 | -------------------------------------------------------------------------------- /packers/tar.red: -------------------------------------------------------------------------------- 1 | Red[ 2 | Title: "ZIP packer and unpacker" 3 | Author: "Boleslav Březovský" 4 | ] 5 | 6 | context [ 7 | 8 | ; -- support functions ----------------------------------------------------------- 9 | 10 | zeroes: func [count [integer!]][append/dup copy #{} #"^@" count] 11 | 12 | make-checksum: func [ 13 | "Return TAR header checksum" 14 | data [binary!] 15 | /local result byte 16 | ][ 17 | result: 0 18 | foreach byte data [result: result + byte] 19 | result 20 | ] 21 | 22 | to-octal: func [ 23 | "Convert integer to octal value in TAR format" 24 | value [integer!] 25 | /local octal digit 26 | ][ 27 | octal: copy "" 28 | until [ 29 | digit: value // 8 30 | insert octal form digit 31 | value: value - digit / 8 32 | value < 8 33 | ] 34 | insert octal form value 35 | append octal #"^@" 36 | insert/dup octal #"0" 12 - length? octal 37 | octal 38 | ] 39 | 40 | load-octal: func [ 41 | "Convert octal in TAR format to integer" 42 | value [binary! string!] 43 | /local result mult digit 44 | ][ 45 | mult: 1 46 | result: 0 47 | replace/all value #"^@" "" 48 | replace/all value #" " "" 49 | foreach digit reverse copy value [ 50 | result: result + (mult * to integer! form digit) 51 | try [mult: mult * 8] 52 | ] 53 | result 54 | ] 55 | 56 | load-bin: func [binary][ 57 | "Convert binary text in TAR format to string" 58 | binary: to string! binary 59 | take/last binary 60 | binary 61 | ] 62 | 63 | get-type: func [ 64 | "Describe TAR file format" 65 | type [string!] 66 | ][ 67 | switch/default type [ 68 | "1" ['hard] 69 | "2" ['symbolic] 70 | "3" ['character] 71 | "4" ['block] 72 | "5" ['directory] 73 | "6" ['FIFO] 74 | "7" ['contiguous-file] 75 | "g" ['global-ext-header] 76 | "x" ['ext-header] 77 | ; TODO: "A" - "Z" 78 | ][none] 79 | ] 80 | 81 | print-file-info: does [ 82 | print [ 83 | "Filename: " mold filename newline 84 | "Filemode: " filemode newline 85 | "Owner ID: " owner-id newline 86 | "Group ID: " group-id newline 87 | "Filesize: " filesize newline 88 | "Mod.date: " modification-date newline 89 | "Checksum: " chksm tab "computed:" computed-checksum tab "diff:" chksm - computed-checksum newline 90 | "Link ind: " link-indicator newline 91 | "Linkfile: " linked-filename newline 92 | "Owner nm: " owner-name newline 93 | "Group nm: " group-name newline 94 | "Devmajor: " device-major-number newline 95 | "Devminor: " device-minor-number newline 96 | "Fileprfx: " filename-prefix newline 97 | ] 98 | ] 99 | 100 | ; -- local words ----------------------------------------------------------------- 101 | 102 | number: name: filename: linked-filename: filesize: filename-prefix: 103 | filemode: owner-id: group-id: owner-name: group-name: 104 | modification-date: 105 | chksm: computed-checksum: 106 | link-indicator: ustar-version: 107 | device-major-number: device-minor-number: 108 | i: j: pad: files: 109 | none 110 | 111 | ; -- parse rules ----------------------------------------------------------------- 112 | 113 | name-rule: [ 114 | copy name 100 skip 115 | (name: load-bin name) 116 | ] 117 | filename-rule: [ 118 | name-rule 119 | (filename: first parse name [collect [keep to #"^@"]]) ; TODO: to file! ? 120 | ] 121 | linked-filename-rule: [ 122 | name-rule 123 | (linked-filename: name) ; TODO: to file! ? 124 | ] 125 | filemode-rule: [ 126 | copy filemode 8 skip 127 | (filemode: load-bin filemode) 128 | ] 129 | owner-id-rule: [ 130 | copy owner-id 8 skip 131 | (owner-id: load-bin owner-id) 132 | ] 133 | group-id-rule: [ 134 | copy group-id 8 skip 135 | (group-id: load-bin group-id) 136 | ] 137 | filesize-rule: [ 138 | copy filesize 12 skip 139 | (filesize: load-octal load-bin filesize) 140 | ] 141 | modification-date-rule: [ 142 | copy modification-date 12 skip 143 | (modification-date: to date! load-octal load-bin modification-date) 144 | ] 145 | checksum-rule: [ 146 | copy chksm 8 skip 147 | ( 148 | chksm: load-bin chksm 149 | take/last chksm ; remove space at end 150 | chksm: load-octal chksm 151 | computed-checksum: make-checksum header-start 152 | ) 153 | ] 154 | link-indicator-rule: [ 155 | copy link-indicator skip 156 | (link-indicator: switch/default load-bin link-indicator ["1" ['hard] "2" ['symbolic]]['normal]) 157 | ] 158 | ustar-rule: [ 159 | #{7573746172} [#"^@" | space] ;"ustar" 160 | copy ustar-version 2 skip 161 | ] 162 | owner-name-rule: [ 163 | copy name 32 skip 164 | (owner-name: load-bin name) 165 | ] 166 | group-name-rule: [ 167 | copy name 32 skip 168 | (group-name: load-bin name) 169 | ] 170 | device-number-rule: [ 171 | copy number 8 skip 172 | (device-major-number: load-bin number) 173 | copy number 8 skip 174 | (device-minor-number: load-bin number) 175 | ] 176 | filename-prefix-rule: [ 177 | copy name 155 skip 178 | (filename-prefix: load-bin name) 179 | ] 180 | filedata-rule: [ 181 | i: (pad: 513 - ((index? i) // 512)) 182 | pad skip 183 | copy content filesize skip 184 | (files/:filename: content) 185 | j: (pad: (513 - ((index? j) // 512) // 512)) 186 | pad skip 187 | ] 188 | 189 | empty-block: [512 #"^@"] 190 | 191 | file-rule: [ 192 | header-start: 193 | filename-rule 194 | filemode-rule 195 | owner-id-rule 196 | group-id-rule 197 | filesize-rule 198 | modification-date-rule 199 | checksum-rule 200 | link-indicator-rule 201 | linked-filename-rule 202 | ustar-rule 203 | owner-name-rule 204 | group-name-rule 205 | device-number-rule 206 | filename-prefix-rule 207 | ; --- 208 | filedata-rule 209 | ] 210 | 211 | ; -- internal functions ---------------------------------------------------------- 212 | 213 | make-entry: func [ 214 | filename [file!] 215 | /local 216 | entry empty name data size date username chksm 217 | ][ 218 | entry: copy #{} 219 | empty: zeroes 8 220 | name: zeroes 100 221 | data: read/binary filename 222 | size: to-octal length? data 223 | date: to-octal to integer! query filename 224 | username: rejoin [#{} "sony" zeroes 28] ; TODO: replace with real username later 225 | insert/dup size #"0" 12 - length? size ; filename 226 | change name filename 227 | entry: rejoin [ 228 | #{} 229 | name 230 | {0000644^@} ; file mode (TODO: replace with real mode) 231 | {0001750^@} ; owner's numeric user ID (TODO: replace with real value) 232 | {0001750^@} ; group's numeric user ID (TODO: replace with real value) 233 | size ; file size 234 | date ; file modification date 235 | " " ; checksum 236 | entry #{30} ; link type (0 - normal file, 1 - hard, 2 - soft) 237 | zeroes 100 238 | "ustar " 239 | #{2000} ; version 240 | username ; TODO: owner's name 241 | username ; TODO: owner's group 242 | zeroes 8 ; TODO: device major number 243 | zeroes 8 ; TODO: device minor number 244 | zeroes 155 ; TODO: split filename when needed 245 | zeroes 12 ; pad entry to be 512 bytes 246 | ] 247 | ; fix checksum 248 | chksm: skip to-octal make-checksum entry 4 249 | change chksm #"^@" 250 | change at entry 148 chksm ; 148 is checksum position in header 251 | ; pad to record size (512 bytes) 252 | repend entry [ 253 | data 254 | zeroes 512 - ((length? data) // 512) 255 | ] 256 | entry 257 | 258 | ] 259 | ; -- in-Red functions ------------------------------------------------------------ 260 | 261 | 262 | set 'load-tar func [ 263 | data 264 | /verbose 265 | ][ 266 | if all [data/1 = 31 data/2 = 139][data: decompress data 'gzip] 267 | files: copy #() 268 | parse data [ 269 | some [ 270 | 2 empty-block to end 271 | | file-rule (if verbose [print-file-info]) 272 | ] 273 | ] 274 | files 275 | ] 276 | 277 | set 'make-tar func [ 278 | files [file! block!] 279 | ][ 280 | files: append copy [] files 281 | out: copy #{} 282 | foreach file files [ 283 | ; TODO: handle directories 284 | append out make-entry file 285 | ] 286 | append out zeroes 1024 ; two empty records 287 | padding: (length? out) // 10240 288 | append out zeroes 10240 - padding ; pad to 20 records 289 | out 290 | ] 291 | 292 | ; -- file functions -------------------------------------------------------------- 293 | 294 | set 'tar func [ 295 | "Save TAR archive created from given files or paths" 296 | where [file!] "Where to save" 297 | files [file! block!] "File(s) and/or path(s) to archive" 298 | /gzip "Compress TAR with GZIP (.tar.gz)" 299 | /local grab-files out 300 | ][ 301 | ; TODO: auto-handle extensions when needed 302 | grab-files: func [path /local files][ 303 | either dir? path [ 304 | files: read path 305 | append out path 306 | foreach file files [ 307 | grab-files rejoin [path file] 308 | ] 309 | ][ 310 | append out path 311 | ] 312 | ] 313 | 314 | files: append copy [] files 315 | out: copy [] 316 | foreach file files [grab-files file] 317 | out: make-tar out 318 | if gzip [out: compress out 'gzip] 319 | write/binary where out 320 | ] 321 | 322 | set 'untar func [ 323 | "Extract files from TAR archive" 324 | value [file!] "TAR archive to extract" 325 | /local data file content out 326 | ][ 327 | out: copy [] 328 | data: load-tar read/binary value 329 | foreach [file content] data [ 330 | append out file: to file! file 331 | either dir? file [ 332 | make-dir/deep file 333 | ][ 334 | write/binary file content 335 | ] 336 | ] 337 | out 338 | ] 339 | ; -- end of context 340 | ] 341 | 342 | -------------------------------------------------------------------------------- /codecs/xml.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Title: "XML" 3 | Description: "Encoder and decoder for XML and HTML format" 4 | Author: "Boleslav Březovský" 5 | Notes: [ 6 | { 7 | == UNCLOSED

TAG == 8 | 9 | A p element’s end tag may be omitted if the p element is immediately followed 10 | by an address, article, aside, blockquote, dir, div, dl, fieldset, footer, 11 | form, h1, h2, h3, h4, h5, h6, header, hr, menu, nav, ol, p, pre, section, 12 | table, or ul element, or if there is no more content in the parent element 13 | and the parent element is not an a element. 14 | } 15 | ] 16 | ] 17 | 18 | debug: func [ 19 | value 20 | /init 21 | ] [ 22 | if all [debug? init] [write value "" exit] 23 | if debug? [ 24 | write/append %debug value 25 | print value 26 | print [ 27 | "stack:" length? xml/stack 28 | "atts-stack:" length? xml/atts-stack 29 | rejoin [index? xml/pos "/" length? xml/doc] 30 | ] 31 | if (length? xml/stack) <> (length? xml/atts-stack) [ 32 | print "stacks differ" 33 | halt 34 | ] 35 | ; wait 0.02 36 | ; if "q" = ask "Q to quit:" [halt] 37 | ] 38 | ] 39 | debug?: no 40 | debug/init %debug 41 | 42 | ; ============================================================================ 43 | 44 | ; TODO: NAME* rules should be CHAR* 45 | 46 | xml: context [ 47 | 48 | ; === SETTINGS =========================================================== 49 | 50 | empty-value: none ; used for single tags that have no content 51 | align-content?: yes ; store `HTML` strings as one or three values: 52 | ; `string` or `[NONE string NONE]` 53 | ; this required for traversing with `foreach-node` 54 | key-type: string! ; `string!` or `word!` for conversion where possible 55 | 56 | ; === RULES ============================================================== 57 | 58 | s: e: t: none 59 | 60 | push-atts: [(append atts-stack copy atts=)] 61 | pop-atts: [keep (take/last atts-stack)] 62 | 63 | document: [ 64 | (clear stack) 65 | (clear atts-stack) 66 | some content 67 | ] 68 | whitespace: charset " ^-^/^M" 69 | ws: [any whitespace] 70 | name-start-char: charset [ 71 | ":_" #"a" - #"z" #"A" - #"Z" #"0" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" 72 | #"^(F8)" - #"^(02FF)" #"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" 73 | #"^(200C)" - #"^(200D)" #"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" 74 | #"^(3001)" - #"^(D7FF)" #"^(F900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)" 75 | #"^(010000)" - #"^(0EFFFF)" 76 | ] 77 | name-char: union name-start-char charset [ 78 | "-." #"0" - #"9" #"^(B7)" #"^(0300)" - #"^(036F)" #"^(203F)" - #"^(2040)" 79 | ] 80 | name: [name-start-char any name-char] 81 | single-tags: [ 82 | "area" | "base" | "br" | "col" | "command" | "embed" | "hr" | "img" 83 | | "input" | "keygen" | "link" | "meta" | "param" | "source" | "track" 84 | | "wbr" 85 | ] 86 | open-tag: [ 87 | ws #"<" 88 | not ahead single-tags 89 | (debug "--open-tag?") 90 | copy name= some name 91 | (debug ["--open-tag" mold name=]) 92 | ws atts ws 93 | #">" 94 | push-atts 95 | (append stack name=) 96 | keep (to word! name=) 97 | ] 98 | close-tag: [ 99 | (debug "--close-tag?") 100 | close-p-tag1 101 | | ws "" ; in case of badly writen HTML (wild close tag) 106 | (close=: name=) ; for debug purpose only 107 | (name=: none) 108 | pop-atts 109 | ] 110 | wild-close-tag: [ 111 | ws " can be unlcosed so it's not error 114 | not name= 115 | copy name= some name #">" 116 | ] 117 | 118 | close-p-tag1: [ 119 | ; there are three ways to close

tag: 120 | if ("p" = last stack) 121 | pos: 122 | (debug ["|para|" mold stack mold pos]) 123 | [ 124 | ws " 126 | (name=: last stack) 127 | name= 128 | #">" 129 | ; 2. close parent tag 130 | | (name=: first back back stack) 131 | name= 132 | :pos ; rewind so CLOSE-TAG for above tag can catch it again 133 | ; TODO: change to AHEAD, needs rule rewrite 134 | ] 135 | | if (para?) 136 | ] 137 | (take/last stack) 138 | (close=: name=) ; for debug purpose only 139 | (name=: none) 140 | pop-atts 141 | (para?: false) 142 | (debug "closed para1") 143 | ] 144 | close-p-tag2: [ 145 | ; 3. open tag from END-P-TAG list 146 | ahead [#"<" end-p-tag] 147 | (para?: true) 148 | ] 149 | end-p-tag: [ 150 | "address" | "article" | "aside" | "blockquote" | "dir" | "div" | "dl" 151 | | "fieldset" | "footer" | "form" | "h1" | "h2" | "h3" | "h4" | "h5" 152 | | "h6" | "header" | "hr" | "menu" | "nav" | "ol" | "p" | "pre" 153 | | "section" | "table" | "ul" 154 | ] 155 | close-char: #"/" 156 | action: none 157 | single-tag: [ 158 | (close-char: #"/") 159 | ws #"<" opt [#"!" (close-char: "")] 160 | (debug "--single-tag?") 161 | copy name= [ 162 | single-tags (close-char: [opt #"/"]) 163 | | some name 164 | ] 165 | (debug ["--single-tag" mold name=]) 166 | ws atts ws 167 | close-char #">" 168 | opt [""] 169 | push-atts 170 | keep (to word! name=) 171 | keep (empty-value) ; empty content 172 | pop-atts 173 | ] 174 | ;TODO: for HTML attribute names, #":" should be excluded 175 | pair-att: [ 176 | ws not #"/" 177 | copy att-name= some name 178 | #"=" [ 179 | set quot-char [#"^"" | #"'"] 180 | copy att-value= to quot-char skip 181 | | copy att-value= to [#">" | whitespace] 182 | ] 183 | ws ( 184 | all [ 185 | equal? word! key-type 186 | try [t: to set-word! att-name=] 187 | att-name=: t 188 | ] 189 | atts=/:att-name=: att-value= 190 | ) 191 | ] 192 | single-att: [ 193 | ws not #"/" 194 | copy att-name= some name 195 | ws 196 | (atts=/:att-name=: true) 197 | ] 198 | atts: [ 199 | (atts=: copy #()) ; FIXME: IMO `clear` should be enough here, but it is not 200 | ws any [pair-att | single-att] 201 | ] 202 | comment: [ws "" ws] 203 | string: [ 204 | s: any [ 205 | if (find ["script" "pre"] name=) not ahead [""] skip 206 | ; accept #"<" inside