diff --git a/.circleci/config.yml b/.circleci/config.yml index 94032dc..18dd386 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,31 +1,35 @@ -# Use the latest 2.1 version of CircleCI pipeline process engine. -# See: https://circleci.com/docs/2.0/configuration-reference version: 2.1 -# Define a job to be invoked later in a workflow. -# See: https://circleci.com/docs/2.0/configuration-reference/#jobs jobs: - # Below is the definition of your job to build and test your app, you can rename and customize it as you want. - build-and-test: - # These next lines define a Docker executor: https://circleci.com/docs/2.0/executor-types/ - # You can specify an image from Dockerhub or use one of our Convenience Images from CircleCI's Developer Hub. - # Be sure to update the Docker image tag below to openjdk version of your application. - # A list of available CircleCI Docker Convenience Images are available here: https://circleci.com/developer/images/image/cimg/openjdk + test: docker: - image: cimg/openjdk:11.0 - # Add steps to the job - # See: https://circleci.com/docs/2.0/configuration-reference/#steps steps: - # Checkout the code as the first step. - checkout - # Use mvn clean and package as the standard maven build phase - - run: - name: Build - command: mvn -B -DskipTests clean package - # Then run your tests! + - run: name: Test - command: mvn test + command: | + cd kawa-web-collection + git submodule update --init + mvn install -DskipTests=true + cd .. + mvn test + + build: + machine: true + steps: + - checkout + + - run: | + cd kawa-web-collection + git submodule update --init + cd .. + docker login -u $DOCKER_USER -p $DOCKER_PASSWORD + docker build -t arvyy/r7rs-index:$CIRCLE_BRANCH -f docker/Dockerfile . + + - run: docker push arvyy/r7rs-index:$CIRCLE_BRANCH + deploy: machine: true steps: @@ -34,13 +38,17 @@ jobs: command: | ssh $SSH_USER@$SSH_HOST "bash ~/update.sh" -# Invoke jobs via workflows -# See: https://circleci.com/docs/2.0/configuration-reference/#workflows workflows: - sample: # This is the name of the workflow, feel free to change it to better match your workflow. - # Inside the workflow, you define the jobs you want to run. + sample: jobs: - - build-and-test + - test + - build: + requires: + - test - deploy: requires: - - build-and-test + - build + filters: + branches: + only: + - master diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..a8c335c --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "kawa-web-collection"] + path = kawa-web-collection + url = https://github.com/arvyy/kawa-web-collection diff --git a/README.adoc b/README.adoc new file mode 100644 index 0000000..90bb489 --- /dev/null +++ b/README.adoc @@ -0,0 +1,382 @@ += R7RS index +:toc: left + +R7RS index is a tool for indexing and searching through procedures and syntax from R7RS-small and R7RS-large libraries. +R7RS index can be used in 3 ways - as a site (https://r7rsindex.com), through REST API, or through stdio API + +== Userguide for site visitors + +R7RS index search consists of control pane on the left, and result list in the center. + +=== Control pane + +In the control pane, optionally select values from the filter list, optionally enter search query in the text field, and press either enter or button with magnifying glass to display the results. If you have javascript enabled, typing in the search query field should give you auto suggestions for identifier names, although those suggestions are not filtered by current selection. If you have javascript enabled and have checked apropriate option in settings, you can use control + f to quickly focus to the query text field. + +=== Result list + +Each result item can be either a procedure, a macro, or a value. At the top it shows a library it is exported from. Note, that some identifiers are exported from multiple libraries. The library name can be pressed, which will result in starting new search using said library as a filter. On the right side top, associated list of tags with the result is shown. Like with library, tags are also clickable, and start a search using the clicked tag as a filter. + +Procedure, procedure-like macros and value names are rendered in *red*. Procedures are distinguished by being surrounded with parenthesis, as if being called. Following the name until the "=>" sign are parameters. If parameter is just a name, it means it has an unspecified type. Otherwise, parameter may be a list of type and name. Types are represented as predicate procedures. After the "=>" sign is the return type. The return can be one of: + +* predicate procedure name (just like parameter type); + +* a "*" symbol (meaning it returns a value of unknown type); + +* a word "undefined" (meaning it returns a value which shouldn't be used in portable code); + +* a list with "values" word in car position (meaning it has a multivalue return); + +* a list with "or" word in car position (meaning the return type is a union between given types). + +Types expressed as predicates in *blue* are links. Pressing on a type in parameter position will search using that type as *return value* filter; pressing on a type in return value position will search using that type as *parameter* filter. + +Scheme is a functional language and thus it'd be useful to specify taken / returned procedure values. Therefore, if one of parameters is *procedure?*, it's signature is defined below the main procedure's signature, using parameter's name in car position. Likewise same is done if return value is a procedure; but in that case word "return" is used as a name. + +Procedures can have more than one entry, even from same library. This occurs, if the procedures is has optional parameters and therefore can be called in multiple ways; or if the result type can be determined more precisely under more specific input parameters. + +Structural macros that don't resemble functions are rendered in *green*. If macro is complex, some parts of it are grouped, and the syntax of those groups shown below the syntax of whole macro. Macro literals are also rendered in green. To make parenthesis more obvious, auxiliary parenthesis coloring is used, however this coloring doesn't signify any information. + +=== Tags + +Result items might have one or more of following tags + +* pure - this procedure is referentially transparent (as long as whatever procedure parameters it has are also referentially transparent). Procedures that return undefined value cannot be marked as pure; +* predicate - this procedure that takes any object and returns a boolean. Such procedure may be used as a type; +* parameterized - the behavior of the procedure depends on a dynamic parameter (ie, uses procedure created with "make-parameter"); +* parameter - this procedure was created with "make-parameter" and may be used in parameterize form; +* syntax - this is actually a macro, although presented as a procedure (the justification is that combining ad-hoc type annotation with syntax specification might be confusing. Simple macros were subjectively chosen to be shown as if they were procedures if they superficially appear and are called as such. This might be changed in the future); +* deprecated - not recommended to be used, exists only for backwards compatibility with older SRFIs. + +=== Filtering logic + +Selecting multiple libraries, will return results that are part of *any* of the given libraries. + +Selecting multiple tags, will return results that contain *all* of the given tags. + +Selecting multiple parameter types will return results that match *all* of the given types. + +Some types contain logical "parent" / more general types, eg. *number?* is a parent of *integer?*. When searching by parameter type, the procedures that take parent type will be matched. However, the results with more precise "child" type are weight more heavily and should appear at the start of the search. + +Some types are defined as a union of other types; for example *list?* is a union of *pair?* and *null?*. If loose parameter filtering is enabled under settings, the composing parts will be treated as parent of union type; ie searching for *list?* you'd be also presented with procedures applicable to *pair?*. On one hand this presents extra results you might be interested, on the other hand those results might not be applicable in general case. + +Selecting multiple return types will return results that match *all* of the given types. As and in case filter by parameter type, when filtering by return type the type hierarchy is taken into consideration. Searching by a "parent" return type will also yield procedures returning more precise "child" types. + +The text query is parsed by edismax parser, and is used to filter by name and parameter / subsyntax names. This means it supports and interprets common searching syntax, such as using "-" in front of the word to exclude results containing said word. This has its disadvantages; eg. if you tried to search for coercion functions and typed "->string" (without quotes) into the search input field, you wouldn't find anything interesting, because the leading minus was interpreted specially. Instead, you'd have to search using "exact phrase", by putting double quotes around the search. + + +== Building and running + +=== Natively + +You can build R7RS index by running `ant` from the root of the source directory. Note that the build process required following executables to be on path + +* `ant` - Apache Ant build tool + +* `mvn` - Apache maven project tool + +* `asciidoctor` - Asciidoctor documentation compiler + +After the build successfully completes, you should find everything R7RS index needs in `dist` directory. + +Alternatively, you may find release zip available for downloads at https://github.com/arvyy/r7rs-index-site/releases. + +Once you have the built version, you can run it using: + +``` +java -jar r7rs-index.jar +``` + +See <> section for configuring the application behavior. + +=== Using docker + +If you prefer using docker, you can build a docker image using + +``` +docker build -t r7rs-index -f docker/Dockerfile . +``` + +which can the be run with + +``` +docker run -p 8080:8080 --init r7rs-index +``` + +The built image has same structure as a native build inside the `/app` path. + +=== Running for development + +First, install dependencies under kawa-web-collection submodule + +``` +cd kawa-web-collection +mvn install +``` + +Afterwards, run the application with + +``` +mvn kawa:run +``` + +== Configuration + +=== Config.scm + +Core application behavior is managed using a scm configuration file, containing a list of key-value pairs, where each key is a symbol (ie. an alist). +Running the application, first argument is interpreted as a path to configuration file. If not set, it defaults to `./config/configuration.scm` + +The following is exhaustive list of valid properties +[cols="1,3,1"] +|=== +| Property +| Description +| Default + +| solr-embed +| Specify whether embed solr / lucene index inside the application itself (if #t), or connect to a standalone solr instance (if #f) +| #t + +| solr-home +| Directory contain solr home / configuration. Relevant only if solr-embed is #t +| "./solrhome" + +| solr-url +| Solr url to connect to. Relevant only if solr-embed is #f +| "http://localhost:8983/solr" + +| solr-core +| Solr core to use +| "scmindex" + +| enable-web +| Whether enable web ui and REST api +| #t + +| port +| Which port to use. Relevant only if enable-web is #t +| 8080 + +| cache-templates +| Whether templates should be cached (ie compiled once and remembered). Use #f in development, so that you don't need to restart the app to see changes +| #t + +| serve-static +| Whether application should serve static resources from ./static folder. Use #f if you have some other web server (eg nginx in front) serving the content. +| #t + +| enable-repl +| Whether to enable stdio repl api +| #f + +| spec-index +| Index of definitions to load (see Types definitions section) +| "./types/index.scm" +|=== + +=== Types definitions + +Type definitions are structured into type files one for each library, and a single root index file which defines names and paths to those library files. +The index file is specified in configuration under `spec-index` property, with a default value "./types/index.scm". + +Index should be a list of pairs - where `car` is a symbolic library name, and `cdr` is the file to load its definitions from. + +``` +( + ((scheme base) . "types/scheme.base.scm") +) +``` + +Each library file is a list of entries, where each entry itself is a list and consists of 2 - 5 elements. An entry may be defining a function, a syntax macro, or a plain value. + +==== Function format + +1. name. ++ +Note, that the name doesn't have to be unique -- if the function has multiple overloaded signatures, simply create multiple definition for each possible option. + +2. signature, in the form of `(lambda ( ...) )` ++ +Each parameter is either of the form `( param-name)` or just `param-name`, when type is "any". Each parameter may be succeeded by a `...` literal to indicate varargs / repetition. ++ +Parameter type is either: + +* a predicate name (eg. `list?`); +* a type union in the form of `(or ...)` (eg. `(or list? number?)`). When using `or`, `#f` might be used as a type inside of it due to its common appearance as a "null" value. + ++ +Return type can be same as parameter type described above, plus: + +* `undefined`, indicating a value that shouldn't be used in portable code (eg. result of `for-each`); +* `*`, indicating a useful value but of unknown type. +* `(values ...)` form when the function returns more than one value. + +3. list of tags ++ +One of `pure`, `parameterized`, `parameter`, `predicate`, `syntax`, `deprecated`. + +4. list of parameter signatures, in case this is a higher order function. ++ +Each entry in this list is a list, where first element is a parameter name (must match one of parameters in main signature), and second parameter +is its signature of same format as a main function's signature definition. To describe return value's signature, use `return` as a name. + +5. list of associated types. Only applicable when this function is a predicate and logically describes a type. ++ +All elements in the associated types list should be predicate function names. +If the list has just one entry, then said entry corresponds to logical supertype of currently defined function / type. +If the list has more than one entry, then currently defined function / type is a union of those types. + +Some examples: + +``` +( + ;; type definition of a union + (list? + (lambda (obj) boolean?) + (pure predicate) + () + (pair? null?)) + + ;; parameters with types, parameter signature + (map + (lambda ((procedure? proc) (list? list1) (list? list2) ...) list?) + (pure) + ((proc (lambda (obj1 obj2 ...) *)))) + + ;; use of `values` + (exact-integer-sqrt + (lambda ((integer? k)) (values integer? integer?)) + (pure)) + + ;; use of `or`, use of overloading same name + (assoc + (lambda (obj (list? alist)) (or pair? #f)) + (pure)) + + (assoc + (lambda (obj (list? alist) (procedure? =)) (or pair? #f)) + (pure) + ((= (lambda (a b) *)))) +) +``` + +==== Syntax macro format + +1. name + +2. signature, in the form of `(syntax-rules ( ...) () ...)` ++ +Pattern should be: symbol, `.`, `...`, or grouping of patterns inside `()`. As a hatch to rendering outside of parens, +use `(_append )` form, which concatenates its arguments (see an example below). + +3. tags + +4. list of subpattern signatures + +Each entry in this list is a list, in the form of `(name ...)`, where name should match one of identifiers +in other signature, and the pattern is as described in 2. + +Some examples: + +``` +( + + (cond + (syntax-rules (else =>) + ((_ clause1 clause2 ...))) + () + ((clause (test expression1 ...) + (test => expression) + (else expression1 expression2 ...)))) + + (syntax-rules + (syntax-rules () + ((_ (literal ...) syntax-rule ...)) + ((_ ellipsis (literal ...) syntax-rule ...))) + () + ((syntax-rule (pattern template)) + (pattern identifier + constant + (pattern ...) + (pattern pattern ... . pattern) + (pattern ... pattern ellipsis pattern ...) + (pattern ... pattern ellipsis pattern ... . pattern) + (_append |#| (pattern ...)) + (_append |#| (pattern ... pattern ellipsis pattern ...))) + (template identifier + constant + (element ...) + (element element ... . template) + (ellipsis template) + (_append |#| (element ...))) + (element template + (_append template ellipsis)))) +) +``` + +==== Value format + + +1. name. + +2. signature, in the form of `(value )` + +where type is same as described under functions. + +Some examples: + +``` +( + (stream-null + (value stream-null?)) +) +``` + + +=== Logging + +R7RS index uses logback for logging. By default (as defined in `src/main/resources/logback.xml`) it only does rolling file logging into `./logs` directory, and not into standard output. +You can provide custom logging configuration by running + +``` +java -Dlogback.configurationFile=/path/to/config.xml -jar r7rs-index.jar +``` + +Consult logback documentation for details. + +== REST API + +All of the following endpoints accept `wt` query parameter. +If the parameter's value is `sexpr`, the results are returned as if with `write`, using scheme-json convention +as defined in srfi 180. Otherwise, results are returned as json. + +`/rest/libs` returns array of libraries found in index as strings; + +`/rest/tags` returns array of tags found in index as strings; + +`/rest/returns` returns array of types, which were used as a return type, found in index as strings; + +`/rest/params` returns array of types, which were used as a parameter type, found in index as strings; + +`/rest/procedures` returns found procedures with faceting meta data. The endpoint accepts following query parameters: + + +* `query` text search parameter. + +* `start` result offset (pagination). + +* `rows` size of returned result list. Defaults to 40 if unspecified. + +* `lib` library filter. Possible values returned in `/rest/libs`. The parameter can appear multiple times, and the result will include procedures from any of given libraries. + +* `tag` tag filter. Possible values returned in `/rest/tags`. The parameter can appear multiple times, and the result will include procedures which contain all given tags. + +* `param` param type filter. Possible values returned in `/rest/params`. The parameter can appear multiple times, and the result will include procedures which contain all given parameter types. + +* `filter_loose` whether enable loose filtering as described in <> + +* `return` return type filter. Possible values returned in `/rest/returns`. The parameter can appear multiple times, and the result will include procedures which contain all given return types. + +Note that current REST api is unstable, and subject to change without a warning. + +== STDIO API diff --git a/README.md b/README.md deleted file mode 100644 index 954cbfd..0000000 --- a/README.md +++ /dev/null @@ -1,33 +0,0 @@ -# R7RS index - -Source code for https://r7rsindex.com - -## Running locally - -### Docker for development - -The default `docker-compose up` launches a development configuration. You can access application through port 80, and solr admin gui through port 8983. Under this configuration static and template files -are mounted into the container. Templates aren't cached and are recompiled on each render which may affect performance. - -### Docker for use - -First generate local certifactes using `make create-dev-certs`. Next, run `docker-compose -f docker-compose.yml -f docker-compose.local.yml up`. Access application through port 443. - -### Without docker - -Install -* JDK11, -* Maven, -* Solr 6+. - -Launch solr, and create a core using configuration found in `./solrconfig`. Compile the application with `mvn clean package`. You should see `target/r7rs-index-.jar`. Move the jar to desired directory. Copy dockerconfig folder next to the jar, but rename from dockerconfig to just config. Edit configuration.scm file inside to point to solr url. Copy types folder next to the jar. To run the application, change working directory to the jar's folder, and execute `java -jar r7rs-index-.jar`. - -## Type definition format - -Types are defined in types folder. The `index.scm` acts as a root reference on where types for each library as stored. Each library file is a list of entries, where each entry itself consists of 2 - 5 elements - -* function name, -* function signature, -* list of tags, -* list of signatures for parameters, giving extra detail for `procedure?` types. Each entry is a list, where first element is a parameter name, and second element is its signature (same shape as and function signature in the second point), -* list of super types, if the current function being described is a predicate, and can be reasonably equivalted to a type. diff --git a/build.xml b/build.xml new file mode 100644 index 0000000..ba09e26 --- /dev/null +++ b/build.xml @@ -0,0 +1,71 @@ + + + + + + + + + + + + Detected windows environment + + + + + + Detected unix environment + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dockerconfig/configuration.scm b/config/configuration-dist.scm similarity index 50% rename from dockerconfig/configuration.scm rename to config/configuration-dist.scm index ac25622..348c076 100644 --- a/dockerconfig/configuration.scm +++ b/config/configuration-dist.scm @@ -1,5 +1,6 @@ -((solr-url . "http://solr:8983") - (solr-core . "scmindex") - (page-size . 40) - (cache-templates . #t) - (serve-static . #f)) +((solr-embed . #t) + (solr-core . "scmindex") + (enable-repl . #t) + (page-size . 40) + (cache-templates . #t) + (serve-static . #t)) diff --git a/dockerdevconfig/configuration.scm b/config/configuration.scm similarity index 69% rename from dockerdevconfig/configuration.scm rename to config/configuration.scm index 3837b09..9848e55 100644 --- a/dockerdevconfig/configuration.scm +++ b/config/configuration.scm @@ -1,5 +1,6 @@ -((solr-url . "http://solr:8983") +((solr-embed . #t) (solr-core . "scmindex") + (enable-repl . #t) (page-size . 40) (cache-templates . #f) (serve-static . #t)) diff --git a/docker-compose.local.yml b/docker-compose.local.yml deleted file mode 100644 index fff901e..0000000 --- a/docker-compose.local.yml +++ /dev/null @@ -1,6 +0,0 @@ -services: - nginx: - volumes: - - "./nginx.conf:/etc/nginx/nginx.conf" - - "./static:/www/data" - - "./cert/:/etc/letsencrypt/live/r7rsindex.com" diff --git a/docker-compose.override.yml b/docker-compose.override.yml deleted file mode 100644 index 84990e9..0000000 --- a/docker-compose.override.yml +++ /dev/null @@ -1,23 +0,0 @@ -services: - solr: - ports: - - "8983:8983" - app: - ports: - - "80:4567" - volumes: - - type: bind - source: ./static - target: /app/static - - type: bind - source: ./templates - target: /app/templates - - type: bind - source: ./dockerdevconfig - target: /app/config - nginx: - entrypoint: ["echo", "nginx disabled in dev"] - prometheus: - entrypoint: ["echo", "prometheus disabled in dev"] - solr_exporter: - entrypoint: ["echo", "solr_exporter disabled in dev"] diff --git a/docker-compose.yml b/docker-compose.yml deleted file mode 100644 index c0b6d33..0000000 --- a/docker-compose.yml +++ /dev/null @@ -1,51 +0,0 @@ -services: - - solr: - image: "solr:8" - volumes: - - "./solrconfig:/scmindex" - healthcheck: - test: ["CMD", "curl", "-f", "http://localhost:8983/solr/scmindex/admin/ping"] - interval: 10s - timeout: 10s - retries: 10 - command: ["solr-precreate", "scmindex", "/scmindex"] - - solr_exporter: - image: "solr:8" - entrypoint: - - "/opt/solr/contrib/prometheus-exporter/bin/solr-exporter" - - "-b" - - "http://solr:8983/solr" - - "-f" - - "/opt/solr/contrib/prometheus-exporter/conf/solr-exporter-config.xml" - - app: - build: . - depends_on: - solr: - condition: service_healthy - - nginx: - image: "nginx:1.21" - volumes: - - "./nginx.conf:/etc/nginx/nginx.conf" - - "./monitoring-password:/etc/nginx/monitoring-password" - - "./static:/www/data" - - "/etc/letsencrypt/:/etc/letsencrypt/" - ports: - - "80:80" - - "9090:9090" - - "443:443" - - prometheus: - image: prom/prometheus - volumes: - - "./prometheus.yml:/etc/prometheus/prometheus.yml" - - prometheus_exporter: - image: nginx/nginx-prometheus-exporter:0.10.0 - command: ["-nginx.scrape-uri=http://nginx:80/stub_status"] - depends_on: - - nginx - - prometheus diff --git a/Dockerfile b/docker/Dockerfile similarity index 54% rename from Dockerfile rename to docker/Dockerfile index 224782b..f652cc3 100644 --- a/Dockerfile +++ b/docker/Dockerfile @@ -1,15 +1,16 @@ FROM maven:3.8-openjdk-11 -WORKDIR app +RUN apt-get update && apt-get -y install ant asciidoctor +WORKDIR /app +COPY kawa-web-collection kawa-web-collection +WORKDIR /app/kawa-web-collection +RUN mvn install +WORKDIR /app COPY pom.xml . RUN mvn -B org.apache.maven.plugins:maven-dependency-plugin:3.1.0:resolve-plugins org.apache.maven.plugins:maven-dependency-plugin:3.1.0:resolve org.apache.maven.plugins:maven-dependency-plugin:3.1.0:go-offline COPY . . -RUN mvn clean package +RUN ant FROM openjdk:11 WORKDIR app -COPY --from=0 /app/target/r7rs-index-0.0.1.jar . -COPY types types -COPY dockerconfig config -COPY templates templates -COPY static static -CMD java -jar r7rs-index-0.0.1.jar +COPY --from=0 /app/dist . +CMD java -jar r7rs-index.jar diff --git a/docker/devcert/fullchain.pem b/docker/devcert/fullchain.pem new file mode 100644 index 0000000..c20c46d --- /dev/null +++ b/docker/devcert/fullchain.pem @@ -0,0 +1,21 @@ +-----BEGIN CERTIFICATE----- +MIIDazCCAlOgAwIBAgIUW3vF/WLScBXqPcAvBgrhGSUTyDEwDQYJKoZIhvcNAQEL +BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM +GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMjAyMjcyMDIyNDBaFw0yNDEx +MjIyMDIyNDBaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw +HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggEiMA0GCSqGSIb3DQEB +AQUAA4IBDwAwggEKAoIBAQC7doQ4fHISYo2MIAGSOSdC69DTJmjECbZv6oSnKWSg +mc4lTGzWHhgsnHcHvw5rcjqaLrzznbzVwwYDBoFL6FTRW6QQ99b9u3GFTX3ji7tO +kFeATL6VroRCq+uPgoppa66DHaAfWd0vpKhmnYDpOA3TBViWKv55VvnD4gWQVX7R +Slza/1cb0XwOxU52O9/n/jHh3xZeg91fsCkkLmM5AxzTCoNG+Ior2dC0sgr/oh2q +58kZXyqhzDofsnJwZ20RwCZDrNZ2zEdkwsa8IMo7GMPn9seozqlciVzBSyAFUrhL +WOJEaKcyjPiEHLvAeiw/w2UfSWFG6kChjXZ1tigjc1I3AgMBAAGjUzBRMB0GA1Ud +DgQWBBRfKKOi5MA7laGEl4+LmcRXlVkt4jAfBgNVHSMEGDAWgBRfKKOi5MA7laGE +l4+LmcRXlVkt4jAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQCJ +jpVkquFI8swweSBYUe1SRUgSy2mFgB8esolbULN5Oxd8vQ2u4ptUlVmzPTk/iyTW +cBzbHk8Id3pB/8awstdfgfcs5okolu2MmzOLF+KtSkHRm6vw+hmBR7wA88buJ8qO +VIDs4VgaNqkiyK+r0+oh9dNW/Uopdo+4Lsp9xwMh/iPKHAnBiIk6EjO8XGh2io0W +z5teaJr+sNHvBVgK2JdnM2iiImB7ndU/FOaGZuJ3uMl/oFg6bO5udS7dFZXJWB7F +wM07+21I0YtAXRFMpJRdra645yA7PIh6/H3FGznEDJYdCxYlNa85DKhfmddWzH2F +3VjyujwotUPh6Nl55R3A +-----END CERTIFICATE----- diff --git a/docker/devcert/privkey.pem b/docker/devcert/privkey.pem new file mode 100644 index 0000000..b51df16 --- /dev/null +++ b/docker/devcert/privkey.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQC7doQ4fHISYo2M +IAGSOSdC69DTJmjECbZv6oSnKWSgmc4lTGzWHhgsnHcHvw5rcjqaLrzznbzVwwYD +BoFL6FTRW6QQ99b9u3GFTX3ji7tOkFeATL6VroRCq+uPgoppa66DHaAfWd0vpKhm +nYDpOA3TBViWKv55VvnD4gWQVX7RSlza/1cb0XwOxU52O9/n/jHh3xZeg91fsCkk +LmM5AxzTCoNG+Ior2dC0sgr/oh2q58kZXyqhzDofsnJwZ20RwCZDrNZ2zEdkwsa8 +IMo7GMPn9seozqlciVzBSyAFUrhLWOJEaKcyjPiEHLvAeiw/w2UfSWFG6kChjXZ1 +tigjc1I3AgMBAAECggEBALHfOoX+Tp5zNKuIkvUTldVBu9sdzrp0HM8ETunttLVO +OvPZGEvyMi3iKG8JMb1xnXk+b7sYKF0Lt2CXg4dq40/jDEGtaClI+eXqKVEG/KsG ++n+aUhvkg0pfpht9Wae9rNBsA8q7kcvrCH6VZAPmU/euUufp05t+k27xvyW8eaBK +tyYyJR7beYklV4HcUSJV1z1f5c8MpEKB92T7kiIaA3nuHtN6cZcFyUbSnQRdIFr0 +pA3j2eAQISGfAL69rIOTmOyGdEPz0c6dBBr3o6XadyyPALkVPimJE9kfjkjrLNUG +y1YnNOB2OuACv778mT0ndf/ATuUHtj+GRlexOnDMcYECgYEA28wiLCj3RPiT6o9W +3M/ZxDrd9dPlowROYLN8B1CVHs/hnRZAegxwswkN0U9XgePJjEgPTAJRzLYbhIxP +zRCvS1kbh77vF6dU7K6d8luYNv2Uee3gEUX7OHu7R8Zv2agQ2Prt8oXW9w6WLxnn +FLexScAKtrlt7Xqlw0a6lyVL0z8CgYEA2lb8Nhv8M7VWTqEoDe9wgCX4c8V2Q8ec +serWsH5MLa9vA37VnggQBtxeWv1ZcUq8n603VZlo95k2WwMn8neQU30x07sXW6oi +YzmgwOUkR7lii50ieBSuXMc+d0jTkHu+uxSCmPpkBJhY3sg/qvjeWpOeHbPknWwl +0r4/5Y9u2wkCgYEAzFz9/P9OAZP6vCHwiri7aqetTu9pWWwcj+7ySD7Vl+ODi7Jv +2ssMUnr9nPrfi0bHVCaACpUxh1xfM5veavWzdyRv44RU/DI6VSJ6eyhM2/xk/AV/ +y6+8yKTK2g6YWtDYcVbGvTNSTz4Bx+OWpv2w2rizfXflzOO3klyGCxjDarMCgYEA +i4gvYfz8bacjYtiGmnE8OgkKACJe8+3q66CiVuQ/lqqYjWlO5tFMPLYz7n4d3NLg +PEMcK64AcMsO+5bGvqM+LrzBTQgxYzkVBMhdPSiyyMtmeMaQsqC01UHXX6/A1ILg +Xvo6g7zwkicyFB1w4rhskQHpeB3wqdHlUgqXFwNU2tECgYBkls94I97WK3M1CFOe +IfGZW7GPL/GFayUZ7zud85W//hJmuPyhm6g11DYe3a8e1nAxzNzNAeHRyZ4DAZNt +/kUBTMuqX+6Kgr72cEcSer6inyPQJYrkvXIM/Vkpg2mbRsFA7UOJVpcjtsMQa5Sm +QqBVE3EvbEG4zxOgRtyQaJy27g== +-----END PRIVATE KEY----- diff --git a/docker/docker-compose.override.yml b/docker/docker-compose.override.yml new file mode 100644 index 0000000..0664c15 --- /dev/null +++ b/docker/docker-compose.override.yml @@ -0,0 +1,5 @@ +services: + nginx: + volumes: + - "./nginx.conf:/etc/nginx/nginx.conf" + - "./devcert/:/etc/letsencrypt/live/r7rsindex.com" diff --git a/docker/docker-compose.yml b/docker/docker-compose.yml new file mode 100644 index 0000000..e2aef3b --- /dev/null +++ b/docker/docker-compose.yml @@ -0,0 +1,21 @@ +services: + app: + image: "arvyy/r7rs-index:master" + volumes: + - "statics:/app/static" + - type: bind + source: ./logs + target: /app/logs + + nginx: + image: "nginx:1.21" + volumes: + - "./nginx.conf:/etc/nginx/nginx.conf" + - "statics:/www/data:ro" + - "/etc/letsencrypt/:/etc/letsencrypt/" + ports: + - "80:80" + - "443:443" + +volumes: + statics: diff --git a/docker/nginx.conf b/docker/nginx.conf new file mode 100644 index 0000000..375ded3 --- /dev/null +++ b/docker/nginx.conf @@ -0,0 +1,39 @@ +events {} + +http { + + server { + listen 80; + + location / { + return 301 https://$host$request_uri; + } + } + + server { + listen 443 ssl; + ssl_certificate /etc/letsencrypt/live/r7rsindex.com/fullchain.pem; + ssl_certificate_key /etc/letsencrypt/live/r7rsindex.com/privkey.pem; + root /www/data; + + location /README.html { + } + + location /css { + } + + location /js { + } + + location /scmindex.png { + } + + location / { + resolver 127.0.0.11 valid=30s; + set $upstream_app app; + proxy_set_header Host $host; + proxy_pass http://$upstream_app:8080; + } + } + +} diff --git a/kawa-web-collection b/kawa-web-collection new file mode 160000 index 0000000..e543b80 --- /dev/null +++ b/kawa-web-collection @@ -0,0 +1 @@ +Subproject commit e543b801acdd344bd06a1a0984796d412b4991d3 diff --git a/makefile b/makefile deleted file mode 100644 index 2aafce9..0000000 --- a/makefile +++ /dev/null @@ -1,6 +0,0 @@ -create-dev-certs: - mkdir -p cert - openssl req -new -x509 -days 999 -nodes -out cert/fullchain.pem -keyout cert/privkey.pem - -create-monitoring-user: - htpasswd -c monitoring-password monitoring diff --git a/nginx.conf b/nginx.conf deleted file mode 100644 index d452d73..0000000 --- a/nginx.conf +++ /dev/null @@ -1,62 +0,0 @@ -events {} - -http { - - server { - listen 80; - - location /stub_status { - stub_status on; - allow 172.16.0.0/12; - allow 192.168.0.0/16; - deny all; - } - - location / { - return 301 https://$host$request_uri; - } - } - - server { - listen 443 ssl; - ssl_certificate /etc/letsencrypt/live/r7rsindex.com/fullchain.pem; - ssl_certificate_key /etc/letsencrypt/live/r7rsindex.com/privkey.pem; - root /www/data; - - location /css { - } - - location /js { - } - - location /scmindex.png { - } - - location /monitoring { - return 301 https://$host:9090; - } - - location / { - resolver 127.0.0.11 valid=30s; - set $upstream_app app; - proxy_set_header Host $host; - proxy_pass http://$upstream_app:4567; - } - } - - server { - listen 9090 ssl; - ssl_certificate /etc/letsencrypt/live/r7rsindex.com/fullchain.pem; - ssl_certificate_key /etc/letsencrypt/live/r7rsindex.com/privkey.pem; - - location / { - auth_basic "Monitoring"; - auth_basic_user_file /etc/nginx/monitoring-password; - resolver 127.0.0.11 valid=30s; - set $upstream_prometheus prometheus; - proxy_set_header Host $host; - proxy_pass http://$upstream_prometheus:9090; - } - } - -} diff --git a/pom.xml b/pom.xml index b68d82b..f132af9 100644 --- a/pom.xml +++ b/pom.xml @@ -42,31 +42,57 @@ - com.sparkjava - spark-core - 2.9.2 + com.github.arvyy.kawa-web-collection + solr-embedded + 0.0.1 + kawalib + + + org.apache.logging.log4j + log4j-slf4j-impl + + - org.apache.httpcomponents - fluent-hc - 4.5.12 + com.github.arvyy.kawa-web-collection + solrj + 0.0.1 + kawalib + + + org.apache.logging.log4j + log4j-slf4j-impl + + - - org.slf4j - slf4j-simple - 1.7.21 - test + com.github.arvyy.kawa-web-collection + spark + 0.0.1 + kawalib - - commons-io - commons-io - 2.8.0 - test + com.github.arvyy.kawa-web-collection + slf4j + 0.0.1 + kawalib + + + + com.github.arvyy.kawa-web-collection + mustache + 0.0.1 + kawalib + + + + com.github.arvyy.kawa-web-collection + srfi-180 + 0.0.1 + kawalib @@ -93,7 +119,26 @@ maven-shade-plugin 3.2.4 + + + *:* + + META-INF/*.SF + META-INF/*.DSA + META-INF/*.RSA + + + + + META-INF/services/org.apache.lucene.codecs.Codec + + + META-INF/services/org.apache.lucene.codecs.DocValuesFormat + + + META-INF/services/org.apache.lucene.codecs.PostingsFormat + main @@ -114,7 +159,8 @@ com.github.arvyy kawa-maven-plugin - 0.0.5 + 0.0.7 + true test @@ -129,20 +175,6 @@ - - - arvyy/kawa-spark.scm - arvyy/mustache.scm - arvyy/slf4j.scm - srfi/180.scm - scmindex/types-parser.scm - scmindex/solr.scm - scmindex/main.scm - - scmindex/main.scm - false - - diff --git a/prometheus.yml b/prometheus.yml deleted file mode 100644 index a8d1a31..0000000 --- a/prometheus.yml +++ /dev/null @@ -1,12 +0,0 @@ -global: - scrape_interval: 15s -scrape_configs: - - job_name: nginx - static_configs: - - targets: ['prometheus_exporter:9113'] - - job_name: node - static_configs: - - targets: ['host.docker.internal:9100'] - - job_name: solr - static_configs: - - targets: ['solr_exporter:9983'] diff --git a/solrconfig/conf/schema.xml b/solrhome/scmindex/conf/schema.xml similarity index 100% rename from solrconfig/conf/schema.xml rename to solrhome/scmindex/conf/schema.xml diff --git a/solrconfig/conf/solrconfig.xml b/solrhome/scmindex/conf/solrconfig.xml similarity index 97% rename from solrconfig/conf/solrconfig.xml rename to solrhome/scmindex/conf/solrconfig.xml index 7593fb3..149135c 100644 --- a/solrconfig/conf/solrconfig.xml +++ b/solrhome/scmindex/conf/solrconfig.xml @@ -35,8 +35,12 @@ ${solr.ulog.numVersionBuckets:65536} + + 2000 + 30 + false ${solr.autoSoftCommit.maxTime:15000} diff --git a/solrhome/scmindex/core.properties b/solrhome/scmindex/core.properties new file mode 100644 index 0000000..f6fc61c --- /dev/null +++ b/solrhome/scmindex/core.properties @@ -0,0 +1 @@ +name=scmindex \ No newline at end of file diff --git a/solrhome/solr.xml b/solrhome/solr.xml new file mode 100644 index 0000000..e4cb227 --- /dev/null +++ b/solrhome/solr.xml @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/src/main/resources/logback.xml b/src/main/resources/logback.xml index b35926b..bd3aaa3 100644 --- a/src/main/resources/logback.xml +++ b/src/main/resources/logback.xml @@ -1,11 +1,21 @@ - + + + + + ${LOG_ROOT}/${LOG_FILE_NAME}.log + + ${LOG_ROOT}/${LOG_FILE_NAME}-%d{yyyy-MM-dd}.%i.log.gz + 10MB + 30 + 100GB + %d{HH:mm:ss.SSS} [%thread] %-5level %logger{36} - %msg%n - + - + \ No newline at end of file diff --git a/src/main/scheme/arvyy/httpclient.scm b/src/main/scheme/arvyy/httpclient.scm deleted file mode 100644 index 24e550c..0000000 --- a/src/main/scheme/arvyy/httpclient.scm +++ /dev/null @@ -1,43 +0,0 @@ -(define-library - (arvyy httpclient) - (import (scheme base) - (scheme write) - (srfi 180) - (class org.apache.http.client.fluent Request) - (class org.apache.http.entity ContentType) - (class java.net URLEncoder)) - (export post-json encode-query) - - (begin - - (define (post-json url ::String payload) - (let ((content (open-output-string)) - (r (Request:Post url))) - (json-write payload content) - (r:bodyString (get-output-string content) ContentType:APPLICATION_JSON) - (let* ((resp (r:execute)) - (content (resp:returnContent)) - (str-content (content:asString)) - (str-port (open-input-string str-content))) - (json-read str-port)))) - - (define (encode-query alist) - (let loop ((str "") - (alist alist) - (first #t)) - (cond - ((null? alist) str) - (else (let ((key (caar alist)) - (value (cdar alist)) - (rest (cdr alist))) - (define fragment - (string-append - (URLEncoder:encode (symbol->string key) "UTF-8") - "=" - (URLEncoder:encode value "UTF-8"))) - (define new-str - (if first - fragment - (string-append str "&" fragment))) - (loop new-str rest #f)))))) - )) diff --git a/src/main/scheme/arvyy/kawa-spark.scm b/src/main/scheme/arvyy/kawa-spark.scm deleted file mode 100644 index a915a9e..0000000 --- a/src/main/scheme/arvyy/kawa-spark.scm +++ /dev/null @@ -1,291 +0,0 @@ -(define-library - (arvyy kawa-spark) - (import (scheme base) - (class spark Spark Request Response Session Filter Route)) - (export - ;; path mappings - get - post - put - delete - options - before - before-all - after - after-all - after-after - after-after-all - redirect/get - redirect/post - redirect - path - - ;; request - req/attributes - req/attribute - req/set-attribute! - req/body - req/body-as-bytes - req/content-length - req/content-type - req/context-path - req/cookies - req/cookie - req/headers - req/header - req/host - req/ip - req/params - req/param - req/path-info - req/port - req/protocol - req/query-string - req/query-params - req/query-param - req/query-param-values - req/request-method - req/scheme - req/session - req/create-session! - req/splat - req/uri - req/url - req/user-agent - - ;; response - resp/body - resp/set-body! - resp/set-header! - resp/redirect - resp/status - resp/set-status! - resp/type - resp/set-type! - resp/set-cookie! - resp/remove-cookie! - - ;; session - session/attribute - session/set-attribute! - session/remove-attribute! - session/attributes - session/id - session/new? - - ;; halt - halt! - - ;; error handling - not-found - internal-server-error - exception - - ;; static files - static-files/location - static-files/external-location - static-files/expire-time - static-files/header - - ;; other - init - stop - port - secure - thread-pool - await-initialization - await-stop) - - (begin - - ;; private util - (define (map->alist m ::java.util.Map) - (define (entry->pair e ::java.util.Map:Entry) - (cons - (string->symbol (e:getKey)) - (e:getValue))) - (map entry->pair (m:entrySet))) - - (define-syntax route-stx - (syntax-rules () - ((_ fn) - (lambda (req resp) (fn req resp))))) - - - ;; path mappings - (define (get path route) - (Spark:get path (route-stx route))) - (define (post path route) - (Spark:post path (route-stx route))) - (define (put path route) - (Spark:put path (route-stx route))) - (define (delete path route) - (Spark:delete path (route-stx route))) - (define (options path route) - (Spark:options path (route-stx route))) - (define (before path handler) - (define (before* p ::String h ::Filter) - (Spark:before p h)) - (before* path (route-stx handler))) - (define (before-all handler) - (define (before-all* h ::Filter) - (Spark:before h)) - (before-all* (route-stx handler))) - (define (after path handler) - (define (after* p ::String h ::Filter) - (Spark:after p h)) - (after* path (route-stx handler))) - (define (after-all handler) - (define (after-all* h ::Filter) - (Spark:after h)) - (after-all* (route-stx handler))) - (define (after-after path handler) - (Spark:afterAfter path (route-stx handler))) - (define (after-after-all handler) - (Spark:afterAfter (route-stx handler))) - (define (redirect/get from to) - (Spark:redirect:get from to)) - (define (redirect/post from to) - (Spark:redirect:post from to)) - (define (redirect from to) - (Spark:redirect:any from to)) - (define-syntax path - (syntax-rules () - ((_ p body ...) - (Spark:path p (lambda () body ...))))) - - ;; request - (define (req/attributes req ::Request) - ; convert Set to list - (map (lambda (e) e) (req:attributes))) - (define (req/attribute req ::Request attr) - (req:attribute attr)) - (define (req/set-attribute! req ::Request attr value) - (req:attribute attr value)) - (define (req/body req ::Request) - (req:body)) - (define (req/body-as-bytes req ::Request) - ; convert java byte array into vector - (vector-map (lambda (e) e) (req:bodyAsBytes))) - (define (req/content-length req ::Request) - (req:contentLength)) - (define (req/content-type req ::Request) - (req:contentType)) - (define req/context-path Request:contextPath) - (define (req/cookies req ::Request) - (map->alist (req:cookies))) - (define (req/cookie req ::Request name) - (req:cookie name)) - (define (req/headers req ::Request) - (map (lambda (e) e) (req:headers))) - (define (req/header req ::Request name) - (req:headers name)) - (define (req/host req ::Request) - (req:host)) - (define (req/ip req ::Request) - (req:ip)) - (define (req/params req ::Request) - (map->alist (req:params))) - (define (req/param req ::Request param) - (define p (req:params param)) - (if (eq? #!null p) - #f - p)) - (define (req/path-info req ::Request) - (req:pathInfo)) - (define (req/port req ::Request) - (req:port)) - (define (req/protocol req ::Request) - (req:protocol)) - (define (req/query-string req ::Request) - (req:queryString)) - (define (req/query-params req ::Request) - (map (lambda (e) e) (req:queryParams))) - (define (req/query-param req ::Request param) - (define p (req:queryParams param)) - (if (eq? #!null p) - #f - p)) - (define (req/query-param-values req ::Request param) - (define vals (req:queryParamsValues param)) - (map (lambda (e) e) (if (eq? #!null vals) '() vals))) - (define (req/request-method req ::Request) - (req:requestMethod)) - (define (req/scheme req ::Request) - (req:scheme)) - (define (req/session req ::Request) - (req:session #f)) - (define (req/create-session! req ::Request) - (req:session #t)) - (define (req/splat req ::Request) - (map (lambda (e) e) (req:splat))) - (define (req/uri req ::Request) - (req:uri)) - (define (req/url req ::Request) - (req:url)) - (define (req/user-agent req ::Request) - (req:userAgent)) - - ;; response - (define (resp/body resp ::Response) - (resp:body)) - (define (resp/set-body! resp ::Response body) - (resp:body body)) - (define (resp/set-header! resp ::Response name value) - (resp:header name value)) - (define (resp/redirect resp ::Response target) - (resp:redirect target)) - (define (resp/status resp ::Response) - (resp:status)) - (define (resp/set-status! resp ::Response status) - (resp:status status)) - (define (resp/type resp ::Response) - (resp:type)) - (define (resp/set-type! resp ::Response type) - (resp:type type)) - (define (resp/set-cookie! resp ::Response name value) - (resp:cookie name value)) - (define (resp/remove-cookie! resp ::Response name) - (resp:removeCookie name)) - - ;; session - (define (session/attribute s ::Session attr) - (s:attribute attr)) - (define (session/set-attribute! s ::Session attr value) - (s:attribute attr value)) - (define session/remove-attribute! Session:removeAttribute) - (define session/attributes Session:attributes) - (define session/id Session:id) - (define session/new? Session:isNew) - - ;; halt - (define (halt! code message) - (Spark:halt code message)) - - ;; error handling - (define (not-found route) - (define (not-found* r ::Route) - (Spark:notFound r)) - (not-found* (route-stx route))) - (define (internal-server-error route) - (define (internal-server-error* r ::Route) - (Spark:internalServerError r)) - (internal-server-error* (route-stx route))) - (define (exception handler) - (Spark:exception Object:class - (lambda (exception req resp) (handler exception req resp)))) - - ;; static files - (define static-files/location Spark:staticFiles:location) - (define static-files/external-location Spark:staticFiles:externalLocation) - (define static-files/expire-time Spark:staticFiles:expireTime) - (define static-files/header Spark:staticFiles:header) - - ;; other - (define init Spark:init) - (define stop Spark:stop) - (define port Spark:port) - (define secure Spark:secure) - (define thread-pool Spark:threadPool) - (define await-initialization Spark:awaitInitialization) - (define await-stop Spark:awaitStop))) diff --git a/src/main/scheme/arvyy/mustache-impl.scm b/src/main/scheme/arvyy/mustache-impl.scm deleted file mode 100644 index fc2156a..0000000 --- a/src/main/scheme/arvyy/mustache-impl.scm +++ /dev/null @@ -1,106 +0,0 @@ -(define (default-writer obj out) - (when obj - (display obj out))) - -(define default-lookup - (compose-lookups - alist-lookup)) - -(define default-collection - (compose-collections - vector-collection - stream-collection)) - -(define (port->string port) - (define str - (let loop ((chunks '()) - (chunk (read-string 2000 port))) - (if (eof-object? chunk) - (apply string-append (reverse chunks)) - (loop (cons chunk chunks) - (read-string 2000 port))))) - (close-input-port port) - str) - -(define (template-get-partials template) - (define partials - (let loop ((template template) - (parts '())) - (cond - ((null? template) parts) - (else (let ((t (car template)) - (rest (cdr template))) - (cond - ((partial? t) (loop rest - (cons (partial-name t) parts))) - ((section? t) (loop rest - (append (template-get-partials (section-content t)) - parts))) - (else (loop rest - parts)))))))) - (delete-duplicates! partials)) - -(define compile - (case-lambda - ((template) (compile/without-partials template)) - ((root partial-locator) (compile/with-partials root partial-locator)))) - -(define (compile/without-partials template) - (compile/with-partials #f (lambda (partial) - (if partial - #f - template)))) - -(define (compile/with-partials root partial-locator) - - ;; returns 2 values: missing partials (found in part) and compiled part template - (define (compile-part part resolved-partials) - (define source (partial-locator part)) - (define in (cond - ((not source) "") - ((string? source) source) - ((port? source) (port->string source)) - (else (error "Partial locator returned unrecognized type")))) - (define template (parse (read-tokens in))) - (define partials (template-get-partials template)) - (define missing-partials (lset-difference string=? partials resolved-partials)) - (values missing-partials template)) - - (let loop ((unresolved (list root)) - (resolved-map '()) - (resolved-lst '())) - (cond - ((null? unresolved) (cons root resolved-map)) - (else (let ((part (car unresolved))) - (define-values (unresolved* template) - (compile-part part resolved-lst)) - (loop (append unresolved* (cdr unresolved)) - (cons (cons part template) resolved-map) - (cons part resolved-lst))))))) - -(define current-lookup (make-parameter default-lookup)) -(define current-collection (make-parameter default-collection)) -(define current-writer (make-parameter default-writer)) - -(define execute - (case-lambda - ((compilation data) - (let ((out (open-output-string))) - (execute compilation data out) - (get-output-string out))) - ((compilation data out) - (define root (car compilation)) - (define partials (cdr compilation)) - (define template (cdr (assoc root partials))) - (define lookup (current-lookup)) - (define collection* (current-collection)) - (define writer (current-writer)) - (executor-execute template - (list data) - partials - out - lookup - (collection-pred-proc collection*) - (collection-empty?-proc collection*) - (collection-for-each-proc collection*) - writer)))) diff --git a/src/main/scheme/arvyy/mustache.scm b/src/main/scheme/arvyy/mustache.scm deleted file mode 100644 index 42aea6f..0000000 --- a/src/main/scheme/arvyy/mustache.scm +++ /dev/null @@ -1,27 +0,0 @@ -(define-library - (arvyy mustache) - (import (scheme base) - (scheme case-lambda) - (scheme write) - (arvyy mustache lookup) - (arvyy mustache collection) - (prefix (arvyy mustache executor) executor-) - (arvyy mustache parser) - (arvyy mustache tokenizer) - (srfi 1)) - (export - execute - compile - current-lookup - current-collection - current-writer - - compose-lookups - alist-lookup - - collection - compose-collections - vector-collection - list-collection - stream-collection) - (include "mustache-impl.scm")) diff --git a/src/main/scheme/arvyy/mustache/collection.scm b/src/main/scheme/arvyy/mustache/collection.scm deleted file mode 100644 index 1688a1a..0000000 --- a/src/main/scheme/arvyy/mustache/collection.scm +++ /dev/null @@ -1,64 +0,0 @@ -(define-library - (arvyy mustache collection) - (import (scheme base) - (srfi 41)) - (export - collection - collection-pred-proc - collection-empty?-proc - collection-for-each-proc - - compose-collections - vector-collection - stream-collection - list-collection) - (begin - - (define-record-type - (collection pred-proc empty?-proc for-each-proc) - collection? - (pred-proc collection-pred-proc) - (empty?-proc collection-empty?-proc) - (for-each-proc collection-for-each-proc)) - - (define vector-collection - (collection vector? - (lambda (v) (= 0 (vector-length v))) - vector-for-each)) - - (define list-collection - (collection list? - null? - for-each)) - - (define stream-collection - (collection stream? - stream-null? - stream-for-each)) - - (define (compose-collections . collections) - (define (find-collection object) - (let loop ((collections collections)) - (cond - ((null? collections) - #f) - (((collection-pred-proc (car collections)) object) - (car collections)) - (else (loop (cdr collections)))))) - - (collection - ;; predicate - (lambda (object) - (cond - ((find-collection object) #t) - (else #f))) - ;; empty proc - (lambda (object) - (cond - ((find-collection object) => (lambda (c) ((collection-empty?-proc c) object))) - (else (error "Collection not found")))) - ;; for-each proc - (lambda (proc object) - (cond - ((find-collection object) => (lambda (c) ((collection-for-each-proc c) proc object))) - (else (error "Collection not found")))))))) diff --git a/src/main/scheme/arvyy/mustache/executor-impl.scm b/src/main/scheme/arvyy/mustache/executor-impl.scm deleted file mode 100644 index 50c59e1..0000000 --- a/src/main/scheme/arvyy/mustache/executor-impl.scm +++ /dev/null @@ -1,97 +0,0 @@ -(define (html-escape writer value) - (define str-value - (let ((out (open-output-string))) - (writer value out) - (get-output-string out))) - (define out (open-output-string)) - (string-for-each - (lambda (char) - (case char - ((#\&) (write-string "&" out)) - ((#\<) (write-string "<" out)) - ((#\>) (write-string ">" out)) - ((#\") (write-string """ out)) - (else (write-char char out)))) - str-value) - (get-output-string out)) - -(define (lookup-in-stack-single name objs-stack lookup) - (let loop ((objs objs-stack)) - (if (null? objs) - (values objs #f) - (lookup (car objs) - name - (lambda (value) (values objs value)) - (lambda () (loop (cdr objs))))))) - -(define (lookup-in-stack name-lst objs-stack lookup) - (define-values (objs value) - (lookup-in-stack-single (car name-lst) objs-stack lookup)) - (cond - ((not value) #f) - ((null? (cdr name-lst)) value) - (else (lookup-in-stack (cdr name-lst) - (list value) - lookup)))) - -(define (execute template objs-stack partials out lookup collection? collection-empty? collection-for-each writer) - (define (execute-h template indent objs-stack) - (for-each - (lambda (fragment) - (cond - ((string? fragment) - (write-string fragment out)) - ((new-line? fragment) - (begin - (write-string (new-line-content fragment) out) - (write-string (make-string indent #\space) out))) - ((interp? fragment) - (let* ((name (interp-ref fragment)) - (value (if (equal? '(".") name) - (car objs-stack) - (lookup-in-stack name - objs-stack - lookup)))) - (if (interp-escape? fragment) - (write-string (html-escape writer value) out) - (writer value out)))) - - ((section? fragment) - (let* ((name (section-ref fragment)) - (value (if (equal? '(".") name) - (car objs-stack) - (lookup-in-stack (section-ref fragment) - objs-stack - lookup))) - (inner-template (section-content fragment))) - - (cond - ((not value) - (when (section-invert? fragment) - (execute-h inner-template indent objs-stack))) - ((not (collection? value)) - (unless (section-invert? fragment) - (execute-h inner-template indent (cons value objs-stack)))) - (else - (if (section-invert? fragment) - (when (collection-empty? value) - (execute-h inner-template indent objs-stack)) - (collection-for-each - (lambda (el) - (execute-h inner-template indent (cons el objs-stack))) - value)))))) - - ((partial? fragment) - (let () - (define partial-tpl - (cond - ((assoc (partial-name fragment) partials) => cdr) - (else #f))) - (when partial-tpl - (execute-h partial-tpl - (+ indent (partial-indent fragment)) - objs-stack) ))) - - (else (error "Unknown fragment")))) - template)) - (execute-h template 0 objs-stack)) diff --git a/src/main/scheme/arvyy/mustache/executor.scm b/src/main/scheme/arvyy/mustache/executor.scm deleted file mode 100644 index 47e013b..0000000 --- a/src/main/scheme/arvyy/mustache/executor.scm +++ /dev/null @@ -1,6 +0,0 @@ -(define-library - (arvyy mustache executor) - (import (scheme base) - (arvyy mustache parser)) - (export execute) - (include "executor-impl.scm")) diff --git a/src/main/scheme/arvyy/mustache/lookup.scm b/src/main/scheme/arvyy/mustache/lookup.scm deleted file mode 100644 index 4d9135d..0000000 --- a/src/main/scheme/arvyy/mustache/lookup.scm +++ /dev/null @@ -1,27 +0,0 @@ -(define-library - (arvyy mustache lookup) - (import (scheme base)) - (export - compose-lookups - alist-lookup) - (begin - - (define (compose-lookups . lookups) - (lambda (obj name found not-found) - (let loop ((lookups lookups)) - (if (null? lookups) - (not-found) - (let ((l (car lookups))) - (l obj name found (lambda () - (loop (cdr lookups))))))))) - - (define (alist-lookup obj name found not-found) - (define key (string->symbol name)) - (define alist? (and (list? obj) - (or (null? obj) - (pair? (car obj))))) - (if alist? - (cond - ((assoc key obj) => (lambda (pair) (found (cdr pair)))) - (else (not-found))) - (not-found))))) diff --git a/src/main/scheme/arvyy/mustache/parser-impl.scm b/src/main/scheme/arvyy/mustache/parser-impl.scm deleted file mode 100644 index 8a90cc7..0000000 --- a/src/main/scheme/arvyy/mustache/parser-impl.scm +++ /dev/null @@ -1,296 +0,0 @@ -(define-record-type - (interp ref escape?) - interp? - (ref interp-ref) - (escape? interp-escape?) ;; should html be escaped - ) - -(define-record-type
- (section ref invert? content raw-content) - section? - (ref section-ref) - (invert? section-invert?) ;; normal section if false, {{^ section if true - (content section-content) ;; compiled inner content - (raw-content section-raw-content) ;; uncompiled inner content as a string; used for lambdas - ) - -(define-record-type - (partial name indent) - partial? - (name partial-name) - (indent partial-indent)) - -(define-record-type - (new-line content) - new-line? - (content new-line-content)) - -(define (parse tokens) - (let* ((tokens (replace-standalone tokens)) - (tokens (remove-non-visible tokens)) - (tokens (convert-string-tokens tokens)) - (tokens (parse-interp+sections tokens))) - tokens)) - -(define (tpl->string tokens) - (define (->string item out) - (cond - ((string? item) (write-string item out)) - ((new-line? item) (write-string (new-line-content item) out)) - ((section? item) - (let ((tagname (list->tagname (section-ref item)))) - (write-string (if (section-invert? item) "{{^" "{{#") out) - (write-string tagname out) - (write-string "}}" out) - (for-each - (lambda (item*) - (->string item* out)) - (section-content item)) - (write-string "{{/" out) - (write-string tagname out) - (write-string "}}" out))) - ((interp? item) - (let ((tagname (list->tagname (interp-ref item)))) - (write-string (if (interp-escape? item) "{{" "{{&") out) - (write-string tagname out) - (write-string "}}" out))))) - (define out (open-output-string)) - (for-each - (lambda (item) (->string item out)) - tokens) - (get-output-string out)) - -;;TODO remove this -(define (debug-tokens tokens) - (for-each - (lambda (t) - (cond - ((token-str? t) (display (string-append "#< " (token-str-content t) "> "))) - ((token-nl? t) (display "#<> ")) - ((token-section-open? t) (display (string-append "#< " (token-section-open-tag t) "> "))) - ((token-section-close? t) (display "#<> ")) - ((token-ws? t) (display (string-append "#< " (number->string (token-ws-count t)) "> "))) - ((token-interp? t) (display (string-append "#< " (token-interp-tag t) "> "))) - (else (display t)))) - tokens - ) - - ) - -(define (standalone/remove? token) - (or (token-comment? token) - (token-delimchager? token))) - -(define (standalone/trim? token) - (or (token-section-open? token) - (token-section-close? token))) - -(define (replace-standalone tokens) - (let loop ((tokens tokens) - (result/inv '()) - (first #t)) - - (cond - ((null? tokens) (reverse result/inv)) - - ((and first - (or (match-follows tokens standalone/remove? token-ws? token-nl?) - (match-follows tokens standalone/remove? token-nl?) - (match-follows tokens token-ws? standalone/remove? token-ws? token-nl?) - (match-follows tokens token-ws? standalone/remove? token-nl?))) => - (lambda (tokens*) - (loop tokens* - result/inv - #t))) - - ((and first - (or (match-follows tokens token-ws? standalone/remove? token-ws? eof-object?) - (match-follows tokens token-ws? standalone/remove? eof-object?) - (match-follows tokens standalone/remove? token-ws? eof-object?) - (match-follows tokens standalone/remove? eof-object?))) => - (lambda (tokens*) - (loop '() - result/inv - #t))) - - ((and first - (or (match-follows tokens token-ws? standalone/trim? token-ws? token-nl?) - (match-follows tokens token-ws? standalone/trim? token-nl?) - (match-follows tokens token-ws? standalone/trim? token-ws? eof-object?) - (match-follows tokens token-ws? standalone/trim? eof-object?))) => - (lambda (tokens*) - (loop tokens* - (append (list (cadr tokens)) - result/inv) - #t))) - - ((and first - (or (match-follows tokens standalone/trim? token-ws? token-nl?) - (match-follows tokens standalone/trim? token-nl?) - (match-follows tokens standalone/trim? token-ws? eof-object?) - (match-follows tokens standalone/trim? eof-object?))) => - (lambda (tokens*) - (loop tokens* - (append (list (car tokens)) - result/inv) - #t))) - - ((and first - (or (match-follows tokens token-ws? token-partial? token-ws? token-nl?) - (match-follows tokens token-ws? token-partial? token-nl?) - (match-follows tokens token-ws? token-partial? token-ws? eof-object?) - (match-follows tokens token-ws? token-partial? eof-object?))) => - (lambda (tokens*) - (loop tokens* - (append (list (partial (token-partial-tag (cadr tokens)) - (token-ws-count (car tokens)))) - result/inv) - #t))) - - ((and first - (or (match-follows tokens token-partial? token-ws? token-nl?) - (match-follows tokens token-partial? token-nl?) - (match-follows tokens token-partial? token-ws? eof-object?) - (match-follows tokens token-partial? eof-object?))) => - (lambda (tokens*) - (loop tokens* - (append (list (partial (token-partial-tag (car tokens)) - 0)) - result/inv) - #t))) - - ((match-follows tokens token-partial?) => (lambda (tokens*) - (loop tokens* - (cons (partial (token-partial-tag (car tokens)) - 0) - result/inv) - #f))) - - (else (loop (cdr tokens) - (cons (car tokens) result/inv) - (token-nl? (car tokens))))))) - -(define (convert-string-tokens tokens) - (let loop ((tokens tokens) - (out #f) - (result/inv '())) - (cond - ((null? tokens) - (let ((result-final/inv (if out - (cons (get-output-string out) - result/inv) - result/inv))) - (reverse result-final/inv))) - ((or (token-str? (car tokens)) - (token-ws? (car tokens))) - (let* ((token (car tokens)) - (out* (if out - out - (open-output-string))) - (str (if (token-str? token) - (token-str-content token) - (make-string (token-ws-count token) #\space)))) - (write-string str out*) - (loop (cdr tokens) - out* - result/inv))) - (else (let* ((token (car tokens)) - (value (cond - ((token-nl? token) (new-line (list->string (token-nl-chars token)))) - (else token))) - (new-result/inv (if out - (cons (get-output-string out) - result/inv) - result/inv))) - (loop (cdr tokens) - #f - (cons value new-result/inv))))))) - -(define (parse-interp+sections tokens) - (define (parse-interp+sections* tokens expected-close-tag) - (let loop ((tokens tokens) - (result/inv '())) - (cond - ((null? tokens) - (if expected-close-tag - (error "Unexpected eof") - (values '() (reverse result/inv)))) - ((token-section-close? (car tokens)) - (if (equal? expected-close-tag (token-section-close-tag (car tokens))) - (values (cdr tokens) (reverse result/inv)) - (error "Closing token mismatch"))) - ((token-section-open? (car tokens)) - (let* ((token (car tokens)) - (tag (token-section-open-tag token)) - (ref (tagname->list tag))) - (define-values (tokens* result*) - (parse-interp+sections* (cdr tokens) - tag)) - (define value (section ref - (token-section-open-inverted? token) - result* - #f)) - (loop tokens* - (cons value result/inv)))) - ((token-interp? (car tokens)) - (let* ((token (car tokens)) - (tag (token-interp-tag token)) - (ref (tagname->list tag))) - (define value (interp ref (token-interp-escape? token))) - (loop (cdr tokens) - (cons value result/inv)))) - (else (loop (cdr tokens) - (cons (car tokens) - result/inv)))))) - (define-values (tokens* result) - (parse-interp+sections* tokens #f)) - result) - -(define (remove-non-visible tokens) - (filter - (lambda (token) - (not (or (token-comment? token) - (token-delimchager? token)))) - tokens)) - -(define (match-follows in . preds) - (let loop ((in* in) - (preds* preds)) - (cond - ((null? preds*) in*) - ((null? in*) (and (null? (cdr preds*)) - (eq? (car preds*) eof-object?) - '())) - (((car preds*) (car in*)) - (loop (cdr in*) - (cdr preds*))) - (else #f)))) - -(define (tagname->list str) - (define (prepend-part parts part) - (when (null? part) - (error "Trailing period in tag name")) - (cons (list->string (reverse part)) - parts)) - (if (equal? "." str) - '(".") - (let loop ((in (string->list str)) - (parts '()) - (part '())) - (cond - ((null? in) - (reverse (prepend-part parts part))) - ((char=? #\. (car in)) - (loop (cdr in) - (prepend-part parts part) - '())) - (else (loop (cdr in) - parts - (cons (car in) part))))))) - -(define (list->tagname lst) - (apply string-append - (cdr (apply append - (map - (lambda (el) (list "." el)) - lst))))) diff --git a/src/main/scheme/arvyy/mustache/parser.scm b/src/main/scheme/arvyy/mustache/parser.scm deleted file mode 100644 index 6efa52a..0000000 --- a/src/main/scheme/arvyy/mustache/parser.scm +++ /dev/null @@ -1,14 +0,0 @@ -(define-library - (arvyy mustache parser) - (import (scheme base) - (scheme write) - (scheme cxr) - (arvyy mustache tokenizer) - (srfi 1)) - (export - parse - interp? interp-ref interp-escape? - section? section-ref section-invert? section-content section-raw-content - partial? partial-name partial-indent - new-line? new-line-content) - (include "parser-impl.scm")) diff --git a/src/main/scheme/arvyy/mustache/tokenizer-impl.scm b/src/main/scheme/arvyy/mustache/tokenizer-impl.scm deleted file mode 100644 index 4870e89..0000000 --- a/src/main/scheme/arvyy/mustache/tokenizer-impl.scm +++ /dev/null @@ -1,237 +0,0 @@ -(define-record-type - (token-ws count) - token-ws? - (count token-ws-count)) - -(define-record-type - (token-nl chars) - token-nl? - (chars token-nl-chars)) - -(define-record-type - (token-comment) - token-comment?) - -(define-record-type - (token-str content) - token-str? - (content token-str-content)) - -(define-record-type - (token-delimchager open close) - token-delimchager? - (open token-delimchager-open) - (close token-delimchager-close)) - -(define-record-type - (token-interp tag escape?) - token-interp? - (tag token-interp-tag) - (escape? token-interp-escape?)) - -(define-record-type - (token-section-open tag inverted?) - token-section-open? - (tag token-section-open-tag) - (inverted? token-section-open-inverted?)) - -(define-record-type - (token-section-close tag) - token-section-close? - (tag token-section-close-tag)) - -(define-record-type - (token-partial tag) - token-partial? - (tag token-partial-tag)) - -(define (read-tokens str) - (let loop ((in (string->list str)) - (ws-count 0) - (str-value '()) - (open-delim '(#\{ #\{)) - (close-delim '(#\} #\})) - (result/inv '())) - - (define (resolve-ws/str) - (cond - ;; unflushed ws and str info - ((and (not (null? str-value)) - (> ws-count 0)) - (append (list (token-ws ws-count) - (token-str (list->string (reverse str-value)))) - result/inv)) - - ;; unflushed str info - ((not (null? str-value)) - (cons (token-str (list->string (reverse str-value))) - result/inv)) - - ;; unflushed ws info - ((> ws-count 0) - (cons (token-ws ws-count) - result/inv)) - - ;; no unflushed info - (else result/inv))) - - ;; handle when in is null; ie final function return - (define (return) - (define final-result/inv (resolve-ws/str)) - (reverse final-result/inv)) - - ;; handle after tag read - (define (continue-after-tag in token) - (loop - in - 0 - '() - open-delim - close-delim - (cons token (resolve-ws/str)))) - - (define (process-interp in) - (define-values (in* tag) - (read-tag in close-delim)) - (continue-after-tag in* (token-interp tag #t))) - - (define (process-triple-mustache in) - (define-values (in* tag) - (read-tag in '(#\} #\} #\}))) - (continue-after-tag in* (token-interp tag #f))) - - (define (process-ampersand in) - (define-values (in* tag) - (read-tag in close-delim)) - (continue-after-tag in* (token-interp tag #f))) - - (define (process-inverted in) - (define-values (in* tag) - (read-tag in close-delim)) - (continue-after-tag in* (token-section-open tag #t))) - - (define (process-section in) - (define-values (in* tag) - (read-tag in close-delim)) - (continue-after-tag in* (token-section-open tag #f))) - - (define (process-close in) - (define-values (in* tag) - (read-tag in close-delim)) - (continue-after-tag in* (token-section-close tag))) - - (define (process-partial in) - (define-values (in* tag) - (read-tag in close-delim)) - (continue-after-tag in* (token-partial tag))) - - (define (process-comment in) - (let loop* ((in in)) - (cond - ((null? in) (error "Unexpected EOF")) - ((match-follows in close-delim) => (lambda (in*) - (continue-after-tag in* (token-comment)))) - (else (loop* (cdr in)))))) - - (define (process-delim-change in) - (let*-values (((in new-open) (read-tag in #f)) - ((in new-close) (read-tag in (cons #\= close-delim)))) - (loop in - 0 - '() - (string->list new-open) - (string->list new-close) - (cons (token-delimchager new-open new-close) - (resolve-ws/str))))) - - (define (process-open-delim in*) - (cond - ((match-follows in* '(#\&)) => process-ampersand) - ((match-follows in* '(#\^)) => process-inverted) - ((match-follows in* '(#\#)) => process-section) - ((match-follows in* '(#\/)) => process-close) - ((match-follows in* '(#\>)) => process-partial) - ((match-follows in* '(#\=)) => process-delim-change) - ((match-follows in* '(#\!)) => process-comment) - (else (process-interp in*)))) - - (define (process-space in*) - (loop in* - (+ 1 ws-count) - str-value - open-delim - close-delim - result/inv)) - - (define (process-eol in* chars) - (loop in* - 0 - '() - open-delim - close-delim - (cons (token-nl chars) - (resolve-ws/str)))) - - (define (process-nl in*) - (process-eol in* '(#\newline))) - - (define (process-crnl in*) - (process-eol in* '(#\return #\newline))) - - (define (process-char) - (loop (cdr in) - 0 - (append (list (car in)) - (make-list ws-count #\space) - str-value) - open-delim - close-delim - result/inv)) - - ;; loop handler - (cond - ((null? in) (return)) - ((match-follows in '(#\{ #\{ #\{)) => process-triple-mustache) - ((match-follows in open-delim) => process-open-delim) - ((match-follows in '(#\space)) => process-space) - ((match-follows in '(#\newline)) => process-nl) - ((match-follows in '(#\return #\newline)) => process-crnl) - (else (process-char))))) - -(define (match-follows in chars) - (let loop ((in* in) - (chars* chars)) - (cond - ((null? chars*) in*) - ((null? in*) #f) - ((char=? (car in*) (car chars*)) - (loop (cdr in*) - (cdr chars*))) - (else #f)))) - -(define (skip-spaces in) - (cond - ((null? in) '()) - ((char=? (car in) #\space) (skip-spaces (cdr in))) - (else in))) - -(define (read-tag in close-delim) - (define-values - (tag in*) - (let loop ((in (skip-spaces in)) - (result '())) - (define (return) - (values (list->string (reverse result)) - in)) - (cond - ((null? in) (error "Unexpected EOF")) - ((char=? (car in) #\space) (return)) - ((and close-delim (match-follows in close-delim)) - (return)) - (else (loop (cdr in) - (cons (car in) result)))))) - (cond - ((not close-delim) (values in* tag)) - ((match-follows (skip-spaces in*) close-delim) => (lambda (in**) - (values in** tag))) - (else (error "Bad tag")))) diff --git a/src/main/scheme/arvyy/mustache/tokenizer.scm b/src/main/scheme/arvyy/mustache/tokenizer.scm deleted file mode 100644 index edeea7e..0000000 --- a/src/main/scheme/arvyy/mustache/tokenizer.scm +++ /dev/null @@ -1,15 +0,0 @@ -(define-library - (arvyy mustache tokenizer) - (import (scheme base)) - (export - read-tokens - token-ws? token-ws-count - token-nl token-nl? token-nl-chars - token-comment? - token-str? token-str-content - token-delimchager? token-delimchager-open token-delimchager-close - token-interp? token-interp-tag token-interp-escape? - token-section-open? token-section-open-tag token-section-open-inverted? - token-section-close? token-section-close-tag - token-partial? token-partial-tag) - (include "tokenizer-impl.scm")) diff --git a/src/main/scheme/arvyy/slf4j.scm b/src/main/scheme/arvyy/slf4j.scm deleted file mode 100644 index ffc01a1..0000000 --- a/src/main/scheme/arvyy/slf4j.scm +++ /dev/null @@ -1,76 +0,0 @@ -(define-library - (arvyy slf4j) - (import (scheme base) - (class org.slf4j Logger LoggerFactory) - ) - (export - get-logger - logger-name - - log-info - info-enabled? - - log-debug - debug-enabled? - - log-error - error-enabled? - - log-trace - trace-enabled? - - log-warn - warn-enabled?) - - (begin - - (define (get-logger name ::String) ::Logger - (LoggerFactory:getLogger name)) - - (define (logger-name logger ::Logger) ::String - (logger:getName)) - - (define-syntax log-info - (syntax-rules () - ((_ logger message args ...) - (when (info-enabled? logger) - (logger:info message args ...))))) - - (define (info-enabled? logger ::Logger) ::boolean - (logger:isInfoEnabled)) - - (define-syntax log-warn - (syntax-rules () - ((_ logger message args ...) - (when (warn-enabled? logger) - (logger:warn message args ...))))) - - (define (warn-enabled? logger ::Logger) ::boolean - (logger:isWarnEnabled)) - - (define-syntax log-error - (syntax-rules () - ((_ logger message args ...) - (when (error-enabled? logger) - (logger:error message args ...))))) - - (define (error-enabled? logger ::Logger) ::boolean - (logger:isErrorEnabled)) - - (define-syntax log-debug - (syntax-rules () - ((_ logger message args ...) - (when (debug-enabled? logger) - (logger:debug message args ...))))) - - (define (debug-enabled? logger ::Logger) ::boolean - (logger:isDebugEnabled)) - - (define-syntax log-trace - (syntax-rules () - ((_ logger message args ...) - (when (trace-enabled? logger) - (logger:trace message args ...))))) - - (define (trace-enabled? logger ::Logger) ::boolean - (logger:isTraceEnabled)))) diff --git a/src/main/scheme/main.scm b/src/main/scheme/main.scm new file mode 100644 index 0000000..8163414 --- /dev/null +++ b/src/main/scheme/main.scm @@ -0,0 +1,32 @@ +(import + (scheme base) + (scheme read) + (arvyy solr-embedded) + (arvyy solrj) + (scmindex types-parser) + (scmindex solr) + (scmindex settings) + (scmindex web-ui) + (scmindex repl-ui)) + +(define config-file + (cond + ((= 0 (vector-length command-line-arguments)) "./config/configuration.scm") + (else (vector-ref command-line-arguments 0)))) + +(define config (with-input-from-file config-file read)) + +(define solr-core (deploy-setting/solr-core config)) +(define solr-client + (cond + ((deploy-setting/solr-embed config) (create-embedded-solr-client (deploy-setting/solr-home config) solr-core)) + (else (create-http-solr-client (deploy-setting/solr-url config))))) + +(let ((funcs (read-specs (deploy-setting/spec-index config)))) + (index-types solr-client solr-core funcs)) + +(when (deploy-setting/enable-web config) + (init-web-ui config solr-client solr-core)) + +(when (deploy-setting/enable-repl config) + (init-repl-ui config solr-client solr-core)) \ No newline at end of file diff --git a/src/main/scheme/scmindex/mustache.scm b/src/main/scheme/scmindex/mustache.scm index 8674b42..b927801 100644 --- a/src/main/scheme/scmindex/mustache.scm +++ b/src/main/scheme/scmindex/mustache.scm @@ -4,8 +4,8 @@ (scheme read) (scheme write) (scheme cxr) - (only (srfi 1) iota filter find) - (arvyy httpclient)) + (class java.net URLEncoder) + (only (srfi 1) iota filter find)) (export make-mustache-search-data make-mustache-nav-data @@ -28,13 +28,10 @@ (link . "/settings") (page . settings)) - ((label . "User guide") - (link . "/userguide") - (page . userguide)) - - ((label . "REST api") - (link . "/restapi") - (page . restapi)) + ((label . "Documentation") + (link . "/README.html") + (page . docs)) + )) (define (make-mustache-nav-data page) @@ -104,6 +101,27 @@ (cons 'selected (and (member (cdr (assoc 'value f)) selected-values) #t)) f)) facet-result)) + + ;TODO move out + (define (encode-query alist) + (let loop ((str "") + (alist alist) + (first #t)) + (cond + ((null? alist) str) + (else (let ((key (caar alist)) + (value (cdar alist)) + (rest (cdr alist))) + (define fragment + (string-append + (URLEncoder:encode (symbol->string key) "UTF-8") + "=" + (URLEncoder:encode value "UTF-8"))) + (define new-str + (if first + fragment + (string-append str "&" fragment))) + (loop new-str rest #f)))))) (define (make-pager-data page total-pages query) (define query-without-page diff --git a/src/main/scheme/scmindex/repl-ui.scm b/src/main/scheme/scmindex/repl-ui.scm new file mode 100644 index 0000000..debbe33 --- /dev/null +++ b/src/main/scheme/scmindex/repl-ui.scm @@ -0,0 +1,45 @@ +(define-library + (scmindex repl-ui) + (import (scheme base) + (scheme read) + (scheme write) + (scmindex solr)) + (export init-repl-ui) + (begin + (define (init-repl-ui config solr-client solr-core) + (let loop () + (define value (read)) + (if (eof-object? value) + #f + (begin + (handle-query solr-client solr-core value) + (loop))))) + (define (param alist key default) + (cond + ((assoc key alist) => cdr) + (else default))) + (define (handle-query solr-client solr-core q) + (call/cc + (lambda (k) + (with-exception-handler + (lambda (err) + (write `(error ,err)) + (k #t)) + (lambda () + (do-handle-query solr-client solr-core q)))))) + (define (do-handle-query solr-client solr-core q) + (define resp-value + (cond + ((equal? (car q) 'search) + (let* ((p (cdr q)) + (start (param p 'start 0)) + (rows (param p 'rows 40)) + (query (param p 'query "")) + (libs (param p 'libs '())) + (param-types (param p 'param-types '())) + (return-types (param p 'return-types '())) + (tags (param p 'tags '())) + (filter-params-loose? (param p 'filter-params-loose? #t))) + (exec-solr-query solr-client solr-core start rows query libs param-types return-types tags filter-params-loose?))) + (else (solr-facet-values solr-client solr-core (car q))))) + (write resp-value)))) \ No newline at end of file diff --git a/src/main/scheme/scmindex/settings.scm b/src/main/scheme/scmindex/settings.scm index 3d4c722..b7fe16f 100644 --- a/src/main/scheme/scmindex/settings.scm +++ b/src/main/scheme/scmindex/settings.scm @@ -5,6 +5,12 @@ (srfi 26) (arvyy kawa-spark)) (export + deploy-setting/enable-repl + deploy-setting/enable-web + deploy-setting/port + deploy-setting/spec-index + deploy-setting/solr-embed + deploy-setting/solr-home deploy-setting/solr-url deploy-setting/solr-core deploy-setting/cache-templates @@ -21,16 +27,22 @@ (begin - (define (get-property deploy-settings prop) + (define (get-property deploy-settings prop default-value) (cond ((assoc prop deploy-settings) => cdr) - (else (error (string-append "Required property missing " (symbol->string prop)))))) + (else default-value))) - (define deploy-setting/solr-url (cut get-property <> 'solr-url)) - (define deploy-setting/solr-core (cut get-property <> 'solr-core)) - (define deploy-setting/cache-templates (cut get-property <> 'cache-templates)) - (define deploy-setting/page-size (cut get-property <> 'page-size)) - (define deploy-setting/serve-static (cut get-property <> 'serve-static)) + (define deploy-setting/enable-repl (cut get-property <> 'enable-repl #f)) + (define deploy-setting/enable-web (cut get-property <> 'enable-web #t)) + (define deploy-setting/port (cut get-property <> 'port 8080)) + (define deploy-setting/spec-index (cut get-property <> 'spec-index "types/index.scm")) + (define deploy-setting/solr-embed (cut get-property <> 'solr-embed #t)) + (define deploy-setting/solr-home (cut get-property <> 'solr-home "./solrhome")) + (define deploy-setting/solr-url (cut get-property <> 'solr-url "http://localhost:8983/solr")) + (define deploy-setting/solr-core (cut get-property <> 'solr-core "scmindex")) + (define deploy-setting/cache-templates (cut get-property <> 'cache-templates #t)) + (define deploy-setting/page-size (cut get-property <> 'page-size 40)) + (define deploy-setting/serve-static (cut get-property <> 'serve-static #t)) (define settings-data `#( @@ -72,13 +84,13 @@ (define (user-setting/light-theme? req) (cond - ((assoc 'overrideCtrlF (req/cookies req)) => (lambda (e) + ((assoc 'theme (req/cookies req)) => (lambda (e) (equal? "light" (cdr e)))) (else #t))) (define (user-setting/ctrl-f-override req) (cond - ((assoc 'theme (req/cookies req)) => (lambda (e) + ((assoc 'overrideCtrlF (req/cookies req)) => (lambda (e) (equal? "yes" (cdr e)))) (else #f))) diff --git a/src/main/scheme/scmindex/solr.scm b/src/main/scheme/scmindex/solr.scm index ca98181..5119ce2 100644 --- a/src/main/scheme/scmindex/solr.scm +++ b/src/main/scheme/scmindex/solr.scm @@ -2,7 +2,8 @@ (scmindex solr) (import (scheme base) (scheme write) - (arvyy httpclient) + ;(arvyy httpclient) + (arvyy solrj) (scmindex types-parser)) (export @@ -14,19 +15,19 @@ solr-get-suggestions) (begin - - (define (solr-get-suggestions suggest-url text) - (let* ((resp (post-json suggest-url `((params . ((q . ,text)))))) - (suggest (cdr (assoc 'suggest resp))) - (nameSuggester (cdar suggest)) - (result (cdar nameSuggester)) - (suggestions (cdr (assoc 'suggestions result)))) + + (define (solr-get-suggestions solr-client core text) + (define resp (query solr-client core "/suggest" `((q . ,text)))) + (define suggest (cdr (assoc 'suggest resp))) + (define nameSuggester (cdar suggest)) + (define value (cdar nameSuggester)) + (define suggestions (cdr (assoc 'suggestions value))) (vector-map (lambda (s) (cdr (assoc 'term s))) - suggestions))) + suggestions)) - (define (index-types solr-url funcs) + (define (index-types solr-client core funcs) (define-values (supertype-map subtype-strict-map subtype-loose-map) (make-type-maps funcs)) @@ -41,11 +42,14 @@ (return_supertypes . ,(list->vector (map symbol->string (flatten-type supertype-map (func-return-types f))))))) (append extra json)) funcs))) - (post-json (string-append solr-url "/update/json") payload)) - - (define (solr-facet-values solr-url facet) - (define solr-query `((params . ((rows . 0))))) - (define solr-resp (post-json solr-url solr-query)) + (parameterize ((commit-within 10)) + (delete-by-query solr-client core "*:*") + (add solr-client core payload) + (commit solr-client core))) + + (define (solr-facet-values solr-client core facet) + (define solr-query `((rows . 0))) + (define solr-resp (query solr-client core "/search" solr-query)) (define facet-counts (cdr (assoc 'facet_counts solr-resp))) (define facet-fields (cdr (assoc 'facet_fields facet-counts))) (define facet-values (fold-facet-values (cdr (assoc facet facet-fields)))) @@ -53,10 +57,10 @@ (lambda (e) (cdr (assoc 'value e))) facet-values)) - - (define (exec-solr-query solr-url start page-size text libs params returns tags filter-params-loose?) + + (define (exec-solr-query solr-client core start page-size text libs params returns tags filter-params-loose?) (define body (build-solr-query start page-size text libs params returns tags filter-params-loose?)) - (define solr-resp (post-json solr-url body)) + (define solr-resp (query solr-client core "/search" body)) (parse-solr-response solr-resp)) (define (build-solr-query start page-size text libs params returns tags filter-params-loose?) @@ -100,20 +104,22 @@ (if (null? bq-params) '() `((bq . ,(list->vector bq-params))))) - (define fq - `((fq . ,(list->vector (append fq-returns fq-params fq-lib fq-tags))))) + (define fq + (let ((vals (list->vector (append fq-returns fq-params fq-lib fq-tags)))) + (if (= (vector-length vals) 0) + '() + `((fq . ,vals))))) (define q (if text `((q . ,text)) `())) (define params-json (append q bq fq `((start . ,start) (rows . ,page-size)))) - - `((params . ,params-json))) + params-json) (define (parse-solr-response response) (define resp (cdr (assoc 'response response))) - (define total (cdr (assoc 'numFound resp))) + (define total (cdr (assoc 'num-found resp))) (define docs (cdr (assoc 'docs resp))) (define facet-counts (cdr (assoc 'facet_counts response))) (define facet-fields (cdr (assoc 'facet_fields facet-counts))) @@ -128,20 +134,13 @@ (param . ,param-facets) (tag . ,tag-facets) (return . ,return-facets))) - + (define (fold-facet-values vals) - (let loop ((lst (vector->list vals)) - (rez '())) - (cond - ((null? lst) (list->vector (reverse rez))) - (else (let ((val (car lst)) - (count (cadr lst)) - (rest (cddr lst))) - (loop rest - (cons - `((value . ,val) - (count . ,count)) - rez))))))) + (list->vector (map + (lambda (e) + `((value . ,(symbol->string (car e))) + (count . ,(cdr e)))) + vals))) (define (escape-solr-spec str) (define lst* diff --git a/src/main/scheme/scmindex/main.scm b/src/main/scheme/scmindex/web-ui.scm similarity index 73% rename from src/main/scheme/scmindex/main.scm rename to src/main/scheme/scmindex/web-ui.scm index e3946a6..5de5c82 100644 --- a/src/main/scheme/scmindex/main.scm +++ b/src/main/scheme/scmindex/web-ui.scm @@ -1,182 +1,189 @@ -(import - (scheme base) - (scheme write) - (scheme read) - (arvyy httpclient) - (arvyy kawa-spark) - (arvyy mustache) - (scmindex types-parser) - (scmindex mustache) - (scmindex solr) - (scmindex settings) - (srfi 180)) - -(define config - (with-input-from-file "./config/configuration.scm" read)) - -(define (partial-locator name) - (open-input-file (string-append "templates/" name ".html"))) - -(define get-template/cached - (let ((cache '())) - (lambda (name) - (cond - ((assoc name cache) => cdr) - (else (let ((tpl (compile name partial-locator))) - (set! cache (cons (cons name tpl) cache)) - tpl)))))) - -(define (get-template/uncached name) - (compile name partial-locator)) - -(define get-template - (if (deploy-setting/cache-templates config) - get-template/cached - get-template/uncached)) - -(define (get/html path handler) - (get path (lambda (req resp) - (define-values (name data) (handler req resp)) - (execute (get-template name) data)))) - -(define (get/rest path handler) - (get path (lambda (req resp) - (define result (handler req resp)) - (define type-param (req/query-param req "wt")) - (define keep-sexpr (equal? "sexpr" type-param)) - (define payload (open-output-string)) - (if keep-sexpr - (begin - (write result payload) - (resp/set-type! resp "application/sexpr")) - (begin - (json-write result payload) - (resp/set-type! resp "application/json"))) - (resp/set-header! resp "Access-Control-Allow-Origin" "*") - (get-output-string payload)))) - -(define (make-tpl-getter name) - (if (deploy-setting/cache-templates config) - (let ((tpl (compile name partial-locator))) - (lambda () tpl)) - (lambda () (compile name partial-locator)))) - -(define solr-url (string-append (deploy-setting/solr-url config) "/solr/" (deploy-setting/solr-core config))) -(define solr-search-url (string-append solr-url "/search")) -(define solr-suggest-url (string-append solr-url "/suggest")) -(define default-page-size (deploy-setting/page-size config)) - -(define (make-head-data req) - `((light-theme . ,(user-setting/light-theme? req)) - (ctrlf-override . ,(user-setting/ctrl-f-override req)))) - -(let ((funcs (read-specs "types/index.scm"))) - (index-types solr-url funcs)) - -(when (deploy-setting/serve-static config) - (static-files/external-location "static")) - -(get/html "/" - (lambda (req resp) - (values "index" - `((page-title . "Home") - ,@(make-mustache-nav-data 'index) - ,@(make-head-data req))))) - -(get/html "/settings" - (lambda (req resp) - (values "settings" - `((page-title . "Settings") - ,@(make-mustache-nav-data 'settings) - ,@(make-head-data req) - ,@(mustache-settings-data req))))) - -(post "/settings" - (lambda (req resp) - (for-each - (lambda (opt) - (define value (req/query-param req opt)) - (if value - (resp/set-cookie! resp opt value) - (resp/remove-cookie! resp opt))) - settings-options) - (resp/redirect resp "/settings"))) - -(get/html "/search" - (lambda (req resp) - (define page-size (user-setting/page-size req)) - (define filter-params-loose? (user-setting/param-filter-loose req)) - (define page (let ((value (req/query-param req "page"))) - (if value - (string->number value) - 1))) - (define start (* page-size (- page 1))) - (define query (req/query-param req "query")) - (define libs (req/query-param-values req "lib")) - (define param-types (or (req/query-param-values req "param") '())) - (define return-types (or (req/query-param-values req "return") '())) - (define tags (or (req/query-param-values req "tag") '())) - (define data (exec-solr-query solr-search-url start page-size query libs param-types return-types tags filter-params-loose?)) - (define search-data - (make-mustache-search-data - page - page-size - query - libs - param-types - return-types - tags - data)) - (values "search" - `((page-title . "Search") - ,@search-data - ,@(make-mustache-nav-data 'search) - ,@(make-head-data req))))) - -(get/html "/userguide" - (lambda (req resp) - (values "userguide" - `((page-title . "User guide") - ,@(make-mustache-nav-data 'userguide) - ,@(make-head-data req))))) - -(get/html "/restapi" - (lambda (req resp) - (values "restapi" - `((page-title . "REST api") - ,@(make-mustache-nav-data 'restapi) - ,@(make-head-data req))))) - -(get/rest "/suggest" - (lambda (req resp) - (define text (req/query-param req "text")) - (solr-get-suggestions solr-suggest-url text))) - -(path "/rest" - (get/rest "/libs" - (lambda (req resp) - (solr-facet-values solr-search-url 'lib))) - - (get/rest "/params" - (lambda (req resp) - (solr-facet-values solr-search-url 'param_types))) - - (get/rest "/returns" - (lambda (req resp) - (solr-facet-values solr-search-url 'return_types))) - - (get/rest "/tags" - (lambda (req resp) - (solr-facet-values solr-search-url 'tags))) - - (get/rest "/procedures" - (lambda (req resp) - (define start (or (req/query-param req "start") 0)) - (define rows (or (req/query-param req "rows") default-page-size)) - (define query (req/query-param req "query")) - (define libs (req/query-param-values req "lib")) - (define param-types (or (req/query-param-values req "param") '())) - (define return-types (or (req/query-param-values req "return") '())) - (define tags (or (req/query-param-values req "tag") '())) - (define filter-params-loose? (or (req/query-param req "filter_loose") #t)) - (exec-solr-query solr-search-url start rows query libs param-types return-types tags filter-params-loose?)))) +(define-library + (scmindex web-ui) + (import + (scheme base) + (scheme write) + (scheme read) + (scheme file) + (arvyy kawa-spark) + (arvyy mustache) + (arvyy solr-embedded) + (arvyy solrj) + (scmindex types-parser) + (scmindex mustache) + (scmindex solr) + (scmindex settings) + (srfi 180)) + (export init-web-ui) + (begin + + (define (init-web-ui config solr-client solr-core) +(define (partial-locator name) + (open-input-file (string-append "templates/" name ".html"))) + +(define get-template/cached + (let ((cache '())) + (lambda (name) + (cond + ((assoc name cache) => cdr) + (else (let ((tpl (compile name partial-locator))) + (set! cache (cons (cons name tpl) cache)) + tpl)))))) + +(define (get-template/uncached name) + (compile name partial-locator)) + +(define get-template + (if (deploy-setting/cache-templates config) + get-template/cached + get-template/uncached)) + +(define (get/html path handler) + (get path (lambda (req resp) + (define-values (name data) (handler req resp)) + (execute (get-template name) data)))) + +(define (get/rest path handler) + (get path (lambda (req resp) + (define result (handler req resp)) + (define type-param (req/query-param req "wt")) + (define keep-sexpr (equal? "sexpr" type-param)) + (define payload (open-output-string)) + (if keep-sexpr + (begin + (write result payload) + (resp/set-type! resp "application/sexpr")) + (begin + (json-write result payload) + (resp/set-type! resp "application/json"))) + (resp/set-header! resp "Access-Control-Allow-Origin" "*") + (get-output-string payload)))) + +(define (make-tpl-getter name) + (if (deploy-setting/cache-templates config) + (let ((tpl (compile name partial-locator))) + (lambda () tpl)) + (lambda () (compile name partial-locator)))) + +(define solr-url (string-append (deploy-setting/solr-url config) "/solr/" (deploy-setting/solr-core config))) +(define solr-search-url (string-append solr-url "/search")) +(define solr-suggest-url (string-append solr-url "/suggest")) +(define default-page-size (deploy-setting/page-size config)) + +(define (make-head-data req) + `((light-theme . ,(user-setting/light-theme? req)) + (ctrlf-override . ,(user-setting/ctrl-f-override req)))) + +(port (deploy-setting/port config)) + +(when (deploy-setting/serve-static config) + (static-files/external-location "static")) + +(get/html "/" + (lambda (req resp) + (values "index" + `((page-title . "Home") + ,@(make-mustache-nav-data 'index) + ,@(make-head-data req))))) + +(get/html "/settings" + (lambda (req resp) + (values "settings" + `((page-title . "Settings") + ,@(make-mustache-nav-data 'settings) + ,@(make-head-data req) + ,@(mustache-settings-data req))))) + +(post "/settings" + (lambda (req resp) + (for-each + (lambda (opt) + (define value (req/query-param req opt)) + (if value + (resp/set-cookie! resp opt value) + (resp/remove-cookie! resp opt))) + settings-options) + (resp/redirect resp "/settings"))) + +(get/html "/search" + (lambda (req resp) + (define page-size (user-setting/page-size req)) + (define filter-params-loose? (user-setting/param-filter-loose req)) + (define page (let ((value (req/query-param req "page"))) + (if value + (string->number value) + 1))) + (define start (* page-size (- page 1))) + (define query (req/query-param req "query")) + (define libs (req/query-param-values req "lib")) + (define param-types (or (req/query-param-values req "param") '())) + (define return-types (or (req/query-param-values req "return") '())) + (define tags (or (req/query-param-values req "tag") '())) + (define data (exec-solr-query solr-client solr-core start page-size query libs param-types return-types tags filter-params-loose?)) + (define search-data + (make-mustache-search-data + page + page-size + query + libs + param-types + return-types + tags + data)) + (values "search" + `((page-title . "Search") + ,@search-data + ,@(make-mustache-nav-data 'search) + ,@(make-head-data req))))) + +(get/html "/userguide" + (lambda (req resp) + (values "userguide" + `((page-title . "User guide") + ,@(make-mustache-nav-data 'userguide) + ,@(make-head-data req))))) + +(get/html "/restapi" + (lambda (req resp) + (values "restapi" + `((page-title . "REST api") + ,@(make-mustache-nav-data 'restapi) + ,@(make-head-data req))))) + +(get/rest "/suggest" + (lambda (req resp) + (define text (req/query-param req "text")) + (solr-get-suggestions solr-client solr-core text))) + +(path "/rest" + (get/rest "/libs" + (lambda (req resp) + (solr-facet-values solr-client solr-core 'lib))) + + (get/rest "/params" + (lambda (req resp) + (solr-facet-values solr-client solr-core 'param_types))) + + (get/rest "/returns" + (lambda (req resp) + (solr-facet-values solr-client solr-core 'return_types))) + + (get/rest "/tags" + (lambda (req resp) + (solr-facet-values solr-client solr-core 'tags))) + + (get/rest "/procedures" + (lambda (req resp) + (define start (or (req/query-param req "start") 0)) + (define rows (or (req/query-param req "rows") default-page-size)) + (define query (req/query-param req "query")) + (define libs (req/query-param-values req "lib")) + (define param-types (or (req/query-param-values req "param") '())) + (define return-types (or (req/query-param-values req "return") '())) + (define tags (or (req/query-param-values req "tag") '())) + (define filter-params-loose? (equal? (or (req/query-param req "filter_loose") "true") "true")) + (exec-solr-query solr-client solr-core start rows query libs param-types return-types tags filter-params-loose?)))) + ) + + + )) diff --git a/src/main/scheme/srfi/180-impl.scm b/src/main/scheme/srfi/180-impl.scm deleted file mode 100644 index d122abb..0000000 --- a/src/main/scheme/srfi/180-impl.scm +++ /dev/null @@ -1,734 +0,0 @@ -(define-syntax assume - (syntax-rules () - ((assume obj . _) obj))) - -(define (%read-error? x) ::boolean - (read-error? x)) -(define (valid-number? s) ::boolean - (number? (string->number s))) - -(define json-number-of-character-limit (make-parameter +inf.0)) - -(define json-nesting-depth-limit (make-parameter +inf.0)) - -(define (json-null? obj) ::boolean - (eq? obj 'null)) - -(define-record-type - (make-json-error reason) - json-error? - (reason json-error-reason)) - -(define (json-whitespace? char) ::boolean - (case char - ((#\x20 ; Space - #\x09 ; Horizontal tab - #\x0A ; Line feed or New line - #\x0D - #\x1E ;; Record Separator - ) - #t) - (else #f))) - -(define (expect value other) - (when (eof-object? value) - (raise (make-json-error "Unexpected end-of-file."))) - (assume (char? value)) - (assume (char? other)) - (unless (char=? value other) - (raise (make-json-error "Unexpected character.")))) - -(define (port->generator port ::input-port) ::procedure - (let ((count 0) - (limit (json-number-of-character-limit))) - (lambda () - (let ((out (guard (ex ((%read-error? ex) (raise (make-json-error "Read error!")))) - (read-char port)))) - (if (= count limit) - (raise (make-json-error "Maximum number of character reached.")) - (begin - (set! count (+ count 1)) - out)))))) - -(define (gcons head generator ::procedure) ::procedure - ;; returns a generator that will yield, HEAD the first time, and - ;; after than, it will yield items from GENERATOR. - (let ((head? #t)) - (lambda () - (if head? - (begin (set! head? #f) head) - (generator))))) - -(define (%json-tokens generator ::procedure) - - (define (maybe-ignore-whitespace generator ::procedure) - (let loop ((char (generator))) - (if (json-whitespace? char) - (loop (generator)) - char))) - - (define (expect-null generator ::procedure) ::void - (expect (generator) #\u) - (expect (generator) #\l) - (expect (generator) #\l)) - - (define (expect-true generator ::procedure) ::void - (expect (generator) #\r) - (expect (generator) #\u) - (expect (generator) #\e)) - - (define (expect-false generator ::procedure) ::void - (expect (generator) #\a) - (expect (generator) #\l) - (expect (generator) #\s) - (expect (generator) #\e)) - - (define (maybe-char generator ::procedure) - (let ((char (generator))) - (when (eof-object? char) - (raise (make-json-error "Unexpected end-of-file."))) - (when (char=? char #\") - (raise (make-json-error "Unexpected end of string."))) - char)) - - (define (read-unicode-escape generator ::procedure) ::number - (let* ((one (maybe-char generator)) - (two (maybe-char generator)) - (three (maybe-char generator)) - (four (maybe-char generator))) - (let ((out (string->number (list->string (list one two three four)) 16))) - (if out - out - (raise (make-json-error "Invalid code point.")))))) - - (define ash arithmetic-shift) - - (define (read-json-string generator ::procedure) - (let loop ((char (generator)) - (out '())) - - (when (eof-object? char) - (raise (make-json-error "Unexpected end of file."))) - - (when (or (char=? char #\x00) - (char=? char #\newline) - (char=? char #\tab)) - (raise (make-json-error "Unescaped control char."))) - - ;; XXX: Here be dragons. - (if (char=? char #\\) - (begin - (let loop-unescape ((char (generator)) - (chars-unescaped '())) - (case char - ((#\" #\\ #\/) (loop (generator) - (cons char (append chars-unescaped - out)))) - ((#\b) (loop (generator) (cons #\backspace - (append chars-unescaped - out)))) - ((#\f) (loop (generator) (cons #\x0C - (append chars-unescaped - out)))) - ((#\n) (loop (generator) (cons #\newline - (append chars-unescaped - out)))) - ((#\r) (loop (generator) (cons #\x0D - (append chars-unescaped - out)))) - ((#\t) (loop (generator) (cons #\tab - (append chars-unescaped - out)))) - ((#\u) (let loop-unicode ((code1 (read-unicode-escape generator)) - (chars chars-unescaped)) - (let ((next-char (generator))) - (if (and (<= #xd800 code1 #xdbff) - (char=? next-char #\\)) - (if (char=? (generator) #\u) - (let ((code2 (read-unicode-escape generator))) - (if (<= #xdc00 code2 #xdfff) - (let ((integer - (+ #x10000 (bitwise-ior - (ash (- code1 #xd800) 10) - (- code2 #xdc00))))) - ;; full escape of unicode is parsed... - (loop (generator) - (cons (integer->char integer) - (append chars - out)))) - ;; This is another unicode char - (loop-unicode (read-unicode-escape generator) - (cons (integer->char code1) chars)))) - ;; The escaped unicode char is - ;; parsed, need to parse another - ;; escape that is not a unicode - ;; escape sequence - (loop-unescape char (cons (integer->char code1) - chars))) - ;; This is not a big-ish unicode char and - ;; the next thing is some other char. - (loop next-char - (cons (integer->char code1) (append chars out))))))) - (else (raise (make-json-error "Unexpected escaped sequence.")))))) - (cond - ((char=? char #\") - (list->string (reverse out))) - (else - (loop (generator) (cons char out))))))) - - (define (maybe-read-number generator ::procedure) - ;; accumulate chars until a control char or whitespace is reached, - ;; validate that it is JSON number, then intrepret it as Scheme - ;; number using string->number - (let loop ((char (generator)) - (out '())) - (if (or (eof-object? char) - (json-whitespace? char) - (char=? char #\,) - (char=? char #\]) - (char=? char #\})) - (let ((string (list->string (reverse out)))) - (if (valid-number? string) - (let ((number (string->number string))) - (if number - (values number char) - (raise (make-json-error "Invalid number.")))) - (raise (make-json-error "Invalid number.")))) - (loop (generator) (cons char out))))) - - ;; gist - (assume (procedure? generator)) - - (let ((char (generator))) - (if (eof-object? char) - ;; return an empty generator - ;; NOTE default impl returned just eof-object - (lambda () char) - (begin - - (unless (char=? char #\xFEFF) - ;; if it is not a UTF-8 BOM, put back the char in front of - ;; the generator - (set! generator (gcons char generator))) - - (lambda () - - (define char (maybe-ignore-whitespace generator)) - - (if (eof-object? char) - char ;; return that eof-object - (case char - ((#\n) (expect-null generator) 'null) - ((#\t) (expect-true generator) #t) - ((#\f) (expect-false generator) #f) - ((#\:) 'colon) - ((#\,) 'comma) - ((#\[) 'array-start) - ((#\]) 'array-end) - ((#\{) 'object-start) - ((#\}) 'object-end) - ((#\") (read-json-string generator)) - (else - (call-with-values (lambda () (maybe-read-number (gcons char generator))) - (lambda (number next) - (set! generator (gcons next generator)) - number)))))))))) - -(define json-tokens - (case-lambda - (() (json-tokens (current-input-port))) - ((port-or-generator) - (cond - ((procedure? port-or-generator) - (%json-tokens port-or-generator)) - ((and (textual-port? port-or-generator) (input-port? port-or-generator)) - (%json-generator (port->generator port-or-generator))) - (else (error 'json "json-tokens error, argument is not valid" port-or-generator)))))) - -(define (%json-generator tokens ::procedure) ::procedure - - (define limit (json-nesting-depth-limit)) - (define count 0) - - (define (handle-limit!) - (if (= count limit) - (raise (make-json-error "Maximum JSON nesting depth reached")) - (set! count (+ count 1)))) - - (define (array-maybe-continue tokens ::procedure k) ::procedure - (lambda () - (let ((token (tokens))) - (case token - ((comma) (start tokens (array-maybe-continue tokens k))) - ((array-end) (values 'array-end k)) - (else (raise (make-json-error "Invalid array, expected comma or array close."))))))) - - (define (array-start tokens ::procedure k) ::procedure - (lambda () - (handle-limit!) - (let ((token (tokens))) - (if (eq? token 'array-end) - (values 'array-end k) - (start (gcons token tokens) (array-maybe-continue tokens k)))))) - - (define (object-maybe-continue tokens ::procedure k) ::procedure - (lambda () - (let ((token (tokens))) - (case token - ((object-end) (values 'object-end k)) - ((comma) (let ((token (tokens))) - (unless (string? token) - (raise (make-json-error "Invalid object, expected an object key"))) - (values token - (object-colon tokens k)))) - (else (raise (make-json-error "Invalid object, expected comma or object close."))))))) - - (define (object-colon tokens ::procedure k) ::procedure - (lambda () - (let ((token (tokens))) - (if (eq? token 'colon) - (let ((token (tokens))) - (if (eof-object? token) - (raise (make-json-error "Invalid object, expected object value.")) - (start (gcons token tokens) (object-maybe-continue tokens k)))) - (raise (make-json-error "Invalid object, expected colon.")))))) - - (define (object-start tokens ::procedure k) ::procedure - (lambda () - (handle-limit!) - (let ((token (tokens))) - (cond - ((eq? token 'object-end) (values 'object-end k)) - ((string? token) - (values token - (object-colon tokens k))) - (else (raise (make-json-error "Invalid object, expected object key or object close."))))))) - - (define (start tokens ::procedure k) - (let ((token (tokens))) - (if (eof-object? token) - (values token k) - (cond - ((or (json-null? token) - (number? token) - (string? token) - (boolean? token)) - (values token k)) - ((eq? token 'array-start) - (values 'array-start (array-start tokens k))) - ((eq? token 'object-start) - (values 'object-start (object-start tokens k))) - (else (raise (make-json-error "Is it JSON text?!"))))))) - - (define (end-of-top-level-value) - ;; json-generator returns a generator that reads one top-level - ;; json. If there is more than one top-level json value in the - ;; generator separated with space as it is the case of json-lines, - ;; you need to call json-generator with the same port or - ;; generator. - (values (eof-object) #f)) - - (define (make-trampoline-generator tokens ::procedure) ::procedure - (let ((continuation (lambda () (start tokens end-of-top-level-value)))) - (lambda () - (when continuation - (call-with-values continuation - (lambda (event new-continuation) - (set! continuation new-continuation) - event)))))) - - ;; gist - - (assume (procedure? tokens)) - - (make-trampoline-generator tokens)) - -(define json-generator-error - "Argument does not look like a generator and is not a textual input port.") - -(define json-generator - (case-lambda - (() (json-generator (current-input-port))) - ((port) - (%json-generator (json-tokens (port->generator port)))))) - - -(define (%json-fold proc - array-start ::procedure - array-end ::procedure - object-start ::procedure - object-end ::procedure - seed - port-or-generator) - - ;; json-fold is inspired from the above foldts definition, unlike - ;; the above definition, it is continuation-passing-style. fhere is - ;; renamed PROC. Unlike foldts, json-fold will call (proc obj seed) - ;; everytime a JSON value or complete structure is read from the - ;; EVENTS generator, where OBJ will be: a) In the case of - ;; structures, the the result of the recursive call or b) a JSON - ;; value. - - ;; json-fold will terminates in three cases: - ;; - ;; - eof-object was generated, return the seed. - ;; - ;; - event-type 'array-end is generated, if EVENTS is returned by - ;; json-generator, it means a complete array was read. - ;; - ;; - event-type 'object-end is generated, similarly, if EVENTS is - ;; returned by json-generator, it means complete array was - ;; read. - ;; - ;; IF EVENTS does not follow the json-generator protocol, the - ;; behavior is unspecified. - - (define events (json-generator port-or-generator)) - - (define (ruse seed k) - (lambda () - (let loop ((seed seed)) - (let ((event (events))) - (if (eof-object? event) - (begin (k seed) #f) - (case event - ;; termination cases - ((array-end) (k seed)) - ((object-end) (k seed)) - ;; recursion - ((array-start) (ruse (array-start seed) - (lambda (out) (loop (proc (array-end out) seed))))) - ((object-start) (ruse (object-start seed) - (lambda (out) (loop (proc (object-end out) seed))))) - (else (loop (proc event seed))))))))) - - (define (make-trampoline-fold k) - (let ((thunk (ruse seed k))) - (let loop ((thunk thunk)) - (when thunk - (loop (thunk)))))) - - (define %unset '(unset)) - - (let ((out %unset)) - (define (escape out*) - (set! out out*) - #f) - (make-trampoline-fold escape) - (if (eq? out %unset) - (error 'json "Is this JSON text") - out))) - -(define json-fold - (case-lambda - ((proc array-start array-end object-start object-end seed) - (json-fold proc array-start array-end object-start object-end seed (current-input-port))) - ((proc array-start array-end object-start object-end seed port-or-generator) - (%json-fold proc array-start array-end object-start object-end seed port-or-generator)))) - -(define (%json-read port-or-generator) - - (define %root '(root)) - - (define (array-start seed) - ;; array will be read as a list, then converted into a vector in - ;; array-end. - '()) - - (define (array-end items) - (list->vector (reverse items))) - - (define (object-start seed) - ;; object will be read as a property list, then converted into an - ;; alist in object-end. - '()) - - (define (plist->alist plist) - ;; PLIST is a list of even items, otherwise json-generator - ;; would have raised a json-error. - (let loop ((plist plist) - (out '())) - (if (null? plist) - out - (loop (cddr plist) (cons (cons (string->symbol (cadr plist)) (car plist)) out))))) - - (define object-end plist->alist) - - (define (proc obj seed) - ;; proc is called when a JSON value or structure was completly - ;; read. The parse result is passed as OBJ. In the case where - ;; what is parsed is a JSON simple json value then OBJ is simply - ;; the token that is read that can be 'null, a number or a string. - ;; In the case where what is parsed is a JSON structure, OBJ is - ;; what is returned by OBJECT-END or ARRAY-END. - (if (eq? seed %root) - ;; It is toplevel, a complete JSON value or structure was read, - ;; return it. - obj - ;; This is not toplevel, hence json-fold is called recursivly, - ;; to parse an array or object. Both ARRAY-START and - ;; OBJECT-START return an empty list as a seed to serve as an - ;; accumulator. Both OBJECT-END and ARRAY-END expect a list - ;; as argument. - (cons obj seed))) - - (let ((out (json-fold proc - array-start - array-end - object-start - object-end - %root - port-or-generator))) - ;; if out is the root object, then the port or generator is empty. - (if (eq? out %root) - (eof-object) - out))) - -(define json-read - (case-lambda - (() (json-read (current-input-port))) - ((port-or-generator) (%json-read port-or-generator)))) - -;; json-lines-read - -(define json-lines-read - (case-lambda - (() (json-lines-read (current-input-port))) - ((port-or-generator) - (lambda () - (json-read port-or-generator))))) - -;; json-sequence-read - -(define json-sequence-read - (case-lambda - (() (json-sequence-read (current-input-port))) - ((port-or-generator) - (lambda () - (let loop () - (guard (ex ((json-error? ex) (loop))) - (json-read port-or-generator))))))) - -;; write procedures - -(define (json-accumulator accumulator ::procedure) ::procedure - - (define (write-json-char char accumulator ::procedure) - (case char - ((#\x00) (accumulator "\\u0000")) - ((#\") (accumulator "\\\"")) - ((#\\) (accumulator "\\\\")) - ((#\/) (accumulator "\\/")) - ((#\return) (accumulator "\\r")) - ((#\newline) (accumulator "\\n")) - ((#\tab) (accumulator "\\t")) - ((#\backspace) (accumulator "\\b")) - ((#\x0c) (accumulator "\\f")) - ((#\x0d) (accumulator "\\r")) - (else (accumulator char)))) - - (define (write-json-string string accumulator ::procedure) - (accumulator #\") - (string-for-each - (lambda (char) (write-json-char char accumulator)) - string) - (accumulator #\")) - - (define (write-json-value obj accumulator ::procedure) - (cond - ((eq? obj 'null) (accumulator "null")) - ((boolean? obj) (if obj - (accumulator "true") - (accumulator "false"))) - ((string? obj) (write-json-string obj accumulator)) - ((number? obj) (accumulator (number->string obj))) - (else (raise (make-json-error "Invalid json value."))))) - - (define (raise-invalid-event event) - (raise event)) - - (define (object-start k) ::procedure - (lambda (accumulator event) - (accumulator #\{) - (case (car event) - ((json-value) - (let ((key (cdr event))) - (unless (symbol? key) (raise-invalid-event event)) - (write-json-string (symbol->string key) accumulator) - (object-value k))) - ((json-structure) - (case (cdr event) - ((object-end) - (accumulator #\}) - k) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (object-value k) ::procedure - (lambda (accumulator event) - (accumulator #\:) - (case (car event) - ((json-value) - (write-json-value (cdr event) accumulator) - (object-maybe-continue k)) - ((json-structure) - (case (cdr event) - ((array-start) - (array-start (object-maybe-continue k))) - ((object-start) - (object-start (object-maybe-continue k))) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (object-maybe-continue k) ::procedure - (lambda (accumulator event) - (case (car event) - ((json-value) - (accumulator #\,) - (let ((key (cdr event))) - (unless (symbol? key) (raise-invalid-event event)) - (write-json-value (symbol->string key) accumulator) - (object-value k))) - ((json-structure) - (case (cdr event) - ((object-end) - (accumulator #\}) - k) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (array-start k) ::procedure - (lambda (accumulator event) - (accumulator #\[) - (case (car event) - ((json-value) - (write-json-value (cdr event) accumulator) - (array-maybe-continue k)) - ((json-structure) - (case (cdr event) - ((array-end) - (accumulator #\]) - k) - ((array-start) (array-start (array-maybe-continue k))) - ((object-start) (object-start (array-maybe-continue k))) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (array-maybe-continue k) ::procedure - (lambda (accumulator event) - (case (car event) - ((json-value) - (accumulator #\,) - (write-json-value (cdr event) accumulator) - (array-maybe-continue k)) - ((json-structure) - (case (cdr event) - ((array-end) - (accumulator #\]) - k) - ((array-start) - (accumulator #\,) - (array-start (array-maybe-continue k))) - ((object-start) - (accumulator #\,) - (object-start (array-maybe-continue k))) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event))))) - - (define (start accumulator ::procedure event ::pair) - (case (car event) - ((json-value) - (write-json-value (cdr event) accumulator) - raise-invalid-event) - ((json-structure) - (case (cdr event) - ((array-start) - (array-start raise-invalid-event)) - ((object-start) - (object-start raise-invalid-event)) - (else (raise-invalid-event event)))) - (else (raise-invalid-event event)))) - - (assume (procedure? accumulator) - "ACCUMULATOR does look like a valid accumulator.") - - (let ((k start)) - (lambda (event) - (set! k (k accumulator event))))) - -(define (%json-write obj accumulator ::procedure) - - (define (void) - (if #f #f)) - - (define (raise-unless-valid? obj) - (cond - ((null? obj) (void)) - ((eq? obj 'null) (void)) - ((boolean? obj) (void)) - ((string? obj) (void)) - ((and (number? obj) - (not (infinite? obj)) - (not (nan? obj)) - (real? obj) - (or (and (exact? obj) (= (denominator obj) 1)) - (inexact? obj))) - (void)) - ((vector? obj) - (vector-for-each (lambda (obj) (raise-unless-valid? obj)) obj)) - ;; XXX: use pair? then recursively check the tail. - ((pair? obj) - (for-each (lambda (obj) - (unless (pair? obj) - (raise (make-json-error "Unexpected object, not a pair."))) - (unless (symbol? (car obj)) - (raise (make-json-error "Unexpected object, not a symbol key."))) - (raise-unless-valid? (cdr obj))) - obj)) - (else (raise (make-json-error "Unexpected object"))))) - - (define (write obj accumulator ::procedure) - (cond - ((or (eq? obj 'null) - (boolean? obj) - (string? obj) - (symbol? obj) - (number? obj)) - (accumulator (cons 'json-value obj))) - ((vector? obj) - (accumulator '(json-structure . array-start)) - (vector-for-each (lambda (obj) (write obj accumulator)) obj) - (accumulator '(json-structure . array-end))) - ((null? obj) - (accumulator '(json-structure . object-start)) - (accumulator '(json-structure . object-end))) - ((pair? obj) - (accumulator '(json-structure . object-start)) - (for-each (lambda (pair) - (write (car pair) accumulator) - (write (cdr pair) accumulator)) - obj) - (accumulator '(json-structure . object-end))) - (else (error "Unexpected error!")))) - - (assume (procedure? accumulator)) - (raise-unless-valid? obj) - (write obj (json-accumulator accumulator))) - -(define (port->accumulator port ::output-port) - (lambda (char-or-string) - (cond - ((char? char-or-string) (write-char char-or-string port)) - ((string? char-or-string) (write-string char-or-string port)) - (else (raise (make-json-error "Not a char or string")))))) - -(define json-write - (case-lambda - ((obj) (json-write obj (current-output-port))) - ((obj port-or-accumulator) - (assume (or (procedure? port-or-accumulator) - (and (textual-port? port-or-accumulator) - (output-port? port-or-accumulator)))) - (if (procedure? port-or-accumulator) - (%json-write obj port-or-accumulator) - (%json-write obj (port->accumulator port-or-accumulator)))))) diff --git a/src/main/scheme/srfi/180.scm b/src/main/scheme/srfi/180.scm deleted file mode 100644 index c9108be..0000000 --- a/src/main/scheme/srfi/180.scm +++ /dev/null @@ -1,23 +0,0 @@ -(define-library - (srfi 180) - (export json-number-of-character-limit - json-nesting-depth-limit - json-null? - json-error? - json-error-reason - json-fold - json-generator - json-read - json-lines-read - json-sequence-read - json-accumulator - json-write) - - (import (scheme base) - (scheme inexact) - (scheme case-lambda) - (scheme char) - (scheme write) - (only (srfi 60) arithmetic-shift bitwise-ior)) - - (include "180-impl.scm")) diff --git a/src/test/resources/static1/test1.txt b/src/test/resources/static1/test1.txt deleted file mode 100644 index a5bce3f..0000000 --- a/src/test/resources/static1/test1.txt +++ /dev/null @@ -1 +0,0 @@ -test1 diff --git a/src/test/resources/static2/test2.txt b/src/test/resources/static2/test2.txt deleted file mode 100644 index 180cf83..0000000 --- a/src/test/resources/static2/test2.txt +++ /dev/null @@ -1 +0,0 @@ -test2 diff --git a/src/test/scheme/kawa-spark-test/main-test.scm b/src/test/scheme/kawa-spark-test/main-test.scm deleted file mode 100644 index ba072a3..0000000 --- a/src/test/scheme/kawa-spark-test/main-test.scm +++ /dev/null @@ -1,29 +0,0 @@ -(define-library - (kawa-spark-test main-test) - (import (scheme base) - (kawa-spark-test mapping-test) - (kawa-spark-test request-test) - (kawa-spark-test response-test) - (kawa-spark-test session-test) - (srfi 64)) - (export do-kawa-spark-test) - (begin - (define (do-kawa-spark-test) - (test-begin "Kawa-Spark test") - - (test-group - "Mapping test" - (do-mapping-test)) - - (test-group - "Request methods test" - (do-request-test)) - - (test-group - "Response methods test" - (do-response-test)) - - (test-group - "Session methods test" - (do-session-test)) - (test-end)))) diff --git a/src/test/scheme/kawa-spark-test/mapping-test.scm b/src/test/scheme/kawa-spark-test/mapping-test.scm deleted file mode 100644 index c81d50d..0000000 --- a/src/test/scheme/kawa-spark-test/mapping-test.scm +++ /dev/null @@ -1,150 +0,0 @@ -(define-library - (kawa-spark-test mapping-test) - (import - (scheme base) - (scheme write) - (srfi 64) - (kawa-spark-test test-util) - (arvyy kawa-spark) - (class org.apache.commons.io IOUtils) - (class java.nio.charset StandardCharsets) - (class org.apache.http.client.fluent Request Response Content Form) - (class org.apache.http.entity ContentType)) - (export do-mapping-test) - - (begin - (define (do-mapping-test) - - (static-files/location "/static1") - (static-files/external-location "src/test/resources/static2") - - (port 8080) - (init) - (await-initialization) - - (get "/a" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "a-get")) - - (put "/a" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "a-put")) - - (post "/a" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "a-post")) - - (delete "/a" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "a-delete")) - - (options "/a" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "a-options")) - - (path "/a" - (get "/subpath" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "a-subpath-get"))) - - (get "/before1" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "")) - - (get "/before2" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "")) - - (get "/after1" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "")) - - (get "/after2" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "")) - - (get "/after3" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "")) - - (get "/after4" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - "")) - - (redirect/get "/redirect-get" "/a") - (redirect/post "/redirect-post" "/a") - (redirect "/redirect-any" "/a") - - (before "/before1" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - (halt! 200 "a-before1"))) - - (before-all (lambda (req resp) - (when (equal? (req/url req) "http://localhost:8080/before2") - (resp/set-type! resp "text/plain; charset=utf-8") - (halt! 200 "a-before2")))) - - (after "/after1" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - (resp/set-body! resp "a-after1"))) - - (after-all (lambda (req resp) - (when (equal? (req/url req) "http://localhost:8080/after2") - (resp/set-type! resp "text/plain; charset=utf-8") - (resp/set-body! resp "a-after2")))) - - (after-after "/after3" (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - (resp/set-body! resp "a-after3"))) - - (after-after-all (lambda (req resp) - (when (equal? (req/url req) "http://localhost:8080/after4") - (resp/set-type! resp "text/plain; charset=utf-8") - (resp/set-body! resp "a-after4")))) - - (not-found - (lambda (req resp) - "Not found message")) - - (get "/exception" - (lambda (req resp) - (error "exception-msg" 'exception-obj))) - - (exception - (lambda (e req resp) - (define port (open-output-string)) - (write (cons (error-object-message e) - (error-object-irritants e)) port) - (resp/set-body! resp (get-output-string port)))) - - - (await-initialization) - - (test-req (Request:Get "http://localhost:8080/a") "a-get") - (test-req (Request:Put "http://localhost:8080/a") "a-put") - (test-req (Request:Post "http://localhost:8080/a") "a-post") - (test-req (Request:Delete "http://localhost:8080/a") "a-delete") - (test-req (Request:Options "http://localhost:8080/a") "a-options") - (test-req (Request:Get "http://localhost:8080/a/subpath") "a-subpath-get") - (test-req (Request:Get "http://localhost:8080/before1") "a-before1") - (test-req (Request:Get "http://localhost:8080/before2") "a-before2") - (test-req (Request:Get "http://localhost:8080/after1") "a-after1") - (test-req (Request:Get "http://localhost:8080/after2") "a-after2") - (test-req (Request:Get "http://localhost:8080/after3") "a-after3") - (test-req (Request:Get "http://localhost:8080/after4") "a-after4") - (test-req (Request:Get "http://localhost:8080/redirect-get") "a-get") - (test-req (Request:Get "http://localhost:8080/redirect-any") "a-get") - (let* ((req (Request:Get "http://localhost:8080/not-found")) - (resp (req:execute)) - (http-resp (resp:returnResponse)) - (resp-string (IOUtils:toString ((http-resp:getEntity):getContent) StandardCharsets:UTF_8))) - (test-equal 404 ((http-resp:getStatusLine):getStatusCode)) - (test-equal "Not found message" resp-string)) - (test-req (Request:Get "http://localhost:8080/exception") "(\"exception-msg\" exception-obj)") - (test-req (Request:Get "http://localhost:8080/test1.txt") "test1\n") - (test-req (Request:Get "http://localhost:8080/test2.txt") "test2\n") - - - (stop) - (await-stop)))) - diff --git a/src/test/scheme/kawa-spark-test/request-test.scm b/src/test/scheme/kawa-spark-test/request-test.scm deleted file mode 100644 index a2baa15..0000000 --- a/src/test/scheme/kawa-spark-test/request-test.scm +++ /dev/null @@ -1,204 +0,0 @@ -(define-library - (kawa-spark-test request-test) - (import - (scheme base) - (scheme write) - (srfi 64) - (srfi 95) ;sort - (arvyy kawa-spark) - (kawa-spark-test test-util) - (class org.apache.http.client.fluent Request Response Content Form) - (class org.apache.http.entity ContentType)) - - (export do-request-test) - (begin - (define (do-request-test) - (port 8080) - (init) - (await-initialization) - - (before "/attributes1" - (lambda (req resp) - (req/set-attribute! req "foo" "bar"))) - (get "/attributes1" - (lambda (req resp) - (req/attribute req "foo"))) - - (before "/attributes2" - (lambda (req resp) - (req/set-attribute! req "foo" "bar"))) - (get "/attributes2" - (lambda (req resp) - (car (req/attributes req)))) - - (post "/body1" - (lambda (req resp) - (req/body req))) - - (post "/body2" - (lambda (req resp) - (define port (open-output-string)) - (write (req/body-as-bytes req) port) - (get-output-string port))) - - (post "/body3" - (lambda (req resp) - (define port (open-output-string)) - (write (req/body req) port) - (get-output-string port))) - - (post "/content-length" - (lambda (req resp) - (number->string (req/content-length req)))) - - (post "/content-type" - (lambda (req resp) - (req/content-type req))) - - (get "/cookies" - (lambda (req resp) - (define port (open-output-string)) - (write (req/cookies req) port) - (get-output-string port ))) - - (get "/cookie" - (lambda (req resp) - (req/cookie req "foo"))) - - (get "/host" - (lambda (req resp) - (req/host req))) - - (get "/ip" - (lambda (req resp) - (req/ip req))) - - (get "/param1/:var" - (lambda (req resp) - (resp/set-type! resp "text/plain; charset=utf-8") - (req/param req "var"))) - - (get "/param2/:var" - (lambda (req resp) - (define params (req/params req)) - (resp/set-type! resp "text/plain; charset=utf-8") - (cdr (assoc ':var params)))) - - (get "/param3/:var" - (lambda (req resp) - (define port (open-output-string)) - (write (req/param req "foo") port) - (get-output-string port))) - - (get "/path-info/:foo" - (lambda (req resp) - (req/path-info req))) - - (get "/port" - (lambda (req resp) - (req/port req))) - - (get "/protocol" - (lambda (req resp) - (req/protocol req))) - - (get "/query-string" - (lambda (req resp) - (req/query-string req))) - - (get "/query-params" - (lambda (req resp) - (define port (open-output-string)) - (write (req/query-params req) port) - (get-output-string port))) - - (get "/query-param" - (lambda (req resp) - (req/query-param req "foo"))) - - (get "/query-param2" - (lambda (req resp) - (define port (open-output-string)) - (write (req/query-param req "foo") port) - (get-output-string port))) - - (get "/query-param-values" - (lambda (req resp) - (define port (open-output-string)) - (write (sort (req/query-param-values req "foo") string cdr) - (else #f))))) - (test-equal name expected (execute (compile "root" fn) data)))))) - - (test-begin "mustache") - - (test-group - "comments" - (include "mustache-test-comments.scm")) - - (test-group - "delimiters" - (include "mustache-test-delimiters.scm")) - - (test-group - "interpolation" - (include "mustache-test-interpolation.scm")) - - (test-group - "inverted" - (include "mustache-test-inverted.scm")) - - (test-group - "partials" - (include "mustache-test-partials.scm")) - - (test-group - "sections" - (include "mustache-test-sections.scm")) - - (test-group - "implementation-specific" - (include "mustache-test-implementation-specific.scm")) - - (test-end)))) diff --git a/src/test/scheme/mustache-test/mustache-test-comments.scm b/src/test/scheme/mustache-test/mustache-test-comments.scm deleted file mode 100644 index dec5fe9..0000000 --- a/src/test/scheme/mustache-test/mustache-test-comments.scm +++ /dev/null @@ -1,55 +0,0 @@ -(test-mustache "Inline" - '() - "12345{{! Comment Block! }}67890" - "1234567890") - -(test-mustache "Multiline" - '() - "12345{{!\n This is a\n multi-line comment...\n}}67890" - "1234567890") - -(test-mustache "Standalone" - '() - "Begin.\n{{! Comment Block! }}\nEnd." - "Begin.\nEnd.") - -(test-mustache "Indented Standalone" - '() - "Begin.\n {{! Comment Block! }}\nEnd." - "Begin.\nEnd.") - -(test-mustache "Standalone Line Endings" - '() - "\r\n{{! Standalone Comment }}\r\n" - "\r\n") - -(test-mustache "Standalone Without Previous Line" - '() - " {{! I'm Still Standalone }}\n!" - "!") - -(test-mustache "Standalone Without Newline" - '() - "!\n {{! I'm Still Standalone }}" - "!\n") - -(test-mustache "Multiline Standalone" - '() - "Begin.\n{{!\nSomething's going on here...\n}}\nEnd." - "Begin.\nEnd.") - -(test-mustache "Indented Multiline Standalone" - '() - "Begin.\n {{!\n Something's going on here...\n }}\nEnd." - "Begin.\nEnd.") - -(test-mustache "Indented Inline" - '() - " 12 {{! 34 }}\n" - " 12 \n") - -(test-mustache "Surrounding Whitespace" - '() - "12345 {{! Comment Block! }} 67890" - "12345 67890") - diff --git a/src/test/scheme/mustache-test/mustache-test-delimiters.scm b/src/test/scheme/mustache-test/mustache-test-delimiters.scm deleted file mode 100644 index 8809b8f..0000000 --- a/src/test/scheme/mustache-test/mustache-test-delimiters.scm +++ /dev/null @@ -1,73 +0,0 @@ -(test-mustache "Pair Behavior" - '((text . "Hey!")) - "{{=<% %>=}}(<%text%>)" - "(Hey!)") - -(test-mustache "Special Characters" - '((text . "It worked!")) - "({{=[ ]=}}[text])" - "(It worked!)") - -(test-mustache "Sections" - '((section . #t) - (data . "I got interpolated.")) - "[\n{{#section}}\n {{data}}\n |data|\n{{/section}}\n\n{{= | | =}}\n|#section|\n {{data}}\n |data|\n|/section|\n]\n" - "[\n I got interpolated.\n |data|\n\n {{data}}\n I got interpolated.\n]\n") - -(test-mustache "Inverted Sections" - '((section . #f) - (data . "I got interpolated.")) - "[\n{{^section}}\n {{data}}\n |data|\n{{/section}}\n\n{{= | | =}}\n|^section|\n {{data}}\n |data|\n|/section|\n]\n" - "[\n I got interpolated.\n |data|\n\n {{data}}\n I got interpolated.\n]\n") - -(test-mustache "Partial Inheritence" - '((value . "yes")) - '(("include" . ".{{value}}.")) - "[ {{>include}} ]\n{{= | | =}}\n[ |>include| ]\n" - "[ .yes. ]\n[ .yes. ]\n") - -(test-mustache "Post-Partial Behavior" - '((value . "yes")) - '(("include" . ".{{value}}. {{= | | =}} .|value|.")) - "[ {{>include}} ]\n[ .{{value}}. .|value|. ]\n" - "[ .yes. .yes. ]\n[ .yes. .|value|. ]\n") - -(test-mustache "Surrounding Whitespace" - '() - "| {{=@ @=}} |" - "| |") - -(test-mustache "Outlying Whitespace (Inline)" - '() - " | {{=@ @=}}\n" - " | \n") - -(test-mustache "Standalone Tag" - '() - "Begin.\n{{=@ @=}}\nEnd.\n" - "Begin.\nEnd.\n") - -(test-mustache "Indented Standalone Tag" - '() - "Begin.\n {{=@ @=}}\nEnd.\n" - "Begin.\nEnd.\n") - -(test-mustache "Standalone Line Endings" - '() - "|\r\n{{= @ @ =}}\r\n|" - "|\r\n|") - -(test-mustache "Standalone Without Previous Line" - '() - " {{=@ @=}}\n=" - "=") - -(test-mustache "Standalone Without Newline" - '() - "=\n {{=@ @=}}" - "=\n") - -(test-mustache "Pair with Padding" - '() - "|{{= @ @ =}}|" - "||") diff --git a/src/test/scheme/mustache-test/mustache-test-implementation-specific.scm b/src/test/scheme/mustache-test/mustache-test-implementation-specific.scm deleted file mode 100644 index 3559f90..0000000 --- a/src/test/scheme/mustache-test/mustache-test-implementation-specific.scm +++ /dev/null @@ -1,69 +0,0 @@ -(define-record-type (foo bar) foo? (bar foo-bar)) - -(define (foo-lookup obj name found not-found) - (cond - ((not (foo? obj)) (not-found)) - ((string=? "bar" name) (found (foo-bar obj))) - (else (not-found)))) - -(define alist+foo (compose-lookups alist-lookup foo-lookup)) - -(define (write-foo obj out) - (write-string "(foo " out) - (display (foo-bar obj) out) - (write-string ")" out)) - -(define-record-type (num-lst count) num-lst? (count num-lst-count)) -(define num-lst-collection - (collection - num-lst? - (lambda (obj) (= 0 (num-lst-count obj))) - (lambda (proc obj) - (define target (num-lst-count obj)) - (let loop ((i 0)) - (when (< i target) - (begin - (proc i) - (loop (+ 1 i)))))))) - -(parameterize - ((current-writer (lambda (obj out) - (cond - ((not obj) #t) - ((foo? obj) (write-foo obj out)) - (else (display obj out)))))) - (test-mustache "Custom writer" - `((obj . ,(foo "baz"))) - "Test {{obj}}" - "Test (foo baz)")) - -(parameterize - ((current-lookup alist+foo)) - (test-mustache "Custom lookup" - `((a . ((bar . "baz1"))) - (b . ,(foo "baz2"))) - "{{a.bar}}, {{b.bar}}" - "baz1, baz2")) - -(parameterize - ((current-collection num-lst-collection)) - (test-mustache "Custom collection" - `((a . ,(num-lst 3))) - "{{#a}}{{.}};{{/a}}" - "0;1;2;")) - -(parameterize - ((current-collection list-collection) - (current-lookup foo-lookup)) - (test-mustache "List collection" - (foo '(0 1 2)) - "{{#bar}}{{.}};{{/bar}}" - "0;1;2;")) - -#;(parameterize - ((current-collection stream-collection) - (current-lookup foo-lookup)) - (test-mustache "Stream collection" - (foo (list->stream '(0 1 2))) - "{{#bar}}{{.}};{{/bar}}" - "0;1;2;")) diff --git a/src/test/scheme/mustache-test/mustache-test-interpolation.scm b/src/test/scheme/mustache-test/mustache-test-interpolation.scm deleted file mode 100644 index 57f357b..0000000 --- a/src/test/scheme/mustache-test/mustache-test-interpolation.scm +++ /dev/null @@ -1,197 +0,0 @@ -(test-mustache "No Interpolation" - '() - "Hello from {Mustache}!" - "Hello from {Mustache}!") - -(test-mustache "Basic Interpolation" - '((subject . "world")) - "Hello, {{subject}}!" - "Hello, world!") - -(test-mustache "HTML Escaping" - '((forbidden . "& \" < >")) - "These characters should be HTML escaped: {{forbidden}}" - "These characters should be HTML escaped: & " < >") - -(test-mustache "Triple Mustache" - '((forbidden . "& \" < >")) - "These characters should not be HTML escaped: {{{forbidden}}}" - "These characters should not be HTML escaped: & \" < >") - -(test-mustache "Ampersand" - '((forbidden . "& \" < >")) - "These characters should not be HTML escaped: {{&forbidden}}" - "These characters should not be HTML escaped: & \" < >") - -(test-mustache "Basic Integer Interpolation" - '((mph . 85)) - "\"{{mph}} miles an hour!\"" - "\"85 miles an hour!\"") - -(test-mustache "Triple Mustache Integer Interpolation" - '((mph . 85)) - "\"{{{mph}}} miles an hour!\"" - "\"85 miles an hour!\"") - -(test-mustache "Ampersand Mustache Integer Interpolation" - '((mph . 85)) - "\"{{&mph}} miles an hour!\"" - "\"85 miles an hour!\"") - -(test-mustache "Basic Decimal Interpolation" - '((power . 1.210)) - "\"{{power}} jiggawatts!\"" - "\"1.21 jiggawatts!\"") - -(test-mustache "Triple Mustache Decimal Interpolation" - '((power . 1.210)) - "\"{{{power}}} jiggawatts!\"" - "\"1.21 jiggawatts!\"") - -(test-mustache "Ampersand Mustache Decimal Interpolation" - '((power . 1.210)) - "\"{{&power}} jiggawatts!\"" - "\"1.21 jiggawatts!\"") - -(test-mustache "Basic Null Interpolation" - '((cannot . #f)) - "I ({{cannot}}) be seen!" - "I () be seen!") - -(test-mustache "Triple Mustache Null Interpolation" - '((cannot . #f)) - "I ({{{cannot}}}) be seen!" - "I () be seen!") - -(test-mustache "Ampersand Null Interpolation" - '((cannot . #f)) - "I ({{&cannot}}) be seen!" - "I () be seen!") - -(test-mustache "Basic Context Miss Interpolation" - '() - "I ({{cannot}}) be seen!" - "I () be seen!") - -(test-mustache "Triple Mustache Context Miss Interpolation" - '() - "I ({{{cannot}}}) be seen!" - "I () be seen!") - -(test-mustache "Ampersand Context Miss Interpolation" - '() - "I ({{&cannot}}) be seen!" - "I () be seen!") - -(test-mustache "Dotted Names - Basic Interpolation" - '((person . ((name . "Joe")))) - "\"{{person.name}}\" == \"{{#person}}{{name}}{{/person}}\"" - "\"Joe\" == \"Joe\"") - -(test-mustache "Dotted Names - Triple Mustache Interpolation" - '((person . ((name . "Joe")))) - "\"{{{person.name}}}\" == \"{{#person}}{{{name}}}{{/person}}\"" - "\"Joe\" == \"Joe\"") - -(test-mustache "Dotted Names - Ampersand Interpolation" - '((person . ((name . "Joe")))) - "\"{{&person.name}}\" == \"{{#person}}{{&name}}{{/person}}\"" - "\"Joe\" == \"Joe\"") - -(test-mustache "Dotted Names - Arbitrary Depth" - '((a . ((b . ((c . ((d . ((e . ((name . "Phil")))))))))))) - "\"{{a.b.c.d.e.name}}\" == \"Phil\"" - "\"Phil\" == \"Phil\"") - -(test-mustache "Dotted Names - Broken Chains" - '((a . ())) - "\"{{a.b.c}}\" == \"\"" - "\"\" == \"\"") - -(test-mustache "Dotted Names - Broken Chain Resolution" - '((a . ((b . ()))) - (c . ((name . "Jim")))) - "\"{{a.b.c.name}}\" == \"\"" - "\"\" == \"\"") - -(test-mustache "Dotted Names - Initial Resolution" - '((a . ((b . ((c . ((d . ((e . ((name . "Phil"))))))))))) - (b . ((c . ((d . ((e . ((name . "Wrong")))))))))) - "\"{{#a}}{{b.c.d.e.name}}{{/a}}\" == \"Phil\"" - "\"Phil\" == \"Phil\"") - -(test-mustache "Dotted Names - Context Precedence" - '((a . ((b . ()))) - (b . ((c . "ERROR")))) - "{{#a}}{{b.c}}{{/a}}" - "") - -(test-mustache "Implicit Iterators - Basic Interpolation" - "world" - "Hello, {{.}}!" - "Hello, world!") - -(test-mustache "Implicit Iterators - HTML Escaping" - "& \" < >" - "These characters should be HTML escaped: {{.}}" - "These characters should be HTML escaped: & " < >") - -(test-mustache "Implicit Iterators - Triple Mustache" - "& \" < >" - "These characters should not be HTML escaped: {{{.}}}" - "These characters should not be HTML escaped: & \" < >") - -(test-mustache "Implicit Iterators - Ampersand" - "& \" < >" - "These characters should not be HTML escaped: {{&.}}" - "These characters should not be HTML escaped: & \" < >") - -(test-mustache "Implicit Iterators - Basic Integer Interpolation" - 85 - "\"{{.}} miles an hour!\"" - "\"85 miles an hour!\"") - -(test-mustache "Interpolation - Surrounding Whitespace" - '((string . "---")) - "| {{string}} |" - "| --- |") - -(test-mustache "Triple Mustache - Surrounding Whitespace" - '((string . "---")) - "| {{{string}}} |" - "| --- |") - -(test-mustache "Ampersand - Surrounding Whitespace" - '((string . "---")) - "| {{&string}} |" - "| --- |") - -(test-mustache "Interpolation - Standalone" - '((string . "---")) - " {{string}}\n" - " ---\n") - -(test-mustache "Triple Mustache - Standalone" - '((string . "---")) - " {{{string}}}\n" - " ---\n") - -(test-mustache "Ampersand - Standalone" - '((string . "---")) - " {{&string}}\n" - " ---\n") - -(test-mustache "Interpolation With Padding" - '((string . "---")) - "|{{ string }}|" - "|---|") - -(test-mustache "Triple Mustache With Padding" - '((string . "---")) - "|{{{ string }}}|" - "|---|") - -(test-mustache "Ampersand With Padding" - '((string . "---")) - "|{{& string }}|" - "|---|") diff --git a/src/test/scheme/mustache-test/mustache-test-inverted.scm b/src/test/scheme/mustache-test/mustache-test-inverted.scm deleted file mode 100644 index d112403..0000000 --- a/src/test/scheme/mustache-test/mustache-test-inverted.scm +++ /dev/null @@ -1,144 +0,0 @@ -(test-mustache "Falsey" - '((boolean . #f)) - "\"{{^boolean}}This should be rendered.{{/boolean}}\"" - "\"This should be rendered.\"") - -(test-mustache "Truthy" - '((boolean . #t)) - "\"{{^boolean}}This should not be rendered.{{/boolean}}\"" - "\"\"") - -;; "Null is falsey" test is skipped; no meaningful value for null - -(test-mustache "Context" - '((context . ((name . "Joe")))) - "\"{{^context}}Hi {{name}}.{{/context}}\"" - "\"\"") - -(test-mustache "List" - '(list . #(((n . 1)) - ((n . 2)) - ((n . 3)))) - "\"{{^list}}{{n}}{{/list}}\"" - "\"\"") - -(test-mustache "Empty List" - '(list . #()) - "\"{{^list}}Yay lists!{{/list}}\"" - "\"Yay lists!\"") - -(test-mustache "Doubled" - '((bool . #f) (two . "second")) - " - {{^bool}} - * first - {{/bool}} - * {{two}} - {{^bool}} - * third - {{/bool}} - " - " - * first - * second - * third - ") - -(test-mustache "Nested (Falsey)" - '((bool . #f)) - "| A {{^bool}}B {{^bool}}C{{/bool}} D{{/bool}} E |" - "| A B C D E |") - -(test-mustache "Nested (Truthy)" - '((bool . #t)) - "| A {{^bool}}B {{^bool}}C{{/bool}} D{{/bool}} E |" - "| A E |") - -(test-mustache "Context Misses" - '(()) - "[{{^missing}}Cannot find key 'missing'!{{/missing}}]" - "[Cannot find key 'missing'!]") - -(test-mustache "Dotted Names - Truthy" - '((a . ((b . ((c . #t)))))) - "\"{{^a.b.c}}Not Here{{/a.b.c}}\" == \"\"" - "\"\" == \"\"") - -(test-mustache "Dotted Names - Falsey" - '((a . ((b . ((c . #f)))))) - "\"{{^a.b.c}}Not Here{{/a.b.c}}\" == \"Not Here\"" - "\"Not Here\" == \"Not Here\"") - -(test-mustache "Dotted Names - Broken Chains" - '((a . ())) - "\"{{^a.b.c}}Not Here{{/a.b.c}}\" == \"Not Here\"" - "\"Not Here\" == \"Not Here\"") - -(test-mustache "Surrounding Whitespace" - '((boolean . #f)) - " | {{^boolean}}\t|\t{{/boolean}} | \n" - " | \t|\t | \n") - -(test-mustache "Internal Whitespace" - '((boolean . #f)) - " | {{^boolean}} {{! Important Whitespace }}\n {{/boolean}} | \n" - " | \n | \n") - -(test-mustache "Indented Inline Sections" - '((boolean . #f)) - " {{^boolean}}NO{{/boolean}}\n {{^boolean}}WAY{{/boolean}}\n" - " NO\n WAY\n") - -(test-mustache "Standalone Lines" - '((boolean . #f)) - " - | - | This Is - {{^boolean}} - | - {{/boolean}} - | A Line - " - " - | - | This Is - | - | A Line - ") - -(test-mustache "Standalone Indented Lines" - '((boolean . #f)) - " - | - | This Is - {{^boolean}} - | - {{/boolean}} - | A Line - " - " - | - | This Is - | - | A Line - ") - -(test-mustache "Standalone Line Endings" - '((boolean . #f)) - "|\r\n{{^boolean}}\r\n{{/boolean}}\r\n|" - "|\r\n|") - -(test-mustache "Standalone Without Previous Line" - '((boolean . #f)) - " {{^boolean}}\n^{{/boolean}}\n/" - "^\n/") - -(test-mustache "Standalone Without Newline" - '((boolean . #f)) - "^{{^boolean}}\n/\n {{/boolean}}" - "^\n/\n") - -(test-mustache "Padding" - '((boolean . #f)) - "|{{^ boolean }}={{/ boolean }}|" - "|=|") diff --git a/src/test/scheme/mustache-test/mustache-test-partials.scm b/src/test/scheme/mustache-test/mustache-test-partials.scm deleted file mode 100644 index 62e27c0..0000000 --- a/src/test/scheme/mustache-test/mustache-test-partials.scm +++ /dev/null @@ -1,43 +0,0 @@ -(test-mustache "Basic Behavior" - '() - '(("text" . "from partial")) - "\"{{>text}}\"" - "\"from partial\"") - -(test-mustache "Failed Lookup" - '() - '() - "\"{{>text}}\"" - "\"\"") - -(test-mustache "Context" - '((text . "content")) - '(("partial" . "*{{text}}*")) - "\"{{>partial}}\"" - "\"*content*\"") - -(test-mustache "Recursion" - '((content . "X") - (nodes . #(((content . "Y") - (nodes . #()))))) - '(("node" . "{{content}}<{{#nodes}}{{>node}}{{/nodes}}>")) - "{{>node}}" - "X>") - -(test-mustache "Surrounding Whitespace" - '() - '(("partial" . "\t|\t")) - "| {{>partial}} |" - "| \t|\t |") - -(test-mustache "Inline Indentation" - '((data . "|")) - '(("partial" . ">\n>")) - " {{data}} {{> partial}}\n" - " | >\n>\n") - -(test-mustache "Standalone Line Endings" - '() - '(("partial" . ">")) - "|\r\n{{>partial}}\r\n|" - "|\r\n>|") diff --git a/src/test/scheme/mustache-test/mustache-test-sections.scm b/src/test/scheme/mustache-test/mustache-test-sections.scm deleted file mode 100644 index b3cbb74..0000000 --- a/src/test/scheme/mustache-test/mustache-test-sections.scm +++ /dev/null @@ -1,247 +0,0 @@ -(test-mustache "Truthy" - '((boolean . #t)) - "\"{{#boolean}}This should be rendered.{{/boolean}}\"" - "\"This should be rendered.\"") - -(test-mustache "Falsey" - '((boolean . #f)) - "\"{{#boolean}}This should not be rendered.{{/boolean}}\"" - "\"\"") - -;; "Null is falsey" test is skipped; no meaningful value for null - -(test-mustache "Context" - '((context . ((name . "Joe")))) - "\"{{#context}}Hi {{name}}.{{/context}}\"" - "\"Hi Joe.\"") - -(test-mustache "Parent contexts" - '((a . "foo") - (b . "wrong") - (sec . ((b . "bar"))) - (c . ((d . "baz")))) - "\"{{#sec}}{{a}}, {{b}}, {{c.d}}{{/sec}}\"" - "\"foo, bar, baz\"") - -(test-mustache "Variable test" - '((foo . "bar")) - "\"{{#foo}}{{.}} is {{foo}}{{/foo}}\"" - "\"bar is bar\"") - -(test-mustache "List Contexts" - '((tops . #(((tname . ((upper . "A") - (lower . "a"))) - (middles . #(((mname . "1") - (bottoms . #(((bname . "x")) - ((bname . "y"))))))))))) - "{{#tops}}{{#middles}}{{tname.lower}}{{mname}}.{{#bottoms}}{{tname.upper}}{{mname}}{{bname}}.{{/bottoms}}{{/middles}}{{/tops}}" - "a1.A1x.A1y.") - -(test-mustache "Deeply Nested Contexts" - '((a . ((one . 1))) - (b . ((two . 2))) - (c . ((three . 3) - (d . ((four . 4) - (five . 5)))))) - " - {{#a}} - {{one}} - {{#b}} - {{one}}{{two}}{{one}} - {{#c}} - {{one}}{{two}}{{three}}{{two}}{{one}} - {{#d}} - {{one}}{{two}}{{three}}{{four}}{{three}}{{two}}{{one}} - {{#five}} - {{one}}{{two}}{{three}}{{four}}{{five}}{{four}}{{three}}{{two}}{{one}} - {{one}}{{two}}{{three}}{{four}}{{.}}6{{.}}{{four}}{{three}}{{two}}{{one}} - {{one}}{{two}}{{three}}{{four}}{{five}}{{four}}{{three}}{{two}}{{one}} - {{/five}} - {{one}}{{two}}{{three}}{{four}}{{three}}{{two}}{{one}} - {{/d}} - {{one}}{{two}}{{three}}{{two}}{{one}} - {{/c}} - {{one}}{{two}}{{one}} - {{/b}} - {{one}} - {{/a}} - " - " - 1 - 121 - 12321 - 1234321 - 123454321 - 12345654321 - 123454321 - 1234321 - 12321 - 121 - 1 - " - ) - -(test-mustache "List" - '((list . #(((item . 1)) - ((item . 2)) - ((item . 3))))) - "\"{{#list}}{{item}}{{/list}}\"" - "\"123\"") - - (test-mustache "Empty List" -'((list . #())) -"\"{{#list}}Yay lists!{{/list}}\"" -"\"\"") - - (test-mustache "Doubled" - '((bool . #t) (two . "second")) - " - {{#bool}} - * first - {{/bool}} - * {{two}} - {{#bool}} - * third - {{/bool}} - " - - " - * first - * second - * third - " - ) - -(test-mustache "Nested (Truthy)" - '((bool . #t)) - "| A {{#bool}}B {{#bool}}C{{/bool}} D{{/bool}} E |" - "| A B C D E |" - ) - -(test-mustache "Nested (Falsey)" - '((bool . #f)) - "| A {{#bool}}B {{#bool}}C{{/bool}} D{{/bool}} E |" - "| A E |" - ) - -(test-mustache "Context Misses" - '() - "[{{#missing}}Found key 'missing'!{{/missing}}]" - "[]") - -(test-mustache "Implicit Iterator - String" - '((list . #("a" "b" "c" "d" "e"))) - "\"{{#list}}({{.}}){{/list}}\"" - "\"(a)(b)(c)(d)(e)\"") - -(test-mustache "Implicit Iterator - Integer" - '((list . #(1 2 3 4 5))) - "\"{{#list}}({{.}}){{/list}}\"" - "\"(1)(2)(3)(4)(5)\"") - -(test-mustache "Implicit Iterator - Decimal" - '((list . #(1.10 2.20 3.30 4.40 5.50))) - "\"{{#list}}({{.}}){{/list}}\"" - "\"(1.1)(2.2)(3.3)(4.4)(5.5)\"") - -(test-mustache "Implicit Iterator - Array" - '((list . #(#(1 2 3) #("a" "b" "c")))) - "\"{{#list}}({{#.}}{{.}}{{/.}}){{/list}}\"" - "\"(123)(abc)\"") - -(test-mustache "Dotted Names - Truthy" - '((a . ((b . ((c . #t)))))) - "\"{{#a.b.c}}Here{{/a.b.c}}\" == \"Here\"" - "\"Here\" == \"Here\"" - ) - -(test-mustache "Dotted Names - Falsey" - '((a . ((b . ((c . #f)))))) - "\"{{#a.b.c}}Here{{/a.b.c}}\" == \"\"" - "\"\" == \"\"" - ) - -(test-mustache "Dotted Names - Broken Chains" - '((a . ())) - "\"{{#a.b.c}}Here{{/a.b.c}}\" == \"\"" - "\"\" == \"\"" - ) - -(test-mustache "Surrounding Whitespace" - '((boolean . #t)) - " | {{#boolean}}\t|\t{{/boolean}} | \n" - " | \t|\t | \n" - ) - -(test-mustache "Internal Whitespace" - '((boolean . #t)) - " | {{#boolean}} {{! Important Whitespace }}\n {{/boolean}} | \n" - " | \n | \n" - ) - -(test-mustache "Indented Inline Sections" - '((boolean . #t)) - " {{#boolean}}YES{{/boolean}}\n {{#boolean}}GOOD{{/boolean}}\n" - " YES\n GOOD\n" - ) - -(test-mustache "Standalone Lines" - '((boolean . #t)) - " - | - | This Is - {{#boolean}} - | - {{/boolean}} - | A Line - " - " - | - | This Is - | - | A Line - " - ) - -(test-mustache "Indented Standalone Lines" - '((boolean . #t)) - " - | - | This Is - {{#boolean}} - | - {{/boolean}} - | A Line - " - - " - | - | This Is - | - | A Line - " - - ) - -(test-mustache "Standalone Line Endings" - '((boolean . #t)) - "|\r\n{{#boolean}}\r\n{{/boolean}}\r\n|" - "|\r\n|" - ) -(test-mustache "Standalone Without Previous Line" - '((boolean . #t)) - " {{#boolean}}\n#{{/boolean}}\n/" - "#\n/" - ) - -(test-mustache "Standalone Without Newline" - '((boolean . #t)) - "#{{#boolean}}\n/\n {{/boolean}}" - "#\n/\n" - ) - -(test-mustache "Padding" - '((boolean . #t)) - "|{{# boolean }}={{/ boolean }}|" - "|=|" - ) diff --git a/src/test/scheme/scmindex-test/main-test.scm b/src/test/scheme/scmindex-test/main-test.scm deleted file mode 100644 index b3c972b..0000000 --- a/src/test/scheme/scmindex-test/main-test.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define-library - (scmindex-test main-test) - (import (scheme base) - (scheme write) - (scheme read) - (scmindex types-parser) - (scmindex mustache) - (only (srfi 1) lset=) - (srfi 64) - (srfi 180)) - - (export do-scmindex-test) - - (begin - - (define (do-scmindex-test) - (test-begin "SCM index test") - (test-group "types-parser" - (include "test-types-parser.scm")) - (test-group "mustache" - (include "test-mustache.scm")) - (test-end)))) diff --git a/src/test/scheme/scmindex-test/test-mustache.scm b/src/test/scheme/test-mustache.scm similarity index 100% rename from src/test/scheme/scmindex-test/test-mustache.scm rename to src/test/scheme/test-mustache.scm diff --git a/src/test/scheme/scmindex-test/test-types-parser.scm b/src/test/scheme/test-types-parser.scm similarity index 100% rename from src/test/scheme/scmindex-test/test-types-parser.scm rename to src/test/scheme/test-types-parser.scm diff --git a/templates/index.html b/templates/index.html index e6ff7ef..317e1ba 100644 --- a/templates/index.html +++ b/templates/index.html @@ -4,7 +4,7 @@ {{>topnavigation}}

R7RS index

-

R7RS index allows searching for R7RS-small and R7RS-large (work in progress) procedures, syntax and constants through types, tags, and names. Please see user guide for details +

R7RS index allows searching for R7RS-small and R7RS-large (work in progress) procedures, syntax and constants through types, tags, and names. Please see user guide for details

@@ -23,6 +23,9 @@

R7RS index

+

REST api, STDIO repl api

+

R7RS provides multiple options for integrating its search component with other software. Please consult documentation for details.

+

Report an issue

Please report any issues or suggestions you may have at github.

diff --git a/templates/topnavigation.html b/templates/topnavigation.html index 4ec911c..2294839 100644 --- a/templates/topnavigation.html +++ b/templates/topnavigation.html @@ -7,10 +7,4 @@ {{label}} {{/active}} {{/nav-links}} -