├── .dockerignore ├── .github └── workflows │ └── haskell.yaml ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.md ├── DOCTODO.md ├── Dockerfile ├── LICENSE ├── README.md ├── bin ├── dev ├── docgen └── release ├── cabal.project ├── client ├── declarations.d.ts ├── dist │ ├── action.d.ts │ ├── browser.d.ts │ ├── events.d.ts │ ├── http.d.ts │ ├── hyperbole.js │ ├── index.d.ts │ ├── lib.d.ts │ ├── response.d.ts │ └── sockets.d.ts ├── package-lock.json ├── package.json ├── src │ ├── action.ts │ ├── browser.ts │ ├── events.ts │ ├── http.ts │ ├── index.ts │ ├── lib.ts │ ├── response.ts │ └── sockets.ts ├── tsconfig.json └── webpack.config.js ├── docs ├── Main.hs ├── docgen.cabal ├── javascript_api.md └── package.yaml ├── examples ├── .dockerignore ├── Example │ ├── App.hs │ ├── AppRoute.hs │ ├── Cache.hs │ ├── Colors.hs │ ├── Data │ │ └── ProgrammingLanguage.hs │ ├── Docs │ │ ├── App.hs │ │ ├── BasicPage.hs │ │ ├── Component.hs │ │ ├── Encoding.hs │ │ ├── Interactive.hs │ │ ├── MultiCopies.hs │ │ ├── MultiPage.hs │ │ ├── MultiView.hs │ │ ├── Nested.hs │ │ ├── Page │ │ │ ├── Messages.hs │ │ │ └── Users.hs │ │ ├── Params.hs │ │ ├── Sessions.hs │ │ ├── SideEffects.hs │ │ ├── State.hs │ │ └── ViewFunctions.hs │ ├── Effects │ │ ├── Debug.hs │ │ ├── Random.hs │ │ ├── Todos.hs │ │ └── Users.hs │ ├── Page │ │ ├── Autocomplete.hs │ │ ├── CSS.hs │ │ ├── CSS │ │ │ ├── External.hs │ │ │ ├── Tooltips.hs │ │ │ └── Transitions.hs │ │ ├── Concurrency.hs │ │ ├── Contact.hs │ │ ├── Contacts.hs │ │ ├── Counter.hs │ │ ├── DataTable.hs │ │ ├── Errors.hs │ │ ├── Filter.hs │ │ ├── FormSimple.hs │ │ ├── FormValidation.hs │ │ ├── Forms.hs │ │ ├── Intro.hs │ │ ├── Javascript.hs │ │ ├── Requests.hs │ │ ├── Simple.hs │ │ ├── State │ │ │ ├── Effects.hs │ │ │ ├── Query.hs │ │ │ └── Sessions.hs │ │ └── Todo.hs │ ├── Style.hs │ └── View │ │ ├── Icon.hs │ │ ├── Inputs.hs │ │ ├── Layout.hs │ │ └── SortableTable.hs ├── Main.hs ├── README.md ├── examples.cabal ├── fourmolu.yaml ├── hie.yaml ├── package.yaml └── static │ ├── custom.js │ ├── examples.png │ ├── external.css │ ├── logo-robot.png │ └── nso.png ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── hie.yaml ├── hyperbole.cabal ├── package.yaml ├── src └── Web │ ├── Hyperbole.hs │ └── Hyperbole │ ├── Application.hs │ ├── Data │ ├── Cookie.hs │ ├── Encoded.hs │ ├── Param.hs │ ├── QueryData.hs │ └── URI.hs │ ├── Effect │ ├── Event.hs │ ├── Handler.hs │ ├── Hyperbole.hs │ ├── Javascript.hs │ ├── Query.hs │ ├── Request.hs │ ├── Response.hs │ ├── Server.hs │ └── Session.hs │ ├── HyperView.hs │ ├── HyperView │ ├── Event.hs │ ├── Forms.hs │ ├── Input.hs │ └── Types.hs │ ├── Page.hs │ ├── Route.hs │ ├── TypeList.hs │ ├── View.hs │ └── View │ ├── CSS.hs │ ├── Embed.hs │ ├── Render.hs │ ├── Tag.hs │ └── Types.hs └── test ├── Spec.hs └── Test ├── EncodedSpec.hs ├── FormSpec.hs ├── QuerySpec.hs ├── RouteSpec.hs ├── SessionSpec.hs ├── ViewActionSpec.hs └── ViewIdSpec.hs /.dockerignore: -------------------------------------------------------------------------------- 1 | .git 2 | .stack-work 3 | client/node_modules 4 | Dockerfile 5 | dist-newstyle 6 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yaml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ "main", "ci" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | permissions: 10 | contents: read 11 | 12 | 13 | 14 | jobs: 15 | build-cache: 16 | runs-on: ubuntu-latest 17 | container: 18 | image: haskell:9.8.2 19 | steps: 20 | - uses: actions/checkout@v4 21 | 22 | - name: Cache Cabal 23 | id: cache-cabal 24 | uses: actions/cache@v4 25 | with: 26 | path: | 27 | /github/home/.cache 28 | /github/home/.config 29 | /github/home/.local 30 | key: ${{ runner.os }}-${{ hashFiles('**/cabal.project') }}-${{ hashFiles('**/*.cabal') }} 31 | # restore-keys: | 32 | # ${{ runner.os }}- 33 | 34 | - name: Install dependencies 35 | run: | 36 | cabal update 37 | 38 | - name: Build dependencies 39 | run: | 40 | cabal build --only-dependencies --enable-tests --enable-benchmarks 41 | 42 | - name: Install skeletest-preprocessor 43 | run: | 44 | cabal install skeletest --installdir=$HOME/.local/bin --install-method=copy --overwrite-policy=always 45 | 46 | - name: Check Cache 47 | run: | 48 | ls -ahl /github/home/ 49 | ls -ahl /github/home/.cache 50 | ls -ahl /github/home/.config 51 | ls -ahl /github/home/.local 52 | 53 | build-982: 54 | needs: build-cache 55 | runs-on: ubuntu-latest 56 | container: 57 | image: haskell:9.8.2 58 | steps: 59 | - uses: actions/checkout@v4 60 | 61 | - name: Cache Cabal Restore 62 | id: cache-cabal-restore 63 | uses: actions/cache@v4 64 | with: 65 | path: | 66 | /github/home/.cache 67 | /github/home/.config 68 | /github/home/.local 69 | key: ${{ runner.os }}-${{ hashFiles('**/cabal.project') }}-${{ hashFiles('**/*.cabal') }} 70 | # restore-keys: | 71 | # ${{ runner.os }}-build-${{ env.cache-name }}- 72 | # ${{ runner.os }}-build- 73 | # ${{ runner.os }}- 74 | 75 | - name: Check Cache 76 | run: | 77 | ls -ahl /github/home/ 78 | ls -ahl /github/home/.cache 79 | ls -ahl /github/home/.config 80 | ls -ahl /github/home/.local 81 | 82 | - name: Source skeletest-preprocessor 83 | run: | 84 | echo "$HOME/.local/bin" >> $GITHUB_PATH 85 | 86 | - name: Build 87 | run: cabal build --enable-tests --enable-benchmarks all 88 | 89 | - name: Test 90 | run: cabal test 91 | 92 | # build-966: 93 | # runs-on: ubuntu-latest 94 | # container: 95 | # image: haskell:9.6.6 96 | # steps: *cabal-test 97 | 98 | 99 | # - uses: actions/setup-haskell@v1 100 | # with: 101 | # ghc-version: '9.6' 102 | # cabal-version: '3.2' 103 | 104 | # - name: Cache 105 | # uses: actions/cache@v3 106 | # env: 107 | # cache-name: cache-cabal 108 | # with: 109 | # path: ~/.cabal 110 | # key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 111 | # restore-keys: | 112 | # ${{ runner.os }}-build-${{ env.cache-name }}- 113 | # ${{ runner.os }}-build- 114 | # ${{ runner.os }}- 115 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | .DS_Store 3 | tags 4 | node_modules 5 | # Auto-generated pre-commit config 6 | .pre-commit-config.yaml 7 | # Nix output dir 8 | result 9 | .direnv 10 | client/dist/hyperbole.js.LICENSE.txt 11 | client/dist/hyperbole.js.map 12 | Session.vim 13 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: 2 | - -XOverloadedRecordDot 3 | 4 | - ignore: {name: "Use <$>"} 5 | - ignore: {name: "Use newtype instead of data"} 6 | 7 | # Hlint is not aware of OverloadedRecordDot 8 | # See https://github.com/ndmitchell/hlint/issues/1383 9 | - ignore: { name: Redundant id } 10 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for hyperbole 2 | 3 | ## 0.4.4 -- 2025-03-09 4 | 5 | * fixed source links in examples 6 | 7 | ## 0.4.3 -- 2024-01-31 8 | 9 | * Bug fixes and improvements 10 | 11 | ## 0.4.2 -- 2024-01-21 12 | 13 | * Cleaner HyperView class [(@cgeorgii)](https://github.com/cgeorgii) 14 | * data family Action 15 | * update 16 | * Type-safe resolution of HyperViews 17 | * Record-based Forms 18 | * textarea [(@tusharad)](https://github.com/tusharad) 19 | * High-level sessions and query params 20 | * Events: onLoad, onClick onInput, onSubmit, onDblClick, onKeyDown, onKeyUp 21 | * Major refactoring 22 | * Nix build and CI [(@Skyfold)](https://github.com/Skyfold) 23 | * New Examples Live: https://docs.hyperbole.live 24 | * New Examples Added: 25 | * TodoMVC 26 | * Forms - Simple 27 | * DataTable 28 | * Search - Filters 29 | * Search - Autocomplete 30 | 31 | ## 0.3.6 -- 2024-05-21 32 | 33 | * First version. Released on an unsuspecting world. 34 | -------------------------------------------------------------------------------- /DOCTODO.md: -------------------------------------------------------------------------------- 1 | Documentation Outline 2 | ====================== 3 | 4 | 5 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell:9.8.2 AS base 2 | WORKDIR /opt/build 3 | 4 | RUN cabal update 5 | RUN cabal install bytestring containers casing effectful text time string-interpolate file-embed http-api-data http-types wai warp wai-websockets network cookie string-conversions hpack websockets 6 | 7 | 8 | FROM haskell:9.8.2 AS dependencies 9 | WORKDIR /opt/build 10 | COPY --from=base /root/.cache /root/.cache 11 | COPY --from=base /root/.local /root/.local 12 | COPY --from=base /root/.config /root/.config 13 | 14 | # RUN apt-get update && apt-get install -y libpcre3 libpcre3-dev libcurl4-openssl-dev cron vim rsyslog 15 | ADD ./package.yaml . 16 | # ADD ./cabal.project . 17 | # ADD ./docs/docgen.cabal . 18 | # ADD ./examples/examples.cabal . 19 | RUN hpack 20 | RUN cabal update 21 | RUN cabal build --only-dependencies 22 | 23 | FROM haskell:9.8.2 AS build 24 | WORKDIR /opt/build 25 | COPY --from=dependencies /root/.cache /root/.cache 26 | COPY --from=dependencies /root/.local /root/.local 27 | COPY --from=dependencies /root/.config /root/.config 28 | ADD ./package.yaml . 29 | ADD ./cabal.project . 30 | ADD ./client ./client 31 | ADD ./test ./test 32 | ADD ./src ./src 33 | ADD ./examples ./examples 34 | ADD ./docs ./docs 35 | ADD *.md . 36 | ADD LICENSE . 37 | RUN hpack 38 | RUN hpack examples 39 | RUN hpack docs 40 | RUN cabal build examples 41 | RUN mkdir bin 42 | RUN cd examples && export EXEC=$(cabal list-bin examples); cp $EXEC /opt/build/bin/examples 43 | 44 | 45 | FROM debian:10 AS app 46 | WORKDIR /opt/app 47 | 48 | COPY --from=build /opt/build/bin/examples ./bin/examples 49 | ADD ./client ./client 50 | ADD ./examples/static ./examples/static 51 | 52 | # ENV DYNAMO_LOCAL=False 53 | ENTRYPOINT ["/opt/app/bin/examples"] 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Sean Hess 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Sean Hess nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /bin/dev: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | 4 | package() { 5 | hpack 6 | hpack docs 7 | hpack examples 8 | } 9 | 10 | watch() { 11 | ghcid -c "cabal repl examples lib:hyperbole" -T Example.App.run -W --reload=./client/dist/hyperbole.js 12 | } 13 | 14 | client() { 15 | cd client 16 | # npx webpack -w --mode=development 17 | npx webpack -w 18 | } 19 | 20 | # run tests once (so we don't forget!) 21 | cabal test 22 | 23 | (trap 'kill 0' SIGINT; client & package && watch) 24 | -------------------------------------------------------------------------------- /bin/docgen: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | hpack examples 6 | hpack docs 7 | cabal run docgen 8 | 9 | cd /tmp/hyperbole 10 | cabal haddock 11 | 12 | -------------------------------------------------------------------------------- /bin/release: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | 4 | # Make sure everything is working 5 | hpack 6 | cabal test 7 | 8 | 9 | # Compile the JS client 10 | cd client 11 | npm install 12 | npx webpack --mode=production 13 | cd .. 14 | 15 | 16 | # Compile the package 17 | cabal sdist 18 | 19 | # NEXT: Update branch release tags and push 20 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | -- bust ci cache 3 2 | tests: True 3 | multi-repl: True 4 | packages: 5 | . 6 | ./examples/ 7 | ./docs/ 8 | ../atomic-css/ 9 | -- temporary until https://github.com/seanhess/hyperbole/issues/76 is resolved 10 | -- https://hackage.haskell.org/package/web-view-0.7.0/candidate/web-view-0.7.0.tar.gz 11 | 12 | 13 | -- source-repository-package 14 | -- type: git 15 | -- location: https://github.com/seanhess/atomic-css.git 16 | -- tag: c4152e5d32ae7c109876c25a3f8563a3983bdf1a 17 | -------------------------------------------------------------------------------- /client/declarations.d.ts: -------------------------------------------------------------------------------- 1 | declare module 'omdomdom/lib/omdomdom.es.js' { 2 | export function create(node: any, ...args: any[]): any; 3 | export function patch(template: any, vNode: any, rootNode?: any): void; 4 | export function render(vNode: any, root: any): void; 5 | } 6 | 7 | -------------------------------------------------------------------------------- /client/dist/action.d.ts: -------------------------------------------------------------------------------- 1 | export declare function actionUrl(id: ViewId, action: string): URL; 2 | export declare function toSearch(form?: FormData): URLSearchParams | undefined; 3 | export declare function actionMessage(id: ViewId, action: string, form?: FormData): ActionMessage; 4 | export type ActionMessage = { 5 | id: ViewId; 6 | url: URL; 7 | form: URLSearchParams | undefined; 8 | }; 9 | export type ViewId = string; 10 | export declare function encodedTextInput(action: string, value: string): string; 11 | export declare function encodedJSONInput(action: string, value: string): string; 12 | export type RequestId = string; 13 | export declare function requestId(): RequestId; 14 | -------------------------------------------------------------------------------- /client/dist/browser.d.ts: -------------------------------------------------------------------------------- 1 | export declare function setQuery(query: string): void; 2 | -------------------------------------------------------------------------------- /client/dist/events.d.ts: -------------------------------------------------------------------------------- 1 | export type UrlFragment = string; 2 | export declare function listenKeydown(cb: (target: HTMLElement, action: string) => void): void; 3 | export declare function listenKeyup(cb: (target: HTMLElement, action: string) => void): void; 4 | export declare function listenKeyEvent(event: string, cb: (target: HTMLElement, action: string) => void): void; 5 | export declare function listenBubblingEvent(event: string, cb: (target: HTMLElement, action: string) => void): void; 6 | export declare function listenClick(cb: (target: HTMLElement, action: string) => void): void; 7 | export declare function listenDblClick(cb: (target: HTMLElement, action: string) => void): void; 8 | export declare function listenTopLevel(cb: (target: HTMLElement, action: string) => void): void; 9 | export declare function listenLoad(node: HTMLElement): void; 10 | export declare function listenMouseEnter(node: HTMLElement): void; 11 | export declare function listenMouseLeave(node: HTMLElement): void; 12 | export declare function listenChange(cb: (target: HTMLElement, action: string) => void): void; 13 | export declare function listenInput(cb: (target: HTMLElement, action: string) => void): void; 14 | export declare function listenFormSubmit(cb: (target: HTMLElement, action: string, form: FormData) => void): void; 15 | -------------------------------------------------------------------------------- /client/dist/http.d.ts: -------------------------------------------------------------------------------- 1 | import { ActionMessage, RequestId } from './action'; 2 | import { Response } from "./response"; 3 | export declare function sendActionHttp(reqId: RequestId, msg: ActionMessage): Promise; 4 | -------------------------------------------------------------------------------- /client/dist/index.d.ts: -------------------------------------------------------------------------------- 1 | declare global { 2 | interface Window { 3 | Hyperbole?: HyperboleAPI; 4 | } 5 | } 6 | export interface HyperboleAPI { 7 | runAction(target: HTMLElement, action: string, form?: FormData): Promise; 8 | action(con: string, ...params: any[]): string; 9 | hyperView(viewId: ViewId): HyperView | undefined; 10 | } 11 | export interface HyperView extends HTMLElement { 12 | runAction(target: HTMLElement, action: string, form?: FormData): Promise; 13 | } 14 | export type ViewId = string; 15 | -------------------------------------------------------------------------------- /client/dist/lib.d.ts: -------------------------------------------------------------------------------- 1 | export declare function takeWhileMap(pred: (val: T) => A | undefined, lines: T[]): A[]; 2 | export declare function dropWhile(pred: (val: T) => A | undefined, lines: T[]): T[]; 3 | -------------------------------------------------------------------------------- /client/dist/response.d.ts: -------------------------------------------------------------------------------- 1 | export type Response = { 2 | requestId: string; 3 | location?: string; 4 | query?: string; 5 | body: ResponseBody; 6 | }; 7 | export type ResponseBody = string; 8 | export declare function parseResponse(res: ResponseBody): LiveUpdate; 9 | export type LiveUpdate = { 10 | content: HTMLElement; 11 | css: HTMLStyleElement | null; 12 | }; 13 | export declare function fetchError(msg: string): Error; 14 | -------------------------------------------------------------------------------- /client/dist/sockets.d.ts: -------------------------------------------------------------------------------- 1 | import { ActionMessage, ViewId, RequestId } from './action'; 2 | import { Response, ResponseBody } from "./response"; 3 | export declare class SocketConnection { 4 | socket: WebSocket; 5 | hasEverConnected: Boolean; 6 | isConnected: Boolean; 7 | reconnectDelay: number; 8 | constructor(); 9 | connect(addr?: string): void; 10 | sendAction(reqId: RequestId, action: ActionMessage): Promise; 11 | fetch(reqId: RequestId, id: ViewId, msg: string): Promise; 12 | private sendMessage; 13 | private waitMessage; 14 | disconnect(): void; 15 | } 16 | type SocketResponse = { 17 | metadata: Metadata; 18 | body: ResponseBody; 19 | }; 20 | type Metadata = { 21 | viewId?: ViewId; 22 | cookies: string[]; 23 | redirect?: string; 24 | error?: string; 25 | query?: string; 26 | requestId?: string; 27 | }; 28 | export {}; 29 | -------------------------------------------------------------------------------- /client/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "web-ui", 3 | "version": "0.4.4b", 4 | "description": "Development -----------", 5 | "main": "index.js", 6 | "directories": { 7 | "client": "client" 8 | }, 9 | "scripts": { 10 | "build": "npx webpack" 11 | }, 12 | "author": "", 13 | "license": "ISC", 14 | "devDependencies": { 15 | "ts-loader": "^9.4.1", 16 | "typescript": "^4.8.3", 17 | "uglify": "^0.1.5", 18 | "webpack": "^5.88.2", 19 | "webpack-cli": "^4.10.0" 20 | }, 21 | "dependencies": { 22 | "omdomdom": "^0.3.2", 23 | "debounce": "^2.2.0" 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /client/src/action.ts: -------------------------------------------------------------------------------- 1 | export function actionUrl(id: ViewId, action: string): URL { 2 | let url = new URL(window.location.href) 3 | url.searchParams.append("hyp-id", id) 4 | url.searchParams.append("hyp-action", action) 5 | return url 6 | } 7 | 8 | export function toSearch(form?: FormData): URLSearchParams | undefined { 9 | if (!form) return undefined 10 | 11 | const params = new URLSearchParams() 12 | 13 | form.forEach((value, key) => { 14 | params.append(key, value as string) 15 | }) 16 | 17 | return params 18 | } 19 | 20 | export function actionMessage(id: ViewId, action: string, form?: FormData): ActionMessage { 21 | let url = actionUrl(id, action) 22 | return { id, url, form: toSearch(form) } 23 | } 24 | 25 | export type ActionMessage = { 26 | id: ViewId 27 | url: URL 28 | form: URLSearchParams | undefined 29 | } 30 | 31 | export type ViewId = string 32 | 33 | 34 | export function encodedTextInput(action: string, value: string): string { 35 | return action + ' "' + sanitizeInput(value) + '"' 36 | } 37 | 38 | export function encodedJSONInput(action: string, value: string): string { 39 | return action + " " + value 40 | } 41 | 42 | 43 | // WARNING: security flaw, unescaped output. no closing quotes allowed? 44 | function sanitizeInput(input: string): string { 45 | // replace any escape characters: '/' etc 46 | // replace any quotes with escaped quotes 47 | return input.replace(/\\/g, "\\\\").replace(/"/g, '\\"') 48 | } 49 | 50 | 51 | export type RequestId = string 52 | 53 | export function requestId(): RequestId { 54 | return Math.random().toString(36).substring(2, 8) 55 | } 56 | -------------------------------------------------------------------------------- /client/src/browser.ts: -------------------------------------------------------------------------------- 1 | 2 | export function setQuery(query: string) { 3 | if (query != currentQuery()) { 4 | if (query != "") query = "?" + query 5 | let url = location.pathname + query 6 | console.log("history.replaceState(", url, ")") 7 | window.history.replaceState({}, "", url) 8 | } 9 | } 10 | 11 | function currentQuery(): string { 12 | const query = window.location.search; 13 | return query.startsWith('?') ? query.substring(1) : query; 14 | } 15 | -------------------------------------------------------------------------------- /client/src/http.ts: -------------------------------------------------------------------------------- 1 | import { ActionMessage, RequestId } from './action' 2 | import { Response, fetchError } from "./response" 3 | 4 | export async function sendActionHttp(reqId: RequestId, msg: ActionMessage): Promise { 5 | // console.log("HTTP sendAction", msg.url.toString()) 6 | let res = await fetch(msg.url, { 7 | method: "POST", 8 | headers: 9 | { 10 | 'Accept': 'text/html', 11 | 'Content-Type': 'application/x-www-form-urlencoded', 12 | 'Request-Id': reqId 13 | }, 14 | body: msg.form, 15 | // we never want this to be redirected 16 | redirect: "manual" 17 | }) 18 | 19 | let body = await res.text() 20 | 21 | if (!res.ok) { 22 | throw fetchError(body) 23 | } 24 | 25 | let response: Response = { 26 | requestId: res.headers.get("Request-Id"), 27 | location: res.headers.get("location"), 28 | query: res.headers.get("set-query"), 29 | body 30 | } 31 | 32 | return response 33 | } 34 | 35 | 36 | -------------------------------------------------------------------------------- /client/src/lib.ts: -------------------------------------------------------------------------------- 1 | 2 | 3 | export function takeWhileMap(pred:(val:T) => A | undefined, lines:T[]):A[] { 4 | var output = [] 5 | for (var line of lines) { 6 | let a = pred(line) 7 | if (a) 8 | output.push(a) 9 | else 10 | break; 11 | } 12 | 13 | return output 14 | } 15 | 16 | export function dropWhile(pred:(val:T) => A | undefined, lines:T[]):T[] { 17 | let index = 0; 18 | while (index < lines.length && pred(lines[index])) { 19 | index++; 20 | } 21 | return lines.slice(index); 22 | } 23 | -------------------------------------------------------------------------------- /client/src/response.ts: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | export type Response = { 6 | requestId: string 7 | location?: string 8 | query?: string 9 | body: ResponseBody 10 | } 11 | 12 | export type ResponseBody = string 13 | 14 | export function parseResponse(res: ResponseBody): LiveUpdate { 15 | const parser = new DOMParser() 16 | const doc = parser.parseFromString(res, 'text/html') 17 | const css = doc.querySelector("style") as HTMLStyleElement 18 | const content = doc.querySelector("div") as HTMLElement 19 | 20 | return { 21 | content: content, 22 | css: css 23 | } 24 | } 25 | 26 | export type LiveUpdate = { 27 | content: HTMLElement 28 | css: HTMLStyleElement | null 29 | } 30 | 31 | 32 | export function fetchError(msg: string): Error { 33 | let err = new Error() 34 | err.name = "Fetch Error" 35 | err.message = msg 36 | return err 37 | } 38 | -------------------------------------------------------------------------------- /client/src/sockets.ts: -------------------------------------------------------------------------------- 1 | import { ActionMessage, ViewId, RequestId } from './action' 2 | import { takeWhileMap, dropWhile } from "./lib" 3 | import { Response, ResponseBody, fetchError } from "./response" 4 | 5 | const protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:'; 6 | const defaultAddress = `${protocol}//${window.location.host}${window.location.pathname}` 7 | 8 | 9 | 10 | export class SocketConnection { 11 | 12 | 13 | socket: WebSocket 14 | 15 | hasEverConnected: Boolean 16 | isConnected: Boolean 17 | reconnectDelay: number = 0 18 | 19 | constructor() { } 20 | 21 | // we need to faithfully transmit the 22 | connect(addr = defaultAddress) { 23 | const sock = new WebSocket(addr) 24 | this.socket = sock 25 | 26 | function onConnectError(ev: Event) { 27 | console.log("Connection Error", ev) 28 | } 29 | 30 | sock.addEventListener('error', onConnectError) 31 | 32 | sock.addEventListener('open', (event) => { 33 | console.log("Opened", event) 34 | this.isConnected = true 35 | this.hasEverConnected = true 36 | this.reconnectDelay = 0 37 | this.socket.removeEventListener('error', onConnectError) 38 | }) 39 | 40 | // TODO: Don't reconnet if the socket server is OFF, only if we've successfully connected once 41 | sock.addEventListener('close', _ => { 42 | this.isConnected = false 43 | console.log("Closed") 44 | 45 | // attempt to reconnect in 1s 46 | if (this.hasEverConnected) { 47 | this.reconnectDelay += 1000 48 | console.log("Reconnecting in " + (this.reconnectDelay / 1000) + "s") 49 | setTimeout(() => this.connect(addr), this.reconnectDelay) 50 | } 51 | }) 52 | } 53 | 54 | async sendAction(reqId: RequestId, action: ActionMessage): Promise { 55 | // console.log("SOCKET sendAction", action) 56 | let msg = [action.url.pathname + action.url.search 57 | , "Host: " + window.location.host 58 | , "Cookie: " + document.cookie 59 | , "Request-Id: " + reqId 60 | , action.form 61 | ].join("\n") 62 | let { metadata, body } = await this.fetch(reqId, action.id, msg) 63 | 64 | return { 65 | requestId: metadata.requestId, 66 | location: metadata.redirect, 67 | query: metadata.query, 68 | body 69 | } 70 | 71 | } 72 | 73 | async fetch(reqId: RequestId, id: ViewId, msg: string): Promise { 74 | this.sendMessage(msg) 75 | let res = await this.waitMessage(reqId, id) 76 | return res 77 | } 78 | 79 | private sendMessage(msg: string) { 80 | this.socket.send(msg) 81 | } 82 | 83 | private async waitMessage(reqId: RequestId, id: ViewId): Promise { 84 | return new Promise((resolve, reject) => { 85 | const onMessage = (event: MessageEvent) => { 86 | let data = event.data 87 | 88 | let { metadata, body } = parseMetadataResponse(data) 89 | 90 | if (!metadata.requestId) { 91 | console.error("Missing RequestId!", metadata, event.data) 92 | return 93 | } 94 | 95 | if (metadata.requestId != reqId) { 96 | // skip, it's not us! 97 | return 98 | } 99 | 100 | if (metadata.error) { 101 | throw fetchError(metadata.error) 102 | } 103 | 104 | // We have found our message. Remove the listener 105 | this.socket.removeEventListener('message', onMessage) 106 | 107 | // set the cookies. These happen automatically in http 108 | metadata.cookies.forEach(cookie => { 109 | document.cookie = cookie 110 | }) 111 | 112 | resolve({ metadata, body }) 113 | } 114 | 115 | this.socket.addEventListener('message', onMessage) 116 | this.socket.addEventListener('error', reject) 117 | }) 118 | } 119 | 120 | disconnect() { 121 | this.socket.close() 122 | } 123 | } 124 | 125 | // function socketError(inp: string): Error { 126 | // let error = new Error() 127 | // error.name = inp.substring(0, inp.indexOf(' ')); 128 | // error.message = inp.substring(inp.indexOf(' ') + 1); 129 | // return error 130 | // } 131 | 132 | 133 | 134 | 135 | 136 | 137 | type SocketResponse = { 138 | metadata: Metadata, 139 | body: ResponseBody 140 | } 141 | 142 | type Metadata = { 143 | viewId?: ViewId 144 | cookies: string[] 145 | redirect?: string 146 | error?: string 147 | query?: string 148 | requestId?: string 149 | } 150 | 151 | type Meta = { key: string, value: string } 152 | 153 | 154 | function parseMetadataResponse(ret: string): SocketResponse { 155 | let lines = ret.split("\n") 156 | let metas: Meta[] = takeWhileMap(parseMeta, lines) 157 | let rest = dropWhile(parseMeta, lines).join("\n") 158 | 159 | return { 160 | metadata: parseMetas(metas), 161 | body: rest 162 | } 163 | 164 | function parseMeta(line: string): Meta | undefined { 165 | let match = line.match(/^\|([A-Z\-]+)\|(.*)$/) 166 | if (match) { 167 | return { 168 | key: match[1], 169 | value: match[2] 170 | } 171 | } 172 | } 173 | } 174 | 175 | function parseMetas(meta: Meta[]): Metadata { 176 | 177 | let requestId = meta.find(m => m.key == "REQUEST-ID")?.value 178 | 179 | return { 180 | cookies: meta.filter(m => m.key == "COOKIE").map(m => m.value), 181 | redirect: meta.find(m => m.key == "REDIRECT")?.value, 182 | error: meta.find(m => m.key == "ERROR")?.value, 183 | viewId: meta.find(m => m.key == "VIEW-ID")?.value, 184 | query: meta.find(m => m.key == "QUERY")?.value, 185 | requestId 186 | } 187 | } 188 | 189 | -------------------------------------------------------------------------------- /client/tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compilerOptions": { 3 | "outDir": "./dist/", 4 | "sourceMap": true, 5 | "noImplicitAny": true, 6 | "module": "es6", 7 | "target": "es5", 8 | "allowJs": true, 9 | "moduleResolution": "node", 10 | "declaration": true 11 | /*"declarationMap": true*/ 12 | }, 13 | "include": [ 14 | "./src/**/*", 15 | "./declarations.d.ts" 16 | ] 17 | } 18 | -------------------------------------------------------------------------------- /client/webpack.config.js: -------------------------------------------------------------------------------- 1 | const path = require('path'); 2 | // var PACKAGE = require('./package.json'); 3 | // var version = PACKAGE.version; 4 | 5 | module.exports = { 6 | entry: "./src/index.ts", 7 | mode: "development", 8 | target: "web", 9 | devtool: "source-map", 10 | mode: "production", 11 | module: { 12 | rules: [ 13 | { 14 | test: /\.tsx?$/, 15 | use: 'ts-loader', 16 | exclude: /node_modules/, 17 | }, 18 | ], 19 | }, 20 | resolve: { 21 | mainFields: ['browser', 'module', 'main'], 22 | extensions: ['.tsx', '.ts', '.js'], 23 | }, 24 | 25 | output: { 26 | // filename: `hyperbole-${version}.js`, 27 | filename: "hyperbole.js", 28 | path: path.resolve(__dirname, 'dist'), 29 | }, 30 | 31 | // devServer: { 32 | // contentBase: path.join(__dirname, 'dist'), 33 | // compress: true, 34 | // port: 9000, 35 | // }, 36 | } 37 | 38 | -------------------------------------------------------------------------------- /docs/docgen.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: docgen 8 | version: 0.4.3 9 | synopsis: Interactive HTML apps using type-safe serverside Haskell 10 | description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView 11 | category: Web, Network 12 | homepage: https://github.com/seanhess/hyperbole 13 | bug-reports: https://github.com/seanhess/hyperbole/issues 14 | author: Sean Hess 15 | maintainer: seanhess@gmail.com 16 | license: BSD-3-Clause 17 | build-type: Simple 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/seanhess/hyperbole 22 | 23 | executable docgen 24 | main-is: Main.hs 25 | other-modules: 26 | Paths_docgen 27 | autogen-modules: 28 | Paths_docgen 29 | hs-source-dirs: 30 | ./ 31 | default-extensions: 32 | OverloadedStrings 33 | OverloadedRecordDot 34 | DuplicateRecordFields 35 | NoFieldSelectors 36 | TypeFamilies 37 | DataKinds 38 | DerivingStrategies 39 | DeriveAnyClass 40 | ghc-options: -Wall -fdefer-typed-holes 41 | build-depends: 42 | base 43 | , directory 44 | , filepath 45 | , string-conversions 46 | , text 47 | default-language: GHC2021 48 | -------------------------------------------------------------------------------- /docs/javascript_api.md: -------------------------------------------------------------------------------- 1 | Javascript API 2 | ----------------- 3 | 4 | Requirements 5 | 6 | 1. Call runAction() - you ought to be able to tell the server to run a particular action, and allow the normal update cycle to happen 7 | 8 | 9 | ### Javascript Components 10 | 1. data-xxxx updates 11 | 2. trigger events to update - the server controls how to serialize this 12 | 13 | 14 | 15 | https://github.com/seanhess/hyperbole/issues/25 16 | - wants to be able to trigger an action, and run javascript during it... 17 | - but 18 | 19 | 20 | 21 | 22 | Phoenix LiveView MouseOver / MouseEnter: 23 | ---------------------------------------- 24 | 25 | import { Socket } from "phoenix"; 26 | import { LiveSocket } from "phoenix_live_view"; 27 | 28 | // Register hooks here 29 | let Hooks = {}; 30 | Hooks.HoverHook = { 31 | mounted() { 32 | console.log("Hook mounted!"); 33 | this.el.addEventListener("mouseenter", () => { 34 | this.pushEvent("mouse_enter", { id: this.el.id }); 35 | }); 36 | this.el.addEventListener("mouseleave", () => { 37 | this.pushEvent("mouse_leave", { id: this.el.id }); 38 | }); 39 | } 40 | }; 41 | 42 | // Initialize LiveSocket with hooks 43 | let liveSocket = new LiveSocket("/live", Socket, { 44 | hooks: Hooks, // Hooks get passed here 45 | }); 46 | 47 | // Connect LiveSocket 48 | liveSocket.connect(); 49 | 50 | 51 | Phoenix LiveView Push Event to Client 52 | -------------------------------------- 53 | 54 | def handle_event("firebase_login", %{"token" => token}, socket) do 55 | case UserAuth.verify_firebase_token(token) do 56 | {:ok, user_info} -> 57 | socket = 58 | socket 59 | |> assign(:current_user, user_info) # Triggers re-render 60 | |> push_event("auth_success", %{email: user_info.email}) # Sends data to JS 61 | 62 | {:noreply, socket} 63 | end 64 | end 65 | 66 | 67 | Hooks.FirebaseAuth = { 68 | mounted() { 69 | this.handleEvent("auth_success", ({ email }) => { 70 | console.log("Authenticated as:", email); 71 | document.getElementById("user-info").innerText = `Logged in as ${email}`; 72 | }); 73 | 74 | this.handleEvent("auth_failed", () => { 75 | console.log("Authentication failed."); 76 | document.getElementById("user-info").innerText = "Login failed."; 77 | }); 78 | } 79 | }; 80 | -------------------------------------------------------------------------------- /docs/package.yaml: -------------------------------------------------------------------------------- 1 | name: docgen 2 | version: 0.4.3 3 | synopsis: Interactive HTML apps using type-safe serverside Haskell 4 | homepage: https://github.com/seanhess/hyperbole 5 | github: seanhess/hyperbole 6 | license: BSD-3-Clause 7 | author: Sean Hess 8 | maintainer: seanhess@gmail.com 9 | category: Web, Network 10 | description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView 11 | 12 | language: GHC2021 13 | 14 | ghc-options: 15 | - -Wall 16 | - -fdefer-typed-holes 17 | 18 | default-extensions: 19 | - OverloadedStrings 20 | - OverloadedRecordDot 21 | - DuplicateRecordFields 22 | - NoFieldSelectors 23 | - TypeFamilies 24 | - DataKinds 25 | - DerivingStrategies 26 | - DeriveAnyClass 27 | 28 | dependencies: 29 | - base 30 | - directory 31 | - filepath 32 | - text 33 | - string-conversions 34 | 35 | executables: 36 | docgen: 37 | main: Main.hs 38 | source-dirs: 39 | - . 40 | dependencies: [] 41 | 42 | -------------------------------------------------------------------------------- /examples/.dockerignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | .git 3 | -------------------------------------------------------------------------------- /examples/Example/AppRoute.hs: -------------------------------------------------------------------------------- 1 | module Example.AppRoute where 2 | 3 | import Data.Text (Text, unpack) 4 | import Example.Effects.Users (UserId) 5 | import Text.Read (readMaybe) 6 | import Web.Hyperbole 7 | 8 | data AppRoute 9 | = Main 10 | | Intro 11 | | Simple 12 | | Hello Hello 13 | | Contacts ContactRoute 14 | | AtomicCSS 15 | | State StateRoute 16 | | Counter 17 | | Forms 18 | | Requests 19 | | Concurrency 20 | | Data DataRoute 21 | | Todos 22 | | Errors 23 | | Javascript 24 | deriving (Eq, Generic, Show) 25 | instance Route AppRoute where 26 | baseRoute = Just Main 27 | 28 | data DataRoute 29 | = DataLists 30 | | SortableTable 31 | | Autocomplete 32 | | Filter 33 | deriving (Eq, Generic, Show) 34 | instance Route DataRoute where 35 | baseRoute = Just DataLists 36 | 37 | data StateRoute 38 | = StateRoot 39 | | Effects 40 | | Query 41 | | Sessions 42 | deriving (Eq, Generic, Show) 43 | instance Route StateRoute where 44 | baseRoute = Just StateRoot 45 | 46 | data ContactRoute 47 | = ContactsAll 48 | | Contact UserId 49 | deriving (Eq, Generic, Show) 50 | instance Route ContactRoute where 51 | baseRoute = Just ContactsAll 52 | 53 | matchRoute [] = pure ContactsAll 54 | matchRoute [""] = pure ContactsAll 55 | matchRoute [contactId] = do 56 | cid <- readMaybe $ unpack contactId 57 | pure $ Contact cid 58 | matchRoute _ = Nothing 59 | 60 | routePath (Contact uid) = routePath uid 61 | routePath ContactsAll = [] 62 | 63 | data Hello 64 | = Greet Text 65 | | Redirected 66 | deriving (Eq, Generic, Route, Show) 67 | -------------------------------------------------------------------------------- /examples/Example/Cache.hs: -------------------------------------------------------------------------------- 1 | module Example.Cache where 2 | 3 | import Network.HTTP.Types (Header) 4 | import Network.Wai.Middleware.Static 5 | 6 | clientCache :: IO Options 7 | clientCache = do 8 | container <- initCaching PublicStaticCaching 9 | -- container <- initCaching (CustomCaching customCache) 10 | pure $ defaultOptions{cacheContainer = container} 11 | 12 | -- for testing if caching is working 13 | customCache :: FileMeta -> [Header] 14 | customCache (FileMeta lm etag _file) = do 15 | [("Cache-Control", "no-transform,public,max-age=30"), ("Last-Modified", lm), ("Etag", etag)] 16 | -------------------------------------------------------------------------------- /examples/Example/Colors.hs: -------------------------------------------------------------------------------- 1 | module Example.Colors where 2 | 3 | import Web.Atomic.CSS 4 | import Web.Hyperbole 5 | 6 | data AppColor 7 | = White 8 | | Light 9 | | GrayLight 10 | | GrayDark 11 | | Dark 12 | | DarkHighlight 13 | | Success 14 | | Danger 15 | | Warning 16 | | Primary 17 | | PrimaryLight 18 | | Secondary 19 | | SecondaryLight 20 | deriving (Show, Read, Eq, Generic, ToJSON, FromJSON, ToParam, FromParam) 21 | 22 | instance Default AppColor where 23 | def = White 24 | 25 | instance ToColor AppColor where 26 | colorValue White = "#FFF" 27 | colorValue Light = "#F2F2F3" 28 | colorValue GrayLight = "#E3E5E9" 29 | colorValue GrayDark = "#2С3С44" 30 | -- colorValue Dark = "#2E3842" -- "#232C41" 31 | colorValue Dark = "#121726" -- "#232C41" 32 | colorValue DarkHighlight = "#343945" -- "#232C41" 33 | colorValue Primary = "#4171b7" 34 | colorValue PrimaryLight = "#6D9BD3" 35 | colorValue Secondary = "#5D5A5C" 36 | colorValue SecondaryLight = "#9D999C" 37 | -- colorValue Success = "67C837" 38 | colorValue Success = "#149e5a" 39 | colorValue Danger = "#ef1509" 40 | colorValue Warning = "#e1c915" 41 | -------------------------------------------------------------------------------- /examples/Example/Data/ProgrammingLanguage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | module Example.Data.ProgrammingLanguage where 4 | 5 | import Data.Text (Text, isInfixOf, toLower) 6 | import Web.Hyperbole 7 | 8 | data ProgrammingLanguage = ProgrammingLanguage 9 | { family :: LanguageFamily 10 | , name :: Text 11 | , features :: [TypeFeature] 12 | , description :: Text 13 | } 14 | deriving (Generic, ToJSON, FromJSON) 15 | instance Eq ProgrammingLanguage where 16 | p1 == p2 = p1.name == p2.name 17 | 18 | data LanguageFamily 19 | = Functional 20 | | ObjectOriented 21 | deriving (Eq, Show, Ord, Generic, ToJSON, FromJSON, FromParam, ToParam) 22 | 23 | data TypeFeature 24 | = Dynamic 25 | | Typed 26 | | Generics 27 | | TypeClasses 28 | | TypeFamilies 29 | deriving (Eq, Show, Generic, ToJSON, FromJSON, ToParam, FromParam) 30 | 31 | isMatchLanguage :: Text -> ProgrammingLanguage -> Bool 32 | isMatchLanguage term p = 33 | isInfixOf (toLower term) . toLower $ p.name 34 | 35 | allLanguages :: [ProgrammingLanguage] 36 | allLanguages = 37 | [ ProgrammingLanguage ObjectOriented "JavaScript" [Dynamic] "A versatile scripting language mainly used for web development." 38 | , ProgrammingLanguage ObjectOriented "Java" [Typed] "A robust, platform-independent language commonly used for enterprise applications." 39 | , ProgrammingLanguage ObjectOriented "TypeScript" [Typed, Generics] "A superset of JavaScript that adds static typing." 40 | , ProgrammingLanguage ObjectOriented "Python" [Dynamic] "A beginner-friendly language with a wide range of applications, from web to data science." 41 | , ProgrammingLanguage ObjectOriented "PHP" [Dynamic] "A server-side scripting language primarily used for web development." 42 | , ProgrammingLanguage ObjectOriented "Go" [Typed, Generics] "A statically typed, compiled language designed for simplicity and efficiency." 43 | , ProgrammingLanguage ObjectOriented "C++" [Typed] "A powerful language for system programming, game development, and high-performance applications." 44 | , ProgrammingLanguage ObjectOriented "C#" [Typed, Generics] "A language developed by Microsoft, widely used for developing Windows and web applications." 45 | , ProgrammingLanguage ObjectOriented "Objective-C" [Typed] "A language used primarily for macOS and iOS application development before Swift." 46 | , ProgrammingLanguage ObjectOriented "Rust" [Typed, Generics, TypeClasses, TypeFamilies] "A memory-safe language focused on performance and reliability." 47 | , ProgrammingLanguage ObjectOriented "Ruby" [Dynamic] "A dynamic language known for its simplicity and used in web frameworks like Ruby on Rails." 48 | , ProgrammingLanguage ObjectOriented "Swift" [Typed, Generics] "A modern language for iOS and macOS application development." 49 | , ProgrammingLanguage Functional "Haskell" [Typed, Generics, TypeClasses, TypeFamilies] "An elegant functional language for those with excellent taste." 50 | , ProgrammingLanguage Functional "Elm" [Typed, Generics] "A functional language for building reliable web front-end applications." 51 | , ProgrammingLanguage Functional "Scheme" [Dynamic] "A minimalist, functional dialect of Lisp." 52 | ] 53 | -------------------------------------------------------------------------------- /examples/Example/Docs/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Example.Docs.App where 4 | 5 | import Data.ByteString (ByteString) 6 | import Data.String.Interpolate (i) 7 | import Effectful.Dispatch.Dynamic (send) 8 | import Example.Effects.Users (User, Users (..)) 9 | 10 | import Example.Docs.Page.Messages qualified as Messages 11 | import Example.Docs.Page.Users qualified as Users 12 | import Web.Hyperbole 13 | 14 | customDocument :: ByteString -> ByteString 15 | customDocument content = 16 | [i| 17 | 18 | My Website 19 | 20 | 21 | 22 | 23 | #{content} 24 | |] 25 | 26 | router :: (Hyperbole :> es) => AppRoute -> Eff es Response 27 | router Messages = runPage Messages.page 28 | router (User cid) = runPage $ Users.page cid 29 | router Main = do 30 | view $ do 31 | el "click a link below to visit a page" 32 | route Messages "Messages" 33 | route (User 1) "User 1" 34 | route (User 2) "User 2" 35 | 36 | type UserId = Int 37 | 38 | data AppRoute 39 | = Main 40 | | Messages 41 | | User UserId 42 | deriving (Eq, Generic) 43 | 44 | instance Route AppRoute where 45 | baseRoute = Just Main 46 | 47 | findUser :: (Hyperbole :> es, Users :> es) => Int -> Eff es User 48 | findUser uid = do 49 | mu <- send (LoadUser uid) 50 | maybe notFound pure mu 51 | 52 | userPage :: (Hyperbole :> es, Users :> es) => Eff es (Page '[]) 53 | userPage = do 54 | user <- findUser 100 55 | 56 | -- skipped if user not found 57 | pure $ userView user 58 | 59 | userView :: User -> View c () 60 | userView _ = none 61 | -------------------------------------------------------------------------------- /examples/Example/Docs/BasicPage.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | module Example.Docs.BasicPage where 4 | 5 | import Data.Text (Text) 6 | import Web.Atomic.CSS 7 | import Web.Hyperbole 8 | 9 | main :: IO () 10 | main = do 11 | run 3000 $ do 12 | liveApp (basicDocument "Example") (runPage page) 13 | 14 | page :: Eff es (Page '[]) 15 | page = do 16 | pure $ do 17 | col ~ pad 10 $ do 18 | el ~ bold $ "Hello World" 19 | 20 | messageView :: Text -> View context () 21 | messageView msg = 22 | el ~ bold $ (text msg) 23 | 24 | helloWorld :: View context () 25 | helloWorld = 26 | el ~ bold $ "Hello World" 27 | 28 | page' :: Eff es (Page '[]) 29 | page' = do 30 | pure $ do 31 | col ~ pad 10 $ do 32 | messageView "Hello World" 33 | -------------------------------------------------------------------------------- /examples/Example/Docs/Component.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Component where 2 | 3 | import Data.Text (Text) 4 | import Example.Colors 5 | import Web.Atomic.CSS 6 | import Web.Hyperbole 7 | 8 | styledButton :: (ViewAction (Action id)) => Action id -> Text -> View id () 9 | styledButton clickAction lbl = do 10 | button clickAction ~ btn $ text lbl 11 | where 12 | btn = pad 10 . bg Primary . hover (bg PrimaryLight) . rounded 5 13 | -------------------------------------------------------------------------------- /examples/Example/Docs/Encoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Docs.Encoding where 4 | 5 | import Data.Text (Text) 6 | import Web.Hyperbole 7 | 8 | data Filters = Filters 9 | { active :: Bool 10 | , term :: Text 11 | } 12 | deriving (Generic, Eq, FromQuery, ToQuery) 13 | -------------------------------------------------------------------------------- /examples/Example/Docs/Interactive.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Interactive where 2 | 3 | import Data.Text (Text) 4 | import Web.Atomic.CSS 5 | import Web.Hyperbole 6 | 7 | page :: Eff es (Page '[Message]) 8 | page = do 9 | pure $ do 10 | col ~ pad 10 . gap 10 $ do 11 | el ~ bold . fontSize 24 $ "Unchanging Header" 12 | hyper Message $ messageView "Hello World" 13 | 14 | messageView :: Text -> View Message () 15 | messageView msg = do 16 | el ~ bold $ text msg 17 | button (SetMessage "Goodbye") ~ border 1 $ "Say Goodbye" 18 | 19 | data Message = Message 20 | deriving (Generic, ViewId) 21 | 22 | instance HyperView Message es where 23 | data Action Message 24 | = SetMessage Text 25 | deriving (Generic, ViewAction) 26 | 27 | update (SetMessage msg) = 28 | pure $ messageView msg 29 | -------------------------------------------------------------------------------- /examples/Example/Docs/MultiCopies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Example.Docs.MultiCopies where 6 | 7 | import Data.Text (Text) 8 | import Web.Atomic.CSS 9 | import Web.Hyperbole 10 | 11 | page :: Eff es (Page '[Message]) 12 | page = do 13 | pure $ do 14 | hyper Message1 $ messageView "Hello" 15 | hyper Message2 $ messageView "World!" 16 | 17 | data Message = Message1 | Message2 18 | deriving (Generic, ViewId) 19 | 20 | instance HyperView Message es where 21 | data Action Message = Louder Text 22 | deriving (Generic, ViewAction) 23 | 24 | update (Louder m) = do 25 | let new = m <> "!" 26 | pure $ messageView new 27 | 28 | messageView :: Text -> View Message () 29 | messageView m = do 30 | row ~ gap 10 $ do 31 | button (Louder m) ~ border 1 . pad 5 $ "Louder" 32 | el ~ pad 5 $ text m 33 | -------------------------------------------------------------------------------- /examples/Example/Docs/MultiPage.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 2 | 3 | module Example.Docs.MultiPage where 4 | 5 | import Example.Docs.Interactive qualified as Message 6 | import Example.Docs.MultiView qualified as Counter 7 | import Web.Atomic.CSS 8 | import Web.Hyperbole 9 | 10 | data AppRoute 11 | = Message -- /message 12 | | Counter -- /counter 13 | deriving (Generic, Eq, Route) 14 | 15 | main = do 16 | run 3000 $ do 17 | liveApp (basicDocument "Multiple Pages") (routeRequest router) 18 | where 19 | router Message = runPage Message.page 20 | router Counter = runPage Counter.page 21 | 22 | menu :: View c () 23 | menu = do 24 | route Message "Link to /message" 25 | route Counter "Link to /counter" 26 | 27 | exampleLayout :: View c () -> View c () 28 | exampleLayout content = do 29 | col ~ grow $ do 30 | el ~ border 1 $ "My Website Header" 31 | row $ do 32 | menu 33 | content 34 | 35 | examplePage :: Eff es (Page '[]) 36 | examplePage = do 37 | pure $ exampleLayout $ do 38 | el "page contents" 39 | -------------------------------------------------------------------------------- /examples/Example/Docs/MultiView.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Docs.MultiView where 4 | 5 | import Data.Text (pack) 6 | import Example.Docs.Interactive (Message (..), messageView) 7 | import Web.Atomic.CSS 8 | import Web.Hyperbole 9 | 10 | page :: Eff es (Page [Message, Count]) 11 | page = do 12 | pure $ do 13 | row $ do 14 | hyper Message $ messageView "Hello" 15 | hyper Count $ countView 0 16 | 17 | data Count = Count 18 | deriving (Generic, ViewId) 19 | 20 | instance HyperView Count es where 21 | data Action Count 22 | = Increment Int 23 | | Decrement Int 24 | deriving (Generic, ViewAction) 25 | 26 | update (Increment n) = do 27 | pure $ countView (n + 1) 28 | update (Decrement n) = do 29 | pure $ countView (n - 1) 30 | 31 | countView :: Int -> View Count () 32 | countView n = do 33 | el $ text $ pack $ show n 34 | button (Increment n) "Increment" ~ border 1 35 | button (Decrement n) "Decrement" ~ border 1 36 | -------------------------------------------------------------------------------- /examples/Example/Docs/Nested.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Nested where 2 | 3 | import Control.Monad (forM_) 4 | import Data.Text (Text) 5 | import Web.Hyperbole 6 | 7 | page :: (Hyperbole :> es) => Eff es (Page '[AllTodos, TodoItem]) 8 | page = do 9 | pure $ do 10 | hyper AllTodos $ todosView allTodos 11 | where 12 | allTodos = [todo "One", todo "Two", todo " Three"] 13 | todo t = Todo t False 14 | 15 | data Todo = Todo 16 | { task :: Text 17 | , completed :: Bool 18 | } 19 | deriving (Show, Read, Eq, Generic, ToJSON, FromJSON) 20 | 21 | data AllTodos = AllTodos 22 | deriving (Generic, ViewId) 23 | 24 | instance HyperView AllTodos es where 25 | type Require AllTodos = '[TodoItem] 26 | 27 | data Action AllTodos 28 | = AddTodo Text [Todo] 29 | deriving (Generic, ViewAction) 30 | 31 | update (AddTodo txt todos) = do 32 | let new = Todo txt False : todos 33 | pure $ todosView new 34 | 35 | todosView :: [Todo] -> View AllTodos () 36 | todosView todos = do 37 | forM_ todos $ \todo -> do 38 | hyper TodoItem $ todoView todo 39 | button (AddTodo "Shopping" todos) "Add Shopping" 40 | 41 | data TodoItem = TodoItem 42 | deriving (Generic, ViewId) 43 | 44 | instance HyperView TodoItem es where 45 | data Action TodoItem 46 | = Complete Todo 47 | deriving (Generic, ViewAction) 48 | 49 | update (Complete todo) = do 50 | let new = todo{completed = True} 51 | pure $ todoView new 52 | 53 | todoView :: Todo -> View TodoItem () 54 | todoView todo = do 55 | el (text todo.task) 56 | button (Complete todo) "Mark Completed" 57 | -------------------------------------------------------------------------------- /examples/Example/Docs/Page/Messages.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Page.Messages where 2 | 3 | import Web.Hyperbole 4 | 5 | page :: Eff es (Page '[]) 6 | page = pure $ el "Messages page" 7 | -------------------------------------------------------------------------------- /examples/Example/Docs/Page/Users.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Page.Users where 2 | 3 | import Web.Hyperbole 4 | 5 | page :: Int -> Eff es (Page '[]) 6 | page _ = pure $ el "User page" 7 | -------------------------------------------------------------------------------- /examples/Example/Docs/Params.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Params where 2 | 3 | import Data.Text (Text) 4 | import Web.Atomic.CSS 5 | import Web.Hyperbole 6 | 7 | data Filters = Filters 8 | { search :: Text 9 | } 10 | deriving (ToQuery, FromQuery, Generic) 11 | 12 | page :: (Hyperbole :> es) => Eff es (Page '[Todos]) 13 | page = do 14 | filters <- query @Filters 15 | todos <- loadTodos filters 16 | pure $ do 17 | hyper Todos $ todosView todos 18 | 19 | data Todos = Todos 20 | deriving (Generic, ViewId) 21 | 22 | instance HyperView Todos es where 23 | data Action Todos 24 | = SetSearch Text 25 | deriving (Generic, ViewAction) 26 | 27 | update (SetSearch term) = do 28 | let filters = Filters term 29 | setQuery filters 30 | todos <- loadTodos filters 31 | pure $ todosView todos 32 | 33 | -- Fake User effect 34 | data Todo 35 | 36 | loadTodos :: Filters -> Eff es [Todo] 37 | loadTodos _ = pure [] 38 | 39 | -- Fake Todo View 40 | todosView :: [Todo] -> View Todos () 41 | todosView _ = none 42 | 43 | page' :: (Hyperbole :> es) => Eff es (Page '[Message]) 44 | page' = do 45 | msg <- param "message" 46 | pure $ do 47 | hyper Message $ messageView msg 48 | 49 | messageView :: Text -> View Message () 50 | messageView m = do 51 | el ~ bold $ text $ "Message: " <> m 52 | button (SetMessage "Goodbye") ~ border 1 $ "Say Goodbye" 53 | 54 | data Message = Message 55 | deriving (Generic, ViewId) 56 | 57 | instance HyperView Message es where 58 | data Action Message 59 | = SetMessage Text 60 | deriving (Generic, ViewAction) 61 | 62 | update (SetMessage msg) = do 63 | setParam "message" msg 64 | pure $ messageView msg 65 | -------------------------------------------------------------------------------- /examples/Example/Docs/Sessions.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.Sessions where 2 | 3 | import Web.Atomic.CSS 4 | import Web.Hyperbole 5 | 6 | data AppColor 7 | = White 8 | | Red 9 | | Green 10 | deriving (Show, Generic, ToJSON, FromJSON) 11 | 12 | instance ToColor AppColor where 13 | colorValue White = "#FFF" 14 | colorValue Red = "#F00" 15 | colorValue Green = "#0F0" 16 | 17 | data Preferences = Preferences 18 | { color :: AppColor 19 | } 20 | deriving (Generic, ToJSON, FromJSON, ToParam, FromParam, Session) 21 | instance Default Preferences where 22 | def = Preferences White 23 | 24 | page :: (Hyperbole :> es) => Eff es (Page '[Content]) 25 | page = do 26 | prefs <- session @Preferences 27 | pure $ el ~ bg prefs.color $ "Custom Background" 28 | 29 | data Content = Content 30 | deriving (Generic, ViewId) 31 | 32 | instance HyperView Content es where 33 | data Action Content 34 | = SetColor AppColor 35 | deriving (Generic, ViewAction) 36 | 37 | update (SetColor clr) = do 38 | let prefs = Preferences clr 39 | saveSession prefs 40 | pure $ el ~ bg prefs.color $ "Custom Background" 41 | -------------------------------------------------------------------------------- /examples/Example/Docs/SideEffects.hs: -------------------------------------------------------------------------------- 1 | module Example.Docs.SideEffects where 2 | 3 | import Data.Maybe (fromMaybe) 4 | import Data.Text (Text) 5 | import Web.Atomic.CSS 6 | import Web.Hyperbole 7 | 8 | page :: (Hyperbole :> es) => Eff es (Page '[Message]) 9 | page = do 10 | prm <- lookupParam "msg" 11 | let msg = fromMaybe "hello" prm 12 | pure $ do 13 | hyper Message $ messageView msg 14 | 15 | data Message = Message 16 | deriving (Generic, ViewId) 17 | 18 | instance HyperView Message es where 19 | data Action Message 20 | = Louder Text 21 | deriving (Generic, ViewAction) 22 | 23 | update (Louder msg) = do 24 | let new = msg <> "!" 25 | setParam "msg" new 26 | pure $ messageView new 27 | 28 | messageView :: Text -> View Message () 29 | messageView m = do 30 | button (Louder m) ~ border 1 $ "Louder" 31 | el ~ bold $ text $ "Message: " <> m 32 | -------------------------------------------------------------------------------- /examples/Example/Docs/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Docs.State where 4 | 5 | import Data.Text (Text) 6 | import Web.Atomic.CSS 7 | import Web.Hyperbole 8 | 9 | messageView :: Text -> View Message () 10 | messageView m = do 11 | button (Louder m) ~ border 1 $ "Louder" 12 | el ~ bold $ text m 13 | 14 | page :: Eff es (Page '[Message]) 15 | page = do 16 | pure $ do 17 | hyper Message $ messageView "Hello" 18 | 19 | data Message = Message 20 | deriving (Generic, ViewId) 21 | 22 | instance HyperView Message es where 23 | data Action Message 24 | = Louder Text 25 | deriving (Generic, ViewAction) 26 | 27 | update (Louder m) = do 28 | let new = m <> "!" 29 | pure $ messageView new 30 | -------------------------------------------------------------------------------- /examples/Example/Docs/ViewFunctions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Docs.ViewFunctions where 4 | 5 | import Data.Text (Text) 6 | import Web.Atomic.CSS 7 | import Web.Hyperbole 8 | 9 | page :: Eff es (Page '[Message]) 10 | page = do 11 | pure $ do 12 | hyper Message $ messageView "Hello" 13 | 14 | data Message = Message 15 | deriving (Generic, ViewId) 16 | 17 | instance HyperView Message es where 18 | data Action Message 19 | = SetMessage Text 20 | deriving (Generic, ViewAction) 21 | 22 | update (SetMessage t) = 23 | pure $ messageView t 24 | 25 | messageView :: Text -> View Message () 26 | messageView m = do 27 | header m 28 | messageButton "Salutations!" 29 | messageButton "Good Morning!" 30 | messageButton "Goodbye" 31 | 32 | messageButton :: Text -> View Message () 33 | messageButton msg = do 34 | button (SetMessage msg) ~ border 1 $ text $ "Say " <> msg 35 | 36 | header :: Text -> View context () 37 | header txt = do 38 | el ~ bold $ text txt 39 | -------------------------------------------------------------------------------- /examples/Example/Effects/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module Example.Effects.Debug where 5 | 6 | import Control.Concurrent (threadDelay) 7 | import Data.String.Interpolate (i) 8 | import Effectful 9 | import Effectful.Dispatch.Dynamic 10 | 11 | type Milliseconds = Int 12 | data Debug :: Effect where 13 | Dump :: (Show a) => String -> a -> Debug m () 14 | Delay :: Milliseconds -> Debug m () 15 | 16 | type instance DispatchOf Debug = 'Dynamic 17 | 18 | runDebugIO 19 | :: (IOE :> es) 20 | => Eff (Debug : es) a 21 | -> Eff es a 22 | runDebugIO = interpret $ \_ -> \case 23 | Dump msg a -> do 24 | liftIO $ putStrLn [i| [#{msg}] #{show a}|] 25 | Delay ms -> liftIO $ threadDelay (ms * 1000) 26 | 27 | dump :: (Debug :> es, Show a) => String -> a -> Eff es () 28 | dump msg a = send $ Dump msg a 29 | 30 | delay :: (Debug :> es) => Milliseconds -> Eff es () 31 | delay n = send $ Delay n 32 | -------------------------------------------------------------------------------- /examples/Example/Effects/Random.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Example.Effects.Random 4 | ( GenRandom 5 | , genRandom 6 | , runRandom 7 | ) where 8 | 9 | import Effectful 10 | import Effectful.Dispatch.Dynamic 11 | import System.Random (Random, randomRIO) 12 | 13 | data GenRandom :: Effect where 14 | GenRandom :: (Random a) => (a, a) -> GenRandom m a 15 | 16 | type instance DispatchOf GenRandom = 'Dynamic 17 | 18 | runRandom 19 | :: (IOE :> es) 20 | => Eff (GenRandom : es) a 21 | -> Eff es a 22 | runRandom = interpret $ \_ -> \case 23 | GenRandom range -> liftIO $ randomRIO range 24 | 25 | genRandom :: (Random a, GenRandom :> es) => (a, a) -> Eff es a 26 | genRandom range = send $ GenRandom range 27 | -------------------------------------------------------------------------------- /examples/Example/Effects/Todos.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Example.Effects.Todos where 4 | 5 | import Data.Map (Map) 6 | import Data.Map.Strict qualified as M 7 | import Data.Text (Text, pack) 8 | import Effectful 9 | import Effectful.Dispatch.Dynamic 10 | import System.Random (randomRIO) 11 | import Web.Hyperbole 12 | 13 | type TodoId = Text 14 | 15 | newtype AllTodos = AllTodos (Map TodoId Todo) 16 | deriving newtype (ToJSON, FromJSON) 17 | 18 | instance Session AllTodos where 19 | sessionKey = "todos" 20 | instance Default AllTodos where 21 | def = AllTodos mempty 22 | 23 | data Todo = Todo 24 | { id :: TodoId 25 | , task :: Text 26 | , completed :: Bool 27 | } 28 | deriving (Generic, ToJSON, FromJSON) 29 | 30 | data Todos :: Effect where 31 | LoadAll :: Todos m [Todo] 32 | Save :: Todo -> Todos m () 33 | Remove :: TodoId -> Todos m () 34 | Create :: Text -> Todos m TodoId 35 | type instance DispatchOf Todos = 'Dynamic 36 | runTodosSession 37 | :: forall es a 38 | . (Hyperbole :> es, IOE :> es) 39 | => Eff (Todos : es) a 40 | -> Eff es a 41 | runTodosSession = interpret $ \_ -> \case 42 | LoadAll -> do 43 | AllTodos todos <- session 44 | pure $ M.elems todos 45 | Save todo -> do 46 | modifySession_ $ insert todo 47 | Remove todoId -> do 48 | modifySession_ $ delete todoId 49 | Create task -> do 50 | todoId <- randomId 51 | let todo = Todo todoId task False 52 | modifySession_ $ insert todo 53 | pure todoId 54 | where 55 | randomId :: (IOE :> es) => Eff es Text 56 | randomId = do 57 | n <- randomRIO @Int (0, 9999999) 58 | pure $ "todo-" <> pack (show n) 59 | 60 | insert :: Todo -> AllTodos -> AllTodos 61 | insert todo (AllTodos m) = 62 | AllTodos (M.insert todo.id todo m) 63 | 64 | delete :: TodoId -> AllTodos -> AllTodos 65 | delete todoId (AllTodos m) = 66 | AllTodos (M.delete todoId m) 67 | 68 | loadAll :: (Todos :> es) => Eff es [Todo] 69 | loadAll = send LoadAll 70 | 71 | create :: (Todos :> es) => Text -> Eff es TodoId 72 | create t = send $ Create t 73 | 74 | setTask :: (Todos :> es) => Text -> Todo -> Eff es Todo 75 | setTask task t = do 76 | let updated = t{task} 77 | send $ Save updated 78 | pure updated 79 | 80 | setCompleted :: (Todos :> es) => Bool -> Todo -> Eff es Todo 81 | setCompleted completed todo = do 82 | let updated = todo{completed} 83 | send $ Save updated 84 | pure updated 85 | 86 | toggleAll :: (Todos :> es) => [Todo] -> Eff es [Todo] 87 | toggleAll todos = do 88 | let shouldComplete = any (\t -> not t.completed) todos 89 | mapM (setCompleted shouldComplete) todos 90 | 91 | clearCompleted :: (Todos :> es) => Eff es [Todo] 92 | clearCompleted = do 93 | todos <- loadAll 94 | let completed = filter (.completed) todos 95 | mapM_ clear completed 96 | loadAll 97 | 98 | clear :: (Todos :> es) => Todo -> Eff es () 99 | clear todo = do 100 | send $ Remove todo.id 101 | -------------------------------------------------------------------------------- /examples/Example/Effects/Users.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Example.Effects.Users where 4 | 5 | import Control.Concurrent.MVar 6 | import Data.Map.Strict (Map) 7 | import Data.Map.Strict qualified as M 8 | import Data.Text (Text) 9 | import Effectful 10 | import Effectful.Dispatch.Dynamic 11 | import Web.Hyperbole (Hyperbole, notFound) 12 | 13 | type UserId = Int 14 | 15 | data User = User 16 | { id :: UserId 17 | , firstName :: Text 18 | , lastName :: Text 19 | , age :: Int 20 | , info :: Text 21 | , isActive :: Bool 22 | } 23 | deriving (Show) 24 | 25 | -- Load a user AND do next if missing? 26 | data Users :: Effect where 27 | LoadUser :: UserId -> Users m (Maybe User) 28 | LoadUsers :: Users m [User] 29 | SaveUser :: User -> Users m () 30 | ModifyUser :: UserId -> (User -> User) -> Users m () 31 | DeleteUser :: UserId -> Users m () 32 | NextId :: Users m UserId 33 | 34 | type instance DispatchOf Users = 'Dynamic 35 | 36 | type UserStore = MVar (Map UserId User) 37 | 38 | runUsersIO 39 | :: (IOE :> es) 40 | => UserStore 41 | -> Eff (Users : es) a 42 | -> Eff es a 43 | runUsersIO var = interpret $ \_ -> \case 44 | LoadUser uid -> do 45 | us <- liftIO $ readMVar var 46 | pure $ M.lookup uid us 47 | LoadUsers -> loadAll 48 | SaveUser u -> do 49 | modify $ \us -> pure $ M.insert u.id u us 50 | ModifyUser uid f -> do 51 | modify $ \us -> do 52 | pure $ M.adjust f uid us 53 | DeleteUser uid -> do 54 | modify $ \us -> pure $ M.delete uid us 55 | NextId -> do 56 | us <- loadAll 57 | let umax = maximum $ fmap (.id) us 58 | pure (umax + 1) 59 | where 60 | loadAll :: (MonadIO m) => m [User] 61 | loadAll = do 62 | us <- liftIO $ readMVar var 63 | pure $ M.elems us 64 | 65 | modify :: (MonadIO m) => (Map UserId User -> IO (Map UserId User)) -> m () 66 | modify f = liftIO $ modifyMVar_ var f 67 | 68 | initUsers :: (MonadIO m) => m UserStore 69 | initUsers = 70 | liftIO $ newMVar $ M.fromList $ map (\u -> (u.id, u)) users 71 | where 72 | users = 73 | [ User 1 "Joe" "Blow" 32 "" True 74 | , User 2 "Sara" "Dane" 24 "" False 75 | , User 3 "Billy" "Bob" 48 "" False 76 | , User 4 "Felicia" "Korvus" 84 "" True 77 | ] 78 | 79 | find :: (Hyperbole :> es, Users :> es) => Int -> Eff es User 80 | find uid = do 81 | mu <- send (LoadUser uid) 82 | maybe notFound pure mu 83 | 84 | all :: (Users :> es) => Eff es [User] 85 | all = send LoadUsers 86 | 87 | save :: (Users :> es) => User -> Eff es () 88 | save = send . SaveUser 89 | 90 | delete :: (Users :> es) => Int -> Eff es () 91 | delete = send . DeleteUser 92 | 93 | nextId :: (Users :> es) => Eff es Int 94 | nextId = send NextId 95 | -------------------------------------------------------------------------------- /examples/Example/Page/Autocomplete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Page.Autocomplete where 4 | 5 | import Control.Monad (forM_) 6 | import Data.Text (Text) 7 | import Data.Text qualified as T 8 | import Effectful 9 | import Example.AppRoute as Route 10 | import Example.Colors 11 | import Example.Data.ProgrammingLanguage (ProgrammingLanguage (..), allLanguages, isMatchLanguage) 12 | import Example.Page.Filter as Filter (chosenView, clearButton, resultsTable) 13 | import Example.View.Layout 14 | import Safe (atMay) 15 | import Web.Atomic.CSS 16 | import Web.Hyperbole 17 | import Prelude hiding (even, odd) 18 | 19 | page :: (Hyperbole :> es) => Eff es (Page '[LiveSearch]) 20 | page = do 21 | pure $ exampleLayout (Data Autocomplete) $ do 22 | example "Autocomplete" "Example/Page/Autocomplete.hs" $ do 23 | el "Create a serverside autocomplete with a combination of onInput and onKeyDown" 24 | col ~ embed $ hyper LiveSearch $ liveSearchView allLanguages 0 "" 25 | 26 | data LiveSearch = LiveSearch 27 | deriving (Generic, ViewId) 28 | 29 | instance (IOE :> es) => HyperView LiveSearch es where 30 | data Action LiveSearch 31 | = SearchTerm Int Text 32 | | Select (Maybe ProgrammingLanguage) 33 | deriving (Generic, ViewAction) 34 | 35 | update (SearchTerm current term) = do 36 | pure $ liveSearchView allLanguages current term 37 | update (Select Nothing) = do 38 | pure $ liveSearchView allLanguages 0 "" 39 | update (Select (Just lang)) = do 40 | pure $ selectedView lang 41 | 42 | selectedView :: ProgrammingLanguage -> View LiveSearch () 43 | selectedView selected = do 44 | col ~ gap 10 $ do 45 | Filter.chosenView selected 46 | 47 | liveSearchView :: [ProgrammingLanguage] -> Int -> Text -> View LiveSearch () 48 | liveSearchView langs current term = do 49 | col ~ gap 10 $ do 50 | el ~ stack $ do 51 | search (SearchTerm current) 250 @ searchKeys . placeholder "search programming languages" . value term . autofocus ~ border 1 . pad 10 . grow 52 | Filter.clearButton (SearchTerm current) term 53 | col ~ popup (TRBL 50 0 0 0) . shownIfMatches $ do 54 | searchPopup matchedLanguages currentSearchLang 55 | Filter.resultsTable (Select . Just) langs 56 | where 57 | matchedLanguages = filter (isMatchLanguage term) langs 58 | 59 | currentSearchLang = matchedLanguages `atMay` current 60 | 61 | -- Only show the search popup if there is a search term and matchedLanguages 62 | shownIfMatches = 63 | if T.null term || null matchedLanguages then display None else flexCol 64 | 65 | searchKeys = 66 | onKeyDown Enter (Select currentSearchLang) 67 | . onKeyDown ArrowDown (SearchTerm (current + 1) term) 68 | . onKeyDown ArrowUp (SearchTerm (current - 1) term) 69 | 70 | searchPopup :: [ProgrammingLanguage] -> Maybe ProgrammingLanguage -> View LiveSearch () 71 | searchPopup shownLangs highlighted = do 72 | col ~ border 1 . bg White $ do 73 | forM_ shownLangs $ \lang -> do 74 | button (Select (Just lang)) ~ hover (bg Light) . selected lang . pad 5 $ do 75 | text lang.name 76 | where 77 | selected l = if Just l == highlighted then bg Light else id 78 | -------------------------------------------------------------------------------- /examples/Example/Page/CSS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Example.Page.CSS where 4 | 5 | import Data.String.Interpolate (i) 6 | import Effectful 7 | import Example.AppRoute 8 | import Example.Page.CSS.External qualified as External 9 | import Example.Page.CSS.Tooltips 10 | import Example.Page.CSS.Transitions 11 | import Example.Style qualified as Style 12 | import Example.View.Layout (embed, example, exampleLayout) 13 | import Web.Atomic.CSS 14 | import Web.Hyperbole 15 | import Web.Hyperbole.HyperView.Types (Root (..)) 16 | 17 | page :: (Hyperbole :> es) => Eff es (Page '[Transitions, External.Items]) 18 | page = do 19 | ext <- External.page 20 | pure $ exampleLayout AtomicCSS $ do 21 | example "Atomic CSS" "Example/Page/CSS.hs" $ do 22 | el $ do 23 | text "Hyperbole encourages using the " 24 | link [uri|https://github.com/seanhess/atomic-css|] ~ Style.link $ "Atomic CSS" 25 | text "package to factor styles with haskell functions" 26 | col ~ embed $ do 27 | pre 28 | [i|import Web.Atomic.CSS 29 | import Web.Hyperbole 30 | 31 | header = bold 32 | h1 = header . fontSize 32 33 | h2 = header . fontSize 24 34 | h3 = header . fontSize 18 35 | clickable = pointer . hover bold 36 | 37 | example = do 38 | col $ do 39 | el ~ h3 $ "My Page" 40 | el ~ border 1 . pad 10 . clickable $ "Hover Me" 41 | ... 42 | |] 43 | 44 | col ~ embed $ do 45 | el ~ h3 $ "My Page" 46 | el ~ border 1 . pad 10 . clickable $ "Click Me" 47 | 48 | example "CSS Transitions" "Example/Page/CSS/Transitions.hs" $ do 49 | el "Animate changes with CSS Transitions" 50 | col ~ embed $ hyper Transitions viewSmall 51 | 52 | example "Tooltips" "Example/Page/CSS/Tooltips.hs" $ do 53 | el "For immediate feedback, create interactivity via Atomic CSS whenever possible" 54 | col ~ embed $ tooltips 55 | 56 | example "External Stylesheets" "Example/Page/CSS/External.hs" $ do 57 | el $ do 58 | text "You can opt-out of Atomic CSS and use external classes with " 59 | code "class_" 60 | addContext Root ext 61 | where 62 | header = bold 63 | h3 = header . fontSize 18 64 | clickable = pointer . hover bold 65 | -------------------------------------------------------------------------------- /examples/Example/Page/CSS/External.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.CSS.External where 2 | 3 | import Data.Text (Text) 4 | import Web.Hyperbole 5 | 6 | main :: IO () 7 | main = do 8 | run 3000 $ do 9 | liveApp (basicDocument "Example") (runPage page) 10 | 11 | page :: (Hyperbole :> es) => Eff es (Page '[Items]) 12 | page = do 13 | pure $ do 14 | -- you can choose to include a stylesheet only on the page that uses it 15 | -- or load it in your document function 16 | stylesheet "external.css" 17 | hyper Items $ itemsView "one" 18 | 19 | data Items = Items 20 | deriving (Generic, ViewId) 21 | 22 | instance HyperView Items es where 23 | data Action Items = Select Text 24 | deriving (Generic, ViewAction) 25 | 26 | update (Select t) = do 27 | pure $ itemsView t 28 | 29 | itemsView :: Text -> View Items () 30 | itemsView sel = do 31 | el @ class_ "parent" $ do 32 | item "one" 33 | item "two" 34 | item "three" 35 | item "four" 36 | item "five" 37 | where 38 | selected i = 39 | if sel == i 40 | then class_ "selected" 41 | else id 42 | 43 | item i = 44 | -- the class_ attribute MERGES classes if you set it more than once 45 | button (Select i) @ class_ "item" . selected i $ text i 46 | -------------------------------------------------------------------------------- /examples/Example/Page/CSS/Tooltips.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.CSS.Tooltips where 2 | 3 | import Web.Atomic.CSS 4 | import Web.Hyperbole 5 | import Example.Colors 6 | 7 | tooltips :: View c () 8 | tooltips = do 9 | col ~ pad 10 . gap 10 . width 300 $ do 10 | mapM_ viewItemRow ["One", "Two", "Three", "Four", "Five", "Six"] 11 | where 12 | viewItemRow item = do 13 | col ~ stack . showTooltips . hover (color Primary) . pointer $ do 14 | el ~ border 1 . bg White . pad 5 $ text item 15 | el ~ cls "tooltip" . popup (TR 10 10) . zIndex 1 . visibility Hidden $ do 16 | col ~ border 2 . gap 5 . bg White . pad 5 $ do 17 | el ~ bold $ "DETAILS" 18 | el $ text item 19 | el "details about this item" 20 | 21 | showTooltips = 22 | css 23 | "tooltips" 24 | ".tooltips:hover > .tooltip" 25 | (declarations (visibility Visible)) 26 | -------------------------------------------------------------------------------- /examples/Example/Page/CSS/Transitions.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.CSS.Transitions where 2 | 3 | import Example.Style (btn) 4 | import Web.Atomic.CSS 5 | import Web.Hyperbole 6 | 7 | data Transitions = Transitions 8 | deriving (Generic, ViewId) 9 | 10 | instance HyperView Transitions es where 11 | data Action Transitions 12 | = Expand 13 | | Collapse 14 | deriving (Generic, ViewAction) 15 | update Expand = do 16 | pure viewBig 17 | update Collapse = do 18 | pure viewSmall 19 | 20 | viewSmall :: View Transitions () 21 | viewSmall = do 22 | col ~ gap 10 . transition 300 (Width 200) $ do 23 | el "Small" 24 | button Expand "Expand" ~ btn 25 | 26 | viewBig :: View Transitions () 27 | viewBig = 28 | col ~ gap 10 . transition 300 (Width 400) $ do 29 | el "Expanded" 30 | button Collapse "Collapse" ~ btn 31 | -------------------------------------------------------------------------------- /examples/Example/Page/Concurrency.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Page.Concurrency where 4 | 5 | import Control.Monad (forM_) 6 | import Data.Text (Text, pack) 7 | import Effectful 8 | import Example.AppRoute 9 | import Example.Colors 10 | import Example.Effects.Debug 11 | import Example.Effects.Random 12 | import Example.Style as Style 13 | import Example.View.Inputs (progressBar) 14 | import Example.View.Layout (embed, example, exampleLayout) 15 | import Web.Atomic.CSS 16 | import Web.Hyperbole 17 | 18 | page :: (Hyperbole :> es, Debug :> es) => Eff es (Page '[Polling, LazyData, Progress]) 19 | page = do 20 | pure $ exampleLayout Concurrency $ do 21 | example "Concurrency" source $ do 22 | el "While individual HyperViews can only have one update in progress at a time, multiple HyperViews can overlap updates without issue" 23 | el ~ embed $ do 24 | hyper (Progress 1 100) $ viewProgress 0 25 | hyper (Progress 2 200) $ viewProgress 0 26 | hyper (Progress 3 300) $ viewProgress 0 27 | hyper (Progress 4 400) $ viewProgress 0 28 | hyper (Progress 5 500) $ viewProgress 0 29 | 30 | example "Lazy Loading" source $ do 31 | row ~ gap 5 $ do 32 | text "Instead of preloading everything in our Page, a HyperView can load itself using " 33 | code "onLoad" 34 | el ~ flexRow . embed . flexWrap Wrap $ do 35 | forM_ pretendTasks $ \taskId -> do 36 | el ~ border 1 . width 120 . pad 5 $ do 37 | hyper (LazyData taskId) viewTaskLoad 38 | 39 | example "Polling" source $ do 40 | row ~ gap 5 $ do 41 | text "By including an " 42 | code "onLoad" 43 | text "in every view update, we can poll the server after a given delay" 44 | col ~ embed $ hyper Polling viewInit 45 | where 46 | source = "Example/Page/Concurrency.hs" 47 | 48 | ----------------------------------------------------------- 49 | -- Simple Polling 50 | ----------------------------------------------------------- 51 | 52 | data Polling = Polling 53 | deriving (Generic, ViewId) 54 | 55 | instance (Debug :> es) => HyperView Polling es where 56 | data Action Polling 57 | = Reload Int 58 | | Stop 59 | | Pause Int 60 | deriving (Generic, ViewAction) 61 | 62 | -- to stop, return a view without an onLoad 63 | update (Pause n) = do 64 | pure $ viewPaused n 65 | update Stop = do 66 | pure viewStopped 67 | update (Reload n) = do 68 | pure $ viewPoll n 69 | 70 | viewInit :: View Polling () 71 | viewInit = do 72 | row $ do 73 | button (Reload 1) "Start Polling" ~ btn 74 | 75 | viewStopped :: View Polling () 76 | viewStopped = do 77 | row $ do 78 | button (Reload 1) "Restart Polling" ~ btn 79 | 80 | viewPaused :: Int -> View Polling () 81 | viewPaused n = do 82 | col ~ gap 10 $ do 83 | row $ do 84 | button (Reload n) "Resume" ~ btn 85 | viewStatus n 86 | 87 | viewPoll :: Int -> View Polling () 88 | viewPoll n = do 89 | -- reload every 200ms + round trip delay 90 | col @ onLoad (Reload (n + 1)) 250 ~ gap 10 . loading $ do 91 | row ~ gap 5 $ do 92 | button (Pause n) "Pause" ~ btn 93 | button Stop "Stop" ~ btn 94 | viewStatus n 95 | 96 | viewStatus :: Int -> View Polling () 97 | viewStatus n = do 98 | el $ do 99 | text "Polling... " 100 | text $ pack $ show n 101 | 102 | ----------------------------------------------------------- 103 | -- Lazy Loading Expensive Data 104 | ----------------------------------------------------------- 105 | 106 | data LazyData = LazyData TaskId 107 | deriving (Generic, ViewId) 108 | 109 | instance (Debug :> es, GenRandom :> es) => HyperView LazyData es where 110 | data Action LazyData 111 | = Details 112 | deriving (Generic, ViewAction) 113 | 114 | update Details = do 115 | LazyData taskId <- viewId 116 | task <- pretendLoadTask taskId 117 | pure $ viewTaskDetails task 118 | 119 | viewTaskLoad :: View LazyData () 120 | viewTaskLoad = do 121 | -- 100ms after rendering, get the details 122 | el @ onLoad Details 100 ~ bg GrayLight . textAlign AlignCenter $ do 123 | text "..." 124 | 125 | viewTaskDetails :: Task -> View LazyData () 126 | viewTaskDetails task = do 127 | row ~ color Success $ do 128 | text task.details 129 | 130 | -- Fake Tasks Effect ---------------------------------------- 131 | 132 | type TaskId = Int 133 | 134 | data Task = Task 135 | { taskId :: TaskId 136 | , details :: Text 137 | } 138 | 139 | pretendLoadTask :: (Debug :> es, GenRandom :> es) => TaskId -> Eff es Task 140 | pretendLoadTask taskId = do 141 | randomDelay <- genRandom (100, 1000) 142 | delay randomDelay 143 | 144 | pure $ Task taskId $ "Details for " <> pack (show taskId) 145 | 146 | pretendTasks :: [TaskId] 147 | pretendTasks = [1 .. 30] 148 | 149 | ----------------------------------------------------------- 150 | 151 | data Progress = Progress TaskId Milliseconds 152 | deriving (Generic, ViewId) 153 | 154 | instance (Debug :> es, GenRandom :> es) => HyperView Progress es where 155 | data Action Progress 156 | = CheckProgress Int 157 | deriving (Generic, ViewAction) 158 | update (CheckProgress prg) = do 159 | Progress _ dly <- viewId 160 | 161 | -- this will not block other hyperviews from updating 162 | delay dly 163 | 164 | -- pretend check update of a task 165 | nextProgress <- genRandom (0, 5) 166 | 167 | pure $ viewProgress (prg + nextProgress) 168 | 169 | viewProgress :: Int -> View Progress () 170 | viewProgress prg 171 | | prg >= 100 = viewComplete 172 | | otherwise = viewUpdating prg 173 | 174 | viewComplete :: View Progress () 175 | viewComplete = do 176 | row ~ bg Success . color White . pad 5 $ "Complete" 177 | 178 | viewUpdating :: Int -> View Progress () 179 | viewUpdating prg = do 180 | let pct = fromIntegral prg / 100 181 | Progress taskId _ <- viewId 182 | col @ onLoad (CheckProgress prg) 0 $ do 183 | progressBar pct $ do 184 | el ~ grow $ text $ "Task" <> pack (show taskId) 185 | -------------------------------------------------------------------------------- /examples/Example/Page/Contact.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Page.Contact where 4 | 5 | import Data.Maybe (fromMaybe) 6 | import Data.String.Conversions 7 | import Data.Text (Text, pack) 8 | import Effectful 9 | import Effectful.Reader.Dynamic 10 | import Example.AppRoute qualified as Route 11 | import Example.Colors 12 | import Example.Effects.Debug 13 | import Example.Effects.Users (User (..), UserId, Users) 14 | import Example.Effects.Users qualified as Users 15 | import Example.Style qualified as Style 16 | import Example.View.Layout 17 | import Web.Atomic.CSS 18 | import Web.Hyperbole 19 | 20 | -- Example adding a reader context to the page, based on an argument from the AppRoute 21 | response :: (Hyperbole :> es, Users :> es, Debug :> es) => UserId -> Eff es Response 22 | response uid = runReader uid $ runPage page 23 | 24 | -- The page assumes all effects have been added 25 | page 26 | :: forall es 27 | . (Hyperbole :> es, Users :> es, Debug :> es, Reader UserId :> es) 28 | => Eff es (Page '[Contact]) 29 | page = do 30 | uid <- ask 31 | u <- Users.find uid 32 | pure $ exampleLayout (Route.Contacts $ Route.Contact 0) $ do 33 | example "Contact" "Example/Page/Contact.hs" $ do 34 | col ~ embed $ do 35 | hyper (Contact uid) $ contactView u 36 | 37 | -- Contact ---------------------------------------------------- 38 | 39 | data Contact = Contact UserId 40 | deriving (Generic, ViewId) 41 | 42 | instance (Users :> es, Debug :> es) => HyperView Contact es where 43 | data Action Contact 44 | = Edit 45 | | Save 46 | | View 47 | deriving (Generic, ViewAction) 48 | 49 | update action = do 50 | -- No matter which action we are performing, let's look up the user to make sure it exists 51 | Contact uid <- viewId 52 | u <- Users.find uid 53 | case action of 54 | View -> do 55 | pure $ contactView u 56 | Edit -> do 57 | pure $ contactEditView u 58 | Save -> do 59 | delay 1000 60 | unew <- parseUser uid 61 | Users.save unew 62 | pure $ contactView unew 63 | 64 | data ContactForm f = ContactForm 65 | { firstName :: Field f Text 66 | , lastName :: Field f Text 67 | , age :: Field f Int 68 | , info :: Field f Text 69 | } 70 | deriving (Generic, FromFormF, GenFields FieldName, GenFields Maybe) 71 | 72 | parseUser :: (Hyperbole :> es) => Int -> Eff es User 73 | parseUser uid = do 74 | ContactForm{firstName, lastName, age, info} <- formData @(ContactForm Identity) 75 | pure User{id = uid, isActive = True, firstName, lastName, age, info} 76 | 77 | contactView :: User -> View Contact () 78 | contactView = contactView' Edit 79 | 80 | contactView' :: (ViewId c, ViewAction (Action c)) => Action c -> User -> View c () 81 | contactView' edit u = do 82 | col ~ gap 10 $ do 83 | row ~ fld $ do 84 | el (text "First Name:") 85 | text u.firstName 86 | 87 | row ~ fld $ do 88 | el (text "Last Name:") 89 | text u.lastName 90 | 91 | row ~ fld $ do 92 | el (text "Age:") 93 | text (cs $ show u.age) 94 | 95 | row ~ fld $ do 96 | el (text "Info:") 97 | text u.info 98 | 99 | row ~ fld $ do 100 | el (text "Active:") 101 | text (cs $ show u.isActive) 102 | 103 | button edit "Edit" ~ Style.btn 104 | where 105 | fld = gap 10 106 | 107 | contactEditView :: User -> View Contact () 108 | contactEditView u = do 109 | el contactLoading ~ display None . whenLoading flexCol 110 | el (contactEdit View Save u) ~ (whenLoading (display None)) 111 | 112 | contactEdit :: (ViewId c, ViewAction (Action c)) => Action c -> Action c -> User -> View c () 113 | contactEdit onView onSave u = do 114 | col ~ gap 10 $ do 115 | contactForm onSave contactFromUser 116 | button onView (text "Cancel") ~ Style.btnLight 117 | where 118 | contactFromUser :: ContactForm Maybe 119 | contactFromUser = 120 | ContactForm 121 | { firstName = Just u.firstName 122 | , lastName = Just u.lastName 123 | , age = Just u.age 124 | , info = Just u.info 125 | } 126 | 127 | contactForm :: (ViewId id, ViewAction (Action id)) => Action id -> ContactForm Maybe -> View id () 128 | contactForm onSubmit c = do 129 | let f = fieldNames @ContactForm 130 | form onSubmit ~ gap 10 $ do 131 | field f.firstName ~ fld $ do 132 | label "First Name:" 133 | input Name @ value (fromMaybe "" c.firstName) ~ Style.input 134 | 135 | field f.lastName ~ fld $ do 136 | label "Last Name:" 137 | input Name @ value (fromMaybe "" c.lastName) ~ Style.input 138 | 139 | field f.info ~ fld $ do 140 | label "Info:" 141 | textarea c.info @ value (fromMaybe "" c.info) ~ Style.input 142 | 143 | field f.age ~ fld $ do 144 | label "Age:" 145 | input Number @ value (fromMaybe "" $ pack . show <$> c.age) ~ inp 146 | 147 | submit "Submit" ~ Style.btn 148 | where 149 | fld :: (Styleable a) => CSS a -> CSS a 150 | fld = flexRow . gap 10 151 | inp = Style.input 152 | 153 | contactLoading :: View id () 154 | contactLoading = el ~ (bg Warning . pad 10) $ "Loading..." 155 | -------------------------------------------------------------------------------- /examples/Example/Page/Contacts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Example.Page.Contacts where 5 | 6 | import Control.Monad (forM_) 7 | import Effectful 8 | import Example.AppRoute qualified as Route 9 | import Example.Colors 10 | import Example.Effects.Debug 11 | import Example.Effects.Users (User (..), UserId, Users) 12 | import Example.Effects.Users qualified as Users 13 | import Example.Page.Contact (contactForm, contactLoading, contactView', parseUser) 14 | import Example.Page.Contact qualified as Contact 15 | import Example.Style qualified as Style 16 | import Example.View.Layout 17 | import Web.Atomic.CSS 18 | import Web.Hyperbole 19 | 20 | page 21 | :: forall es 22 | . (Hyperbole :> es, Users :> es, Debug :> es) 23 | => Eff es (Page '[Contacts, InlineContact, NewContact]) 24 | page = do 25 | us <- Users.all 26 | pure $ exampleLayout (Route.Contacts Route.ContactsAll) $ do 27 | example "Contacts" "Example/Page/Contacts.hs" $ do 28 | el "This example combines various features" 29 | col ~ embed $ do 30 | hyper Contacts $ allContactsView Nothing us 31 | 32 | -- Contacts ---------------------------------------------- 33 | 34 | data Contacts = Contacts 35 | deriving (Generic, ViewId) 36 | 37 | data Filter 38 | = Active 39 | | Inactive 40 | deriving (Eq, Show, Read, Generic, ToJSON, FromJSON) 41 | 42 | instance (Users :> es, Debug :> es) => HyperView Contacts es where 43 | data Action Contacts 44 | = Reload (Maybe Filter) 45 | | AddUser 46 | | DeleteUser UserId 47 | deriving (Generic, ViewAction) 48 | 49 | type Require Contacts = '[InlineContact, NewContact] 50 | 51 | update = \case 52 | Reload mf -> do 53 | us <- Users.all 54 | pure $ allContactsView mf us 55 | AddUser -> do 56 | uid <- Users.nextId 57 | u <- parseUser uid 58 | Users.save u 59 | us <- Users.all 60 | pure $ allContactsView Nothing us 61 | DeleteUser uid -> do 62 | Users.delete uid 63 | us <- Users.all 64 | pure $ allContactsView Nothing us 65 | 66 | -- TODO: get the form to close when submitted 67 | 68 | allContactsView :: Maybe Filter -> [User] -> View Contacts () 69 | allContactsView fil us = col ~ gap 20 $ do 70 | row ~ gap 10 $ do 71 | el ~ pad 10 $ "Filter: " 72 | dropdown Reload (== fil) $ do 73 | option Nothing "" 74 | option (Just Active) "Active!" 75 | option (Just Inactive) "Inactive" 76 | 77 | row ~ gap 10 $ do 78 | let filtered = filter (filterUsers fil) us 79 | forM_ filtered $ \u -> do 80 | el ~ border 1 . pad 10 $ do 81 | hyper (InlineContact u.id) $ contactView u 82 | row $ do 83 | space 84 | route (Route.Contacts $ Route.Contact u.id) "details" ~ Style.link 85 | 86 | row ~ gap 10 $ do 87 | button (Reload Nothing) ~ Style.btnLight $ "Reload" 88 | target (InlineContact 2) $ button Edit ~ Style.btnLight $ "Edit Sara" 89 | 90 | hyper NewContact newContactButton 91 | where 92 | filterUsers Nothing _ = True 93 | filterUsers (Just Active) u = u.isActive 94 | filterUsers (Just Inactive) u = not u.isActive 95 | 96 | -- New Contact Form / Button ---------------------------------- 97 | -- Note that it is easier to nest hyperviews here because NewContact has sufficiently different state 98 | -- * It doesn't need to know the users 99 | -- * It DOES need to track it's open / close state 100 | -- * We use target to submit the form to the Contacts parent view 101 | 102 | data NewContact = NewContact 103 | deriving (Generic, ViewId) 104 | 105 | instance (Users :> es) => HyperView NewContact es where 106 | data Action NewContact 107 | = ShowForm 108 | | CloseForm 109 | deriving (Generic, ViewAction) 110 | 111 | type Require NewContact = '[Contacts] 112 | 113 | update action = 114 | case action of 115 | ShowForm -> pure newContactForm 116 | CloseForm -> pure newContactButton 117 | 118 | newContactButton :: View NewContact () 119 | newContactButton = do 120 | button ShowForm ~ Style.btn $ "Add Contact" 121 | 122 | newContactForm :: View NewContact () 123 | newContactForm = do 124 | row ~ pad 10 . gap 10 . border 1 $ do 125 | target Contacts $ do 126 | contactForm AddUser genFields 127 | col $ do 128 | space 129 | button CloseForm ~ Style.btnLight $ "Cancel" 130 | 131 | -- Reuse Contact View ---------------------------------- 132 | -- We want to use the same view as Example.Contact, but customize the edit view to have a delete button 133 | -- Note that we re-implement the actions and the handler 134 | -- Just create functions to deduplicate code and use them here 135 | 136 | data InlineContact = InlineContact UserId 137 | deriving (Generic, ViewId) 138 | 139 | instance (Users :> es, Debug :> es) => HyperView InlineContact es where 140 | data Action InlineContact 141 | = Edit 142 | | View 143 | | Save 144 | deriving (Generic, ViewAction) 145 | 146 | type Require InlineContact = '[Contacts] 147 | 148 | update a = do 149 | InlineContact uid <- viewId 150 | u <- Users.find uid 151 | case a of 152 | View -> 153 | pure $ contactView u 154 | Edit -> 155 | pure $ contactEdit u 156 | Save -> do 157 | delay 1000 158 | unew <- parseUser uid 159 | Users.save unew 160 | pure $ contactView unew 161 | 162 | -- See how we reuse the contactView' from Example.Contact 163 | contactView :: User -> View InlineContact () 164 | contactView = contactView' Edit 165 | 166 | -- See how we reuse the contactEdit' and contactLoading from Example.Contact 167 | contactEdit :: User -> View InlineContact () 168 | contactEdit u = do 169 | el ~ (display None . whenLoading flexCol) $ contactLoading 170 | col ~ (whenLoading (display None) . gap 10) $ do 171 | Contact.contactEdit View Save u 172 | target Contacts $ button (DeleteUser u.id) ~ Style.btn' Danger . pad (XY 10 0) $ text "Delete" 173 | -------------------------------------------------------------------------------- /examples/Example/Page/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Page.Counter where 4 | 5 | import Data.Text (pack) 6 | import Effectful 7 | import Example.Style as Style 8 | import Web.Atomic.CSS 9 | import Web.Hyperbole as Hyperbole 10 | 11 | page :: (Hyperbole :> es) => Eff es (Page '[Counter]) 12 | page = do 13 | pure $ hyper Counter (viewCount 0) 14 | 15 | data Counter = Counter 16 | deriving (Generic, ViewId) 17 | 18 | instance HyperView Counter es where 19 | data Action Counter 20 | = Increment Int 21 | | Decrement Int 22 | deriving (Generic, ViewAction) 23 | 24 | update (Increment n) = do 25 | pure $ viewCount (n + 1) 26 | update (Decrement n) = do 27 | pure $ viewCount (n - 1) 28 | 29 | viewCount :: Int -> View Counter () 30 | viewCount n = col ~ gap 10 $ do 31 | row $ do 32 | el ~ bold . fontSize 48 . border 1 . pad (XY 20 0) $ text $ pack $ show n 33 | row ~ gap 10 $ do 34 | button (Decrement n) "Decrement" ~ Style.btn 35 | button (Increment n) "Increment" ~ Style.btn 36 | -------------------------------------------------------------------------------- /examples/Example/Page/DataTable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Example.Page.DataTable where 4 | 5 | import Data.List (sortOn) 6 | import Data.Text (pack) 7 | import Effectful 8 | import Example.AppRoute as Route 9 | import Example.Data.ProgrammingLanguage (ProgrammingLanguage (..), allLanguages) 10 | import Example.View.Layout 11 | import Example.View.SortableTable (dataTable, sortBtn, sortColumn) 12 | import Web.Atomic.CSS 13 | import Web.Hyperbole 14 | import Prelude hiding (even, odd) 15 | 16 | -- DataTable -> do 17 | -- el "Complex reusable View Functions allow us to " 18 | 19 | page :: (Hyperbole :> es) => Eff es (Page '[Languages]) 20 | page = do 21 | pure $ exampleLayout (Data SortableTable) $ do 22 | example "Data Table" "Example/Page/DataTable.hs" $ do 23 | el "We can write view Functions that work in any view, like a dataTable" 24 | col ~ embed $ hyper Languages $ languagesView Nothing allLanguages 25 | 26 | data Languages = Languages 27 | deriving (Generic, ViewId) 28 | 29 | data SortField 30 | = SortName 31 | | SortDescription 32 | | SortFamily 33 | deriving (Show, Read, Eq, Generic, ToJSON, FromJSON) 34 | 35 | instance HyperView Languages es where 36 | data Action Languages 37 | = SortOn SortField 38 | deriving (Generic, ViewAction) 39 | 40 | update (SortOn fld) = do 41 | let sorted = sortOnField fld allLanguages 42 | pure $ languagesView (Just fld) sorted 43 | 44 | sortOnField :: SortField -> [ProgrammingLanguage] -> [ProgrammingLanguage] 45 | sortOnField = \case 46 | SortName -> sortOn (.name) 47 | SortDescription -> sortOn (.description) 48 | SortFamily -> sortOn (.family) 49 | 50 | languagesView :: Maybe SortField -> [ProgrammingLanguage] -> View Languages () 51 | languagesView fld langs = 52 | table langs ~ dataTable $ do 53 | sortColumn (sortBtn "Language" (SortOn SortName) (fld == Just SortName)) (.name) 54 | sortColumn (sortBtn "Family" (SortOn SortFamily) (fld == Just SortFamily)) $ \d -> pack $ show d.family 55 | sortColumn (sortBtn "Description" (SortOn SortDescription) (fld == Just SortDescription)) (.description) 56 | -------------------------------------------------------------------------------- /examples/Example/Page/Errors.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.Errors where 2 | 3 | import Effectful 4 | import Example.AppRoute qualified as Route 5 | import Example.Style as Style 6 | import Example.View.Layout (exampleLayout) 7 | import Web.Atomic.CSS 8 | import Web.Hyperbole 9 | 10 | page :: (Hyperbole :> es) => Eff es (Page '[Contents]) 11 | page = do 12 | pure $ exampleLayout Route.Errors $ row ~ pad 20 $ do 13 | col ~ gap 10 . border 1 $ do 14 | hyper Contents viewContent 15 | 16 | data Contents = Contents 17 | deriving (Generic, ViewId) 18 | 19 | instance HyperView Contents es where 20 | data Action Contents 21 | = CauseError 22 | deriving (Generic, ViewAction) 23 | 24 | update CauseError = do 25 | -- Return a not found error 404 26 | notFound 27 | 28 | viewContent :: View Contents () 29 | viewContent = do 30 | col ~ gap 10 . pad 20 $ do 31 | button CauseError ~ Style.btn $ "Not Found Error" 32 | 33 | -- Compile Errors (Uncomment) 34 | -------------------------------------------------------------------------------- /examples/Example/Page/FormSimple.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.FormSimple where 2 | 3 | import Data.Text (Text, pack) 4 | import Example.Style qualified as Style 5 | import Web.Atomic.CSS 6 | import Web.Hyperbole 7 | 8 | data AddContact = AddContact 9 | deriving (Generic, ViewId) 10 | 11 | instance HyperView AddContact es where 12 | data Action AddContact 13 | = Submit 14 | deriving (Generic, ViewAction) 15 | 16 | update Submit = do 17 | cf <- formData 18 | pure $ contactView cf 19 | 20 | -- Forms can be pretty simple. Just a type that can be parsed 21 | data ContactForm = ContactForm 22 | { name :: Text 23 | , age :: Int 24 | , isFavorite :: Bool 25 | } 26 | deriving (Generic, FromForm) 27 | 28 | -- and a view that displays an input for each field 29 | formView :: View AddContact () 30 | formView = do 31 | form Submit ~ gap 15 . pad 10 $ do 32 | el ~ Style.h1 $ "Add Contact" 33 | 34 | -- Make sure these names match the field names used by FormParse / formData 35 | field "name" $ do 36 | label "Contact Name" 37 | input Username @ placeholder "contact name" ~ Style.input 38 | 39 | field "age" $ do 40 | label "Age" 41 | input Number @ placeholder "age" . value "0" ~ Style.input 42 | 43 | field "isFavorite" $ do 44 | row ~ gap 10 $ do 45 | checkbox False ~ width 32 46 | label "Favorite?" 47 | 48 | submit "Submit" ~ Style.btn 49 | 50 | -- Alternatively, use Higher Kinded Types, and Hyperbole can guarantee the field names are the same 51 | -- 52 | -- ContactForm' Identity is exactly the same as ContactForm: 53 | -- ContactForm' { name :: Text, age :: Int } 54 | -- 55 | -- ContactForm' FieldName: 56 | -- ContactForm' { name :: FieldName Text, age :: FieldName Int } 57 | -- 58 | -- ContactForm' Maybe: 59 | -- ContactForm' { name :: Maybe Text, age :: Maybe Int } 60 | -- 61 | -- You still have to remember to include all the fields somewhere in the form 62 | data ContactForm' f = ContactForm' 63 | { name :: Field f Text 64 | , age :: Field f Int 65 | , isFavorite :: Field f Bool 66 | } 67 | deriving (Generic, FromFormF, GenFields FieldName) 68 | 69 | formView' :: View AddContact () 70 | formView' = do 71 | -- generate a ContactForm' FieldName 72 | let f = fieldNames @ContactForm' 73 | form Submit ~ gap 15 . pad 10 $ do 74 | el ~ Style.h1 $ "Add Contact" 75 | 76 | -- f.name :: FieldName Text 77 | -- f.name = FieldName "name" 78 | field f.name $ do 79 | label "Contact Name" 80 | input Username @ placeholder "contact name" ~ Style.input 81 | 82 | -- f.age :: FieldName Int 83 | -- f.age = FieldName "age" 84 | field f.age $ do 85 | label "Age" 86 | input Number @ placeholder "age" . value "0" ~ Style.input 87 | 88 | field f.isFavorite $ do 89 | row ~ gap 10 $ do 90 | checkbox False ~ width 32 91 | label "Favorite?" 92 | 93 | submit "Submit" ~ Style.btn 94 | 95 | contactView :: ContactForm -> View AddContact () 96 | contactView u = do 97 | el ~ bold . Style.success $ "Accepted Signup" 98 | row ~ gap 5 $ do 99 | el "Username:" 100 | el $ text u.name 101 | 102 | row ~ gap 5 $ do 103 | el "Age:" 104 | el $ text $ pack (show u.age) 105 | 106 | row ~ gap 5 $ do 107 | el "Favorite:" 108 | el $ text $ pack (show u.isFavorite) 109 | -------------------------------------------------------------------------------- /examples/Example/Page/FormValidation.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.FormValidation where 2 | 3 | import Data.Text (Text, pack) 4 | import Data.Text qualified as T 5 | import Example.Style qualified as Style 6 | import Web.Atomic.CSS 7 | import Web.Hyperbole 8 | 9 | data Signup = Signup 10 | deriving (Generic, ViewId) 11 | 12 | instance HyperView Signup es where 13 | data Action Signup 14 | = Submit 15 | deriving (Generic, ViewAction) 16 | 17 | update Submit = do 18 | uf <- formData @(UserForm Identity) 19 | 20 | let vals = validateForm uf 21 | 22 | if anyInvalid vals 23 | then pure $ formView vals 24 | else pure $ userView uf 25 | 26 | -- Form Fields 27 | newtype User = User {username :: Text} 28 | deriving newtype (FromParam) 29 | 30 | data UserForm f = UserForm 31 | { user :: Field f User 32 | , age :: Field f Int 33 | , pass1 :: Field f Text 34 | , pass2 :: Field f Text 35 | } 36 | deriving (Generic, FromFormF, GenFields Validated, GenFields FieldName) 37 | 38 | anyInvalid :: UserForm Validated -> Bool 39 | anyInvalid u = 40 | or [isInvalid u.user, isInvalid u.age, isInvalid u.pass1, isInvalid u.pass2] 41 | 42 | validateForm :: UserForm Identity -> UserForm Validated 43 | validateForm u = 44 | UserForm 45 | { user = validateUser u.user 46 | , age = validateAge u.age 47 | , pass1 = validatePass u.pass1 u.pass2 48 | , pass2 = NotInvalid 49 | } 50 | 51 | validateAge :: Int -> Validated Int 52 | validateAge a = 53 | validate (a < 20) "User must be at least 20 years old" 54 | 55 | validateUser :: User -> Validated User 56 | validateUser (User u) = 57 | mconcat 58 | [ validate (T.elem ' ' u) "Username must not contain spaces" 59 | , validate (T.length u < 4) "Username must be at least 4 chars" 60 | , if u == "admin" || u == "guest" 61 | then Invalid "Username is already in use" 62 | else Valid 63 | ] 64 | 65 | validatePass :: Text -> Text -> Validated Text 66 | validatePass p1 p2 = 67 | mconcat 68 | [ validate (p1 /= p2) "Passwords did not match" 69 | , validate (T.length p1 < 8) "Password must be at least 8 chars" 70 | ] 71 | 72 | formView :: UserForm Validated -> View Signup () 73 | formView val = do 74 | let f = fieldNames @UserForm 75 | form Submit ~ gap 10 . pad 10 $ do 76 | el ~ Style.h1 $ "Sign Up" 77 | 78 | field f.user ~ valStyle val.user $ do 79 | label "Username" 80 | input Username @ placeholder "username" ~ Style.input 81 | 82 | case val.user of 83 | Invalid t -> el (text t) 84 | Valid -> el "Username is available" 85 | _ -> none 86 | 87 | field f.age ~ valStyle val.age $ do 88 | label "Age" 89 | input Number @ placeholder "age" . value "0" ~ Style.input 90 | el $ invalidText val.age 91 | 92 | field f.pass1 ~ valStyle val.pass1 $ do 93 | label "Password" 94 | input NewPassword @ placeholder "password" ~ Style.input 95 | el $ invalidText val.pass1 96 | 97 | field f.pass2 $ do 98 | label "Repeat Password" 99 | input NewPassword @ placeholder "repeat password" ~ Style.input 100 | 101 | submit "Submit" ~ Style.btn 102 | where 103 | valStyle (Invalid _) = Style.invalid 104 | valStyle Valid = Style.success 105 | valStyle _ = id 106 | 107 | userView :: UserForm Identity -> View Signup () 108 | userView u = do 109 | el ~ bold . Style.success $ "Accepted Signup" 110 | row ~ gap 5 $ do 111 | el "Username:" 112 | el $ text u.user.username 113 | 114 | row ~ gap 5 $ do 115 | el "Age:" 116 | el $ text $ pack (show u.age) 117 | 118 | row ~ gap 5 $ do 119 | el "Password:" 120 | el $ text u.pass1 121 | -------------------------------------------------------------------------------- /examples/Example/Page/Forms.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.Forms where 2 | 3 | import Example.AppRoute 4 | import Example.Page.FormSimple (AddContact(..)) 5 | import Example.Page.FormSimple qualified as FormSimple 6 | import Example.Page.FormValidation (Signup(..)) 7 | import Example.Page.FormValidation qualified as FormValidation 8 | import Example.View.Layout 9 | import Web.Atomic.CSS 10 | import Web.Hyperbole 11 | 12 | page :: (Hyperbole :> es) => Eff es (Page '[Signup, AddContact]) 13 | page = do 14 | pure $ exampleLayout Forms $ do 15 | example "Simple Forms" "Example/Page/FormSimple.hs" $ do 16 | col ~ embed $ do 17 | hyper AddContact FormSimple.formView' 18 | 19 | example "Form Validation" "Example/Page/FormValidation.hs" $ do 20 | -- el $ do 21 | -- code "Validated" 22 | -- text " allows us to manage validation states for each form field" 23 | col ~ embed $ do 24 | hyper Signup $ FormValidation.formView genFields 25 | 26 | -------------------------------------------------------------------------------- /examples/Example/Page/Intro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Example.Page.Intro where 5 | 6 | import Example.AppRoute 7 | import Example.Page.Counter (Counter) 8 | import Example.Page.Counter qualified as Counter 9 | import Example.Page.Simple (Message) 10 | import Example.Page.Simple qualified as Simple 11 | import Example.View.Layout 12 | import Web.Atomic.CSS 13 | import Web.Hyperbole 14 | import Web.Hyperbole.HyperView.Types 15 | 16 | page :: (Hyperbole :> es) => Eff es (Page '[Message, Counter]) 17 | page = do 18 | simple <- Simple.page 19 | counter <- Counter.page 20 | pure $ exampleLayout Intro $ do 21 | example "Simple" "Example/Page/Simple.hs" $ do 22 | el "HyperViews update independently. In this example, two Message HyperViews are embedded into the same page with different ids." 23 | el "Try inspecting the page in the Chrome dev tools and watching both the DOM and messages" 24 | col ~ embed $ do 25 | addContext Root simple 26 | 27 | example "Counter" "Example/Page/Counter.hs" $ do 28 | el "Actions can have parameters for reusability, or to keep track of simple state" 29 | el $ do 30 | text "Use a view function to render the state: " 31 | code "viewCount :: Int -> View Counter ()." 32 | text "Notice how it expects the current count as a parameter" 33 | col ~ embed $ do 34 | addContext Root counter 35 | -------------------------------------------------------------------------------- /examples/Example/Page/Javascript.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.Javascript where 2 | 3 | import Control.Monad (forM_) 4 | import Data.Text (pack) 5 | import Example.AppRoute qualified as Route 6 | import Example.Colors 7 | import Example.View.Layout 8 | import Web.Atomic.CSS 9 | import Web.Hyperbole 10 | 11 | -- TODO: show how to do tooltips with only CSS 12 | -- TODO: a mouseover example that calls the server via runAction 13 | 14 | page :: (Hyperbole :> es) => Eff es (Page '[Boxes]) 15 | page = do 16 | pure $ exampleLayout Route.Javascript $ do 17 | example "JS Mouse Overs" "Example/Page/Javascript.hs" $ do 18 | el "You can implement your own mouseovers in javascript and call the server via the JS API. You should debounce to avoid overloading the server!" 19 | -- NOTE: include custom javascript only on this page 20 | script "custom.js" 21 | col ~ embed $ do 22 | hyper Boxes $ boxesView Nothing 23 | 24 | data Boxes = Boxes 25 | deriving (Generic, ViewId) 26 | 27 | instance HyperView Boxes es where 28 | data Action Boxes 29 | = Selected Int 30 | | Clear 31 | deriving (Generic, ViewAction) 32 | 33 | update (Selected n) = do 34 | pure $ boxesView (Just n) 35 | update Clear = do 36 | pure $ boxesView Nothing 37 | 38 | boxesView :: Maybe Int -> View Boxes () 39 | boxesView mn = do 40 | let ns = [0 .. 50] :: [Int] 41 | el ~ grid . gap 10 . pad 10 $ do 42 | el ~ double . border 2 . bold . fontSize 24 . pad 15 $ text $ pack $ maybe "" show mn 43 | forM_ ns $ \n -> do 44 | el @ onMouseEnter (Selected n) . onMouseLeave Clear ~ border 1 . pad 10 . pointer . hover (bg PrimaryLight) . textAlign AlignCenter $ text $ pack $ show n 45 | where 46 | grid :: (Styleable h) => CSS h -> CSS h 47 | grid = 48 | utility 49 | "grid" 50 | [ "display" :. "grid" 51 | , "grid-template-columns" :. "repeat(auto-fit, minmax(50px, 1fr))" 52 | ] 53 | 54 | double :: (Styleable h) => CSS h -> CSS h 55 | double = 56 | utility 57 | "double" 58 | [ "grid-column" :. "1 / span 2" 59 | , "grid-row" :. "1 / span 2" 60 | ] 61 | -------------------------------------------------------------------------------- /examples/Example/Page/Requests.hs: -------------------------------------------------------------------------------- 1 | module Example.Page.Requests where 2 | 3 | import Data.String.Conversions (cs) 4 | import Data.Text (Text) 5 | import Effectful 6 | import Example.AppRoute qualified as Route 7 | import Example.Colors 8 | import Example.Style as Style 9 | import Example.View.Layout (embed, example, exampleLayout) 10 | import Web.Atomic.CSS 11 | import Web.Hyperbole 12 | import Web.Hyperbole.Data.URI 13 | 14 | page :: (Hyperbole :> es) => Eff es (Page '[CheckRequest, ControlResponse, ControlClient]) 15 | page = do 16 | r <- request 17 | pure $ exampleLayout Route.Requests $ do 18 | example "Requests" source $ do 19 | el "The Hyperbole Effect allows us to access the Request, and manipulate the Client" 20 | col ~ embed $ hyper CheckRequest $ viewRequest r 21 | col ~ embed $ hyper ControlClient viewClient 22 | 23 | example "Response" source $ do 24 | el "It also allows us to directly affect the response" 25 | col ~ embed $ hyper ControlResponse responseView 26 | where 27 | source = "Example/Page/Requests.hs" 28 | 29 | -- REQUEst ------------------------------------------------- 30 | 31 | data CheckRequest = CheckRequest 32 | deriving (Generic, ViewId) 33 | 34 | instance HyperView CheckRequest es where 35 | data Action CheckRequest 36 | = Refresh 37 | deriving (Generic, ViewAction) 38 | 39 | update Refresh = do 40 | r <- request 41 | pure $ viewRequest r 42 | 43 | viewRequest :: Request -> View CheckRequest () 44 | viewRequest r = do 45 | col ~ gap 10 $ do 46 | el $ do 47 | text "Host: " 48 | text $ cs $ show r.host 49 | el $ do 50 | text "Path: " 51 | text $ cs $ show r.path 52 | el $ do 53 | text "Query: " 54 | text $ cs $ show r.query 55 | el $ do 56 | text "Cookies: " 57 | text $ cs $ show r.cookies 58 | 59 | button Refresh ~ Style.btnLight $ "Refresh" 60 | 61 | -- CLIENT ------------------------------------------------- 62 | 63 | data Message = Message 64 | { message :: Text 65 | } 66 | deriving (Generic, ToQuery) 67 | 68 | data ControlClient = ControlClient 69 | deriving (Generic, ViewId) 70 | 71 | instance HyperView ControlClient es where 72 | data Action ControlClient 73 | = SetQuery 74 | deriving (Generic, ViewAction) 75 | 76 | update SetQuery = do 77 | setQuery $ Message "hello" 78 | pure "Updated Query String" 79 | 80 | viewClient :: View ControlClient () 81 | viewClient = do 82 | button SetQuery ~ Style.btn $ "Set Query String" 83 | 84 | -- RESPONSE ------------------------------------------------- 85 | 86 | data ControlResponse = ControlResponse 87 | deriving (Generic, ViewId) 88 | 89 | instance HyperView ControlResponse es where 90 | data Action ControlResponse 91 | = RedirectAsAction 92 | | RespondNotFound 93 | | RespondEarlyView 94 | deriving (Generic, ViewAction) 95 | update RedirectAsAction = do 96 | redirect $ pathUri "/hello/redirected" 97 | update RespondNotFound = do 98 | _ <- notFound 99 | pure $ "This will not be rendered" 100 | update RespondEarlyView = do 101 | _ <- respondEarly ControlResponse $ "Responded early!" 102 | pure $ "This will not be rendered" 103 | 104 | responseView :: View ControlResponse () 105 | responseView = do 106 | row ~ gap 10 $ do 107 | button RedirectAsAction ~ Style.btn $ "Redirect Me" 108 | button RespondEarlyView ~ Style.btn $ "Respond Early" 109 | button RespondNotFound ~ Style.btn' Danger $ "Respond Not Found" 110 | -------------------------------------------------------------------------------- /examples/Example/Page/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Example.Page.Simple where 6 | 7 | import Data.Text (Text) 8 | import Web.Atomic.CSS 9 | import Web.Hyperbole 10 | 11 | main :: IO () 12 | main = do 13 | run 3000 $ do 14 | liveApp (basicDocument "Example") (runPage page) 15 | 16 | page :: (Hyperbole :> es) => Eff es (Page '[Message]) 17 | page = do 18 | pure $ do 19 | hyper Message1 $ messageView "Hello" 20 | hyper Message2 $ messageView "World!" 21 | 22 | data Message = Message1 | Message2 23 | deriving (Generic, ViewId) 24 | 25 | instance HyperView Message es where 26 | data Action Message = Louder Text 27 | deriving (Generic, ViewAction) 28 | 29 | update (Louder m) = do 30 | let new = m <> "!" 31 | pure $ messageView new 32 | 33 | messageView :: Text -> View Message () 34 | messageView m = do 35 | row ~ gap 10 $ do 36 | button (Louder m) ~ border 1 . pad 5 $ "Louder" 37 | el ~ pad 5 $ text m 38 | -------------------------------------------------------------------------------- /examples/Example/Page/State/Effects.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Example.Page.State.Effects where 4 | 5 | import Data.Text (pack) 6 | import Effectful 7 | import Effectful.Concurrent.STM 8 | import Effectful.Reader.Dynamic 9 | import Example.AppRoute hiding (Counter) 10 | import Example.Style as Style 11 | import Example.View.Layout 12 | import Web.Atomic.CSS 13 | import Web.Hyperbole as Hyperbole 14 | 15 | page :: (Hyperbole :> es, Concurrent :> es, Reader (TVar Int) :> es) => Eff es (Page '[Counter]) 16 | page = do 17 | n <- getCount 18 | pure $ do 19 | exampleLayout (State Effects) $ do 20 | example "Counter" "Example/Page/State/Effects.hs" $ do 21 | el $ do 22 | text "Pages and update functions can run side effects before rendering. Here we add a " 23 | code "Reader (TVar Int)" 24 | text "to track the count" 25 | el "Notice that the current count now persists after a browser refresh" 26 | col ~ embed $ hyper Counter (viewCount n) 27 | 28 | data Counter = Counter 29 | deriving (Generic, ViewId) 30 | 31 | instance (Reader (TVar Int) :> es, Concurrent :> es) => HyperView Counter es where 32 | data Action Counter 33 | = Increment 34 | | Decrement 35 | deriving (Generic, ViewAction) 36 | 37 | update Increment = do 38 | n <- modify (+ 1) 39 | pure $ viewCount n 40 | update Decrement = do 41 | n <- modify (subtract 1) 42 | pure $ viewCount n 43 | 44 | viewCount :: Int -> View Counter () 45 | viewCount n = col ~ gap 10 $ do 46 | row $ do 47 | el ~ bold . fontSize 48 . border 1 . pad (XY 20 0) $ text $ pack $ show n 48 | row ~ gap 10 $ do 49 | button Decrement "Decrement" ~ Style.btn 50 | button Increment "Increment" ~ Style.btn 51 | 52 | modify :: (Concurrent :> es, Reader (TVar Int) :> es) => (Int -> Int) -> Eff es Int 53 | modify f = do 54 | var <- ask 55 | atomically $ do 56 | modifyTVar var f 57 | readTVar var 58 | 59 | getCount :: (Concurrent :> es, Reader (TVar Int) :> es) => Eff es Int 60 | getCount = readTVarIO =<< ask 61 | 62 | initCounter :: (Concurrent :> es) => Eff es (TVar Int) 63 | initCounter = newTVarIO 0 64 | 65 | app :: TVar Int -> Application 66 | app var = do 67 | liveApp (basicDocument "Example") (runReader var . runConcurrent $ runPage page) 68 | -------------------------------------------------------------------------------- /examples/Example/Page/State/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Example.Page.State.Query where 5 | 6 | import Data.Text (Text) 7 | import Effectful 8 | import Example.AppRoute as Route 9 | import Example.Colors 10 | import Example.Style as Style 11 | import Example.View.Layout (embed, example, exampleLayout) 12 | import Web.Atomic.CSS 13 | import Web.Hyperbole 14 | import Web.Hyperbole.Effect.Query 15 | 16 | data Preferences = Preferences 17 | { message :: Text 18 | , color :: AppColor 19 | } 20 | deriving (Generic, Show, ToQuery, FromQuery) 21 | instance Default Preferences where 22 | def = Preferences mempty def 23 | 24 | page :: (Hyperbole :> es) => Eff es (Page '[Contents]) 25 | page = do 26 | prefs <- query @Preferences 27 | pure $ exampleLayout (State Query) $ do 28 | example "Query" "Example/Page/Query.hs" $ do 29 | el "Persist state in the query string" 30 | col ~ embed $ hyper Contents $ viewContent prefs 31 | 32 | data Contents = Contents 33 | deriving (Generic, ViewId) 34 | 35 | instance HyperView Contents es where 36 | data Action Contents 37 | = SaveColor AppColor 38 | | SaveMessage Text 39 | | ClearSession 40 | deriving (Generic, ViewAction) 41 | update (SaveColor clr) = do 42 | prefs <- modifyQuery $ \p -> p{color = clr} 43 | pure $ viewContent prefs 44 | update (SaveMessage msg) = do 45 | prefs <- modifyQuery $ \p -> p{message = msg} 46 | pure $ viewContent prefs 47 | update ClearSession = do 48 | setQuery @Preferences def 49 | pure $ viewContent def 50 | 51 | viewContent :: Preferences -> View Contents () 52 | viewContent prefs = do 53 | col ~ gap 20 $ do 54 | viewColorPicker prefs.color 55 | viewMessage prefs.message 56 | button ClearSession ~ Style.btnLight $ "Clear" 57 | 58 | viewColorPicker :: AppColor -> View Contents () 59 | viewColorPicker clr = do 60 | col ~ gap 10 . pad 20 . bg clr . border 1 $ do 61 | el ~ fontSize 18 . bold $ "Session Background" 62 | row ~ gap 10 $ do 63 | button (SaveColor Success) ~ (Style.btn' Success . border 1) $ "Successs" 64 | button (SaveColor Warning) ~ (Style.btn' Warning . border 1) $ "Warning" 65 | button (SaveColor Danger) ~ (Style.btn' Danger . border 1) $ "Danger" 66 | 67 | viewMessage :: Text -> View Contents () 68 | viewMessage msg = do 69 | col ~ gap 10 . pad 20 . border 1 $ do 70 | el ~ fontSize 18 . bold $ "Session Message" 71 | el $ text msg 72 | row ~ (gap 10) $ do 73 | button (SaveMessage "Hello") ~ Style.btnLight $ "Msg: Hello" 74 | button (SaveMessage "Goodbye") ~ Style.btnLight $ "Msg: Goodbye" 75 | -------------------------------------------------------------------------------- /examples/Example/Page/State/Sessions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Example.Page.State.Sessions where 5 | 6 | import Data.Text (Text) 7 | import Effectful 8 | import Example.AppRoute as Route 9 | import Example.Colors 10 | import Example.Style as Style 11 | import Example.View.Layout (embed, example, exampleLayout) 12 | import Web.Atomic.CSS 13 | import Web.Hyperbole 14 | 15 | data Preferences = Preferences 16 | { message :: Text 17 | , color :: AppColor 18 | } 19 | deriving (Generic, Show, ToJSON, FromJSON, FromParam, ToParam, Session) 20 | instance Default Preferences where 21 | def = Preferences "_" White 22 | 23 | page :: (Hyperbole :> es) => Eff es (Page '[Contents]) 24 | page = do 25 | prefs <- session @Preferences 26 | pure $ exampleLayout (State Sessions) $ do 27 | example "Sessions" "Example/Page/Sessions.hs" $ do 28 | el "Persist state in a browser cookie" 29 | col ~ embed $ hyper Contents $ viewContent prefs 30 | 31 | data Contents = Contents 32 | deriving (Generic, ViewId) 33 | 34 | instance HyperView Contents es where 35 | data Action Contents 36 | = SaveColor AppColor 37 | | SaveMessage Text 38 | | ClearSession 39 | deriving (Generic, ViewAction) 40 | update (SaveColor clr) = do 41 | prefs <- modifySession $ \p -> p{color = clr} 42 | pure $ viewContent prefs 43 | update (SaveMessage msg) = do 44 | prefs <- modifySession $ \p -> p{message = msg} 45 | pure $ viewContent prefs 46 | update ClearSession = do 47 | deleteSession @Preferences 48 | pure $ viewContent def 49 | 50 | viewContent :: Preferences -> View Contents () 51 | viewContent prefs = do 52 | col ~ gap 20 $ do 53 | viewColorPicker prefs.color 54 | viewMessage prefs.message 55 | button ClearSession ~ Style.btnLight $ "Clear" 56 | 57 | viewColorPicker :: AppColor -> View Contents () 58 | viewColorPicker clr = do 59 | col ~ gap 10 . pad 20 . bg clr . border 1 $ do 60 | el ~ fontSize 18 . bold $ "Session Background" 61 | row ~ gap 10 $ do 62 | button (SaveColor Success) ~ (Style.btn' Success . border 1) $ "Successs" 63 | button (SaveColor Warning) ~ (Style.btn' Warning . border 1) $ "Warning" 64 | button (SaveColor Danger) ~ (Style.btn' Danger . border 1) $ "Danger" 65 | 66 | viewMessage :: Text -> View Contents () 67 | viewMessage msg = do 68 | col ~ gap 10 . pad 20 . border 1 $ do 69 | el ~ fontSize 18 . bold $ "Session Message" 70 | el $ text msg 71 | row ~ (gap 10) $ do 72 | button (SaveMessage "Hello") ~ Style.btnLight $ "Msg: Hello" 73 | button (SaveMessage "Goodbye") ~ Style.btnLight $ "Msg: Goodbye" 74 | -------------------------------------------------------------------------------- /examples/Example/Page/Todo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Example.Page.Todo where 6 | 7 | import Control.Monad (forM_) 8 | import Data.Text (Text, pack) 9 | import Effectful 10 | import Example.AppRoute qualified as Route 11 | import Example.Colors 12 | import Example.Effects.Todos (Todo (..), TodoId, Todos, runTodosSession) 13 | import Example.Effects.Todos qualified as Todos 14 | import Example.Style qualified as Style 15 | import Example.View.Icon qualified as Icon 16 | import Example.View.Inputs (toggleCheckbox) 17 | import Example.View.Layout 18 | import Web.Atomic.CSS 19 | import Web.Hyperbole as Hyperbole 20 | 21 | page :: (Todos :> es) => Eff es (Page '[AllTodos, TodoView]) 22 | page = do 23 | todos <- Todos.loadAll 24 | pure $ exampleLayout Route.Todos $ do 25 | example "Todos" "Example/Page/Todo.hs" $ do 26 | col ~ embed $ hyper AllTodos $ todosView FilterAll todos 27 | 28 | simplePage :: (Todos :> es) => Eff es (Page '[AllTodos, TodoView]) 29 | simplePage = do 30 | todos <- Todos.loadAll 31 | pure $ do 32 | hyper AllTodos $ todosView FilterAll todos 33 | 34 | --- AllTodos ---------------------------------------------------------------------------- 35 | 36 | data AllTodos = AllTodos 37 | deriving (Generic, ViewId) 38 | 39 | instance (Todos :> es) => HyperView AllTodos es where 40 | type Require AllTodos = '[TodoView] 41 | 42 | data Action AllTodos 43 | = ClearCompleted 44 | | Filter FilterTodo 45 | | SubmitTodo 46 | | ToggleAll FilterTodo 47 | | SetCompleted FilterTodo Todo Bool 48 | deriving (Generic, ViewAction) 49 | 50 | update = \case 51 | SubmitTodo -> do 52 | TodoForm task <- formData @(TodoForm Identity) 53 | _ <- Todos.create task 54 | todos <- Todos.loadAll 55 | pure $ todosView FilterAll todos 56 | ToggleAll filt -> do 57 | todos <- filteredTodos filt 58 | updated <- Todos.toggleAll todos 59 | pure $ todosView filt updated 60 | ClearCompleted -> do 61 | todos <- Todos.clearCompleted 62 | pure $ todosView FilterAll todos 63 | Filter filt -> do 64 | todos <- filteredTodos filt 65 | pure $ todosView filt todos 66 | SetCompleted filt todo completed -> do 67 | _ <- Todos.setCompleted completed todo 68 | todos <- filteredTodos filt 69 | pure $ todosView filt todos 70 | where 71 | filteredTodos filt = 72 | filter (isFilter filt) <$> Todos.loadAll 73 | 74 | isFilter filt todo = 75 | case filt of 76 | FilterAll -> True 77 | Active -> not todo.completed 78 | Completed -> todo.completed 79 | 80 | data FilterTodo 81 | = FilterAll 82 | | Active 83 | | Completed 84 | deriving (Eq, Generic, ToJSON, FromJSON) 85 | 86 | todosView :: FilterTodo -> [Todo] -> View AllTodos () 87 | todosView filt todos = do 88 | todoForm filt 89 | col $ do 90 | forM_ todos $ \todo -> do 91 | hyper (TodoView todo.id) $ todoView filt todo 92 | statusBar filt todos 93 | 94 | todoForm :: FilterTodo -> View AllTodos () 95 | todoForm filt = do 96 | let f :: TodoForm FieldName = fieldNames 97 | row ~ border 1 $ do 98 | el ~ pad 8 $ do 99 | button (ToggleAll filt) Icon.chevronDown ~ width 32 . hover (color Primary) 100 | form SubmitTodo ~ grow $ do 101 | field f.task $ do 102 | input TextInput ~ pad 12 @ placeholder "What needs to be done?" . value "" 103 | 104 | data TodoForm f = TodoForm 105 | { task :: Field f Text 106 | } 107 | deriving (Generic, FromFormF, GenFields FieldName) 108 | 109 | statusBar :: FilterTodo -> [Todo] -> View AllTodos () 110 | statusBar filt todos = do 111 | row ~ pad 10 . color SecondaryLight $ do 112 | let numLeft = length $ filter (\t -> not t.completed) todos 113 | el $ do 114 | text $ pack (show numLeft) 115 | text " items left!" 116 | space 117 | row ~ gap 10 $ do 118 | filterButton FilterAll "All" 119 | filterButton Active "Active" 120 | filterButton Completed "Completed" 121 | space 122 | button ClearCompleted ~ hover (color Primary) $ "Clear completed" 123 | where 124 | filterButton f = 125 | button (Filter f) ~ selectedFilter f . pad (XY 4 0) . rounded 2 126 | selectedFilter f = 127 | if f == filt then border 1 else id 128 | 129 | --- TodoView ---------------------------------------------------------------------------- 130 | 131 | data TodoView = TodoView TodoId 132 | deriving (Generic, ViewId) 133 | 134 | instance (Todos :> es) => HyperView TodoView es where 135 | type Require TodoView = '[AllTodos] 136 | 137 | data Action TodoView 138 | = Edit FilterTodo Todo 139 | | SubmitEdit FilterTodo Todo 140 | deriving (Generic, ViewAction) 141 | 142 | update (Edit filt todo) = do 143 | pure $ todoEditView filt todo 144 | update (SubmitEdit filt todo) = do 145 | TodoForm task <- formData @(TodoForm Identity) 146 | updated <- Todos.setTask task todo 147 | pure $ todoView filt updated 148 | 149 | todoView :: FilterTodo -> Todo -> View TodoView () 150 | todoView filt todo = do 151 | row ~ border (TRBL 0 0 1 0) . pad 10 $ do 152 | target AllTodos $ do 153 | toggleCheckbox (SetCompleted filt todo) todo.completed 154 | el (text todo.task) @ onDblClick (Edit filt todo) ~ completed . pad (XY 18 4) 155 | where 156 | completed = if todo.completed then Style.strikethrough else id 157 | 158 | todoEditView :: FilterTodo -> Todo -> View TodoView () 159 | todoEditView filt todo = do 160 | let f = fieldNames @TodoForm 161 | row ~ border (TRBL 0 0 1 0) . pad 10 $ do 162 | form (SubmitEdit filt todo) ~ pad (TRBL 0 0 0 46) $ do 163 | field f.task $ do 164 | input TextInput @ value todo.task . autofocus ~ pad 4 165 | 166 | main :: IO () 167 | main = do 168 | run 3000 $ do 169 | liveApp (basicDocument "Example") (runTodosSession $ runPage page) 170 | -------------------------------------------------------------------------------- /examples/Example/Style.hs: -------------------------------------------------------------------------------- 1 | module Example.Style where 2 | 3 | import Example.Colors 4 | import Web.Atomic.CSS 5 | 6 | btn :: (Styleable h) => CSS h -> CSS h 7 | btn = btn' Primary 8 | 9 | btn' :: (Styleable h) => AppColor -> CSS h -> CSS h 10 | btn' clr = 11 | bg clr 12 | . hover (bg (hovClr clr)) 13 | . color (txtClr clr) 14 | . pad 10 15 | . shadow () 16 | . rounded 3 17 | where 18 | hovClr Primary = PrimaryLight 19 | hovClr c = c 20 | txtClr _ = White 21 | 22 | btnLight :: (Styleable h) => CSS h -> CSS h 23 | btnLight = 24 | base 25 | . border 2 26 | . borderColor Secondary 27 | . color Secondary 28 | . hover (borderColor SecondaryLight . color SecondaryLight) 29 | where 30 | base = pad (XY 15 8) 31 | 32 | h1 :: (Styleable h) => CSS h -> CSS h 33 | h1 = bold . fontSize 32 34 | 35 | invalid :: (Styleable h) => CSS h -> CSS h 36 | invalid = color Danger 37 | 38 | success :: (Styleable h) => CSS h -> CSS h 39 | success = color Success 40 | 41 | link :: (Styleable h) => CSS h -> CSS h 42 | link = color Primary . underline 43 | 44 | input :: (Styleable h) => CSS h -> CSS h 45 | input = border 1 . pad 8 46 | 47 | -- code :: (Styleable h) => CSS h -> CSS h 48 | -- code = bg Light . pad 10 . fontSize 12 49 | 50 | strikethrough :: (Styleable h) => CSS h -> CSS h 51 | strikethrough = 52 | utility "strike" ["text-decoration" :. "line-through"] 53 | -------------------------------------------------------------------------------- /examples/Example/View/Icon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Example.View.Icon where 4 | 5 | import Data.String.Interpolate (i) 6 | import Web.Hyperbole.View 7 | 8 | hamburger :: View c () 9 | hamburger = 10 | raw 11 | [i| 12 | 13 | 14 | |] 15 | 16 | xCircle :: View c () 17 | xCircle = raw $ do 18 | [i| 19 | 20 | |] 21 | 22 | checkCircle :: View c () 23 | checkCircle = raw $ do 24 | [i| 25 | 26 | |] 27 | 28 | check :: View c () 29 | check = raw $ do 30 | [i| 31 | 32 | |] 33 | 34 | chevronDown :: View c () 35 | chevronDown = raw $ do 36 | [i| 37 | 38 | |] 39 | -------------------------------------------------------------------------------- /examples/Example/View/Inputs.hs: -------------------------------------------------------------------------------- 1 | module Example.View.Inputs where 2 | 3 | import Example.Colors 4 | import Web.Atomic.CSS 5 | import Web.Hyperbole 6 | 7 | toggleCheckbox :: (ViewAction (Action id)) => (Bool -> Action id) -> Bool -> View id () 8 | toggleCheckbox clickAction isSelected = do 9 | tag "input" @ att "type" "checkbox" . onClick (clickAction (not isSelected)) . checked isSelected ~ big $ none 10 | where 11 | big = width 32 . height 32 12 | 13 | progressBar :: Float -> View context () -> View context () 14 | progressBar pct content = do 15 | row ~ bg Light $ do 16 | row ~ bg PrimaryLight . width (Pct pct) . pad 5 $ content 17 | -------------------------------------------------------------------------------- /examples/Example/View/SortableTable.hs: -------------------------------------------------------------------------------- 1 | module Example.View.SortableTable where 2 | 3 | import Data.Text (Text) 4 | import Example.Colors 5 | import Example.Style qualified as Style 6 | import Example.View.Icon qualified as Icon 7 | import Web.Atomic.CSS 8 | import Web.Hyperbole 9 | import Prelude hiding (even, odd) 10 | 11 | dataRow :: (Styleable a) => CSS a -> CSS a 12 | dataRow = gap 10 . pad (All $ PxRem dataRowPadding) 13 | 14 | dataRowPadding :: PxRem 15 | dataRowPadding = 5 16 | 17 | bord :: (Styleable a) => CSS a -> CSS a 18 | bord = border 1 . borderColor Light 19 | 20 | hd :: View id () -> TableHead id () 21 | hd = th ~ pad 4 . bord . bg Light 22 | 23 | cell :: (Styleable a) => CSS a -> CSS a 24 | cell = pad 4 . bord 25 | 26 | dataTable :: (Styleable a) => CSS a -> CSS a 27 | dataTable = 28 | css 29 | "data-table" 30 | ".data-table tr:nth-child(even)" 31 | (declarations (bg Light)) 32 | 33 | sortBtn :: (ViewAction (Action id)) => Text -> Action id -> Bool -> View id () 34 | sortBtn lbl click isSelected = do 35 | button click ~ Style.link . flexRow . gap 0 $ do 36 | el ~ selectedColumn $ (text lbl) 37 | el ~ width 20 $ Icon.chevronDown 38 | where 39 | selectedColumn = 40 | if isSelected 41 | then underline 42 | else id 43 | 44 | sortColumn :: (ViewAction (Action id)) => View id () -> (dt -> Text) -> TableColumns id dt () 45 | sortColumn header cellText = do 46 | tcol (hd header) $ \item -> 47 | td ~ cell $ text $ cellText item 48 | -------------------------------------------------------------------------------- /examples/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Example.App qualified as App 4 | 5 | main :: IO () 6 | main = App.run 7 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | Hyperbole Examples 2 | =================== 3 | 4 | Visit https://docs.hyperbole.live to view these examples with source code 5 | -------------------------------------------------------------------------------- /examples/examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: examples 8 | version: 0.4.3 9 | synopsis: Interactive HTML apps using type-safe serverside Haskell 10 | description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView 11 | category: Web, Network 12 | homepage: https://github.com/seanhess/hyperbole 13 | bug-reports: https://github.com/seanhess/hyperbole/issues 14 | author: Sean Hess 15 | maintainer: seanhess@gmail.com 16 | license: BSD-3-Clause 17 | build-type: Simple 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/seanhess/hyperbole 22 | 23 | executable examples 24 | main-is: Main.hs 25 | other-modules: 26 | Example.App 27 | Example.AppRoute 28 | Example.Cache 29 | Example.Colors 30 | Example.Data.ProgrammingLanguage 31 | Example.Docs.App 32 | Example.Docs.BasicPage 33 | Example.Docs.Component 34 | Example.Docs.Encoding 35 | Example.Docs.Interactive 36 | Example.Docs.MultiCopies 37 | Example.Docs.MultiPage 38 | Example.Docs.MultiView 39 | Example.Docs.Nested 40 | Example.Docs.Page.Messages 41 | Example.Docs.Page.Users 42 | Example.Docs.Params 43 | Example.Docs.Sessions 44 | Example.Docs.SideEffects 45 | Example.Docs.State 46 | Example.Docs.ViewFunctions 47 | Example.Effects.Debug 48 | Example.Effects.Random 49 | Example.Effects.Todos 50 | Example.Effects.Users 51 | Example.Page.Autocomplete 52 | Example.Page.Concurrency 53 | Example.Page.Contact 54 | Example.Page.Contacts 55 | Example.Page.Counter 56 | Example.Page.CSS 57 | Example.Page.CSS.External 58 | Example.Page.CSS.Tooltips 59 | Example.Page.CSS.Transitions 60 | Example.Page.DataTable 61 | Example.Page.Errors 62 | Example.Page.Filter 63 | Example.Page.Forms 64 | Example.Page.FormSimple 65 | Example.Page.FormValidation 66 | Example.Page.Intro 67 | Example.Page.Javascript 68 | Example.Page.Requests 69 | Example.Page.Simple 70 | Example.Page.State.Effects 71 | Example.Page.State.Query 72 | Example.Page.State.Sessions 73 | Example.Page.Todo 74 | Example.Style 75 | Example.View.Icon 76 | Example.View.Inputs 77 | Example.View.Layout 78 | Example.View.SortableTable 79 | Paths_examples 80 | autogen-modules: 81 | Paths_examples 82 | hs-source-dirs: 83 | ./ 84 | default-extensions: 85 | OverloadedStrings 86 | OverloadedRecordDot 87 | DuplicateRecordFields 88 | NoFieldSelectors 89 | TypeFamilies 90 | DataKinds 91 | DerivingStrategies 92 | DeriveAnyClass 93 | ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N 94 | build-depends: 95 | aeson 96 | , atomic-css 97 | , base 98 | , bytestring 99 | , casing 100 | , containers 101 | , cookie 102 | , data-default 103 | , effectful 104 | , file-embed 105 | , foreign-store 106 | , http-api-data 107 | , http-types 108 | , hyperbole 109 | , network 110 | , random 111 | , safe 112 | , string-conversions 113 | , string-interpolate 114 | , text 115 | , time 116 | , wai 117 | , wai-middleware-static 118 | , wai-websockets 119 | , warp 120 | , websockets 121 | default-language: GHC2021 122 | -------------------------------------------------------------------------------- /examples/fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # # Number of spaces per indentation step 2 | indentation: 2 3 | # 4 | # # Max line length for automatic line breaking 5 | # column-limit: none 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | # comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: leading 15 | 16 | # # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | # indent-wheres: false 18 | # 19 | # # Whether to leave a space before an opening record brace 20 | # record-brace-space: false 21 | 22 | # # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | # 25 | # # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | # haddock-style: multi-line 27 | # 28 | # # How to print module docstring 29 | # haddock-style-module: null 30 | 31 | # # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | # let-style: auto 33 | # 34 | # # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | # in-style: right-align 36 | # 37 | # # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | # single-constraint-parens: always 39 | # 40 | # # Output Unicode syntax (choices: detect, always, or never) 41 | # unicode: never 42 | # 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # # Fixity information for operators 47 | # fixities: [] 48 | # 49 | # # Module reexports Fourmolu should know about 50 | # reexports: [] 51 | 52 | -------------------------------------------------------------------------------- /examples/hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /examples/package.yaml: -------------------------------------------------------------------------------- 1 | name: examples 2 | version: 0.4.3 3 | synopsis: Interactive HTML apps using type-safe serverside Haskell 4 | homepage: https://github.com/seanhess/hyperbole 5 | github: seanhess/hyperbole 6 | license: BSD-3-Clause 7 | author: Sean Hess 8 | maintainer: seanhess@gmail.com 9 | category: Web, Network 10 | description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView 11 | 12 | language: GHC2021 13 | 14 | ghc-options: 15 | - -Wall 16 | - -fdefer-typed-holes 17 | 18 | default-extensions: 19 | - OverloadedStrings 20 | - OverloadedRecordDot 21 | - DuplicateRecordFields 22 | - NoFieldSelectors 23 | - TypeFamilies 24 | - DataKinds 25 | - DerivingStrategies 26 | - DeriveAnyClass 27 | 28 | dependencies: 29 | - base 30 | - aeson 31 | - bytestring 32 | - containers 33 | - casing 34 | - data-default 35 | - effectful 36 | - text 37 | - time 38 | - string-interpolate 39 | - file-embed 40 | - http-api-data 41 | - http-types 42 | - random 43 | - wai 44 | - warp 45 | - atomic-css 46 | - string-conversions 47 | - wai-websockets 48 | - network 49 | - websockets 50 | - cookie 51 | - hyperbole 52 | 53 | executables: 54 | examples: 55 | main: Main.hs 56 | ghc-options: 57 | - -threaded 58 | - -rtsopts 59 | - -with-rtsopts=-N 60 | source-dirs: 61 | - ./ 62 | dependencies: 63 | - wai-middleware-static 64 | - safe 65 | - foreign-store 66 | -------------------------------------------------------------------------------- /examples/static/custom.js: -------------------------------------------------------------------------------- 1 | console.log("Custom JS 2!") 2 | 3 | 4 | // Wait for load 5 | window.onload = function() { 6 | let boxes = Hyperbole.hyperView("Boxes") 7 | // document.addEventListener("mouseover", function(e) { 8 | // // if (e.target.classList.contains("box")) { 9 | // // let selected = Hyperbole.action("Selected", parseInt(e.target.innerHTML)) 10 | // // boxes.runAction(selected) 11 | // // } 12 | // }) 13 | // document.addEventListener("mouseout", function(e) { 14 | // // if (e.target.classList.contains("box")) { 15 | // // boxes.runAction("Clear") 16 | // // } 17 | // }) 18 | // document.addEventListener("hyp-content", function(e) { 19 | // // console.log("HYP CONTENT", e.target) 20 | // // document.querySelectorAll("box").forEach(node => { 21 | // // node. 22 | // // }) 23 | // }) 24 | 25 | // // lookup the hyperview 26 | // let message2 = Hyperbole.hyperView("Message2") 27 | // 28 | // if (message2) { 29 | // // call runAction() on the HyperView 30 | // message2.runAction(Hyperbole.action('Louder', "asdf")) 31 | // 32 | // // Alternatively, call runAction() on window.Hyperbole 33 | // setTimeout(() => { 34 | // Hyperbole.runAction(message2, Hyperbole.action('Reset', "reset")) 35 | // }, 2000) 36 | // } 37 | } 38 | -------------------------------------------------------------------------------- /examples/static/examples.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seanhess/hyperbole/a876bfa4d2e4eb7bc6c8d5a69c3f3b459a5e7b64/examples/static/examples.png -------------------------------------------------------------------------------- /examples/static/external.css: -------------------------------------------------------------------------------- 1 | .item { 2 | border: 1px dashed; 3 | padding: 5px; 4 | padding-left: 10px; 5 | padding-right: 10px; 6 | } 7 | 8 | .parent { 9 | display: flex; 10 | flex-direction: row; 11 | gap: 10px; 12 | padding: 10px; 13 | background-color: white; 14 | } 15 | 16 | .selected { 17 | font-weight: bold; 18 | border-width: 2px; 19 | padding: 4px; 20 | padding-left: 9px; 21 | padding-right: 9px; 22 | } 23 | -------------------------------------------------------------------------------- /examples/static/logo-robot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seanhess/hyperbole/a876bfa4d2e4eb7bc6c8d5a69c3f3b459a5e7b64/examples/static/logo-robot.png -------------------------------------------------------------------------------- /examples/static/nso.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seanhess/hyperbole/a876bfa4d2e4eb7bc6c8d5a69c3f3b459a5e7b64/examples/static/nso.png -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # # Number of spaces per indentation step 2 | indentation: 2 3 | # 4 | # # Max line length for automatic line breaking 5 | # column-limit: none 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | # comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: leading 15 | 16 | # # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | # indent-wheres: false 18 | # 19 | # # Whether to leave a space before an opening record brace 20 | # record-brace-space: false 21 | 22 | # # Number of spaces between top-level declarations 23 | newlines-between-decls: 2 24 | # 25 | # # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | # haddock-style: multi-line 27 | # 28 | # # How to print module docstring 29 | # haddock-style-module: null 30 | 31 | # # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | # let-style: auto 33 | # 34 | # # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | # in-style: right-align 36 | # 37 | # # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | # single-constraint-parens: always 39 | # 40 | # # Output Unicode syntax (choices: detect, always, or never) 41 | # unicode: never 42 | # 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # # Fixity information for operators 47 | # fixities: [] 48 | # 49 | # # Module reexports Fourmolu should know about 50 | # reexports: [] 51 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /hyperbole.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: hyperbole 8 | version: 0.4.3 9 | synopsis: Interactive HTML apps using type-safe serverside Haskell 10 | description: Interactive serverside web framework Inspired by HTMX, Elm, and Phoenix LiveView 11 | category: Web, Network 12 | homepage: https://github.com/seanhess/hyperbole 13 | bug-reports: https://github.com/seanhess/hyperbole/issues 14 | author: Sean Hess 15 | maintainer: seanhess@gmail.com 16 | license: BSD-3-Clause 17 | license-file: LICENSE 18 | build-type: Simple 19 | tested-with: 20 | GHC == 9.8.2 21 | , GHC == 9.6.6 22 | extra-source-files: 23 | client/dist/hyperbole.js 24 | extra-doc-files: 25 | README.md 26 | CHANGELOG.md 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/seanhess/hyperbole 31 | 32 | library 33 | exposed-modules: 34 | Web.Hyperbole 35 | Web.Hyperbole.Application 36 | Web.Hyperbole.Data.Cookie 37 | Web.Hyperbole.Data.Encoded 38 | Web.Hyperbole.Data.Param 39 | Web.Hyperbole.Data.QueryData 40 | Web.Hyperbole.Data.URI 41 | Web.Hyperbole.Effect.Event 42 | Web.Hyperbole.Effect.Handler 43 | Web.Hyperbole.Effect.Hyperbole 44 | Web.Hyperbole.Effect.Javascript 45 | Web.Hyperbole.Effect.Query 46 | Web.Hyperbole.Effect.Request 47 | Web.Hyperbole.Effect.Response 48 | Web.Hyperbole.Effect.Server 49 | Web.Hyperbole.Effect.Session 50 | Web.Hyperbole.HyperView 51 | Web.Hyperbole.HyperView.Event 52 | Web.Hyperbole.HyperView.Forms 53 | Web.Hyperbole.HyperView.Input 54 | Web.Hyperbole.HyperView.Types 55 | Web.Hyperbole.Page 56 | Web.Hyperbole.Route 57 | Web.Hyperbole.TypeList 58 | Web.Hyperbole.View 59 | Web.Hyperbole.View.CSS 60 | Web.Hyperbole.View.Embed 61 | Web.Hyperbole.View.Render 62 | Web.Hyperbole.View.Tag 63 | Web.Hyperbole.View.Types 64 | other-modules: 65 | Paths_hyperbole 66 | autogen-modules: 67 | Paths_hyperbole 68 | hs-source-dirs: 69 | src 70 | default-extensions: 71 | OverloadedStrings 72 | OverloadedRecordDot 73 | DuplicateRecordFields 74 | NoFieldSelectors 75 | TypeFamilies 76 | DataKinds 77 | DerivingStrategies 78 | DeriveAnyClass 79 | ghc-options: -Wall -fdefer-typed-holes 80 | build-depends: 81 | aeson 82 | , atomic-css ==0.1.* 83 | , attoparsec 84 | , attoparsec-aeson 85 | , base >=4.16 && <5 86 | , bytestring >=0.11 && <0.13 87 | , casing >0.1 && <0.2 88 | , containers >=0.6 && <1 89 | , cookie >=0.4 && <0.6 90 | , data-default >0.8 && <0.9 91 | , effectful >=2.4 && <3 92 | , file-embed >=0.0.10 && <0.1 93 | , filepath 94 | , http-api-data ==0.6.* 95 | , http-types ==0.12.* 96 | , network >=3.1 && <4 97 | , network-uri 98 | , string-conversions ==0.4.* 99 | , string-interpolate ==0.3.* 100 | , text >=1.2 && <3 101 | , time >=1.12 && <2 102 | , wai >=3.2 && <4 103 | , wai-websockets >=3.0 && <4 104 | , warp >=3.3 && <4 105 | , websockets >=0.12 && <0.14 106 | default-language: GHC2021 107 | 108 | test-suite test 109 | type: exitcode-stdio-1.0 110 | main-is: Spec.hs 111 | other-modules: 112 | Test.EncodedSpec 113 | Test.FormSpec 114 | Test.QuerySpec 115 | Test.RouteSpec 116 | Test.SessionSpec 117 | Test.ViewActionSpec 118 | Test.ViewIdSpec 119 | Paths_hyperbole 120 | autogen-modules: 121 | Paths_hyperbole 122 | hs-source-dirs: 123 | test 124 | default-extensions: 125 | OverloadedStrings 126 | OverloadedRecordDot 127 | DuplicateRecordFields 128 | NoFieldSelectors 129 | TypeFamilies 130 | DataKinds 131 | DerivingStrategies 132 | DeriveAnyClass 133 | ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor 134 | build-depends: 135 | aeson 136 | , atomic-css ==0.1.* 137 | , attoparsec 138 | , attoparsec-aeson 139 | , base >=4.16 && <5 140 | , bytestring >=0.11 && <0.13 141 | , casing >0.1 && <0.2 142 | , containers >=0.6 && <1 143 | , cookie >=0.4 && <0.6 144 | , data-default >0.8 && <0.9 145 | , effectful >=2.4 && <3 146 | , file-embed >=0.0.10 && <0.1 147 | , filepath 148 | , http-api-data ==0.6.* 149 | , http-types ==0.12.* 150 | , hyperbole 151 | , network >=3.1 && <4 152 | , network-uri 153 | , skeletest 154 | , string-conversions ==0.4.* 155 | , string-interpolate ==0.3.* 156 | , text >=1.2 && <3 157 | , time >=1.12 && <2 158 | , wai >=3.2 && <4 159 | , wai-websockets >=3.0 && <4 160 | , warp >=3.3 && <4 161 | , websockets >=0.12 && <0.14 162 | default-language: GHC2021 163 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: hyperbole 2 | version: 0.4.3 3 | synopsis: Interactive HTML apps using type-safe serverside Haskell 4 | homepage: https://github.com/seanhess/hyperbole 5 | github: seanhess/hyperbole 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Sean Hess 9 | maintainer: seanhess@gmail.com 10 | category: Web, Network 11 | description: Interactive serverside web framework Inspired by HTMX, Elm, and Phoenix LiveView 12 | 13 | extra-doc-files: 14 | - README.md 15 | - CHANGELOG.md 16 | 17 | extra-source-files: 18 | - client/dist/hyperbole.js 19 | 20 | language: GHC2021 21 | 22 | ghc-options: 23 | - -Wall 24 | - -fdefer-typed-holes 25 | 26 | tested-with: 27 | - GHC == 9.8.2 28 | - GHC == 9.6.6 29 | 30 | default-extensions: 31 | - OverloadedStrings 32 | - OverloadedRecordDot 33 | - DuplicateRecordFields 34 | - NoFieldSelectors 35 | - TypeFamilies 36 | - DataKinds 37 | - DerivingStrategies 38 | - DeriveAnyClass 39 | 40 | dependencies: 41 | - base >=4.16 && <5 42 | - aeson 43 | - attoparsec 44 | - attoparsec-aeson 45 | - bytestring >= 0.11 && <0.13 46 | - containers >= 0.6 && <1 47 | - casing > 0.1 && <0.2 48 | - data-default > 0.8 && <0.9 49 | - effectful >= 2.4 && <3 50 | - text >= 1.2 && <3 51 | - time >= 1.12 && <2 52 | - string-interpolate >= 0.3 && <0.4 53 | - file-embed >= 0.0.10 && <0.1 54 | - http-api-data >= 0.6 && <0.7 55 | - http-types >= 0.12 && <0.13 56 | - network-uri 57 | - wai >= 3.2 && <4 58 | - warp >= 3.3 && <4 59 | - atomic-css >= 0.1 && < 0.2 60 | - string-conversions >= 0.4 && <0.5 61 | - wai-websockets >= 3.0 && <4 62 | - network >= 3.1 && <4 63 | - websockets >= 0.12 && <0.14 64 | - cookie >=0.4 && <0.6 65 | - filepath 66 | 67 | library: 68 | source-dirs: src 69 | 70 | tests: 71 | test: 72 | main: Spec.hs 73 | source-dirs: test 74 | ghc-options: 75 | - -threaded 76 | - -rtsopts 77 | - -with-rtsopts=-N 78 | - -F -pgmF=skeletest-preprocessor 79 | dependencies: 80 | - hyperbole 81 | - skeletest 82 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Data/Cookie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Web.Hyperbole.Data.Cookie where 4 | 5 | import Data.ByteString (ByteString) 6 | import Data.Map.Strict (Map) 7 | import Data.Map.Strict qualified as M 8 | import Data.Maybe (fromMaybe) 9 | import Data.String.Conversions (cs) 10 | import Data.Text (Text) 11 | import Network.HTTP.Types (urlDecode, urlEncode) 12 | import Web.Hyperbole.Data.URI 13 | 14 | 15 | type Key = Text 16 | 17 | 18 | data Cookie = Cookie 19 | { key :: Key 20 | , path :: Maybe Path 21 | , value :: Maybe CookieValue 22 | } 23 | deriving (Show, Eq) 24 | 25 | 26 | newtype Cookies = Cookies (Map Key Cookie) 27 | deriving newtype (Monoid, Semigroup, Show, Eq) 28 | 29 | 30 | newtype CookieValue = CookieValue ByteString 31 | deriving newtype (Show, Eq) 32 | 33 | 34 | insert :: Cookie -> Cookies -> Cookies 35 | insert cookie (Cookies m) = 36 | Cookies $ M.insert cookie.key cookie m 37 | 38 | 39 | delete :: Key -> Cookies -> Cookies 40 | delete key (Cookies m) = 41 | Cookies $ M.delete key m 42 | 43 | 44 | lookup :: Key -> Cookies -> Maybe CookieValue 45 | lookup key (Cookies m) = do 46 | cook <- M.lookup key m 47 | cook.value 48 | 49 | 50 | fromList :: [Cookie] -> Cookies 51 | fromList cks = Cookies $ M.fromList (fmap keyValue cks) 52 | where 53 | keyValue c = (c.key, c) 54 | 55 | 56 | toList :: Cookies -> [Cookie] 57 | toList (Cookies m) = M.elems m 58 | 59 | 60 | render :: Path -> Cookie -> ByteString 61 | render requestPath cookie = 62 | let p = fromMaybe requestPath cookie.path 63 | in cs cookie.key <> "=" <> value cookie.value <> "; SameSite=None; secure; path=" <> cs (uriToText (pathUri p)) 64 | where 65 | value Nothing = "; expires=Thu, 01 Jan 1970 00:00:00 GMT" 66 | value (Just (CookieValue val)) = urlEncode True $ cs val 67 | 68 | 69 | parse :: [(ByteString, ByteString)] -> Either Text Cookies 70 | parse kvs = do 71 | cks <- mapM (uncurry parseValue) kvs 72 | pure $ fromList cks 73 | 74 | 75 | parseValue :: ByteString -> ByteString -> Either Text Cookie 76 | parseValue k val = do 77 | let cval = CookieValue $ cs $ urlDecode True val 78 | pure $ Cookie (cs k) Nothing (Just $ cval) 79 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Data/URI.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.Data.URI 2 | ( URI (..) 3 | , Segment 4 | , Path (..) 5 | , path 6 | , uri 7 | , pathUri 8 | , uriToText 9 | , pathToText 10 | , cleanSegment 11 | , (./.) 12 | ) 13 | where 14 | 15 | import Data.String (IsString (..)) 16 | import Data.String.Conversions (cs) 17 | import Data.Text (Text) 18 | import Data.Text qualified as T 19 | import GHC.Exts (IsList (..)) 20 | import Network.URI (URI (..), uriToString) 21 | import Network.URI.Static (uri) 22 | import System.FilePath (()) 23 | 24 | 25 | data Path = Path 26 | { isRoot :: Bool 27 | , segments :: [Segment] 28 | } 29 | deriving (Show, Eq) 30 | instance IsList Path where 31 | type Item Path = Segment 32 | fromList ss = Path True ss 33 | toList p = p.segments 34 | instance IsString Path where 35 | fromString = path . cs 36 | 37 | 38 | type Segment = Text 39 | 40 | 41 | cleanSegment :: Segment -> Segment 42 | cleanSegment = T.dropWhileEnd (== '/') . T.dropWhile (== '/') 43 | 44 | 45 | path :: Text -> Path 46 | path p = 47 | let segments = filter (not . T.null) $ T.splitOn "/" $ T.dropWhile (== '/') p 48 | isRoot = "/" `T.isPrefixOf` p 49 | in Path{isRoot, segments} 50 | 51 | 52 | pathUri :: Path -> URI 53 | pathUri p = 54 | URI 55 | { uriPath = cs $ pathToText p 56 | , uriScheme = "" 57 | , uriAuthority = Nothing 58 | , uriQuery = "" 59 | , uriFragment = "" 60 | } 61 | 62 | 63 | uriToText :: URI -> Text 64 | uriToText u = cs $ uriToString id u "" 65 | 66 | 67 | pathPrefix :: Path -> Text 68 | pathPrefix p = 69 | if p.isRoot then "/" else "" 70 | 71 | 72 | pathToText :: Path -> Text 73 | pathToText p = 74 | pathPrefix p <> T.intercalate "/" (fmap cleanSegment p.segments) 75 | 76 | 77 | (./.) :: URI -> Path -> URI 78 | u ./. p = 79 | let newPath = cs $ pathToText p 80 | in u{uriPath = if p.isRoot then newPath else u.uriPath newPath} 81 | infixl 5 ./. 82 | 83 | -- -- you can't create an isstring instance though.... 84 | -- -- hmmm.... 85 | -- -- I mean, they're doing that on purpose 86 | -- 87 | -- relativeUri :: Text -> URI 88 | -- relativeUri t = 89 | -- s <- scheme 90 | -- d <- domain s 91 | -- ps <- paths 92 | -- q <- query 93 | -- pure $ Url{scheme = s, domain = d, path = ps, query = q} 94 | -- where 95 | -- parse :: (State Text :> es) => (Char -> Bool) -> Eff es Text 96 | -- parse b = do 97 | -- inp <- get 98 | -- let match = T.takeWhile b inp 99 | -- rest = T.dropWhile b inp 100 | -- put rest 101 | -- pure match 102 | -- 103 | -- string :: (State Text :> es) => Text -> Eff es (Maybe Text) 104 | -- string pre = do 105 | -- inp <- get 106 | -- case T.stripPrefix pre inp of 107 | -- Nothing -> pure Nothing 108 | -- Just rest -> do 109 | -- put rest 110 | -- pure (Just pre) 111 | -- 112 | -- -- it's either scheme AND domain, or relative path 113 | -- scheme = do 114 | -- http <- string "http://" 115 | -- https <- string "https://" 116 | -- pure $ fromMaybe "" $ http <|> https 117 | -- 118 | -- domain "" = pure "" 119 | -- domain _ = parse (not . isDomainSep) 120 | -- 121 | -- pathText :: (State Text :> es) => Eff es Text 122 | -- pathText = parse (not . isQuerySep) 123 | -- 124 | -- paths :: (State Text :> es) => Eff es [Segment] 125 | -- paths = do 126 | -- p <- pathText 127 | -- pure $ pathSegments p 128 | -- 129 | -- query :: (State Text :> es) => Eff es Query 130 | -- query = do 131 | -- q <- parse (/= '\n') 132 | -- pure $ parseQuery $ encodeUtf8 q 133 | -- 134 | -- isDomainSep '/' = True 135 | -- isDomainSep _ = False 136 | -- 137 | -- isQuerySep '?' = True 138 | -- isQuerySep _ = False 139 | -- 140 | -- 141 | -- renderUrl :: Url -> Text 142 | -- renderUrl u = u.scheme <> u.domain <> renderPath u.path <> decodeUtf8 (renderQuery True u.query) 143 | -- 144 | -- j 145 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Event.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.Effect.Event (getEvent) where 2 | 3 | import Effectful 4 | import Effectful.Dispatch.Dynamic 5 | import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..)) 6 | import Web.Hyperbole.Effect.Server (Event (..), Request (..), lookupEvent) 7 | import Web.Hyperbole.HyperView (HyperView (..)) 8 | import Web.Hyperbole.HyperView.Types (decodeAction, decodeViewId) 9 | 10 | 11 | getEvent :: (HyperView id es, Hyperbole :> es) => Eff es (Maybe (Event id (Action id))) 12 | getEvent = do 13 | q <- (.query) <$> send GetRequest 14 | pure $ do 15 | Event ti ta <- lookupEvent q 16 | vid <- decodeViewId ti 17 | act <- decodeAction ta 18 | pure $ Event vid act 19 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Web.Hyperbole.Effect.Handler where 5 | 6 | import Data.Kind (Type) 7 | import Effectful 8 | import Effectful.Dispatch.Dynamic 9 | import Effectful.Reader.Dynamic 10 | import Web.Hyperbole.Data.Encoded 11 | import Web.Hyperbole.Effect.Event (getEvent) 12 | import Web.Hyperbole.Effect.Hyperbole 13 | import Web.Hyperbole.Effect.Request (request) 14 | import Web.Hyperbole.Effect.Response (respondEarly) 15 | import Web.Hyperbole.Effect.Server 16 | import Web.Hyperbole.HyperView 17 | import Web.Hyperbole.View 18 | 19 | 20 | class RunHandlers (views :: [Type]) es where 21 | runHandlers :: (Hyperbole :> es) => Eff es () 22 | 23 | 24 | instance RunHandlers '[] es where 25 | runHandlers = pure () 26 | 27 | 28 | instance (HyperView view es, RunHandlers views es) => RunHandlers (view : views) es where 29 | runHandlers = do 30 | runHandler @view (update @view) 31 | runHandlers @views 32 | 33 | 34 | runHandler 35 | :: forall id es 36 | . (HyperView id es, Hyperbole :> es) 37 | => (Action id -> Eff (Reader id : es) (View id ())) 38 | -> Eff es () 39 | runHandler run = do 40 | -- Get an event matching our type. If it doesn't match, skip to the next handler 41 | mev <- getEvent @id :: Eff es (Maybe (Event id (Action id))) 42 | case mev of 43 | Just evt -> do 44 | vw <- runReader evt.viewId $ run evt.action 45 | respondEarly evt.viewId vw 46 | _ -> do 47 | pure () 48 | 49 | 50 | runLoad 51 | :: forall views es 52 | . (Hyperbole :> es, RunHandlers views es) 53 | => Eff es (View (Root views) ()) 54 | -> Eff es Response 55 | runLoad loadPage = do 56 | runHandlers @views 57 | guardNoEvent 58 | loadToResponse loadPage 59 | 60 | 61 | guardNoEvent :: (Hyperbole :> es) => Eff es () 62 | guardNoEvent = do 63 | q <- (.query) <$> request 64 | case lookupEvent q of 65 | -- Are id and action set to something? 66 | Just e -> send $ RespondEarly $ Err $ ErrNotHandled e 67 | Nothing -> pure () 68 | 69 | 70 | loadToResponse :: Eff es (View (Root total) ()) -> Eff es Response 71 | loadToResponse run = do 72 | vw <- run 73 | let vid = TargetViewId (encodedToText $ toViewId Root) 74 | let res = Response vid $ addContext Root vw 75 | pure res 76 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Hyperbole.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Web.Hyperbole.Effect.Hyperbole where 5 | 6 | import Effectful 7 | import Effectful.Dispatch.Dynamic 8 | import Effectful.Error.Static 9 | import Effectful.State.Static.Local 10 | import Web.Hyperbole.Effect.Server 11 | 12 | 13 | -- | The 'Hyperbole' 'Effect' allows you to access information in the 'Request', manually 'respondEarly', and manipulate the Client 'session' and 'query'. 14 | data Hyperbole :: Effect where 15 | GetRequest :: Hyperbole m Request 16 | RespondEarly :: Response -> Hyperbole m a 17 | ModClient :: (Client -> Client) -> Hyperbole m () 18 | GetClient :: Hyperbole m Client 19 | 20 | 21 | type instance DispatchOf Hyperbole = 'Dynamic 22 | 23 | 24 | -- | Run the 'Hyperbole' effect to 'Server' 25 | runHyperbole 26 | :: (Server :> es) 27 | => Eff (Hyperbole : es) Response 28 | -> Eff es Response 29 | runHyperbole = fmap combine $ reinterpret runLocal $ \_ -> \case 30 | GetRequest -> do 31 | gets @HyperState (.request) 32 | RespondEarly r -> do 33 | s <- gets @HyperState (.client) 34 | send $ SendResponse s r 35 | throwError_ r 36 | GetClient -> do 37 | gets @HyperState (.client) 38 | ModClient f -> do 39 | modify @HyperState $ \st -> st{client = f st.client} 40 | where 41 | runLocal :: (Server :> es) => Eff (State HyperState : Error Response : es) a -> Eff es (Either Response (a, HyperState)) 42 | runLocal eff = do 43 | -- Load the request ONCE right when we start 44 | r <- send LoadRequest 45 | let client = Client r.requestId mempty mempty 46 | let st = HyperState r client 47 | runErrorNoCallStack @Response . runState st $ eff 48 | 49 | combine :: (Server :> es) => Eff es (Either Response (Response, HyperState)) -> Eff es Response 50 | combine eff = do 51 | er <- eff 52 | case er of 53 | Left res -> 54 | -- responded early, don't need to respond again 55 | pure res 56 | Right (res, st) -> do 57 | send $ SendResponse st.client res 58 | pure res 59 | 60 | 61 | data HyperState = HyperState 62 | { request :: Request 63 | , client :: Client 64 | } 65 | 66 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Javascript.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.Effect.Javascript where 2 | 3 | import Data.Aeson as A 4 | import Data.String (IsString) 5 | import Data.String.Conversions (cs) 6 | import Data.Text (Text) 7 | import Effectful 8 | import GHC.Generics 9 | import Web.Hyperbole.Effect.Hyperbole (Hyperbole) 10 | 11 | 12 | -- A function to execute on the client 13 | data Javascript a = Javascript 14 | { functionName :: JSFunction 15 | , arguments :: [Value] -- all json parameters 16 | } 17 | deriving (Show, Generic, ToJSON) 18 | 19 | 20 | newtype JSFunction = JSFunction Text 21 | deriving newtype (ToJSON, Show, IsString) 22 | 23 | 24 | execute :: (FromJSON result, Hyperbole :> es) => Javascript result -> Eff es result 25 | execute js = do 26 | -- TODO: execute the JS on the client 27 | -- let res = window[js.functionName].apply(js.arguments) 28 | -- sendBackToServer(JSON.stringify(res)) 29 | res <- remoteExecute js 30 | 31 | -- decode the text result as JSON 32 | -- the client will execute 33 | case A.eitherDecode (cs res) of 34 | Right a -> pure a 35 | Left _ -> error "Throw/Send an error" 36 | where 37 | -- pretend to execute it 38 | remoteExecute :: Javascript a -> Eff es Text 39 | remoteExecute _ = pure "\"hello world\"" 40 | 41 | 42 | -- Example: createUser(name, age): User {...} 43 | data User = User Text Int 44 | deriving (Generic, FromJSON, Show) 45 | 46 | 47 | -- FFI: apply the functions to create a fully applied Javascript User 48 | createUser :: Text -> Int -> Javascript User 49 | createUser = foreignJS "createUser" 50 | 51 | 52 | -- Example sum: 53 | sum :: Int -> Int -> Javascript String 54 | sum = foreignJS "sum" 55 | 56 | 57 | noEval :: Int -> Javascript String 58 | noEval = foreignJS "() => console.log('this will not run, it has to be a member of window[]')" 59 | 60 | 61 | -- This will work, because it isn't arbitrary code. We can look for the function on window after splitting on "." 62 | consoleLog :: Text -> Javascript () 63 | consoleLog = foreignJS "console.log" 64 | 65 | 66 | -- Generic remote JS call to be serialized and executed by the client 67 | class ForeignJS a where 68 | foreignJS :: JSFunction -> a 69 | 70 | 71 | instance (ToJSON a) => ForeignJS (a -> Javascript res) where 72 | foreignJS name a = Javascript name [toJSON a] 73 | 74 | 75 | instance (ToJSON a, ToJSON b) => ForeignJS (a -> b -> Javascript res) where 76 | foreignJS name a b = Javascript name [toJSON a, toJSON b] 77 | 78 | 79 | instance (ToJSON a, ToJSON b, ToJSON c) => ForeignJS (a -> b -> c -> Javascript res) where 80 | foreignJS name a b c = Javascript name [toJSON a, toJSON b, toJSON c] 81 | 82 | 83 | instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ForeignJS (a -> b -> c -> d -> Javascript res) where 84 | foreignJS name a b c d = Javascript name [toJSON a, toJSON b, toJSON c, toJSON d] 85 | 86 | 87 | exampleHandler :: (Hyperbole :> es, IOE :> es) => Eff es () 88 | exampleHandler = do 89 | res :: User <- execute $ createUser "henry" 2 90 | liftIO $ print res 91 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Query.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.Effect.Query where 2 | 3 | import Data.ByteString qualified as BS 4 | import Data.Default (Default (..)) 5 | import Data.Maybe (fromMaybe) 6 | import Data.String.Conversions (cs) 7 | import Effectful 8 | import Effectful.Dispatch.Dynamic (send) 9 | import Web.Hyperbole.Data.Param (FromParam (..), Param, ToParam (..)) 10 | import Web.Hyperbole.Data.QueryData (FromQuery (..), QueryData (..), ToQuery (..), queryData) 11 | import Web.Hyperbole.Data.QueryData qualified as QueryData 12 | import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..)) 13 | import Web.Hyperbole.Effect.Request (request) 14 | import Web.Hyperbole.Effect.Server (Client (..), Request (..), Response (..), ResponseError (..)) 15 | import Prelude 16 | 17 | 18 | {- | Parse querystring from the 'Request' into a datatype. See 'FromQuery' 19 | 20 | @ 21 | #EMBED Example/Docs/Params.hs data Filters 22 | 23 | #EMBED Example/Docs/Params.hs page 24 | @ 25 | -} 26 | query :: (FromQuery a, Hyperbole :> es) => Eff es a 27 | query = do 28 | q <- queryParams 29 | case parseQuery q of 30 | Left e -> send $ RespondEarly $ Err $ ErrQuery $ "Query Parse " <> e <> " from " <> cs (show q) 31 | Right a -> pure a 32 | 33 | 34 | {- | Update the client's querystring to an encoded datatype. See 'ToQuery' 35 | 36 | @ 37 | #EMBED Example/Docs/Params.hs instance HyperView Todos 38 | @ 39 | -} 40 | setQuery :: (ToQuery a, Hyperbole :> es) => a -> Eff es () 41 | setQuery a = do 42 | modifyQueryData (const $ toQuery a) 43 | 44 | 45 | modifyQuery :: (ToQuery a, FromQuery a, Default a, Hyperbole :> es) => (a -> a) -> Eff es a 46 | modifyQuery f = do 47 | s <- query 48 | let updated = f s 49 | setQuery updated 50 | pure updated 51 | 52 | 53 | {- | Parse a single query parameter. Return a 400 status if missing or if parsing fails. See 'FromParam' 54 | 55 | @ 56 | #EMBED Example/Docs/Params.hs page' 57 | @ 58 | -} 59 | param :: (FromParam a, Hyperbole :> es) => Param -> Eff es a 60 | param p = do 61 | q <- queryParams 62 | case QueryData.require p q of 63 | Left e -> send $ RespondEarly $ Err $ ErrQuery e 64 | Right a -> pure a 65 | 66 | 67 | -- | Parse a single parameter from the query string if available 68 | lookupParam :: (FromParam a, Hyperbole :> es) => Param -> Eff es (Maybe a) 69 | lookupParam p = do 70 | QueryData.lookup p <$> queryParams 71 | 72 | 73 | {- | Modify the client's querystring to set a single parameter. See 'ToParam' 74 | 75 | @ 76 | #EMBED Example/Docs/Params.hs instance HyperView Message 77 | @ 78 | -} 79 | setParam :: (ToParam a, Hyperbole :> es) => Param -> a -> Eff es () 80 | setParam key a = do 81 | modifyQueryData (QueryData.insert key a) 82 | 83 | 84 | -- | Delete a single parameter from the query string 85 | deleteParam :: (Hyperbole :> es) => Param -> Eff es () 86 | deleteParam key = do 87 | modifyQueryData (QueryData.delete key) 88 | 89 | 90 | -- | Return the query from 'Request' as a 'QueryData' 91 | queryParams :: (Hyperbole :> es) => Eff es QueryData 92 | queryParams = do 93 | cq <- clientQuery 94 | rq <- requestQuery 95 | pure $ fromMaybe rq cq 96 | where 97 | clientQuery = (.query) <$> send GetClient 98 | 99 | requestQuery :: (Hyperbole :> es) => Eff es QueryData 100 | requestQuery = do 101 | r <- request 102 | pure $ queryData $ filter (not . isSystemParam) r.query 103 | 104 | isSystemParam (key, _) = 105 | "hyp-" `BS.isPrefixOf` key 106 | 107 | 108 | modifyQueryData :: (Hyperbole :> es) => (QueryData -> QueryData) -> Eff es () 109 | modifyQueryData f = do 110 | q <- queryParams 111 | send $ ModClient $ \Client{session, requestId} -> 112 | Client{query = Just $ f q, session, requestId} 113 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Web.Hyperbole.Effect.Request where 4 | 5 | import Effectful 6 | import Effectful.Dispatch.Dynamic 7 | import Web.FormUrlEncoded (Form, urlDecodeForm) 8 | import Web.Hyperbole.Data.URI (Path) 9 | import Web.Hyperbole.Effect.Hyperbole 10 | import Web.Hyperbole.Effect.Server 11 | 12 | 13 | -- | Return all information about the 'Request' 14 | request :: (Hyperbole :> es) => Eff es Request 15 | request = reqRemoveSystem <$> send GetRequest 16 | 17 | 18 | reqRemoveSystem :: Request -> Request 19 | reqRemoveSystem Request{..} = 20 | Request{query = filter (not . isSystemParam) query, ..} 21 | 22 | 23 | {- | Return the request path 24 | 25 | >>> reqPath 26 | ["users", "100"] 27 | -} 28 | reqPath :: (Hyperbole :> es) => Eff es Path 29 | reqPath = (.path) <$> request 30 | 31 | 32 | {- | Return the request body as a Web.FormUrlEncoded.Form 33 | 34 | Prefer using Type-Safe 'Form's when possible 35 | -} 36 | formBody :: (Hyperbole :> es) => Eff es Form 37 | formBody = do 38 | b <- (.body) <$> request 39 | let ef = urlDecodeForm b 40 | either (send . RespondEarly . Err . ErrParse) pure ef 41 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Response.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.Effect.Response where 2 | 3 | import Data.Text (Text) 4 | import Effectful 5 | import Effectful.Dispatch.Dynamic 6 | import Web.Hyperbole.Data.Encoded 7 | import Web.Hyperbole.Data.URI 8 | import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..)) 9 | import Web.Hyperbole.Effect.Server (Response (..), ResponseError (..), TargetViewId (..)) 10 | import Web.Hyperbole.HyperView (HyperView (..), ViewId (..), hyperUnsafe) 11 | import Web.Hyperbole.View.Types 12 | 13 | 14 | -- | Respond with the given view, and stop execution 15 | respondEarly :: (Hyperbole :> es, HyperView id es) => id -> View id () -> Eff es a 16 | respondEarly i vw = do 17 | let vid = TargetViewId (encodedToText $ toViewId i) 18 | let res = Response vid $ hyperUnsafe i vw 19 | send $ RespondEarly res 20 | 21 | 22 | {- | Respond immediately with 404 Not Found 23 | 24 | @ 25 | #EMBED Example/Docs/App.hs findUser 26 | 27 | #EMBED Example/Docs/App.hs userPage 28 | @ 29 | -} 30 | notFound :: (Hyperbole :> es) => Eff es a 31 | notFound = send $ RespondEarly NotFound 32 | 33 | 34 | -- | Respond immediately with a parse error 35 | parseError :: (Hyperbole :> es) => Text -> Eff es a 36 | parseError = send . RespondEarly . Err . ErrParse 37 | 38 | 39 | -- | Redirect immediately to the 'Url' 40 | redirect :: (Hyperbole :> es) => URI -> Eff es a 41 | redirect = send . RespondEarly . Redirect 42 | 43 | 44 | -- | Manually set the response to the given view. Normally you would return a 'View' from 'runPage' instead 45 | view :: (Hyperbole :> es) => View () () -> Eff es Response 46 | view vw = do 47 | pure $ Response (TargetViewId "") vw 48 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Effect/Session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | 4 | module Web.Hyperbole.Effect.Session where 5 | 6 | import Data.Aeson as A (FromJSON, ToJSON, eitherDecodeStrict, encode) 7 | import Data.Bifunctor (first) 8 | import Data.Default (Default (..)) 9 | import Data.Maybe (fromMaybe) 10 | import Data.String.Conversions (cs) 11 | import Data.Text (Text) 12 | import Effectful 13 | import Effectful.Dispatch.Dynamic 14 | import GHC.Generics 15 | import Web.Hyperbole.Data.Cookie as Cookie 16 | import Web.Hyperbole.Data.Param 17 | import Web.Hyperbole.Data.URI (Path) 18 | import Web.Hyperbole.Effect.Hyperbole (Hyperbole (..)) 19 | import Web.Hyperbole.Effect.Request (request) 20 | import Web.Hyperbole.Effect.Server (Client (..), Request (..), Response (..), ResponseError (..)) 21 | 22 | 23 | {- | Configure a data type to persist in the 'session' as a cookie. These are type-indexed, so only one of each can exist in the session 24 | 25 | @ 26 | #EMBED Example/Docs/Sessions.hs data Preferences 27 | 28 | #EMBED Example/Docs/Sessions.hs instance DefaultParam Preferences 29 | @ 30 | -} 31 | class Session a where 32 | -- | Unique key for this Session Type. Defaults to the datatypeName 33 | sessionKey :: Key 34 | default sessionKey :: (Generic a, GDatatypeName (Rep a)) => Key 35 | sessionKey = gDatatypeName $ from (undefined :: a) 36 | 37 | 38 | -- | By default Sessions are persisted only to the current page. Set this to `Just []` to make an application-wide Session 39 | cookiePath :: Maybe Path 40 | default cookiePath :: Maybe Path 41 | cookiePath = Nothing 42 | 43 | 44 | -- | Encode type to a a cookie value. Defaults to ToJSON 45 | toCookie :: a -> CookieValue 46 | default toCookie :: (ToJSON a) => a -> CookieValue 47 | toCookie = CookieValue . cs . A.encode 48 | 49 | 50 | -- | Decode from a cookie value. Defaults to FromJSON 51 | parseCookie :: CookieValue -> Either Text a 52 | default parseCookie :: (FromJSON a) => CookieValue -> Either Text a 53 | parseCookie (CookieValue bs) = do 54 | first cs $ A.eitherDecodeStrict bs 55 | 56 | 57 | {- | Persist datatypes in browser cookies. If the session doesn't exist, the 'DefaultParam' is used 58 | 59 | @ 60 | #EMBED Example/Docs/Sessions.hs data Preferences 61 | 62 | #EMBED Example/Docs/Sessions.hs instance DefaultParam Preferences 63 | 64 | #EMBED Example/Docs/Sessions.hs page 65 | @ 66 | -} 67 | session :: (Session a, Default a, Hyperbole :> es) => Eff es a 68 | session = do 69 | ms <- lookupSession 70 | pure $ fromMaybe def ms 71 | 72 | 73 | -- | Return a session if it exists 74 | lookupSession :: forall a es. (Session a, Hyperbole :> es) => Eff es (Maybe a) 75 | lookupSession = do 76 | let key = sessionKey @a 77 | mck <- Cookie.lookup key <$> sessionCookies 78 | case mck of 79 | Nothing -> pure Nothing 80 | Just val -> Just <$> parseSession key val 81 | 82 | 83 | {- | Persist datatypes in browser cookies 84 | 85 | @ 86 | #EMBED Example/Docs/Sessions.hs data Preferences 87 | 88 | #EMBED Example/Docs/Sessions.hs instance DefaultParam Preferences 89 | 90 | #EMBED Example/Docs/Sessions.hs instance HyperView Content 91 | @ 92 | -} 93 | saveSession :: forall a es. (Session a, Hyperbole :> es) => a -> Eff es () 94 | saveSession a = do 95 | modifyCookies $ Cookie.insert $ sessionCookie a 96 | 97 | 98 | modifySession :: (Session a, Default a, Hyperbole :> es) => (a -> a) -> Eff es a 99 | modifySession f = do 100 | s <- session 101 | let updated = f s 102 | saveSession updated 103 | pure updated 104 | 105 | 106 | modifySession_ :: (Session a, Default a, Hyperbole :> es) => (a -> a) -> Eff es () 107 | modifySession_ f = do 108 | _ <- modifySession f 109 | pure () 110 | 111 | 112 | -- | Remove a single 'Session' from the browser cookies 113 | deleteSession :: forall a es. (Session a, Hyperbole :> es) => Eff es () 114 | deleteSession = do 115 | let cookie = Cookie (sessionKey @a) (cookiePath @a) Nothing 116 | modifyCookies $ Cookie.insert cookie 117 | 118 | 119 | parseSession :: (Session a, Hyperbole :> es) => Key -> CookieValue -> Eff es a 120 | parseSession prm cook = do 121 | case parseCookie cook of 122 | Left e -> send $ RespondEarly $ Err $ ErrSession prm e 123 | Right a -> pure a 124 | 125 | 126 | -- | save a single datatype to a specific key in the session 127 | setCookie :: (ToParam a, Hyperbole :> es) => Cookie -> Eff es () 128 | setCookie ck = do 129 | modifyCookies (Cookie.insert ck) 130 | 131 | 132 | -- | Modify the client cookies 133 | modifyCookies :: (Hyperbole :> es) => (Cookies -> Cookies) -> Eff es () 134 | modifyCookies f = 135 | send $ ModClient $ \client -> 136 | Client{session = f client.session, query = client.query, requestId = client.requestId} 137 | 138 | 139 | -- | Return all the cookies, both those sent in the request and others added by the page 140 | sessionCookies :: (Hyperbole :> es) => Eff es Cookies 141 | sessionCookies = do 142 | clt <- clientSessionCookies 143 | req <- requestSessionCookies 144 | pure $ clt <> req 145 | 146 | 147 | -- | Return the session from the Client cookies 148 | clientSessionCookies :: (Hyperbole :> es) => Eff es Cookies 149 | clientSessionCookies = do 150 | (.session) <$> send GetClient 151 | 152 | 153 | -- | Return the session from the 'Request' cookies 154 | requestSessionCookies :: (Hyperbole :> es) => Eff es Cookies 155 | requestSessionCookies = do 156 | (.cookies) <$> request 157 | 158 | 159 | sessionCookie :: forall a. (Session a) => a -> Cookie 160 | sessionCookie a = 161 | Cookie (sessionKey @a) (cookiePath @a) (Just $ toCookie a) 162 | 163 | 164 | -- | generic datatype name 165 | genericTypeName :: forall a. (Generic a, GDatatypeName (Rep a)) => Text 166 | genericTypeName = 167 | gDatatypeName $ from (undefined :: a) 168 | 169 | 170 | class GDatatypeName f where 171 | gDatatypeName :: f p -> Text 172 | 173 | 174 | instance (Datatype d) => GDatatypeName (M1 D d f) where 175 | gDatatypeName _ = 176 | cs $ datatypeName (undefined :: M1 D d f p) 177 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/HyperView.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.HyperView 2 | ( module Web.Hyperbole.HyperView.Types 3 | , module Web.Hyperbole.HyperView.Input 4 | , module Web.Hyperbole.HyperView.Event 5 | ) where 6 | 7 | import Web.Hyperbole.HyperView.Event 8 | import Web.Hyperbole.HyperView.Input 9 | import Web.Hyperbole.HyperView.Types 10 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/HyperView/Event.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.HyperView.Event where 2 | 3 | import Data.String.Conversions (cs) 4 | import Data.Text (Text) 5 | import Text.Casing (kebab) 6 | import Web.Atomic.Types 7 | import Web.Hyperbole.Data.Encoded 8 | import Web.Hyperbole.HyperView.Types 9 | import Web.Hyperbole.View 10 | import Web.Hyperbole.View.Types (ViewContext) 11 | 12 | 13 | type DelayMs = Int 14 | 15 | 16 | event :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Name -> Action id -> Attributes a -> Attributes a 17 | event eventName a = att ("data-on" <> eventName) (encodedToText $ toAction a) 18 | 19 | 20 | {- | Send the action after N milliseconds. Can be used to implement lazy loading or polling. See [Example.Page.Concurrent](https://docs.hyperbole.live/concurrent) 21 | 22 | @ 23 | #EMBED Example/Page/LazyLoading.hs viewTaskLoad 24 | @ 25 | -} 26 | onLoad :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Action id -> DelayMs -> Attributes a -> Attributes a 27 | onLoad a delay = do 28 | event "load" a . att "data-delay" (cs $ show delay) 29 | 30 | 31 | onClick :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Action id -> Attributes a -> Attributes a 32 | onClick = event "click" 33 | 34 | 35 | onDblClick :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Action id -> Attributes a -> Attributes a 36 | onDblClick = event "dblclick" 37 | 38 | 39 | onMouseEnter :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Action id -> Attributes a -> Attributes a 40 | onMouseEnter = event "mouseenter" 41 | 42 | 43 | onMouseLeave :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Action id -> Attributes a -> Attributes a 44 | onMouseLeave = event "mouseleave" 45 | 46 | 47 | {- | Run an action when the user types into an 'input' or 'textarea'. 48 | 49 | WARNING: a short delay can result in poor performance. It is not recommended to set the 'value' of the input 50 | 51 | > input (onInput OnSearch) 250 id 52 | -} 53 | onInput :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => (Text -> Action id) -> DelayMs -> Attributes a -> Attributes a 54 | onInput a delay = do 55 | att "data-oninput" (encodedToText $ toActionInput a) . att "data-delay" (cs $ show delay) 56 | 57 | 58 | -- WARNING: no way to do this generically right now, because toActionInput is specialized to Text 59 | -- the change event DOES assume that the target has a string value 60 | -- but, that doesn't let us implement dropdown 61 | onChange :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => (value -> Action id) -> Attributes a -> Attributes a 62 | onChange a = do 63 | att "data-onchange" (encodedToText $ toActionInput a) 64 | 65 | 66 | onSubmit :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Action id -> Attributes a -> Attributes a 67 | onSubmit = event "submit" 68 | 69 | 70 | onKeyDown :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Key -> Action id -> Attributes a -> Attributes a 71 | onKeyDown key act = do 72 | att ("data-on-keydown-" <> keyDataAttribute key) (encodedToText $ toAction act) 73 | 74 | 75 | onKeyUp :: (ViewAction (Action id), ViewContext a ~ id, Attributable a) => Key -> Action id -> Attributes a -> Attributes a 76 | onKeyUp key act = do 77 | att ("data-on-keyup-" <> keyDataAttribute key) (encodedToText $ toAction act) 78 | 79 | 80 | keyDataAttribute :: Key -> Text 81 | keyDataAttribute = cs . kebab . showKey 82 | where 83 | showKey (OtherKey t) = cs t 84 | showKey k = show k 85 | 86 | 87 | -- https://developer.mozilla.org/en-US/docs/Web/API/UI_Events/Keyboard_event_key_values 88 | data Key 89 | = ArrowDown 90 | | ArrowUp 91 | | ArrowLeft 92 | | ArrowRight 93 | | Enter 94 | | Space 95 | | Escape 96 | | Alt 97 | | CapsLock 98 | | Control 99 | | Fn 100 | | Meta 101 | | Shift 102 | | OtherKey Text 103 | deriving (Show, Read) 104 | 105 | 106 | -- | Serialize a constructor that expects a single input, like `data MyAction = GoSearch Text` 107 | toActionInput :: (ViewAction a) => (val -> a) -> Encoded 108 | toActionInput act = 109 | -- laziness should let us drop the last item? 110 | -- maybe... I bet it evaluates it strictly 111 | let Encoded con vals = toAction (act undefined) 112 | in if null vals 113 | then Encoded con vals 114 | else Encoded con (init vals) 115 | 116 | 117 | -- case toAction (con mempty) of 118 | -- 119 | -- let marker = "%HYP-INP%" 120 | -- in T.replace " \"%HYP-INP%\"" "" $ toAction $ con marker 121 | 122 | -- | Internal 123 | dataTarget :: (ViewId id, ViewContext a ~ id, Attributable a) => id -> Attributes a -> Attributes a 124 | dataTarget = att "data-target" . encodedToText . toViewId 125 | 126 | 127 | -- | Allow inputs to trigger actions for a different view 128 | target :: forall id ctx. (HyperViewHandled id ctx, ViewId id) => id -> View id () -> View ctx () 129 | target newId view = do 130 | -- TEST: Target 131 | addContext newId $ do 132 | view @ dataTarget newId 133 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/HyperView/Input.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.HyperView.Input where 2 | 3 | import Data.Aeson (ToJSON) 4 | import Data.Aeson qualified as A 5 | import Data.String.Conversions (cs) 6 | import Data.Text (Text) 7 | import Web.Atomic.Types 8 | import Web.Hyperbole.HyperView.Event (DelayMs, onChange, onClick, onInput) 9 | import Web.Hyperbole.HyperView.Types (HyperView (..), ViewAction (..)) 10 | import Web.Hyperbole.Route (Route (..), routeUri) 11 | import Web.Hyperbole.View 12 | 13 | 14 | {- | \ HTML tag which sends the action when pressed 15 | 16 | > button SomeAction (border 1) "Click Me" 17 | -} 18 | button :: (ViewAction (Action id)) => Action id -> View id () -> View id () 19 | button action cnt = do 20 | tag "button" cnt @ onClick action 21 | 22 | 23 | -- tag "button" @ att "whatber" "asdf" $ cnt 24 | 25 | -- {- | \ which toggles automatically 26 | -- 27 | -- > toggle True SetIsSelected id 28 | -- -} 29 | -- toggle :: (ViewAction (Action id)) => Bool -> (Bool -> Action id) -> Mod id -> View id () 30 | -- toggle isSelected clickAction f = do 31 | -- tag "input" (att "type" "checkbox" . checked isSelected . onClick (clickAction (not isSelected)) . f) none 32 | 33 | {- | Type-safe dropdown. Sends (opt -> Action id) when selected. The selection predicate (opt -> Bool) controls which option is selected. See [Example.Page.Filter](https://docs.hyperbole.live/filter) 34 | 35 | @ 36 | #EMBED Example/Page/Filter.hs familyDropdown 37 | @ 38 | -} 39 | dropdown 40 | :: (ViewAction (Action id)) 41 | => (opt -> Action id) 42 | -> (opt -> Bool) -- check if selec 43 | -> View (Option opt id) () 44 | -> View id () 45 | dropdown act isSel options = do 46 | tag "select" @ onChange act $ do 47 | addContext (Option isSel) options 48 | 49 | 50 | -- | An option for a 'dropdown'. First argument is passed to (opt -> Action id) in the 'dropdown', and to the selected predicate 51 | option 52 | :: (ViewAction (Action id), Eq opt, ToJSON opt) 53 | => opt 54 | -> View (Option opt id) () 55 | -> View (Option opt id) () 56 | option opt cnt = do 57 | os <- context 58 | tag "option" @ att "value" (cs $ A.encode opt) @ selected (os.selected opt) $ cnt 59 | 60 | 61 | -- | sets selected = true if the 'dropdown' predicate returns True 62 | selected :: (Attributable h) => Bool -> Attributes h -> Attributes h 63 | selected b = if b then att "selected" "true" else id 64 | 65 | 66 | -- | The view context for an 'option' 67 | data Option opt id = Option 68 | { selected :: opt -> Bool 69 | } 70 | 71 | 72 | -- | A live search field 73 | search :: (ViewAction (Action id)) => (Text -> Action id) -> DelayMs -> View id () 74 | search go delay = do 75 | tag "input" none @ onInput go delay 76 | 77 | 78 | {- | Set checkbox = checked via the client (VDOM doesn't work) 79 | designed for input, which has no children 80 | -} 81 | checked :: (Attributable a) => Bool -> Attributes a -> Attributes a 82 | checked c = 83 | att "data-checked" (cs $ show c) 84 | . if c then att "checked" "" else id 85 | 86 | 87 | {- | A hyperlink to another route 88 | 89 | >>> route (User 100) id "View User" 90 | View User 91 | -} 92 | route :: (Route a) => a -> View c () -> View c () 93 | route r = link (routeUri r) 94 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Page.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.Page where 2 | 3 | import Data.Kind (Type) 4 | import Effectful 5 | import Web.Hyperbole.Effect.Handler (RunHandlers, runLoad) 6 | import Web.Hyperbole.Effect.Hyperbole 7 | import Web.Hyperbole.Effect.Server (Response) 8 | import Web.Hyperbole.HyperView (Root) 9 | import Web.Hyperbole.View (View) 10 | 11 | 12 | {- | Conceptually, an application is dividied up into multiple [Pages](#g:pages). Each page module should have a function that returns a 'Page'. The 'Page' itself is a 'View' with a type-level list of 'HyperView's used on the page. 13 | 14 | @ 15 | #EMBED Example/Docs/MultiView.hs page 16 | @ 17 | -} 18 | type Page (views :: [Type]) = View (Root views) () 19 | 20 | 21 | {- | Run a 'Page' and return a 'Response' 22 | 23 | @ 24 | #EMBED Example/Docs/BasicPage.hs main 25 | 26 | #EMBED Example/Docs/BasicPage.hs page 27 | @ 28 | -} 29 | runPage 30 | :: (Hyperbole :> es, RunHandlers views es) 31 | => Eff es (Page views) 32 | -> Eff es Response 33 | runPage = runLoad 34 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/Route.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | 3 | module Web.Hyperbole.Route 4 | ( Route (..) 5 | , findRoute 6 | , routeUri 7 | , GenRoute (..) 8 | , genMatchRoute 9 | , genRoutePath 10 | , genRouteRead 11 | , matchRouteRead 12 | , routePathShow 13 | , module Web.Hyperbole.Data.URI 14 | ) where 15 | 16 | import Control.Applicative ((<|>)) 17 | import Control.Monad (guard) 18 | import Data.Text (Text, pack, toLower, unpack) 19 | import Data.Text qualified as T 20 | import GHC.Generics 21 | import Network.URI 22 | import Text.Read (readMaybe) 23 | import Web.Hyperbole.Data.URI 24 | import Prelude hiding (dropWhile) 25 | 26 | 27 | {- | Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns 28 | 29 | @ 30 | #EMBED Example/Docs/App.hs data AppRoute 31 | 32 | #EMBED Example/Docs/App.hs instance Route 33 | @ 34 | 35 | >>> routeUrl Main 36 | / 37 | 38 | >>> routeUrl (User 9) 39 | /user/9 40 | -} 41 | class Route a where 42 | -- | The route to use if attempting to match on empty segments 43 | baseRoute :: Maybe a 44 | default baseRoute :: (Generic a, GenRoute (Rep a)) => Maybe a 45 | baseRoute = Nothing 46 | 47 | 48 | -- | Try to match segments to a route 49 | matchRoute :: [Segment] -> Maybe a 50 | default matchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a 51 | -- this will match a trailing slash, but not if it is missing 52 | matchRoute segs = 53 | case (segs, baseRoute) of 54 | ([""], Just b) -> pure b 55 | ([], Just b) -> pure b 56 | (_, _) -> genMatchRoute segs 57 | 58 | 59 | -- | Map a route to segments 60 | routePath :: a -> [Segment] 61 | default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> [Segment] 62 | routePath p 63 | | Just p == baseRoute = [] 64 | | otherwise = genRoutePath p 65 | 66 | 67 | -- | Try to match a route, use 'defRoute' if it's empty 68 | findRoute :: (Route a) => [Segment] -> Maybe a 69 | findRoute [] = baseRoute 70 | findRoute ps = matchRoute ps 71 | 72 | 73 | genMatchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a 74 | genMatchRoute segs = to <$> genRoute segs 75 | 76 | 77 | genRoutePath :: (Generic a, GenRoute (Rep a)) => a -> [Segment] 78 | genRoutePath = genPaths . from 79 | 80 | 81 | {- | Convert a 'Route' to a 'Url' 82 | 83 | >>> routeUrl (User 100) 84 | /user/100 85 | -} 86 | routeUri :: (Route a) => a -> URI 87 | routeUri = pathUri . Path True . routePath 88 | 89 | 90 | -- | Automatically derive 'Route' 91 | class GenRoute f where 92 | genRoute :: [Text] -> Maybe (f p) 93 | genPaths :: f p -> [Text] 94 | 95 | 96 | -- datatype metadata 97 | instance (GenRoute f) => GenRoute (M1 D c f) where 98 | genRoute ps = M1 <$> genRoute ps 99 | genPaths (M1 x) = genPaths x 100 | 101 | 102 | -- Constructor names / lines 103 | instance (Constructor c, GenRoute f) => GenRoute (M1 C c f) where 104 | genRoute (n : ps) = do 105 | -- take the first path off the list 106 | -- check that it matches the constructor name 107 | -- check that the rest matches 108 | let name = conName (undefined :: M1 C c f x) 109 | guard (n == toLower (pack name)) 110 | M1 <$> genRoute ps 111 | genRoute [] = Nothing 112 | 113 | 114 | genPaths (M1 x) = 115 | let name = conName (undefined :: M1 C c f x) 116 | in filter (not . T.null) $ toLower (pack name) : genPaths x 117 | 118 | 119 | -- Unary constructors 120 | instance GenRoute U1 where 121 | genRoute [] = pure U1 122 | genRoute _ = Nothing 123 | genPaths _ = [] 124 | 125 | 126 | -- Selectors 127 | instance (GenRoute f) => GenRoute (M1 S c f) where 128 | genRoute ps = 129 | M1 <$> genRoute ps 130 | 131 | 132 | genPaths (M1 x) = genPaths x 133 | 134 | 135 | -- Sum types 136 | instance (GenRoute a, GenRoute b) => GenRoute (a :+: b) where 137 | genRoute ps = L1 <$> genRoute ps <|> R1 <$> genRoute ps 138 | 139 | 140 | genPaths (L1 a) = genPaths a 141 | genPaths (R1 a) = genPaths a 142 | 143 | 144 | -- Product types 145 | instance (GenRoute a, GenRoute b) => GenRoute (a :*: b) where 146 | genRoute (p : ps) = do 147 | ga <- genRoute [p] 148 | gr <- genRoute ps 149 | pure $ ga :*: gr 150 | genRoute _ = Nothing 151 | 152 | 153 | genPaths (a :*: b) = genPaths a <> genPaths b 154 | 155 | 156 | instance (Route sub) => GenRoute (K1 R sub) where 157 | genRoute ts = K1 <$> matchRoute ts 158 | 159 | 160 | genPaths (K1 sub) = routePath sub 161 | 162 | 163 | genRouteRead :: (Read x) => [Text] -> Maybe (K1 R x a) 164 | genRouteRead [t] = do 165 | K1 <$> readMaybe (unpack t) 166 | genRouteRead _ = Nothing 167 | 168 | 169 | instance Route Text where 170 | matchRoute [t] = pure t 171 | matchRoute _ = Nothing 172 | routePath t = [t] 173 | baseRoute = Nothing 174 | 175 | 176 | instance Route String where 177 | matchRoute [t] = pure (unpack t) 178 | matchRoute _ = Nothing 179 | routePath t = [pack t] 180 | baseRoute = Nothing 181 | 182 | 183 | instance Route Integer where 184 | matchRoute = matchRouteRead 185 | routePath = routePathShow 186 | baseRoute = Nothing 187 | 188 | 189 | instance Route Int where 190 | matchRoute = matchRouteRead 191 | routePath = routePathShow 192 | baseRoute = Nothing 193 | 194 | 195 | instance (Route a) => Route (Maybe a) where 196 | matchRoute [] = pure Nothing 197 | matchRoute ps = Just <$> matchRoute ps 198 | routePath (Just a) = routePath a 199 | routePath Nothing = [] 200 | baseRoute = Nothing 201 | 202 | 203 | matchRouteRead :: (Read a) => [Segment] -> Maybe a 204 | matchRouteRead [t] = readMaybe (unpack t) 205 | matchRouteRead _ = Nothing 206 | 207 | 208 | routePathShow :: (Show a) => a -> [Segment] 209 | routePathShow a = [pack (show a)] 210 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/TypeList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Web.Hyperbole.TypeList where 4 | 5 | import Data.Kind (Constraint, Type) 6 | import GHC.TypeLits hiding (Mod) 7 | 8 | 9 | -- concat lists 10 | type family (<++>) xs ys where 11 | '[] <++> ys = ys 12 | xs <++> '[] = xs 13 | (x ': xs) <++> ys = x : xs <++> ys 14 | 15 | 16 | type family Remove x ys where 17 | Remove x '[] = '[] 18 | Remove x (x ': ys) = Remove x ys 19 | Remove x (y ': ys) = y ': Remove x ys 20 | 21 | 22 | type family RemoveAll xs ys where 23 | RemoveAll '[] ys = ys 24 | RemoveAll xs '[] = '[] 25 | RemoveAll (x ': xs) ys = RemoveAll xs (Remove x ys) 26 | 27 | 28 | -- Type family to check if an element is in a type-level list 29 | type Elem e es = ElemOr e es (NotElem e es) 30 | 31 | 32 | -- 'orig' is used to store original list for better error messages 33 | type family ElemOr e es err :: Constraint where 34 | ElemOr x (x ': xs) err = () 35 | ElemOr y (x ': xs) err = ElemOr y xs err 36 | -- Note [Custom Errors] 37 | ElemOr x '[] err = err 38 | 39 | 40 | type family AllElemOr xs ys err :: Constraint where 41 | AllElemOr '[] _ _ = () 42 | AllElemOr (x ': xs) ys err = 43 | (ElemOr x ys err, AllElemOr xs ys err) 44 | 45 | 46 | type NotElem x (orig :: [Type]) = 47 | TypeError 48 | ( 'ShowType x 49 | ':<>: 'Text " not found in " 50 | ':<>: 'ShowType orig 51 | ) 52 | 53 | 54 | type family TupleList a where 55 | TupleList () = '[] 56 | TupleList (a, b) = [a, b] 57 | TupleList (a, b, c) = [a, b, c] 58 | TupleList (a, b, c, d) = [a, b, c, d] 59 | TupleList (a, b, c, d, e) = [a, b, c, d, e] 60 | TupleList (a, b, c, d, e, f) = [a, b, c, d, e, f] 61 | TupleList (a, b, c, d, e, f, g) = [a, b, c, d, e, f, g] 62 | TupleList (a, b, c, d, e, f, g, h) = [a, b, c, d, e, f, g, h] 63 | TupleList (a, b, c, d, e, f, g, h, i) = [a, b, c, d, e, f, g, h, i] 64 | TupleList (a, b, c, d, e, f, g, h, i, j) = [a, b, c, d, e, f, g, h, i, j] 65 | TupleList a = '[a] 66 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/View.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.View 2 | ( module Web.Hyperbole.View.Embed 3 | , module Web.Hyperbole.View.Render 4 | , module Web.Hyperbole.View.Tag 5 | , module Web.Hyperbole.View.Types 6 | , module Web.Hyperbole.View.CSS 7 | , module Web.Atomic.Attributes 8 | ) where 9 | 10 | import Web.Atomic.Attributes 11 | import Web.Hyperbole.View.CSS 12 | import Web.Hyperbole.View.Embed 13 | import Web.Hyperbole.View.Render 14 | import Web.Hyperbole.View.Tag hiding (form, input, label) 15 | import Web.Hyperbole.View.Types (View, addContext, context, none, raw, tag, text) 16 | 17 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/View/CSS.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.View.CSS where 2 | 3 | import Web.Atomic.CSS 4 | 5 | 6 | {- | Apply CSS only when a request is in flight. See [Example.Page.Contact](https://docs.hyperbole.live/contacts/1) 7 | 8 | @ 9 | #EMBED Example/Page/Contact.hs contactEditView 10 | @ 11 | -} 12 | whenLoading :: (Styleable h) => (CSS h -> CSS h) -> CSS h -> CSS h 13 | whenLoading = do 14 | descendentOf "hyp-loading" 15 | 16 | 17 | disabled :: (Styleable h) => CSS h -> CSS h 18 | disabled = 19 | utility 20 | "disabled" 21 | [ "opacity" :. "0.7" 22 | , "pointer-events" :. "none" 23 | ] 24 | 25 | 26 | loading :: (Styleable h) => CSS h -> CSS h 27 | loading = whenLoading disabled 28 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/View/Embed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Web.Hyperbole.View.Embed 4 | ( Atomic.cssResetEmbed 5 | , scriptEmbed 6 | ) 7 | where 8 | 9 | import Data.ByteString 10 | import Data.FileEmbed 11 | import Web.Atomic.CSS.Reset qualified as Atomic 12 | 13 | 14 | scriptEmbed :: ByteString 15 | scriptEmbed = $(embedFile "client/dist/hyperbole.js") 16 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/View/Render.hs: -------------------------------------------------------------------------------- 1 | module Web.Hyperbole.View.Render 2 | ( renderText 3 | , renderLazyByteString 4 | ) where 5 | 6 | import Data.ByteString.Lazy qualified as BL 7 | import Data.Text (Text) 8 | import Web.Atomic.Render qualified as Atomic 9 | import Web.Hyperbole.View.Types (View, runView) 10 | 11 | 12 | renderText :: View () () -> Text 13 | renderText = Atomic.renderText . runView () 14 | 15 | 16 | renderLazyByteString :: View () () -> BL.ByteString 17 | renderLazyByteString = Atomic.renderLazyByteString . runView () 18 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/View/Tag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Web.Hyperbole.View.Tag where 4 | 5 | import Control.Monad (forM_) 6 | import Data.Text (Text, pack) 7 | import Effectful 8 | import Effectful.State.Static.Local 9 | import Web.Atomic.CSS 10 | import Web.Atomic.Types 11 | import Web.Hyperbole.Data.URI 12 | import Web.Hyperbole.View.Types 13 | 14 | 15 | el :: View c () -> View c () 16 | el = tag "div" 17 | 18 | 19 | row :: View c () -> View c () 20 | row = tag "div" ~ flexRow 21 | 22 | 23 | col :: View c () -> View c () 24 | col = tag "div" ~ flexCol 25 | 26 | 27 | space :: View c () 28 | space = tag "div" none ~ grow 29 | 30 | 31 | pre :: Text -> View c () 32 | pre t = tag "pre" (text t) 33 | 34 | 35 | code :: Text -> View c () 36 | code t = tag "code" (text t) 37 | 38 | 39 | -- | A hyperlink to the given url 40 | link :: URI -> View c () -> View c () 41 | link u = tag "a" @ att "href" (uriToText u) 42 | 43 | 44 | img :: Text -> View c () 45 | img sc = tag "img" @ src sc $ none 46 | 47 | 48 | -- * Inputs 49 | 50 | 51 | -- basic forms. See Web.Hyperbole.View.Forms 52 | form :: View c () -> View c () 53 | form = tag "form" 54 | 55 | 56 | input :: View c () 57 | input = tag "input" @ att "type" "text" $ none 58 | 59 | 60 | name :: (Attributable h) => Text -> Attributes h -> Attributes h 61 | name = att "name" 62 | 63 | 64 | value :: (Attributable h) => Text -> Attributes h -> Attributes h 65 | value = att "value" 66 | 67 | 68 | label :: View c () -> View c () 69 | label = tag "label" 70 | 71 | 72 | placeholder :: (Attributable h) => Text -> Attributes h -> Attributes h 73 | placeholder = att "placeholder" 74 | 75 | 76 | autofocus :: (Attributable h) => Attributes h -> Attributes h 77 | autofocus = att "autofocus" "" 78 | 79 | 80 | -- * Document Metadata 81 | 82 | 83 | type_ :: (Attributable h) => Text -> Attributes h -> Attributes h 84 | type_ = att "type" 85 | 86 | 87 | src :: (Attributable h) => Text -> Attributes h -> Attributes h 88 | src = att "src" 89 | 90 | 91 | script :: Text -> View c () 92 | script s = tag "script" none @ type_ "text/javascript" @ src s 93 | 94 | 95 | style :: Text -> View c () 96 | style cnt = tag "style" (text $ "\n" <> cnt <> "\n") @ type_ "text/css" 97 | 98 | 99 | stylesheet :: Text -> View c () 100 | stylesheet href = tag "link" @ att "rel" "stylesheet" . att "href" href $ none 101 | 102 | 103 | -- * Navigation 104 | 105 | 106 | nav :: View c () -> View c () 107 | nav = tag "nav" 108 | 109 | 110 | -- * Tables 111 | 112 | 113 | {- | Create a type safe data table by specifying columns 114 | 115 | > data User = User {name :: Text, email :: Text} 116 | > 117 | > usersTable :: [User] -> View c () 118 | > usersTable us = do 119 | > table us $ do 120 | > tcol (th "Name" ~ hd) $ \u -> td ~ cell $ text u.name 121 | > tcol (th "Email" ~ hd) $ \u -> td ~ cell $ text u.email 122 | > where 123 | > hd = cell . bold 124 | > cell :: (Styleable h) => CSS h -> CSS h 125 | > cell = pad 4 . border 1 126 | -} 127 | table :: [dt] -> TableColumns c dt () -> View c () 128 | table dts (TableColumns wcs) = do 129 | let cols = runPureEff . execState [] $ wcs 130 | tag "table" $ do 131 | tag "thead" $ do 132 | tag "tr" $ do 133 | forM_ cols $ \tc -> do 134 | let TableHead hd = tc.headCell 135 | hd 136 | tag "tbody" $ do 137 | forM_ dts $ \dt -> do 138 | tag "tr" $ do 139 | forM_ cols $ \tc -> do 140 | tc.dataCell dt 141 | 142 | 143 | usersTable :: View c () 144 | usersTable = do 145 | table items $ do 146 | tcol (th "Index" ~ bold) $ \u -> td ~ cell $ text $ pack $ show $ fst u 147 | tcol (th "Item" ~ bold) $ \u -> td ~ cell $ text $ snd u 148 | where 149 | items :: [(Int, Text)] 150 | items = zip [0 ..] ["one", "two", "three"] 151 | cell :: (Styleable h) => CSS h -> CSS h 152 | cell = pad 4 . border 1 153 | 154 | 155 | newtype Table c a = Table (View c a) 156 | deriving newtype (Functor, Applicative, Monad, Styleable) 157 | 158 | 159 | tcol :: forall dt c. TableHead c () -> (dt -> View c ()) -> TableColumns c dt () 160 | tcol hd cell = TableColumns $ do 161 | modify @[TableColumn c dt] $ \cols -> cols <> [TableColumn hd cell] 162 | 163 | 164 | th :: View c () -> TableHead c () 165 | th cnt = do 166 | TableHead $ tag "th" cnt 167 | 168 | 169 | td :: View c () -> View c () 170 | td = tag "td" 171 | 172 | 173 | instance {-# OVERLAPS #-} Styleable (TableColumns c dt () -> View c ()) where 174 | modCSS frr parent eff = modCSS frr (parent eff) 175 | 176 | 177 | newtype TableHead id a = TableHead (View id a) 178 | deriving newtype (Functor, Applicative, Monad, Styleable) 179 | 180 | 181 | newtype TableColumns c dt a = TableColumns (Eff '[State [TableColumn c dt]] a) 182 | deriving newtype (Functor, Applicative, Monad) 183 | 184 | 185 | data TableColumn c dt = TableColumn 186 | { headCell :: TableHead c () 187 | , dataCell :: dt -> View c () 188 | } 189 | 190 | 191 | -- * Lists 192 | 193 | 194 | {- | List elements do not include any inherent styling but are useful for accessibility. See 'Web.Atomic.CSS.list'. 195 | 196 | > ol id $ do 197 | > let nums = list Decimal 198 | > li nums "one" 199 | > li nums "two" 200 | > li nums "three" 201 | -} 202 | ol :: ListItem c () -> View c () 203 | ol (ListItem cnt) = do 204 | tag "ol" cnt 205 | 206 | 207 | ul :: ListItem c () -> View c () 208 | ul (ListItem cnt) = do 209 | tag "ul" cnt 210 | 211 | 212 | li :: View c () -> ListItem c () 213 | li cnt = ListItem $ do 214 | tag "li" cnt 215 | 216 | 217 | newtype ListItem c a = ListItem (View c a) 218 | deriving newtype (Functor, Applicative, Monad, Styleable) 219 | -------------------------------------------------------------------------------- /src/Web/Hyperbole/View/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module Web.Hyperbole.View.Types where 6 | 7 | import Data.Kind (Type) 8 | import Data.String (IsString (..)) 9 | import Data.Text (Text, pack) 10 | import Effectful 11 | import Effectful.Reader.Static 12 | import Web.Atomic.Html (Html (..)) 13 | import Web.Atomic.Html qualified as Atomic 14 | import Web.Atomic.Types 15 | 16 | 17 | -- View ------------------------------------------------------------ 18 | 19 | newtype View c a = View {html :: Eff '[Reader c] (Html a)} 20 | 21 | 22 | instance IsString (View c ()) where 23 | fromString s = View $ pure $ Atomic.text (pack s) 24 | 25 | 26 | runView :: forall c a. c -> View c a -> Html a 27 | runView c (View eff) = do 28 | runPureEff $ runReader c eff 29 | 30 | 31 | instance Functor (View c) where 32 | fmap f (View eff) = View $ do 33 | html <- eff 34 | pure $ fmap f html 35 | instance Applicative (View ctx) where 36 | pure a = View $ pure $ pure a 37 | liftA2 :: (a -> b -> c) -> View ctx a -> View ctx b -> View ctx c 38 | liftA2 abc (View va) (View vb) = View $ do 39 | ha <- va 40 | hb <- vb 41 | pure $ liftA2 abc ha hb 42 | View va *> View vb = View $ do 43 | ha <- va 44 | hb <- vb 45 | pure $ ha *> hb 46 | instance Monad (View ctx) where 47 | (>>) = (*>) 48 | (>>=) :: forall a b. View ctx a -> (a -> View ctx b) -> View ctx b 49 | -- TEST: appending Empty 50 | View ea >>= famb = View $ do 51 | a :: a <- (.value) <$> ea 52 | let View eb :: View ctx b = famb a 53 | hb <- eb 54 | pure $ hb 55 | 56 | 57 | -- Context ----------------------------------------- 58 | 59 | type family ViewContext (v :: Type) where 60 | ViewContext (View c x) = c 61 | ViewContext (View c x -> View c x) = c 62 | 63 | 64 | -- TEST: appending Empty 65 | context :: forall c. View c c 66 | context = View $ do 67 | c <- ask @c 68 | pure $ pure c 69 | 70 | 71 | addContext :: ctx -> View ctx () -> View c () 72 | addContext c (View eff) = View $ do 73 | pure $ runPureEff $ runReader c eff 74 | 75 | 76 | -- Html --------------------------------------------- 77 | 78 | tag :: Text -> View c () -> View c () 79 | tag n (View eff) = View $ do 80 | content <- eff 81 | pure $ Atomic.tag n content 82 | 83 | 84 | text :: Text -> View c () 85 | text t = View $ pure $ Atomic.text t 86 | 87 | 88 | none :: View c () 89 | none = View $ pure Atomic.none 90 | 91 | 92 | raw :: Text -> View c () 93 | raw t = View $ pure $ Atomic.raw t 94 | 95 | 96 | -- Attributes ----------------------------------------- 97 | 98 | instance Attributable (View c a) where 99 | modAttributes f (View eff) = View $ do 100 | h <- eff 101 | pure $ modAttributes f h 102 | 103 | 104 | instance Styleable (View c a) where 105 | modCSS f (View eff) = View $ do 106 | h <- eff 107 | pure $ modCSS f h 108 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Skeletest.Main 2 | 3 | -------------------------------------------------------------------------------- /test/Test/FormSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Test.FormSpec where 4 | 5 | import Data.Text (Text) 6 | import Skeletest 7 | import Web.Hyperbole.HyperView.Forms 8 | 9 | 10 | data Example f = Example 11 | { message :: Field f Text 12 | , age :: Field f Int 13 | , whatever :: Field f (Maybe Float) 14 | } 15 | deriving (Generic, FromFormF, GenFields Maybe) 16 | 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "forms" $ do 21 | it "should parse a form" $ do 22 | case fromForm @(Example Identity) [("message", "hello"), ("age", "23"), ("whatever", "")] of 23 | Left e -> fail $ show e 24 | Right a -> do 25 | a.message `shouldBe` "hello" 26 | a.age `shouldBe` 23 27 | a.whatever `shouldBe` Nothing 28 | -------------------------------------------------------------------------------- /test/Test/QuerySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Test.QuerySpec where 5 | 6 | import Data.Function ((&)) 7 | import Data.Text (Text) 8 | import Skeletest 9 | import Web.Hyperbole 10 | import Web.Hyperbole.Data.QueryData as QueryData 11 | 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "param" paramSpec 16 | describe "render" renderSpec 17 | describe "multi" multiSpec 18 | 19 | 20 | data Woot = Woot Text 21 | deriving (Generic, Show) 22 | 23 | 24 | paramSpec :: Spec 25 | paramSpec = do 26 | describe "ToParam" $ do 27 | it "should encode basics" $ do 28 | toParam @Text "hello" `shouldBe` "hello" 29 | toParam @Int 23 `shouldBe` "23" 30 | 31 | it "should encode Maybe" $ do 32 | toParam @(Maybe Int) Nothing `shouldBe` "" 33 | toParam @(Maybe Int) (Just 23) `shouldBe` "23" 34 | 35 | -- it "should encode lists with spaces = plusses" $ do 36 | -- toParam @[Int] [1, 2, 3] `shouldBe` ParamValue ("1+2+3") 37 | -- toParam @[Text] ["one", "two"] `shouldBe` ParamValue ("one+two") 38 | -- toParam @[Text] ["hello world", "friend"] `shouldBe` ParamValue ("hello%20world+friend") 39 | 40 | it "should not escape text" $ do 41 | toParam @Text "hello world" `shouldBe` "hello world" 42 | 43 | describe "FromParam" $ do 44 | it "should parse basics" $ do 45 | parseParam @Text "hello" `shouldBe` Right "hello" 46 | parseParam @Int "3" `shouldBe` Right 3 47 | 48 | 49 | -- it "should decode lists with plusses" $ do 50 | -- parseParam @[Int] "1+2+3" `shouldBe` Right [1, 2, 3] 51 | -- 52 | -- it "should decode lists with escapes" $ do 53 | -- let vals = ["hello world", "friend"] :: [Text] 54 | -- parseParam (toParam @[Text] vals) `shouldBe` Right vals 55 | 56 | renderSpec :: Spec 57 | renderSpec = do 58 | it "should parse multiple items" $ do 59 | let qd = parse "msg=hello&age=1" 60 | require @Text "msg" qd `shouldBe` Right "hello" 61 | require @Int "age" qd `shouldBe` Right 1 62 | 63 | it "should render as a querystring" $ do 64 | let q = 65 | mempty 66 | & QueryData.insert @Text "msg" "value" 67 | & QueryData.insert @Int "age" 1 68 | QueryData.render q `shouldBe` "age=1&msg=value" 69 | 70 | it "should escape special characters in strings" $ do 71 | let q = mempty & QueryData.insert @Text "msg" "bob&henry=fast" 72 | QueryData.render q `shouldBe` "msg=bob%26henry%3Dfast" 73 | 74 | it "should roundtrip special characters" $ do 75 | let msg = "bob&henry=fast" 76 | let q = mempty & QueryData.insert @Text "msg" msg 77 | let out = QueryData.render q 78 | let q' = QueryData.parse out 79 | QueryData.lookup "msg" q' `shouldBe` Just msg 80 | 81 | 82 | -- it "should preserve plusses" $ do 83 | -- let QueryData q = QueryData $ M.fromList [("items", "one+two")] 84 | -- print $ HTTP.toQuery $ M.toList q 85 | -- QueryData.render (QueryData q) `shouldBe` "items=one+two" 86 | 87 | data Filters = Filters 88 | { term :: Text 89 | , isActive :: Bool 90 | , another :: Maybe Text 91 | } 92 | deriving (Eq, Show) 93 | 94 | 95 | instance ToQuery Filters where 96 | toQuery f = 97 | mempty 98 | & QueryData.insert "term" f.term 99 | & QueryData.insert "isActive" f.isActive 100 | & QueryData.insert "another" f.another 101 | 102 | 103 | instance FromQuery Filters where 104 | parseQuery q = do 105 | term <- QueryData.require "term" q 106 | isActive <- QueryData.require "isActive" q 107 | another <- QueryData.require "another" q 108 | pure Filters{..} 109 | 110 | 111 | data Filters' = Filters' 112 | { term :: Text 113 | , isActive :: Bool 114 | } 115 | deriving (Generic, Eq, ToJSON, FromJSON, FromParam, ToParam) 116 | instance Default Filters' where 117 | def = Filters' "" False 118 | 119 | 120 | data Nested = Nested 121 | { filters :: Filters' 122 | } 123 | deriving (Generic, ToQuery, FromQuery) 124 | 125 | 126 | -- instance ToQuery Nested where 127 | -- toQuery n = 128 | -- mempty & QueryData.insert "filters" (JSON n.filters) 129 | -- 130 | -- 131 | -- instance FromQuery Nested where 132 | -- parseQuery q = 133 | -- mempty & QueryData.insert "filters" (JSON n.filters) 134 | 135 | multiSpec :: Spec 136 | multiSpec = do 137 | it "should convert to querydata" $ do 138 | let f = Filters "woot" False Nothing 139 | QueryData.render (toQuery f) `shouldBe` "another=&isActive=false&term=woot" 140 | 141 | it "should convert to querydata 2" $ do 142 | let f = Filters "woot" False (Just "ok") 143 | QueryData.render (toQuery f) `shouldBe` "another=ok&isActive=false&term=woot" 144 | 145 | it "should parse from querydata" $ do 146 | let f = Filters "woot" False Nothing 147 | let out = QueryData.render (toQuery f) 148 | let q = QueryData.parse out 149 | parseQuery q `shouldBe` Right f 150 | 151 | it "should work with Just" $ do 152 | let f = Filters "woot" False (Just "hello") 153 | let out = QueryData.render (toQuery f) 154 | let q = QueryData.parse out 155 | parseQuery q `shouldBe` Right f 156 | -------------------------------------------------------------------------------- /test/Test/RouteSpec.hs: -------------------------------------------------------------------------------- 1 | module Test.RouteSpec where 2 | 3 | import Data.Text (Text) 4 | import GHC.Generics 5 | import Skeletest 6 | import Web.Hyperbole.Route 7 | 8 | 9 | data Routes 10 | = MainPage 11 | | Hello Hello 12 | | Goodbye 13 | deriving (Show, Generic, Eq) 14 | instance Route Routes where 15 | baseRoute = Just MainPage 16 | 17 | 18 | data Hello 19 | = MainHello 20 | | World 21 | | Message String 22 | deriving (Show, Generic, Eq) 23 | instance Route Hello where 24 | baseRoute = Just MainHello 25 | 26 | 27 | data NoMain = NoMain Nested 28 | deriving (Show, Generic, Eq, Route) 29 | 30 | 31 | data Nested 32 | = Something 33 | | Nested Text 34 | deriving (Show, Generic, Eq, Route) 35 | 36 | 37 | spec :: Spec 38 | spec = do 39 | describe "Route" $ do 40 | describe "routePath" $ do 41 | it "basic" $ 42 | routePath Goodbye `shouldBe` ["goodbye"] 43 | 44 | it "default" $ 45 | routePath MainPage `shouldBe` [] 46 | 47 | it "dynamic" $ 48 | routePath (Hello (Message "woot")) `shouldBe` ["hello", "message", "woot"] 49 | 50 | it "compound" $ 51 | routePath (Hello World) `shouldBe` ["hello", "world"] 52 | 53 | it "compound default" $ 54 | routePath (Hello MainHello) `shouldBe` ["hello"] 55 | 56 | it "constructors with parameters should use full url" $ 57 | routePath (NoMain (Nested "woot")) `shouldBe` ["nomain", "nested", "woot"] 58 | 59 | it "no main should use full url" $ 60 | routePath (NoMain Something) `shouldBe` ["nomain", "something"] 61 | 62 | describe "matchRoute" $ do 63 | it "basic" $ matchRoute ["goodbye"] `shouldBe` Just Goodbye 64 | it "default empty string" $ matchRoute [""] `shouldBe` Just MainPage 65 | it "default empty" $ matchRoute [] `shouldBe` Just MainPage 66 | it "compound" $ matchRoute ["hello", "world"] `shouldBe` Just (Hello World) 67 | it "compound default" $ matchRoute ["hello"] `shouldBe` Just (Hello MainHello) 68 | it "compound dynamic" $ matchRoute ["hello", "message", "whatever"] `shouldBe` Just (Hello (Message "whatever")) 69 | it "no base compound" $ matchRoute ["nomain", "nested", "hello"] `shouldBe` Just (NoMain (Nested "hello")) 70 | 71 | describe "baseRoute" $ do 72 | it "default" $ baseRoute `shouldBe` Just MainPage 73 | it "compound" $ (baseRoute @Hello) `shouldBe` Just MainHello 74 | it "none" $ (baseRoute @Nested) `shouldBe` Nothing 75 | -------------------------------------------------------------------------------- /test/Test/SessionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Test.SessionSpec where 4 | 5 | import Data.Aeson as A (encode) 6 | import Data.String.Conversions (cs) 7 | import Data.Text (Text) 8 | import Network.HTTP.Types (urlEncode) 9 | import Skeletest 10 | import Web.Hyperbole 11 | import Web.Hyperbole.Data.Cookie as Cookie 12 | import Web.Hyperbole.Data.URI 13 | import Web.Hyperbole.Effect.Session (sessionCookie) 14 | 15 | 16 | -- import Skeletest.Predicate qualified as P 17 | 18 | data Woot = Woot Text 19 | deriving (Generic, Show, ToJSON, FromJSON) 20 | instance Session Woot where 21 | cookiePath = Just $ Path True ["somepage"] 22 | 23 | 24 | spec :: Spec 25 | spec = do 26 | describe "Session" $ do 27 | it "should encode cookie" $ do 28 | let woot = Woot "hello" 29 | toCookie woot `shouldBe` CookieValue (cs $ A.encode woot) 30 | 31 | describe "sessionCookie" $ do 32 | it "should create cookie" $ do 33 | let woot = Woot "hello" 34 | sessionCookie woot `shouldBe` Cookie (sessionKey @Woot) (cookiePath @Woot) (Just (toCookie woot)) 35 | 36 | describe "render" $ do 37 | it "should parse cookies" $ do 38 | Cookie.parse [("Woot", "Woot")] `shouldBe` Right (Cookie.fromList [Cookie "Woot" Nothing (Just (CookieValue "Woot"))]) 39 | 40 | it "should render cookie with root path" $ do 41 | let cookie = Cookie "Woot" Nothing (Just (CookieValue "Woot")) 42 | Cookie.render [] cookie `shouldBe` "Woot=Woot; SameSite=None; secure; path=/" 43 | 44 | it "should render complex cookie with included path" $ do 45 | let woot = Woot "hello world" 46 | let cookie = sessionCookie woot 47 | Cookie.render [] cookie `shouldBe` "Woot=" <> urlEncode True (cs $ A.encode woot) <> "; SameSite=None; secure; path=/somepage" 48 | 49 | describe "Session class" $ do 50 | it "should encode class" $ do 51 | let prefs = Preferences "hello" Warning 52 | let cooks = Cookie.insert (sessionCookie prefs) mempty 53 | Cookie.lookup (sessionKey @Preferences) cooks `shouldBe` Just (CookieValue $ cs $ A.encode prefs) 54 | 55 | it "should decode class" $ do 56 | let prefs = Preferences "hello" Warning 57 | let cooks = Cookie.insert (sessionCookie prefs) mempty 58 | Just val <- pure $ Cookie.lookup (sessionKey @Preferences) cooks 59 | parseCookie val `shouldBe` Right prefs 60 | 61 | 62 | data Preferences = Preferences 63 | { message :: Text 64 | , color :: AppColor 65 | } 66 | deriving (Generic, Eq, Show, ToJSON, FromJSON, Session) 67 | instance Default Preferences where 68 | def = Preferences "_" White 69 | 70 | 71 | data AppColor 72 | = White 73 | | Light 74 | | GrayLight 75 | | GrayDark 76 | | Dark 77 | | DarkHighlight 78 | | Success 79 | | Danger 80 | | Warning 81 | | Primary 82 | | PrimaryLight 83 | | Secondary 84 | | SecondaryLight 85 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 86 | -------------------------------------------------------------------------------- /test/Test/ViewActionSpec.hs: -------------------------------------------------------------------------------- 1 | module Test.ViewActionSpec where 2 | 3 | import Data.Aeson qualified as A 4 | import Data.Text (Text) 5 | import GHC.Generics 6 | import Skeletest 7 | import Skeletest.Predicate qualified as P 8 | import Web.Hyperbole (FromJSON, ToJSON) 9 | import Web.Hyperbole.Data.Encoded 10 | import Web.Hyperbole.HyperView (ViewAction (..)) 11 | import Web.Hyperbole.HyperView.Event (toActionInput) 12 | 13 | 14 | data Simple = Simple 15 | deriving (Generic, Eq, Show, Read, ViewAction, ToJSON, FromJSON) 16 | 17 | 18 | data Product = Product String Int 19 | deriving (Generic, Show, Eq, ViewAction, Read, ToJSON, FromJSON, ToEncoded, FromEncoded) 20 | 21 | 22 | data Product' = Product' HasText Int 23 | deriving (Generic, Show, Eq, ViewAction, Read, ToJSON, FromJSON, ToEncoded, FromEncoded) 24 | 25 | 26 | data Sum 27 | = SumA 28 | | SumB Int 29 | | SubC Text 30 | | SubD (Maybe Text) 31 | | SubE Term 32 | | SubF Simple 33 | deriving (Generic, Show, Read, Eq, ViewAction) 34 | 35 | 36 | data Compound = Compound Product 37 | deriving (Generic, Show, Eq, Read, ToJSON, FromEncoded, ToEncoded, FromJSON, ViewAction) 38 | 39 | 40 | data HasText = HasText Text 41 | deriving (Generic, Show, Eq, Read, ViewAction, ToJSON, FromJSON, FromEncoded, ToEncoded) 42 | 43 | 44 | newtype Term = Term Text 45 | deriving newtype (Eq, Show, ToJSON, FromJSON, Read) 46 | 47 | 48 | spec :: Spec 49 | spec = do 50 | describe "ViewAction" $ do 51 | describe "toAction" $ do 52 | it "simple" $ toAction Simple `shouldBe` Encoded "Simple" [] 53 | it "has text" $ toAction (HasText "hello world") `shouldBe` Encoded "HasText" ["hello world"] 54 | it "product" $ toAction (Product "hello world" 123) `shouldBe` Encoded "Product" ["hello world", A.Number 123] 55 | it "sum" $ toAction (SumB 123) `shouldBe` Encoded "SumB" [A.Number 123] 56 | it "compound" $ do 57 | let p = Product "hello world" 123 58 | toAction (Compound p) `shouldBe` Encoded "Compound" [A.toJSON p] 59 | 60 | describe "toActionInput" $ do 61 | it "Constructor Text" $ do 62 | toActionInput SubC `shouldBe` Encoded "SubC" [] 63 | 64 | it "Constructor (Maybe Text)" $ do 65 | toActionInput (SubD . Just) `shouldBe` Encoded "SubD" [] 66 | 67 | it "Constructor newtype Term" $ do 68 | toActionInput (SubE . Term) `shouldBe` Encoded "SubE" [] 69 | 70 | it "renders data constructors" $ do 71 | toActionInput SubF `shouldBe` Encoded "SubF" [] 72 | 73 | describe "parseAction" $ do 74 | it "simple" $ parseAction (Encoded "Simple" []) `shouldBe` pure Simple 75 | 76 | it "parse product" $ do 77 | parseAction @Product (Encoded "Product" ["woot", A.Number 1234]) `shouldSatisfy` P.right P.anything 78 | 79 | it "parse product with spaces" $ do 80 | parseAction @Product (Encoded "Product" ["hello world", A.Number 1234]) `shouldSatisfy` P.right P.anything 81 | 82 | describe "roundTrip" $ do 83 | it "simple" $ do 84 | parseAction (toAction Simple) `shouldBe` pure Simple 85 | it "has text multiple words" $ do 86 | let a = HasText "hello world" 87 | parseAction (toAction a) `shouldBe` pure a 88 | it "product" $ do 89 | let a = Product "hello world" 123 90 | parseAction @Product (toAction a) `shouldBe` pure a 91 | it "product'" $ do 92 | let a = Product' (HasText "hello world") 123 93 | parseAction (toAction a) `shouldBe` pure a 94 | it "compound" $ do 95 | let a = Compound (Product "hello world" 123) 96 | parseAction (toAction a) `shouldBe` pure a 97 | it "sum" $ do 98 | let a = SumB 123 99 | parseAction (toAction a) `shouldBe` pure a 100 | -------------------------------------------------------------------------------- /test/Test/ViewIdSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Test.ViewIdSpec where 4 | 5 | import Data.Text (Text) 6 | import Data.Text qualified as T 7 | import GHC.Generics 8 | import Skeletest 9 | import Web.Hyperbole 10 | import Web.Hyperbole.Data.Encoded 11 | import Web.Hyperbole.HyperView 12 | 13 | 14 | data Thing = Thing 15 | deriving (Generic, Show, Eq, ToJSON, FromJSON, ToEncoded, FromEncoded, ViewId) 16 | 17 | 18 | data Custom = Custom 19 | deriving (Show, Eq) 20 | 21 | 22 | data HasString = HasString String 23 | deriving (Generic, Show, Eq, Read, ViewId) 24 | 25 | 26 | data Compound 27 | = One 28 | | Two Thing 29 | | WithId (Id Thing) 30 | | Compound Text Compound 31 | deriving (Generic, Show, Eq, ToJSON, FromJSON, ToEncoded, FromEncoded, ViewId) 32 | 33 | 34 | data Product4 = Product4 Text Text Text Text 35 | deriving (Generic, Show, Eq, Read, ViewId) 36 | 37 | 38 | newtype Id a = Id {fromId :: Text} 39 | deriving newtype (Eq, Ord, Show, ToJSON, FromJSON) 40 | deriving (Generic) 41 | 42 | 43 | instance ViewId Custom where 44 | toViewId Custom = Encoded "something" [] 45 | parseViewId (Encoded "something" []) = pure Custom 46 | parseViewId _ = Left "NOPE" 47 | 48 | 49 | spec :: Spec 50 | spec = do 51 | describe "ViewId Encoded" $ do 52 | describe "toViewId" $ do 53 | it "basic" $ encodeViewId Thing `shouldBe` "Thing" 54 | it "custom" $ encodeViewId Custom `shouldBe` "something" 55 | 56 | describe "parseViewId" $ do 57 | it "basic lowercase" $ decodeViewId @Thing "thing" `shouldBe` Nothing 58 | it "basic" $ decodeViewId @Thing "Thing" `shouldBe` pure Thing 59 | it "custom" $ decodeViewId @Custom "something" `shouldBe` pure Custom 60 | it "custom other" $ decodeViewId @Thing "custom" `shouldBe` Nothing 61 | 62 | describe "has-string" $ do 63 | it "should not contain single quotes" $ do 64 | encodeViewId (HasString "woot") `shouldBe` "HasString \"woot\"" 65 | containsSingleQuotes (encodeViewId (HasString "woot")) `shouldBe` False 66 | 67 | it "should roundtrip" $ do 68 | let inp = HasString "woot" 69 | decodeViewId (encodeViewId inp) `shouldBe` pure inp 70 | 71 | describe "compound" $ do 72 | it "double roundtrip" $ decodeViewId (encodeViewId (Two Thing)) `shouldBe` pure (Two Thing) 73 | 74 | describe "nested" $ do 75 | let nest = Compound "one" $ Compound "two" (Two Thing) 76 | it "should roundtrip" $ decodeViewId (encodeViewId nest) `shouldBe` pure nest 77 | 78 | describe "big product" $ do 79 | let p = Product4 "one" "two" "three" "four" 80 | it "should roundtrip" $ do 81 | let vid = encodeViewId p 82 | decodeViewId vid `shouldBe` pure p 83 | 84 | 85 | -- describe "Param Attributes" $ do 86 | -- it "should serialize basic id" $ do 87 | -- let atts = mempty :: Attributes id 88 | -- (setId "woot" atts).other `shouldBe` [("id", "woot")] 89 | -- 90 | -- it "should serialize compound id" $ do 91 | -- let atts = mempty :: Attributes id 92 | -- (setId (toViewId $ Two Thing) atts).other `shouldBe` [("id", toViewId $ Two Thing)] 93 | -- 94 | -- it "should serialize stringy id" $ do 95 | -- let atts = mempty :: Attributes id 96 | -- (setId (toViewId $ HasString "woot") atts).other `shouldBe` [("id", pack $ show $ HasString "woot")] 97 | -- 98 | -- it "should serialize with Id" $ do 99 | -- let atts = mempty :: Attributes id 100 | -- (setId (toViewId $ WithId (Id "woot")) atts).other `shouldBe` [("id", "WithId \"woot\"")] 101 | 102 | containsSingleQuotes :: Text -> Bool 103 | containsSingleQuotes = T.elem '\'' 104 | 105 | -- setId :: Text -> Mod id 106 | -- setId = att "id" 107 | --------------------------------------------------------------------------------