hyperbole 0.2.0 → 0.3.5
raw patch · 27 files changed
+2504/−478 lines, 27 filesdep +cookiedep +sydtestdep ~web-viewnew-component:exe:examples
Dependencies added: cookie, sydtest
Dependency ranges changed: web-view
Files
- README.md +87/−0
- client/dist/hyperbole.js +13/−3
- example/Example/Colors.hs +23/−9
- example/Example/Contacts.hs +47/−42
- example/Example/Counter.hs +62/−0
- example/Example/Errors.hs +41/−0
- example/Example/Forms.hs +67/−54
- example/Example/LazyLoading.hs +50/−0
- example/Example/Redirects.hs +39/−0
- example/Example/Sessions.hs +80/−0
- example/Example/Simple.hs +47/−0
- example/Example/Style.hs +43/−0
- example/Example/Transitions.hs +19/−16
- example/HelloWorld.hs +59/−0
- example/Main.hs +91/−35
- hyperbole.cabal +65/−7
- src/Web/Hyperbole.hs +287/−12
- src/Web/Hyperbole/Application.hs +277/−91
- src/Web/Hyperbole/Effect.hs +311/−77
- src/Web/Hyperbole/Forms.hs +271/−54
- src/Web/Hyperbole/HyperView.hs +245/−25
- src/Web/Hyperbole/Route.hs +59/−53
- src/Web/Hyperbole/Session.hs +68/−0
- src/Web/Hyperbole/View.hs +6/−0
- test/Spec.hs +3/−0
- test/Test/RouteSpec.hs +51/−0
- test/Test/ViewSpec.hs +93/−0
README.md view
@@ -0,0 +1,87 @@+Hyperbole+=========++[](https://hackage.haskell.org/package/hyperbole) ++Create fully interactive HTML applications with type-safe serverside Haskell. Inspired by [HTMX](https://htmx.org/), [Elm](https://elm-lang.org/), and [Phoenix LiveView](https://www.phoenixframework.org/)++[Learn more about Hyperbole on Hackage](https://hackage.haskell.org/package/hyperbole/docs/Web-Hyperbole.html)++```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++import Web.Hyperbole++main = do+ run 3000 $ do+ liveApp (basicDocument "Example") (page mainPage)+++mainPage = do+ handle message+ load $ do+ pure $ do+ el bold "My Page"+ hyper (Message 1) $ messageView "Hello"+ hyper (Message 2) $ messageView "World!"+++data Message = Message Int+ deriving (Generic, Param)++data MessageAction = Louder Text+ deriving (Generic, Param)++instance HyperView Message where+ type Action Message = MessageAction+++message :: Message -> MessageAction -> Eff es (View Message ())+message _ (Louder m) = do+ let new = m <> "!"+ pure $ messageView new+++messageView m = do+ el_ $ text m+ button (Louder m) id "Louder"+```++Examples+---------++[The example directory](/example/README.md) contains an app with pages demonstrating different features++Run the examples in this repo using cabal. Then visit http://localhost:3000/ in your browser++```+cabal run+```+* [Main](./Main.hs)+* [Simple](./Example/Simple.hs)+* [Counter](./Example/Counter.hs)+* [CSS Transitions](./Example/Transitions.hs)+* [Forms](./Example/Forms.hs)+* [Sessions](./Example/Forms.hs)+* [Redirects](./Example/Redirects.hs)+* [Lazy Loading and Polling](./Example/LazyLoading.hs)+* [Errors](./Example/Errors.hs)+* [Contacts (Advanced)](./Example/Contacts.hs)++Learn More+----------++View Documentation on Hackage+* https://hackage.haskell.org/package/hyperbole/docs/Web-Hyperbole.html++View on Github+* https://github.com/seanhess/hyperbole++In Production+-------------++<a href="https://nso.edu">+ <img alt="National Solar Observatory" src="https://github.com/seanhess/hyperbole/blob/main/example/doc/nso.png"/>+</a>
client/dist/hyperbole.js view
@@ -26,7 +26,7 @@ \***********************/ /***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => { -eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */ listenChange: () => (/* binding */ listenChange),\n/* harmony export */ listenClick: () => (/* binding */ listenClick),\n/* harmony export */ listenFormSubmit: () => (/* binding */ listenFormSubmit)\n/* harmony export */ });\nfunction listenClick(cb) {\n document.addEventListener(\"click\", function (e) {\n var el = e.target;\n // clicks can fire on internal elements. Find the parent with a click handler\n var source = el.closest(\"[data-on-click]\");\n // console.log(\"CLICK\", source?.dataset.onClick)\n // they should all have an action and target\n if ((source === null || source === void 0 ? void 0 : source.dataset.onClick) && (source === null || source === void 0 ? void 0 : source.dataset.target)) {\n e.preventDefault();\n var target = document.getElementById(source.dataset.target);\n if (!target) {\n console.error(\"Missing target: \", source.dataset.target);\n return;\n }\n cb(target, source.dataset.onClick);\n }\n });\n}\nfunction listenChange(cb) {\n document.addEventListener(\"change\", function (e) {\n var el = e.target;\n // clicks can fire on internal elements. Find the parent with a click handler\n var source = el.closest(\"[data-on-change]\");\n // console.log(\"CHANGE!\", source.value)\n // they should all have an action and target\n if ((source === null || source === void 0 ? void 0 : source.dataset.target) && source.value) {\n e.preventDefault();\n var target = document.getElementById(source.dataset.target);\n if (!target) {\n console.error(\"Missing target: \", source.dataset.target);\n return;\n }\n cb(target, source.value);\n }\n });\n}\nfunction listenFormSubmit(cb) {\n document.addEventListener(\"submit\", function (e) {\n var form = e.target;\n // they should all have an action and target\n if ((form === null || form === void 0 ? void 0 : form.dataset.onSubmit) && (form === null || form === void 0 ? void 0 : form.dataset.target)) {\n e.preventDefault();\n var target = document.getElementById(form.dataset.target);\n if (!target) {\n console.error(\"Missing target: \", form.dataset.target);\n return;\n }\n var formData = new FormData(form);\n cb(target, form.dataset.onSubmit, formData);\n }\n });\n}\n\n\n//# sourceURL=webpack://web-ui/./src/events.ts?");+eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */ listenChange: () => (/* binding */ listenChange),\n/* harmony export */ listenClick: () => (/* binding */ listenClick),\n/* harmony export */ listenFormSubmit: () => (/* binding */ listenFormSubmit),\n/* harmony export */ listenLoad: () => (/* binding */ listenLoad),\n/* harmony export */ listenLoadDocument: () => (/* binding */ listenLoadDocument)\n/* harmony export */ });\nfunction listenClick(cb) {\n document.addEventListener(\"click\", function (e) {\n var el = e.target;\n // clicks can fire on internal elements. Find the parent with a click handler\n var source = el.closest(\"[data-on-click]\");\n // console.log(\"CLICK\", source?.dataset.onClick)\n // they should all have an action and target\n if ((source === null || source === void 0 ? void 0 : source.dataset.onClick) && (source === null || source === void 0 ? void 0 : source.dataset.target)) {\n e.preventDefault();\n var target = document.getElementById(source.dataset.target);\n if (!target) {\n console.error(\"Missing target: \", source.dataset.target);\n return;\n }\n cb(target, source.dataset.onClick);\n }\n });\n}\nfunction listenLoadDocument(cb) {\n document.addEventListener(\"hyp-load\", function (e) {\n var load = e.target;\n var action = load.dataset.onLoad;\n var target = document.getElementById(load.dataset.target);\n if (!target) {\n console.error(\"Missing load target: \", target);\n return;\n }\n cb(target, action);\n });\n}\nfunction listenLoad(node) {\n // it doesn't really matter WHO runs this except that it should have target\n node.querySelectorAll(\"[data-on-load]\").forEach(function (load) {\n var delay = parseInt(load.dataset.delay) || 0;\n setTimeout(function () {\n var event = new Event(\"hyp-load\", { bubbles: true });\n load.dispatchEvent(event);\n }, delay);\n });\n}\nfunction listenChange(cb) {\n document.addEventListener(\"change\", function (e) {\n var el = e.target;\n // clicks can fire on internal elements. Find the parent with a click handler\n var source = el.closest(\"[data-on-change]\");\n // console.log(\"CHANGE!\", source.value)\n // they should all have an action and target\n if ((source === null || source === void 0 ? void 0 : source.dataset.target) && source.value) {\n e.preventDefault();\n var target = document.getElementById(source.dataset.target);\n if (!target) {\n console.error(\"Missing target: \", source.dataset.target);\n return;\n }\n cb(target, source.value);\n }\n });\n}\nfunction listenFormSubmit(cb) {\n document.addEventListener(\"submit\", function (e) {\n var form = e.target;\n // they should all have an action and target\n if ((form === null || form === void 0 ? void 0 : form.dataset.onSubmit) && (form === null || form === void 0 ? void 0 : form.dataset.target)) {\n e.preventDefault();\n var target = document.getElementById(form.dataset.target);\n if (!target) {\n console.error(\"Missing target: \", form.dataset.target);\n return;\n }\n var formData = new FormData(form);\n cb(target, form.dataset.onSubmit, formData);\n }\n });\n}\n\n\n//# sourceURL=webpack://web-ui/./src/events.ts?"); /***/ }), @@ -36,17 +36,27 @@ \**********************/ /***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => { -eval("__webpack_require__.r(__webpack_exports__);\n/* harmony import */ var omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__ = __webpack_require__(/*! omdomdom/lib/omdomdom.es.js */ \"./node_modules/omdomdom/lib/omdomdom.es.js\");\n/* harmony import */ var _sockets__WEBPACK_IMPORTED_MODULE_1__ = __webpack_require__(/*! ./sockets */ \"./src/sockets.ts\");\n/* harmony import */ var _events__WEBPACK_IMPORTED_MODULE_2__ = __webpack_require__(/*! ./events */ \"./src/events.ts\");\n/* harmony import */ var _action__WEBPACK_IMPORTED_MODULE_3__ = __webpack_require__(/*! ./action */ \"./src/action.ts\");\nvar __awaiter = (undefined && undefined.__awaiter) || function (thisArg, _arguments, P, generator) {\n function adopt(value) { return value instanceof P ? value : new P(function (resolve) { resolve(value); }); }\n return new (P || (P = Promise))(function (resolve, reject) {\n function fulfilled(value) { try { step(generator.next(value)); } catch (e) { reject(e); } }\n function rejected(value) { try { step(generator[\"throw\"](value)); } catch (e) { reject(e); } }\n function step(result) { result.done ? resolve(result.value) : adopt(result.value).then(fulfilled, rejected); }\n step((generator = generator.apply(thisArg, _arguments || [])).next());\n });\n};\nvar __generator = (undefined && undefined.__generator) || function (thisArg, body) {\n var _ = { label: 0, sent: function() { if (t[0] & 1) throw t[1]; return t[1]; }, trys: [], ops: [] }, f, y, t, g;\n return g = { next: verb(0), \"throw\": verb(1), \"return\": verb(2) }, typeof Symbol === \"function\" && (g[Symbol.iterator] = function() { return this; }), g;\n function verb(n) { return function (v) { return step([n, v]); }; }\n function step(op) {\n if (f) throw new TypeError(\"Generator is already executing.\");\n while (g && (g = 0, op[0] && (_ = 0)), _) try {\n if (f = 1, y && (t = op[0] & 2 ? y[\"return\"] : op[0] ? y[\"throw\"] || ((t = y[\"return\"]) && t.call(y), 0) : y.next) && !(t = t.call(y, op[1])).done) return t;\n if (y = 0, t) op = [op[0] & 2, t.value];\n switch (op[0]) {\n case 0: case 1: t = op; break;\n case 4: _.label++; return { value: op[1], done: false };\n case 5: _.label++; y = op[1]; op = [0]; continue;\n case 7: op = _.ops.pop(); _.trys.pop(); continue;\n default:\n if (!(t = _.trys, t = t.length > 0 && t[t.length - 1]) && (op[0] === 6 || op[0] === 2)) { _ = 0; continue; }\n if (op[0] === 3 && (!t || (op[1] > t[0] && op[1] < t[3]))) { _.label = op[1]; break; }\n if (op[0] === 6 && _.label < t[1]) { _.label = t[1]; t = op; break; }\n if (t && _.label < t[2]) { _.label = t[2]; _.ops.push(op); break; }\n if (t[2]) _.ops.pop();\n _.trys.pop(); continue;\n }\n op = body.call(thisArg, _);\n } catch (e) { op = [6, e]; y = 0; } finally { f = t = 0; }\n if (op[0] & 5) throw op[1]; return { value: op[0] ? op[1] : void 0, done: true };\n }\n};\n\n\n\n\n// import { listenEvents } from './events';\n// import { WEBSOCKET_ADDRESS, Messages } from './Messages'\n// import { INIT_PAGE, INIT_STATE, State, Class } from './types';\n// import { fromVDOM, VDOM } from './vdom'\n// const CONTENT_ID = \"yeti-root-content\"\n// console.log(\"VERSION 2\", INIT_PAGE, INIT_STATE)\nconsole.log(\"Hyperbole 0.2.0\");\nvar rootStyles;\n(0,_events__WEBPACK_IMPORTED_MODULE_2__.listenClick)(function (target, action) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"CLICK\", target.id, action);\n runAction(target, action);\n return [2 /*return*/];\n });\n });\n});\n(0,_events__WEBPACK_IMPORTED_MODULE_2__.listenFormSubmit)(function (target, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"FORM\", target.id, action, form);\n runAction(target, action, form);\n return [2 /*return*/];\n });\n });\n});\n(0,_events__WEBPACK_IMPORTED_MODULE_2__.listenChange)(function (target, action) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"CHANGE\", target.id, action);\n runAction(target, action);\n return [2 /*return*/];\n });\n });\n});\nfunction sendAction(msg) {\n return __awaiter(this, void 0, void 0, function () {\n function sendActionHttp(msg) {\n return __awaiter(this, void 0, void 0, function () {\n var res;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n console.log(\"HTTP sendAction\", msg.url.toString());\n return [4 /*yield*/, fetch(msg.url, {\n method: \"POST\",\n headers: { 'Accept': 'text/html', 'Content-Type': 'application/x-www-form-urlencoded' },\n body: msg.form\n })];\n case 1:\n res = _a.sent();\n return [2 /*return*/, res.text()];\n }\n });\n });\n }\n return __generator(this, function (_a) {\n if (sock.isConnected) {\n return [2 /*return*/, sock.sendAction(msg)];\n }\n else {\n return [2 /*return*/, sendActionHttp(msg)];\n }\n return [2 /*return*/];\n });\n });\n}\nfunction runAction(target, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n var timeout, msg, ret, res, next, old;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n timeout = setTimeout(function () {\n // add loading after 200ms, not right away\n target.classList.add(\"hyp-loading\");\n }, 200);\n msg = (0,_action__WEBPACK_IMPORTED_MODULE_3__.actionMessage)(target.id, action, form);\n return [4 /*yield*/, sendAction(msg)];\n case 1:\n ret = _a.sent();\n res = parseResponse(ret);\n // First, update the stylesheet\n addCSS(res.css.textContent);\n next = (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.create)(res.content);\n old = (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.create)(target);\n (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.patch)(next, old);\n // Remove loading and clear add timeout\n clearTimeout(timeout);\n target.classList.remove(\"hyp-loading\");\n return [2 /*return*/];\n }\n });\n });\n}\nfunction addCSS(text) {\n var rules = text.split(\"\\n\");\n rules.forEach(function (rule) {\n rootStyles.sheet.insertRule(rule);\n });\n}\nfunction parseResponse(ret) {\n var parser = new DOMParser();\n var doc = parser.parseFromString(ret, 'text/html');\n var css = doc.querySelector(\"style\");\n var content = doc.querySelector(\"div\");\n return {\n content: content,\n css: css\n };\n}\nfunction init() {\n rootStyles = document.querySelector('style');\n}\ndocument.addEventListener(\"DOMContentLoaded\", init);\nvar sock = new _sockets__WEBPACK_IMPORTED_MODULE_1__.SocketConnection();\nsock.connect();\n\n\n//# sourceURL=webpack://web-ui/./src/index.ts?");+eval("__webpack_require__.r(__webpack_exports__);\n/* harmony import */ var omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__ = __webpack_require__(/*! omdomdom/lib/omdomdom.es.js */ \"./node_modules/omdomdom/lib/omdomdom.es.js\");\n/* harmony import */ var _sockets__WEBPACK_IMPORTED_MODULE_1__ = __webpack_require__(/*! ./sockets */ \"./src/sockets.ts\");\n/* harmony import */ var _events__WEBPACK_IMPORTED_MODULE_2__ = __webpack_require__(/*! ./events */ \"./src/events.ts\");\n/* harmony import */ var _action__WEBPACK_IMPORTED_MODULE_3__ = __webpack_require__(/*! ./action */ \"./src/action.ts\");\nvar __awaiter = (undefined && undefined.__awaiter) || function (thisArg, _arguments, P, generator) {\n function adopt(value) { return value instanceof P ? value : new P(function (resolve) { resolve(value); }); }\n return new (P || (P = Promise))(function (resolve, reject) {\n function fulfilled(value) { try { step(generator.next(value)); } catch (e) { reject(e); } }\n function rejected(value) { try { step(generator[\"throw\"](value)); } catch (e) { reject(e); } }\n function step(result) { result.done ? resolve(result.value) : adopt(result.value).then(fulfilled, rejected); }\n step((generator = generator.apply(thisArg, _arguments || [])).next());\n });\n};\nvar __generator = (undefined && undefined.__generator) || function (thisArg, body) {\n var _ = { label: 0, sent: function() { if (t[0] & 1) throw t[1]; return t[1]; }, trys: [], ops: [] }, f, y, t, g;\n return g = { next: verb(0), \"throw\": verb(1), \"return\": verb(2) }, typeof Symbol === \"function\" && (g[Symbol.iterator] = function() { return this; }), g;\n function verb(n) { return function (v) { return step([n, v]); }; }\n function step(op) {\n if (f) throw new TypeError(\"Generator is already executing.\");\n while (g && (g = 0, op[0] && (_ = 0)), _) try {\n if (f = 1, y && (t = op[0] & 2 ? y[\"return\"] : op[0] ? y[\"throw\"] || ((t = y[\"return\"]) && t.call(y), 0) : y.next) && !(t = t.call(y, op[1])).done) return t;\n if (y = 0, t) op = [op[0] & 2, t.value];\n switch (op[0]) {\n case 0: case 1: t = op; break;\n case 4: _.label++; return { value: op[1], done: false };\n case 5: _.label++; y = op[1]; op = [0]; continue;\n case 7: op = _.ops.pop(); _.trys.pop(); continue;\n default:\n if (!(t = _.trys, t = t.length > 0 && t[t.length - 1]) && (op[0] === 6 || op[0] === 2)) { _ = 0; continue; }\n if (op[0] === 3 && (!t || (op[1] > t[0] && op[1] < t[3]))) { _.label = op[1]; break; }\n if (op[0] === 6 && _.label < t[1]) { _.label = t[1]; t = op; break; }\n if (t && _.label < t[2]) { _.label = t[2]; _.ops.push(op); break; }\n if (t[2]) _.ops.pop();\n _.trys.pop(); continue;\n }\n op = body.call(thisArg, _);\n } catch (e) { op = [6, e]; y = 0; } finally { f = t = 0; }\n if (op[0] & 5) throw op[1]; return { value: op[0] ? op[1] : void 0, done: true };\n }\n};\n\n\n\n\n// import { listenEvents } from './events';\n// import { WEBSOCKET_ADDRESS, Messages } from './Messages'\n// import { INIT_PAGE, INIT_STATE, State, Class } from './types';\n// import { fromVDOM, VDOM } from './vdom'\n// const CONTENT_ID = \"yeti-root-content\"\n// console.log(\"VERSION 2\", INIT_PAGE, INIT_STATE)\nconsole.log(\"Hyperbole 0.3.3a\");\nvar rootStyles;\nfunction sendAction(msg) {\n return __awaiter(this, void 0, void 0, function () {\n function sendActionHttp(msg) {\n return __awaiter(this, void 0, void 0, function () {\n var res, error, body;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n console.log(\"HTTP sendAction\", msg.url.toString());\n return [4 /*yield*/, fetch(msg.url, {\n method: \"POST\",\n headers: { 'Accept': 'text/html', 'Content-Type': 'application/x-www-form-urlencoded' },\n body: msg.form,\n // we never want this to be redirected\n redirect: \"manual\"\n })];\n case 1:\n res = _a.sent();\n if (res.headers.get('location')) {\n // manual redirect with status 200\n console.log(\"Found Redirect\", res.headers.get('location'));\n window.location.href = res.headers.get('location');\n return [2 /*return*/];\n }\n console.log(\"RES\", res.headers.get(\"location\"));\n if (res.headers.get(\"location\")) {\n window.location.href = res.headers.get(\"location\");\n return [2 /*return*/];\n }\n if (!!res.ok) return [3 /*break*/, 3];\n error = new Error();\n error.name = \"Fetch Error \" + res.status;\n return [4 /*yield*/, res.text()];\n case 2:\n body = _a.sent();\n error.message = body;\n throw error;\n case 3: return [2 /*return*/, res.text()];\n }\n });\n });\n }\n return __generator(this, function (_a) {\n if (sock.isConnected) {\n return [2 /*return*/, sock.sendAction(msg)];\n }\n else {\n return [2 /*return*/, sendActionHttp(msg)];\n }\n return [2 /*return*/];\n });\n });\n}\nfunction fetchAction(msg) {\n return __awaiter(this, void 0, void 0, function () {\n var ret, err_1;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n _a.trys.push([0, 2, , 3]);\n return [4 /*yield*/, sendAction(msg)];\n case 1:\n ret = _a.sent();\n return [2 /*return*/, ret];\n case 2:\n err_1 = _a.sent();\n // handle error here\n document.body.innerHTML = errorHTML(err_1);\n throw err_1;\n case 3: return [2 /*return*/];\n }\n });\n });\n}\nfunction runAction(target, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n var timeout, msg, ret, res, next, old, newTarget;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n timeout = setTimeout(function () {\n // add loading after 200ms, not right away\n target.classList.add(\"hyp-loading\");\n }, 200);\n msg = (0,_action__WEBPACK_IMPORTED_MODULE_3__.actionMessage)(target.id, action, form);\n return [4 /*yield*/, fetchAction(msg)];\n case 1:\n ret = _a.sent();\n res = parseResponse(ret);\n if (!res.css || !res.content) {\n console.error(\"Empty Response\", res);\n return [2 /*return*/];\n }\n // First, update the stylesheet\n addCSS(res.css.textContent);\n next = (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.create)(res.content);\n old = (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.create)(target);\n (0,omdomdom_lib_omdomdom_es_js__WEBPACK_IMPORTED_MODULE_0__.patch)(next, old);\n newTarget = document.getElementById(target.id);\n // let event = new Event(\"content\", {bubbles:true})\n // newTarget.dispatchEvent(event)\n // load doesn't bubble\n (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenLoad)(newTarget);\n // Remove loading and clear add timeout\n clearTimeout(timeout);\n target.classList.remove(\"hyp-loading\");\n return [2 /*return*/];\n }\n });\n });\n}\nfunction addCSS(text) {\n var rules = text.split(\"\\n\");\n rules.forEach(function (rule) {\n rootStyles.sheet.insertRule(rule);\n });\n}\nfunction parseResponse(vw) {\n var parser = new DOMParser();\n var doc = parser.parseFromString(vw, 'text/html');\n var css = doc.querySelector(\"style\");\n var content = doc.querySelector(\"div\");\n return {\n content: content,\n css: css\n };\n}\nfunction init() {\n rootStyles = document.querySelector('style');\n (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenLoadDocument)(function (target, action) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"INIT LOAD\", target.id, action);\n runAction(target, action);\n return [2 /*return*/];\n });\n });\n });\n (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenLoad)(document.body);\n (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenClick)(function (target, action) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"CLICK\", target.id, action);\n runAction(target, action);\n return [2 /*return*/];\n });\n });\n });\n (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenFormSubmit)(function (target, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"FORM\", target.id, action, form);\n runAction(target, action, form);\n return [2 /*return*/];\n });\n });\n });\n (0,_events__WEBPACK_IMPORTED_MODULE_2__.listenChange)(function (target, action) {\n return __awaiter(this, void 0, void 0, function () {\n return __generator(this, function (_a) {\n console.log(\"CHANGE\", target.id, action);\n runAction(target, action);\n return [2 /*return*/];\n });\n });\n });\n}\ndocument.addEventListener(\"DOMContentLoaded\", init);\n// Should we connect to the socket or not?\nvar sock = new _sockets__WEBPACK_IMPORTED_MODULE_1__.SocketConnection();\nsock.connect();\n// no it should take over the whole page...\nfunction errorHTML(error) {\n // TODO: match on error.name and handle it differently\n var style = [\n \".hyp-error {background-color:#DB3524; color:white; padding: 10px}\",\n \".hyp-details {padding: 10px}\"\n ];\n var content = \"<div class='hyp-error'>\".concat(error.name, \"</div>\");\n var details = \"<div class='hyp-details'>\".concat(error.message, \"</div>\");\n return [\"<style>\" + style.join(\"\\n\") + \"</style>\", content, details].join(\"\\n\");\n}\n\n\n//# sourceURL=webpack://web-ui/./src/index.ts?"); /***/ }), +/***/ "./src/lib.ts":+/*!********************!*\+ !*** ./src/lib.ts ***!+ \********************/+/***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => {++eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */ dropWhile: () => (/* binding */ dropWhile),\n/* harmony export */ takeWhileMap: () => (/* binding */ takeWhileMap)\n/* harmony export */ });\nfunction takeWhileMap(pred, lines) {\n var output = [];\n for (var _i = 0, lines_1 = lines; _i < lines_1.length; _i++) {\n var line = lines_1[_i];\n var a = pred(line);\n if (a)\n output.push(a);\n else\n break;\n }\n return output;\n}\nfunction dropWhile(pred, lines) {\n var index = 0;\n while (index < lines.length && pred(lines[index])) {\n index++;\n }\n return lines.slice(index);\n}\n\n\n//# sourceURL=webpack://web-ui/./src/lib.ts?");++/***/ }),+ /***/ "./src/sockets.ts": /*!************************!*\ !*** ./src/sockets.ts ***! \************************/ /***/ ((__unused_webpack_module, __webpack_exports__, __webpack_require__) => { -eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */ SocketConnection: () => (/* binding */ SocketConnection)\n/* harmony export */ });\nvar __awaiter = (undefined && undefined.__awaiter) || function (thisArg, _arguments, P, generator) {\n function adopt(value) { return value instanceof P ? value : new P(function (resolve) { resolve(value); }); }\n return new (P || (P = Promise))(function (resolve, reject) {\n function fulfilled(value) { try { step(generator.next(value)); } catch (e) { reject(e); } }\n function rejected(value) { try { step(generator[\"throw\"](value)); } catch (e) { reject(e); } }\n function step(result) { result.done ? resolve(result.value) : adopt(result.value).then(fulfilled, rejected); }\n step((generator = generator.apply(thisArg, _arguments || [])).next());\n });\n};\nvar __generator = (undefined && undefined.__generator) || function (thisArg, body) {\n var _ = { label: 0, sent: function() { if (t[0] & 1) throw t[1]; return t[1]; }, trys: [], ops: [] }, f, y, t, g;\n return g = { next: verb(0), \"throw\": verb(1), \"return\": verb(2) }, typeof Symbol === \"function\" && (g[Symbol.iterator] = function() { return this; }), g;\n function verb(n) { return function (v) { return step([n, v]); }; }\n function step(op) {\n if (f) throw new TypeError(\"Generator is already executing.\");\n while (g && (g = 0, op[0] && (_ = 0)), _) try {\n if (f = 1, y && (t = op[0] & 2 ? y[\"return\"] : op[0] ? y[\"throw\"] || ((t = y[\"return\"]) && t.call(y), 0) : y.next) && !(t = t.call(y, op[1])).done) return t;\n if (y = 0, t) op = [op[0] & 2, t.value];\n switch (op[0]) {\n case 0: case 1: t = op; break;\n case 4: _.label++; return { value: op[1], done: false };\n case 5: _.label++; y = op[1]; op = [0]; continue;\n case 7: op = _.ops.pop(); _.trys.pop(); continue;\n default:\n if (!(t = _.trys, t = t.length > 0 && t[t.length - 1]) && (op[0] === 6 || op[0] === 2)) { _ = 0; continue; }\n if (op[0] === 3 && (!t || (op[1] > t[0] && op[1] < t[3]))) { _.label = op[1]; break; }\n if (op[0] === 6 && _.label < t[1]) { _.label = t[1]; t = op; break; }\n if (t && _.label < t[2]) { _.label = t[2]; _.ops.push(op); break; }\n if (t[2]) _.ops.pop();\n _.trys.pop(); continue;\n }\n op = body.call(thisArg, _);\n } catch (e) { op = [6, e]; y = 0; } finally { f = t = 0; }\n if (op[0] & 5) throw op[1]; return { value: op[0] ? op[1] : void 0, done: true };\n }\n};\nvar protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:';\nvar defaultAddress = \"\".concat(protocol, \"//\").concat(window.location.host).concat(window.location.pathname);\nvar SocketConnection = /** @class */ (function () {\n function SocketConnection() {\n }\n SocketConnection.prototype.connect = function (addr) {\n var _this = this;\n if (addr === void 0) { addr = defaultAddress; }\n var sock = new WebSocket(addr);\n this.socket = sock;\n function onConnectError(ev) {\n console.log(\"Connection Error\", ev);\n }\n sock.addEventListener('error', onConnectError);\n sock.addEventListener('open', function (event) {\n console.log(\"Opened\", event);\n _this.isConnected = true;\n _this.socket.removeEventListener('error', onConnectError);\n });\n sock.addEventListener('close', function (event) {\n _this.isConnected = false;\n console.log(\"Closed\", event);\n // attempt to reconnect in 1s\n setTimeout(function () { return _this.connect(addr); }, 1000);\n });\n };\n SocketConnection.prototype.sendAction = function (action) {\n return __awaiter(this, void 0, void 0, function () {\n var msg;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n console.log(\"SOCKET sendAction\", action);\n msg = [action.url.pathname, action.url.search, action.form].join(\"\\n\");\n return [4 /*yield*/, this.fetch(msg)];\n case 1: return [2 /*return*/, _a.sent()];\n }\n });\n });\n };\n SocketConnection.prototype.fetch = function (msg) {\n return __awaiter(this, void 0, void 0, function () {\n var res;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n this.sendMessage(msg);\n return [4 /*yield*/, this.waitMessage()];\n case 1:\n res = _a.sent();\n return [2 /*return*/, res];\n }\n });\n });\n };\n SocketConnection.prototype.sendMessage = function (msg) {\n this.socket.send(msg);\n };\n SocketConnection.prototype.waitMessage = function () {\n return __awaiter(this, void 0, void 0, function () {\n var _this = this;\n return __generator(this, function (_a) {\n return [2 /*return*/, new Promise(function (resolve, reject) {\n var onMessage = function (event) {\n var data = event.data;\n resolve(data);\n _this.socket.removeEventListener('message', onMessage);\n };\n _this.socket.addEventListener('message', onMessage);\n _this.socket.addEventListener('error', reject);\n })];\n });\n });\n };\n SocketConnection.prototype.disconnect = function () {\n this.socket.close();\n };\n return SocketConnection;\n}());\n\nconsole.log(\"CONNECTING\", window.location);\nfunction parseCommand(message) {\n var match = message.match(/^(\\w+)\\s+(.*)$/);\n if (!match)\n console.error(\"Could not parse command: \", message);\n return {\n command: match[1],\n data: JSON.parse(match[2])\n };\n}\n\n\n//# sourceURL=webpack://web-ui/./src/sockets.ts?");+eval("__webpack_require__.r(__webpack_exports__);\n/* harmony export */ __webpack_require__.d(__webpack_exports__, {\n/* harmony export */ SocketConnection: () => (/* binding */ SocketConnection)\n/* harmony export */ });\n/* harmony import */ var _lib__WEBPACK_IMPORTED_MODULE_0__ = __webpack_require__(/*! ./lib */ \"./src/lib.ts\");\nvar __awaiter = (undefined && undefined.__awaiter) || function (thisArg, _arguments, P, generator) {\n function adopt(value) { return value instanceof P ? value : new P(function (resolve) { resolve(value); }); }\n return new (P || (P = Promise))(function (resolve, reject) {\n function fulfilled(value) { try { step(generator.next(value)); } catch (e) { reject(e); } }\n function rejected(value) { try { step(generator[\"throw\"](value)); } catch (e) { reject(e); } }\n function step(result) { result.done ? resolve(result.value) : adopt(result.value).then(fulfilled, rejected); }\n step((generator = generator.apply(thisArg, _arguments || [])).next());\n });\n};\nvar __generator = (undefined && undefined.__generator) || function (thisArg, body) {\n var _ = { label: 0, sent: function() { if (t[0] & 1) throw t[1]; return t[1]; }, trys: [], ops: [] }, f, y, t, g;\n return g = { next: verb(0), \"throw\": verb(1), \"return\": verb(2) }, typeof Symbol === \"function\" && (g[Symbol.iterator] = function() { return this; }), g;\n function verb(n) { return function (v) { return step([n, v]); }; }\n function step(op) {\n if (f) throw new TypeError(\"Generator is already executing.\");\n while (g && (g = 0, op[0] && (_ = 0)), _) try {\n if (f = 1, y && (t = op[0] & 2 ? y[\"return\"] : op[0] ? y[\"throw\"] || ((t = y[\"return\"]) && t.call(y), 0) : y.next) && !(t = t.call(y, op[1])).done) return t;\n if (y = 0, t) op = [op[0] & 2, t.value];\n switch (op[0]) {\n case 0: case 1: t = op; break;\n case 4: _.label++; return { value: op[1], done: false };\n case 5: _.label++; y = op[1]; op = [0]; continue;\n case 7: op = _.ops.pop(); _.trys.pop(); continue;\n default:\n if (!(t = _.trys, t = t.length > 0 && t[t.length - 1]) && (op[0] === 6 || op[0] === 2)) { _ = 0; continue; }\n if (op[0] === 3 && (!t || (op[1] > t[0] && op[1] < t[3]))) { _.label = op[1]; break; }\n if (op[0] === 6 && _.label < t[1]) { _.label = t[1]; t = op; break; }\n if (t && _.label < t[2]) { _.label = t[2]; _.ops.push(op); break; }\n if (t[2]) _.ops.pop();\n _.trys.pop(); continue;\n }\n op = body.call(thisArg, _);\n } catch (e) { op = [6, e]; y = 0; } finally { f = t = 0; }\n if (op[0] & 5) throw op[1]; return { value: op[0] ? op[1] : void 0, done: true };\n }\n};\n\nvar protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:';\nvar defaultAddress = \"\".concat(protocol, \"//\").concat(window.location.host).concat(window.location.pathname);\nvar SocketConnection = /** @class */ (function () {\n function SocketConnection() {\n this.reconnectDelay = 0;\n }\n // we need to faithfully transmit the \n SocketConnection.prototype.connect = function (addr) {\n var _this = this;\n if (addr === void 0) { addr = defaultAddress; }\n var sock = new WebSocket(addr);\n this.socket = sock;\n function onConnectError(ev) {\n console.log(\"Connection Error\", ev);\n }\n sock.addEventListener('error', onConnectError);\n sock.addEventListener('open', function (event) {\n console.log(\"Opened\", event);\n _this.isConnected = true;\n _this.hasEverConnected = true;\n _this.reconnectDelay = 0;\n _this.socket.removeEventListener('error', onConnectError);\n });\n // TODO: Don't reconnet if the socket server is OFF, only if we've successfully connected once\n sock.addEventListener('close', function (_) {\n _this.isConnected = false;\n console.log(\"Closed\");\n // attempt to reconnect in 1s\n if (_this.hasEverConnected) {\n _this.reconnectDelay += 1000;\n console.log(\"Reconnecting in \" + (_this.reconnectDelay / 1000) + \"s\");\n setTimeout(function () { return _this.connect(addr); }, _this.reconnectDelay);\n }\n });\n };\n SocketConnection.prototype.sendAction = function (action) {\n return __awaiter(this, void 0, void 0, function () {\n var msg, ret, _a, metadata, rest;\n return __generator(this, function (_b) {\n switch (_b.label) {\n case 0:\n msg = [action.url.pathname + action.url.search,\n \"Host: \" + window.location.host,\n \"Cookie: \" + document.cookie,\n action.form\n ].join(\"\\n\");\n return [4 /*yield*/, this.fetch(msg)];\n case 1:\n ret = _b.sent();\n _a = parseMetadataResponse(ret), metadata = _a.metadata, rest = _a.rest;\n if (metadata.error) {\n throw socketError(metadata.error);\n }\n if (metadata.session) {\n // console.log(\"setting cookie\", metadata.session)\n document.cookie = metadata.session;\n }\n if (metadata.redirect) {\n window.location.href = metadata.redirect;\n }\n return [2 /*return*/, rest];\n }\n });\n });\n };\n SocketConnection.prototype.fetch = function (msg) {\n return __awaiter(this, void 0, void 0, function () {\n var res;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n this.sendMessage(msg);\n return [4 /*yield*/, this.waitMessage()];\n case 1:\n res = _a.sent();\n return [2 /*return*/, res];\n }\n });\n });\n };\n SocketConnection.prototype.sendMessage = function (msg) {\n this.socket.send(msg);\n };\n SocketConnection.prototype.waitMessage = function () {\n return __awaiter(this, void 0, void 0, function () {\n var _this = this;\n return __generator(this, function (_a) {\n return [2 /*return*/, new Promise(function (resolve, reject) {\n var onMessage = function (event) {\n var data = event.data;\n resolve(data);\n _this.socket.removeEventListener('message', onMessage);\n };\n _this.socket.addEventListener('message', onMessage);\n _this.socket.addEventListener('error', reject);\n })];\n });\n });\n };\n SocketConnection.prototype.disconnect = function () {\n this.socket.close();\n };\n return SocketConnection;\n}());\n\nfunction socketError(inp) {\n var error = new Error();\n error.name = inp.substring(0, inp.indexOf(' '));\n error.message = inp.substring(inp.indexOf(' ') + 1);\n return error;\n}\nconsole.log(\"CONNECTING\", window.location);\nfunction parseMetadataResponse(ret) {\n var lines = ret.split(\"\\n\");\n var metas = parseMetas((0,_lib__WEBPACK_IMPORTED_MODULE_0__.takeWhileMap)(parseMeta, lines));\n var rest = (0,_lib__WEBPACK_IMPORTED_MODULE_0__.dropWhile)(parseMeta, lines).join(\"\\n\");\n return {\n metadata: metas,\n rest: rest\n };\n function parseMeta(line) {\n var match = line.match(/^\\|(\\w+)\\|(.*)$/);\n if (match) {\n return {\n key: match[1],\n value: match[2]\n };\n }\n }\n}\nfunction parseMetas(meta) {\n var _a, _b, _c;\n return {\n session: (_a = meta.find(function (m) { return m.key == \"SESSION\"; })) === null || _a === void 0 ? void 0 : _a.value,\n redirect: (_b = meta.find(function (m) { return m.key == \"REDIRECT\"; })) === null || _b === void 0 ? void 0 : _b.value,\n error: (_c = meta.find(function (m) { return m.key == \"ERROR\"; })) === null || _c === void 0 ? void 0 : _c.value\n };\n}\n\n\n//# sourceURL=webpack://web-ui/./src/sockets.ts?"); /***/ }),
example/Example/Colors.hs view
@@ -1,7 +1,11 @@ module Example.Colors where +import Data.String.Conversions+import Text.Read (readMaybe)+import Web.HttpApiData import Web.Hyperbole + data AppColor = White | Light@@ -9,25 +13,35 @@ | GrayDark | Dark | Success- | Error+ | Danger | Warning | Primary | PrimaryLight | Secondary | SecondaryLight- deriving (Show)+ deriving (Show, Read, Generic, Param) ++instance ToHttpApiData AppColor where+ toQueryParam c = cs (show c)+instance FromHttpApiData AppColor where+ parseQueryParam t = do+ case readMaybe (cs t) of+ Nothing -> Left $ "Invalid AppColor: " <> t+ (Just c) -> pure c++ instance ToColor AppColor where colorValue White = "#FFF" colorValue Light = "#F2F2F3" colorValue GrayLight = "#E3E5E9" colorValue GrayDark = "#2С3С44" colorValue Dark = "#2E3842" -- "#232C41"- colorValue Primary = "#2C74BB"- colorValue PrimaryLight = "#3281cf"- colorValue Secondary = "#5CADDB"- colorValue SecondaryLight = "#8CFDAB"+ colorValue Primary = "#4171b7"+ colorValue PrimaryLight = "#6D9BD3"+ colorValue Secondary = "#5D5A5C"+ colorValue SecondaryLight = "#9D999C" -- colorValue Success = "67C837"- colorValue Success = "#D5E6DE"- colorValue Error = "#F3D8DA"- colorValue Warning = "#FDF3D1"+ colorValue Success = "#149e5a"+ colorValue Danger = "#ef1509"+ colorValue Warning = "#e1c915"
example/Example/Contacts.hs view
@@ -9,43 +9,43 @@ import Example.Effects.Debug import Example.Effects.Users (User (..), Users) import Example.Effects.Users qualified as Users-import GHC.Generics (Generic)+import Example.Style as Style import Web.Hyperbole -page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es ()+page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es Response page = do- hyper contacts- hyper contact+ handle contacts+ handle contact load $ do us <- usersAll pure $ do col (pad 10 . gap 10) $ do- viewId Contacts $ allContactsView Nothing us+ hyper Contacts $ allContactsView Nothing us -- Contacts ---------------------------------------------- data Contacts = Contacts- deriving (Show, Read, Param)+ deriving (Generic, Param) data ContactsAction = Reload (Maybe Filter) | Delete Int- deriving (Show, Read, Param)---instance HyperView Contacts where- type Action Contacts = ContactsAction+ deriving (Generic, Param) data Filter = Active | Inactive- deriving (Show, Read, Eq)+ deriving (Eq, Generic, Param) +instance HyperView Contacts where+ type Action Contacts = ContactsAction++ contacts :: (Hyperbole :> es, Users :> es, Debug :> es) => Contacts -> ContactsAction -> Eff es (View Contacts ()) contacts _ (Reload mf) = do us <- usersAll@@ -59,20 +59,21 @@ allContactsView :: Maybe Filter -> [User] -> View Contacts () allContactsView fil us = do row (gap 10) $ do- button (Reload Nothing) (bg GrayLight) "Reload"-+ el (pad 10) "Filter: " dropdown Reload (== fil) id $ do option Nothing "" option (Just Active) "Active!" option (Just Inactive) "Inactive" - target (Contact 2) $ button Edit (bg GrayLight) "Edit 2"- row (pad 10 . gap 10) $ do let filtered = filter (filterUsers fil) us forM_ filtered $ \u -> do el (border 1) $ do- viewId (Contact u.id) $ contactView u+ hyper (Contact u.id) $ contactView u++ row (gap 10) $ do+ button (Reload Nothing) Style.btnLight "Reload"+ target (Contact 2) $ button Edit Style.btnLight "Edit Sara" where filterUsers Nothing _ = True filterUsers (Just Active) u = u.isActive@@ -82,30 +83,29 @@ -- Contact ---------------------------------------------------- data Contact = Contact Int- deriving (Show, Read, Param)+ deriving (Generic, Param) data ContactAction = Edit | Save | View- deriving (Show, Read, Param)+ deriving (Generic, Param) instance HyperView Contact where type Action Contact = ContactAction -data UserForm a = UserForm- { firstName :: Field a Text- , lastName :: Field a Text- , age :: Field a Int- }- deriving (Generic, Form)+-- Form Fields+data FirstName = FirstName Text deriving (Generic, FormField)+data LastName = LastName Text deriving (Generic, FormField)+data Age = Age Int deriving (Generic, FormField) contact :: (Hyperbole :> es, Users :> es, Debug :> es) => Contact -> ContactAction -> Eff es (View Contact ()) contact (Contact uid) a = do+ -- Lookup the user in the database for all actions u <- userFind uid action u a where@@ -113,14 +113,19 @@ pure $ contactView u action u Edit = do pure $ contactEdit u- action u Save = do+ action _ Save = do delay 1000- UserForm{firstName, lastName, age} <- parseForm- let u' = User{id = u.id, isActive = True, firstName, lastName, age}- userSave u'- pure $ contactView u'+ unew <- parseUser+ userSave unew+ pure $ contactView unew + parseUser = do+ FirstName firstName <- formField @FirstName+ LastName lastName <- formField @LastName+ Age age <- formField @Age+ pure User{id = uid, isActive = True, firstName, lastName, age} + contactView :: User -> View Contact () contactView u = do col (pad 10 . gap 10) $ do@@ -140,7 +145,7 @@ el id (text "Active:") text (cs $ show u.isActive) - button Edit (bg Primary . color White . hover (bg PrimaryLight . color Dark)) "Edit"+ button Edit Style.btn "Edit" where fld = gap 10 @@ -148,26 +153,26 @@ contactEdit :: User -> View Contact () contactEdit u = onRequest loading $ do- form @UserForm Save (pad 10 . gap 10) $ \f -> do- field fld $ do+ form Save mempty (pad 10 . gap 10) $ do+ field @FirstName fld id $ do label "First Name:"- input Name (value u.firstName) f.firstName+ input Name (value u.firstName) - field fld $ do+ field @LastName fld id $ do label "Last Name:"- input Name (value u.lastName) f.lastName+ input Name (value u.lastName) - field fld $ do+ field @Age fld id $ do label "Age:"- input Number (value $ cs $ show u.age) f.age+ input Number (value $ cs $ show u.age) - submit id "Submit"+ submit Style.btn "Submit" - button View id (text "Cancel")+ button View Style.btnLight (text "Cancel") - target Contacts $ button (Delete u.id) (bg Secondary) (text "Delete")+ target Contacts $ button (Delete u.id) (Style.btn' Danger) (text "Delete") where- loading = el (bg Secondary) "Loading..."+ loading = el (bg Warning . pad 10) "Loading..." fld = flexRow . gap 10
+ example/Example/Counter.hs view
@@ -0,0 +1,62 @@+module Example.Counter where++import Data.Text (pack)+import Effectful+import Effectful.Concurrent.STM+import Example.Style as Style+import Web.Hyperbole+++-- We are using a TVar to manage our state+-- In normal web applications, state will be managed in a database, abstracted behind a custom Effect. See Example.EFfects.Users for the interface+-- Optionally, the count could be stored in a session. See Example.Sessions+page :: (Hyperbole :> es, Concurrent :> es) => TVar Int -> Page es Response+page var = do+ handle $ counter var++ load $ do+ n <- readTVarIO var+ pure $ col (pad 20 . gap 10) $ do+ el h1 "Counter"+ hyper Counter (viewCount n)+++data Counter = Counter+ deriving (Generic, Param)+instance HyperView Counter where+ type Action Counter = Count+++data Count+ = Increment+ | Decrement+ deriving (Generic, Param)+++counter :: (Hyperbole :> es, Concurrent :> es) => TVar Int -> Counter -> Count -> Eff es (View Counter ())+counter var _ Increment = do+ n <- modify var $ \n -> n + 1+ pure $ viewCount n+counter var _ Decrement = do+ n <- modify var $ \n -> n - 1+ pure $ viewCount n+++viewCount :: Int -> View Counter ()+viewCount n = col (gap 10) $ do+ row id $ do+ el (bold . fontSize 48 . border 1 . pad (XY 20 0)) $ text $ pack $ show n+ row (gap 10) $ do+ button Decrement Style.btn "Decrement"+ button Increment Style.btn "Increment"+++modify :: (Concurrent :> es) => TVar Int -> (Int -> Int) -> Eff es Int+modify var f =+ atomically $ do+ modifyTVar var f+ readTVar var+++initCounter :: (Concurrent :> es) => Eff es (TVar Int)+initCounter = newTVarIO 0
+ example/Example/Errors.hs view
@@ -0,0 +1,41 @@+module Example.Errors where++import Effectful+import Example.Style as Style+import Web.Hyperbole+++-- this is already running in a different context+page :: (Hyperbole :> es) => Page es Response+page = do+ handle content++ load $ do+ pure $ row (pad 20) $ do+ col (gap 10 . border 1) $ do+ hyper Contents viewContent+++data Contents = Contents+ deriving (Generic, Param)+++data ContentsAction+ = CauseError+ deriving (Generic, Param)+++instance HyperView Contents where+ type Action Contents = ContentsAction+++content :: (Hyperbole :> es) => Contents -> ContentsAction -> Eff es (View Contents ())+content _ CauseError = do+ -- Return a not found error 404+ notFound+++viewContent :: View Contents ()+viewContent = do+ col (gap 10 . pad 20) $ do+ button CauseError Style.btn "Not Found Error"
example/Example/Forms.hs view
@@ -1,93 +1,106 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Example.Forms where -import Data.Functor.Identity (Identity)-import Data.Text (Text, pack)+import Data.Text as T (Text, elem, length, pack) import Effectful-import Example.Colors-import GHC.Generics (Generic)+import Example.Style qualified as Style import Web.Hyperbole -page :: (Hyperbole :> es) => Page es ()+page :: (Hyperbole :> es) => Page es Response page = do- hyper action+ handle formAction load $ do pure $ row (pad 20) $ do- viewId Main formView+ hyper FormView (formView mempty) -data Main = Main- deriving (Show, Read, Param)+data FormView = FormView+ deriving (Generic, Param) -data MainAction- = Submit- | Cancel- deriving (Show, Read, Param)+data FormAction = Submit+ deriving (Generic, Param) -instance HyperView Main where- type Action Main = MainAction+instance HyperView FormView where+ type Action FormView = FormAction -data UserForm a = UserForm- { username :: Field a Text- , age :: Field a Integer- , password1 :: Field a Text- , password2 :: Field a Text- }- deriving (Generic, Form)+-- Form Fields+data User = User Text deriving (Generic, FormField)+data Age = Age Int deriving (Generic, FormField)+data Pass1 = Pass1 Text deriving (Generic, FormField)+data Pass2 = Pass2 Text deriving (Generic, FormField) -action :: (Hyperbole :> es) => Main -> MainAction -> Eff es (View Main ())-action _ Submit = do- u <- parseForm- pure $ userView u-action _ Cancel = do- pure $ el_ "Cancelled"+formAction :: (Hyperbole :> es) => FormView -> FormAction -> Eff es (View FormView ())+formAction _ Submit = do+ u <- formField @User+ a <- formField @Age+ p1 <- formField @Pass1+ p2 <- formField @Pass2 + case validateUser u a p1 p2 of+ Validation [] -> pure $ userView u a p1+ errs -> pure $ formView errs -formView :: View Main ()-formView = do- form @UserForm Submit (gap 10 . pad 10) $ \f -> do- el h1 "Sign Up" - field id $ do+validateUser :: User -> Age -> Pass1 -> Pass2 -> Validation+validateUser (User u) (Age a) (Pass1 p1) (Pass2 p2) =+ validation+ [ validate @Age (a < 20) "User must be at least 20 years old"+ , validate @User (T.elem ' ' u) "Username must not contain spaces"+ , validate @User (T.length u < 4) "Username must be at least 4 chars"+ , validate @Pass1 (p1 /= p2) "Passwords did not match"+ , validate @Pass1 (T.length p1 < 8) "Password must be at least 8 chars"+ ]+++formView :: Validation -> View FormView ()+formView v = do+ form Submit v (gap 10 . pad 10) $ do+ el Style.h1 "Sign Up"++ field @User id Style.invalid $ do label "Username"- input Username (inp . placeholder "username") f.username+ input Username (inp . placeholder "username")+ el_ invalidText - field id $ do+ field @Age id Style.invalid $ do label "Age"- input Number (inp . placeholder "age") f.age+ input Number (inp . placeholder "age" . value "0")+ el_ invalidText - field id $ do+ field @Pass1 id Style.invalid $ do label "Password"- input NewPassword (inp . placeholder "password") f.password1+ input NewPassword (inp . placeholder "password")+ el_ invalidText - field id $ do+ field @Pass2 id id $ do label "Repeat Password"- input NewPassword (inp . placeholder "repeat password") f.password2+ input NewPassword (inp . placeholder "repeat password") - submit id "Submit"- button Cancel id "Cancel"+ submit Style.btn "Submit" where- placeholder = att "placeholder" inp = border 1 . pad 8 -userView :: UserForm Identity -> View Main ()-userView user = do- el_ "User View"- el_ $ text user.username- el_ $ text $ pack (show user.age)- el_ $ text user.password1- el_ $ text user.password2 -btn :: Mod-btn = bg Primary . hover (bg PrimaryLight) . color White . pad 10+userView :: User -> Age -> Pass1 -> View FormView ()+userView (User user) (Age age) (Pass1 pass1) = do+ el (bold . Style.success) "Accepted Signup"+ row (gap 5) $ do+ el_ "Username:"+ el_ $ text user + row (gap 5) $ do+ el_ "Age:"+ el_ $ text $ pack (show age) -h1 :: Mod-h1 = bold . fontSize 32+ row (gap 5) $ do+ el_ "Password:"+ el_ $ text pass1
+ example/Example/LazyLoading.hs view
@@ -0,0 +1,50 @@+module Example.LazyLoading where++import Data.Text (pack)+import Effectful+import Example.Effects.Debug+import Web.Hyperbole+++-- this is already running in a different context+page :: (Hyperbole :> es, Debug :> es) => Page es Response+page = do+ handle content++ load $ do+ pure $ do+ row (pad 20) $ do+ col (gap 10 . border 1 . pad 20) $ do+ hyper Contents viewInit+++data Contents = Contents+ deriving (Generic, Param)+instance HyperView Contents where+ type Action Contents = ContentsAction+++data ContentsAction+ = Load+ | Reload Int+ deriving (Generic, Param)+++content :: (Hyperbole :> es, Debug :> es) => Contents -> ContentsAction -> Eff es (View Contents ())+content _ Load = do+ -- Pretend the initial Load takes 1s to complete+ delay 1000+ pure $ onLoad (Reload 1) 1000 $ do+ el id "Loaded, should reload once more..."+content _ (Reload n) = do+ -- then reload after a 1s delay (client-side)+ pure $ onLoad (Reload (n + 1)) 1000 $ do+ col (gap 10) $ do+ el_ "Reloaded! polling..."+ el_ $ text $ pack $ show n+++viewInit :: View Contents ()+viewInit = do+ onLoad Load 0 $ do+ el id "Lazy Loading..."
+ example/Example/Redirects.hs view
@@ -0,0 +1,39 @@+module Example.Redirects where++import Effectful+import Example.Style as Style+import Web.Hyperbole+++page :: (Hyperbole :> es) => Page es Response+page = do+ handle contents++ load $ do+ pure $ row (pad 20) $ do+ hyper Contents contentsView+++data Contents = Contents+ deriving (Generic, Param)+++data ContentsAction+ = RedirectAsAction+ deriving (Generic, Param)+++instance HyperView Contents where+ type Action Contents = ContentsAction+++contents :: (Hyperbole :> es) => Contents -> ContentsAction -> Eff es (View Contents ())+contents _ RedirectAsAction = do+ redirect "/hello/redirected"+++contentsView :: View Contents ()+contentsView = do+ col (gap 10 . border 1 . pad 20 . transition 300 (Height 200)) $ do+ el id "Redirect as an Action"+ button RedirectAsAction Style.btn "Redirect Me"
+ example/Example/Sessions.hs view
@@ -0,0 +1,80 @@+module Example.Sessions where++import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Effectful+import Example.Colors+import Example.Effects.Debug+import Example.Style as Style+import Web.Hyperbole+++-- this is already running in a different context+page :: (Hyperbole :> es, Debug :> es) => Page es Response+page = do+ handle content++ load $ do+ -- setSession "color" Warning+ -- setSession "msg" ("________" :: Text)+ (clr :: Maybe AppColor) <- session "color"+ (msg :: Maybe Text) <- session "msg"+ pure $ col (pad 20 . gap 10) $ do+ el_ "Reload your browser after changing the settings below to see the session information preserved"+ row id $ do+ hyper Contents $ viewContent clr msg+++data Contents = Contents+ deriving (Generic, Param)+++data ContentsAction+ = SaveColor AppColor+ | SaveMessage Text+ deriving (Generic, Param)+++instance HyperView Contents where+ type Action Contents = ContentsAction+++content :: (Hyperbole :> es, Debug :> es) => Contents -> ContentsAction -> Eff es (View Contents ())+content _ (SaveColor clr) = do+ setSession "color" clr+ msg <- session "msg"+ pure $ viewContent (Just clr) msg+content _ (SaveMessage msg) = do+ setSession "msg" msg+ clr <- session "color"+ pure $ viewContent clr (Just msg)+++viewContent :: Maybe AppColor -> Maybe Text -> View Contents ()+viewContent mclr mmsg =+ col (gap 20) $ do+ viewColorPicker mclr+ viewMessage mmsg+++viewColorPicker :: Maybe AppColor -> View Contents ()+viewColorPicker mc = do+ let clr = fromMaybe White mc+ col (gap 10 . pad 20 . bg clr) $ do+ el (fontSize 24 . bold) "Session Background"+ row (gap 10) $ do+ button (SaveColor Success) (Style.btn' Success . border 1) "Successs"+ button (SaveColor Warning) (Style.btn' Warning . border 1) "Warning"+ button (SaveColor Danger) (Style.btn' Danger . border 1) "Danger"+++viewMessage :: Maybe Text -> View Contents ()+viewMessage mm = do+ let msg = fromMaybe "" mm+ col (gap 10 . pad 20 . border 1) $ do+ el (fontSize 24 . bold) "Session Message:"+ el_ $ text msg+ row (gap 10) $ do+ button (SaveMessage "Hello") Style.btnLight "Msg: Hello"+ button (SaveMessage "Goodbye") Style.btnLight "Msg: Goodbye"+ button (SaveMessage "________") Style.btnLight "Clear"
+ example/Example/Simple.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Example.Simple where++import Data.Text (Text)+import Web.Hyperbole+++main = do+ run 3000 $ do+ liveApp (basicDocument "Example") (page simplePage)+++simplePage :: (Hyperbole :> es) => Page es Response+simplePage = do+ handle message+ load $ do+ pure $ col (pad 20) $ do+ el bold "My Page"+ hyper (Message 1) $ messageView "Hello"+ hyper (Message 2) $ messageView "World!"+++data Message = Message Int+ deriving (Generic, Param)+++data MessageAction = Louder Text+ deriving (Generic, Param)+++instance HyperView Message where+ type Action Message = MessageAction+++message :: Message -> MessageAction -> Eff es (View Message ())+message _ (Louder m) = do+ let new = m <> "!"+ pure $ messageView new+++messageView m = do+ el_ $ text m+ button (Louder m) (border 1) "Louder"
+ example/Example/Style.hs view
@@ -0,0 +1,43 @@+module Example.Style where++import Example.Colors+import Web.View+++btn :: Mod+btn = btn' Primary+++btn' :: AppColor -> Mod+btn' clr = bg clr . hover (bg (hovClr clr)) . color (txtClr clr) . pad 10+ where+ hovClr Primary = PrimaryLight+ hovClr c = c+ txtClr _ = White+++btnLight :: Mod+btnLight =+ base+ . border 2+ . borderColor Secondary+ . color Secondary+ . hover (borderColor SecondaryLight . color SecondaryLight)+ where+ base = pad (XY 15 8)+++h1 :: Mod+h1 = bold . fontSize 32+++invalid :: Mod+invalid = color Danger+++success :: Mod+success = color Success+++link :: Mod+link = color Primary
example/Example/Transitions.hs view
@@ -1,45 +1,48 @@ module Example.Transitions where import Effectful-import Example.Colors+import Example.Style as Style import Web.Hyperbole -page :: (Hyperbole :> es) => Page es ()++page :: (Hyperbole :> es) => Page es Response page = do- hyper content+ handle content load $ do pure $ row (pad 20) $ do- viewId Contents viewSmall+ hyper Contents viewSmall + data Contents = Contents- deriving (Show, Read, Param)+ deriving (Generic, Param) + data ContentsAction = Expand | Collapse- deriving (Show, Read, Param)+ deriving (Generic, Param) + instance HyperView Contents where type Action Contents = ContentsAction + content :: (Hyperbole :> es) => Contents -> ContentsAction -> Eff es (View Contents ()) content _ Expand = do pure viewBig content _ Collapse = do pure viewSmall + viewSmall :: View Contents () viewSmall = do- col (gap 10 . border 1 . pad 20 . transition 300 (Height 200)) $ do- el id "Hello"- button Expand btn "Expand"+ col (gap 10 . border 1 . pad 20 . transition 300 (Width 200)) $ do+ el id "Small"+ button Expand Style.btn "Expand" -viewBig :: View Contents ()-viewBig = col (gap 10 . border 1 . pad 20 . transition 300 (Height 400)) $ do- el_ "One"- el_ "TWO"- button Collapse (bg Secondary . hover (bg SecondaryLight) . color White . pad 10) "Collapse" -btn :: Mod-btn = bg Primary . hover (bg PrimaryLight) . color White . pad 10+viewBig :: View Contents ()+viewBig = col (gap 10 . border 1 . pad 20 . transition 300 (Width 400)) $ do+ el_ "Expanded"+ button Collapse Style.btn "Collapse"
+ example/HelloWorld.hs view
@@ -0,0 +1,59 @@+module HelloWorld where++import Data.Text (Text)+import Web.Hyperbole++++main :: IO ()+main = do+ run 3000 $ do+ liveApp (basicDocument "Example") (page messagePage')+++messagePage :: (Hyperbole :> es) => Page es Response+messagePage = do+ load $ do+ pure $ do+ el bold "Message Page"+ messageView "Hello World"+++messageView :: Text -> View c ()+messageView m = do+ el_ "Message:"+ el_ (text m)+++data Message = Message+ deriving (Generic, Param)+++data MessageAction = SetMessage Text+ deriving (Generic, Param)+++instance HyperView Message where+ type Action Message = MessageAction+++message :: Message -> MessageAction -> Eff es (View Message ())+message _ (SetMessage m) = do+ -- side effects+ pure $ messageView' m+++messageView' :: Text -> View Message ()+messageView' m = do+ el bold "Message"+ el_ (text m)+ button (SetMessage "Goodbye World") id "Change Message"+++messagePage' :: (Hyperbole :> es) => Page es Response+messagePage' = do+ handle message+ load $ do+ pure $ do+ el bold "Message Page"+ hyper Message $ messageView' "Hello World"
example/Main.hs view
@@ -13,71 +13,138 @@ import Data.Text.Lazy qualified as L import Data.Text.Lazy.Encoding qualified as L import Effectful+import Effectful.Concurrent.STM import Effectful.Dispatch.Dynamic+import Effectful.Reader.Static import Effectful.State.Static.Local import Example.Contacts qualified as Contacts-import Example.Effects.Debug+import Example.Counter qualified as Counter+import Example.Effects.Debug as Debug import Example.Effects.Users as Users+import Example.Errors qualified as Errors import Example.Forms qualified as Forms+import Example.LazyLoading qualified as LazyLoading+import Example.Redirects qualified as Redirects+import Example.Sessions qualified as Sessions+import Example.Simple qualified as Simple+import Example.Style qualified as Style import Example.Transitions qualified as Transitions import GHC.Generics (Generic) import Network.HTTP.Types (Method, QueryItem, methodPost, status200, status404)-import Network.Wai ()+import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Middleware.Static (addBase, staticPolicy)+import Network.WebSockets (Connection, PendingConnection, acceptRequest, defaultConnectionOptions) import Web.Hyperbole+import Web.Hyperbole.Effect (Request (..)) -- import Network.Wai.Handler.WebSockets (websocketsOr) main :: IO () main = do- putStrLn "Starting Examples on http://localhost:3003"+ putStrLn "Starting Examples on http://localhost:3000" users <- initUsers- Warp.run 3003- $ staticPolicy (addBase "client/dist")- $ app users+ count <- runEff $ runConcurrent $ newTVarIO 0+ Warp.run 3000 $+ staticPolicy (addBase "client/dist") $+ app users count data AppRoute = Main+ | Simple | Hello Hello | Contacts | Transitions+ | Query+ | Counter | Forms- deriving (Show, Generic, Eq, Route)+ | Sessions+ | Redirects+ | RedirectNow+ | LazyLoading+ | Errors+ deriving (Eq, Generic, Route) data Hello = Greet Text- deriving (Show, Generic, Eq, Route)+ | Redirected+ deriving (Eq, Generic, Route) -app :: UserStore -> Application-app users = application toDocument (runUsersIO users . runDebugIO . router)+app :: UserStore -> TVar Int -> Application+app users count = do+ liveApp+ toDocument+ (runApp . routeRequest $ router) where- router :: (Hyperbole :> es, Users :> es, Debug :> es) => AppRoute -> Eff es ()+ runApp :: (IOE :> es) => Eff (Concurrent : Debug : Users : es) a -> Eff es a+ runApp = runUsersIO users . runDebugIO . runConcurrent++ router :: forall es. (Hyperbole :> es, Users :> es, Debug :> es, Concurrent :> es, IOE :> es) => AppRoute -> Eff es Response router (Hello h) = page $ hello h+ router Simple = page Simple.simplePage router Contacts = page Contacts.page+ router Counter = page $ Counter.page count router Transitions = page Transitions.page router Forms = page Forms.page- router Main = view $ do- col (gap 10 . pad 10) $ do- el (bold . fontSize 32) "Examples"- link (Hello (Greet "World")) id "Hello World"- link Contacts id "Contacts"- link Transitions id "Transitions"- link Forms id "Forms"+ router Sessions = page Sessions.page+ router LazyLoading = page LazyLoading.page+ router Redirects = page Redirects.page+ router Errors = page Errors.page+ router RedirectNow = do+ redirect (routeUrl $ Hello Redirected)+ router Query = do+ p <- reqParam "key"+ view $ el (pad 20) $ do+ text "key: "+ text p+ router Main = do+ view $ do+ col (gap 10 . pad 20) $ do+ el (bold . fontSize 32) "Examples"+ route (Hello (Greet "World")) lnk "Hello World"+ route Simple lnk "Simple"+ route Counter lnk "Counter"+ route Transitions lnk "Transitions"+ route Forms lnk "Forms"+ link "/query?key=value" lnk "Query Params"+ route Sessions lnk "Sessions"+ route Redirects lnk "Redirects"+ route RedirectNow lnk "Redirect Now"+ route LazyLoading lnk "Lazy Loading"+ route Contacts lnk "Contacts (Advanced)"+ route Errors lnk "Errors" - -- example sub-router- hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es ()+ lnk = Style.link++ -- Nested Router+ hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es Response+ hello Redirected = load $ do+ pure $ el_ "You were redirected" hello (Greet s) = load $ do- pure $ do- el (pad 10 . gap 10) $ do- text "Greetings, "+ r <- request+ pure $ col (gap 10 . pad 10) $ do+ el_ $ do+ text "Greetings: " text s+ el_ $ do+ text "Host: "+ text $ cs $ show r.host+ el_ $ do+ text "Path: "+ text $ cs $ show r.path+ el_ $ do+ text "Query: "+ text $ cs $ show r.query+ el_ $ do+ text "Cookies: "+ text $ cs $ show r.cookies - -- Use the embedded version for real applications (see below). The link to /hyperbole.js here is just to make local development easier+ -- Use the embedded version for real applications (see basicDocument).+ -- The link to /hyperbole.js here is just to make local development easier toDocument :: BL.ByteString -> BL.ByteString toDocument cnt = [i|<html>@@ -88,14 +155,3 @@ </head> <body>#{cnt}</body> </html>|]---- toDocument :: BL.ByteString -> BL.ByteString--- toDocument cnt =--- [i|<html>--- <head>--- <title>Hyperbole Examples</title>--- <script type="text/javascript">#{scriptEmbed}</script>--- <style type type="text/css">#{cssResetEmbed}</style>--- </head>--- <body>#{cnt}</body>--- </html>|]
hyperbole.cabal view
@@ -5,10 +5,10 @@ -- see: https://github.com/sol/hpack name: hyperbole-version: 0.2.0-synopsis: Web Framework inspired by HTMX-description: Web Framework inspired by HTMX.-category: Web+version: 0.3.5+synopsis: Interactive HTML apps using type-safe serverside Haskell+description: Interactive HTML applications using type-safe serverside Haskell. Inspired by HTMX, Elm, and Phoenix LiveView+category: Web, Network homepage: https://github.com/seanhess/hyperbole bug-reports: https://github.com/seanhess/hyperbole/issues author: Sean Hess@@ -35,6 +35,8 @@ Web.Hyperbole.Forms Web.Hyperbole.HyperView Web.Hyperbole.Route+ Web.Hyperbole.Session+ Web.Hyperbole.View other-modules: Paths_hyperbole autogen-modules:@@ -56,6 +58,7 @@ , bytestring >=0.11 && <0.13 , casing >0.1 && <0.2 , containers >=0.6 && <1+ , cookie ==0.4.* , effectful >=2.3 && <3 , file-embed >=0.0.10 && <0.1 , http-api-data ==0.6.*@@ -67,20 +70,28 @@ , wai >=3.2 && <4 , wai-websockets >=3.0 && <4 , warp >=3.3 && <4- , web-view >=0.3 && <=0.4+ , web-view >=0.4 && <=0.5 , websockets >=0.12 && <0.14 default-language: GHC2021 -executable example+executable examples main-is: Main.hs other-modules: BulkUpdate Example.Colors Example.Contacts+ Example.Counter Example.Effects.Debug Example.Effects.Users+ Example.Errors Example.Forms+ Example.LazyLoading+ Example.Redirects+ Example.Sessions+ Example.Simple+ Example.Style Example.Transitions+ HelloWorld Paths_hyperbole autogen-modules: Paths_hyperbole@@ -101,6 +112,7 @@ , bytestring >=0.11 && <0.13 , casing >0.1 && <0.2 , containers >=0.6 && <1+ , cookie ==0.4.* , effectful >=2.3 && <3 , file-embed >=0.0.10 && <0.1 , http-api-data ==0.6.*@@ -114,6 +126,52 @@ , wai-middleware-static >=0.9 && <=0.10 , wai-websockets >=3.0 && <4 , warp >=3.3 && <4- , web-view >=0.3 && <=0.4+ , web-view >=0.4 && <=0.5+ , websockets >=0.12 && <0.14+ default-language: GHC2021++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.RouteSpec+ Test.ViewSpec+ Paths_hyperbole+ autogen-modules:+ Paths_hyperbole+ hs-source-dirs:+ test/+ default-extensions:+ OverloadedStrings+ OverloadedRecordDot+ DuplicateRecordFields+ NoFieldSelectors+ TypeFamilies+ DataKinds+ DerivingStrategies+ DeriveAnyClass+ ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends:+ sydtest-discover:sydtest-discover+ build-depends:+ base >=4.16 && <5+ , bytestring >=0.11 && <0.13+ , casing >0.1 && <0.2+ , containers >=0.6 && <1+ , cookie ==0.4.*+ , effectful >=2.3 && <3+ , file-embed >=0.0.10 && <0.1+ , http-api-data ==0.6.*+ , http-types ==0.12.*+ , hyperbole+ , network >=3.1 && <4+ , string-conversions ==0.4.*+ , string-interpolate ==0.3.*+ , sydtest ==0.15.*+ , text >=1.2 && <3+ , wai >=3.2 && <4+ , wai-websockets >=3.0 && <4+ , warp >=3.3 && <4+ , web-view >=0.4 && <=0.5 , websockets >=0.12 && <0.14 default-language: GHC2021
src/Web/Hyperbole.hs view
@@ -1,22 +1,297 @@+{- |+Module: Web.Hyperbole+Copyright: (c) 2024 Sean Hess+License: BSD3+Maintainer: Sean Hess <seanhess@gmail.com>+Stability: experimental+Portability: portable++Create fully interactive HTML applications with type-safe serverside Haskell. Inspired by [HTMX](https://htmx.org/), [Elm](https://elm-lang.org/), and [Phoenix LiveView](https://www.phoenixframework.org/)+-} module Web.Hyperbole- ( module Web.Hyperbole.Route- , module Web.Hyperbole.Effect- , module Web.Hyperbole.HyperView- , module Web.Hyperbole.Application- , module Web.Hyperbole.Forms- , module Web.View+ ( -- * Introduction+ -- $use++ -- ** Hello World+ -- $hello++ -- ** Interactivity+ -- $interactive++ -- ** Independent Updates+ -- $multi++ -- ** Examples+ -- $examples++ -- * Run an Application+ liveApp+ , Warp.run+ , page+ , basicDocument++ -- ** Type-Safe Routes+ , routeRequest -- maybe belongs in an application section+ , Route+ , routeUrl+ , route++ -- * Pages++ -- ** Page+ , Page+ , load+ , handle++ -- ** HyperView+ , HyperView (..)+ , hyper++ -- * Interactive Elements++ -- ** Buttons+ , button++ -- ** Dropdowns+ , dropdown+ , option+ , Option++ -- ** Events+ , onRequest+ , onLoad+ , DelayMs++ -- * Type-Safe Forms++ -- | Painless forms with type-checked field names, and support for validation. See [Example.Forms](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)+ , FormField++ -- ** Form View+ , form+ , field+ , label+ , input+ , submit+ , placeholder+ , InputType (..)++ -- ** Handlers+ , formField++ -- ** Validation+ , Validation (..)+ , validate+ , validation+ , invalidText++ -- * Hyperbole Effect+ , Hyperbole++ -- ** Request Info+ , reqParam+ , reqParams+ , request+ , lookupParam+ , formData++ -- ** Response+ , notFound+ , redirect+ , respondEarly++ -- ** Sessions+ , session+ , setSession+ , clearSession++ -- * Advanced+ , target+ , view+ , Param (..)+ , Response++ -- * Exports++ -- ** Web.View++ -- | Hyperbole is tightly integrated with [Web.View](https://hackage.haskell.org/package/web-view/docs/Web-View.html) for HTML generation+ , module Web.Hyperbole.View++ -- ** Embeds++ -- | Embedded CSS and Javascript to include in your document function. See 'basicDocument'+ , module Web.Hyperbole.Embed++ -- ** Effectful+ -- $effects+ , module Effectful++ -- ** Other , Application- , run- , scriptEmbed+ , Generic ) where +import Effectful (Eff, (:>))+import GHC.Generics (Generic) import Network.Wai (Application)-import Network.Wai.Handler.Warp (run)+import Network.Wai.Handler.Warp as Warp (run) import Web.Hyperbole.Application import Web.Hyperbole.Effect-import Web.Hyperbole.Embed (scriptEmbed)-import Web.Hyperbole.Forms+import Web.Hyperbole.Embed+import Web.Hyperbole.Forms (FormField, InputType (..), Validation (..), field, form, formField, input, invalidText, label, placeholder, submit, validate, validation) import Web.Hyperbole.HyperView import Web.Hyperbole.Route-import Web.View hiding (button, form, input, label, link)+import Web.Hyperbole.View ++-- import Web.View.Types.Url (Segment)++{- $use++Single Page Applications (SPAs) require the programmer to write two programs: a Javascript client and a Server, which both must conform to a common API++Hyperbole allows us instead to write a single Haskell program which runs exclusively on the server. All user interactions are sent to the server for processing, and a sub-section of the page is updated with the resulting HTML.++There are frameworks that support this in different ways, including [HTMX](https://htmx.org/), [Phoenix LiveView](https://www.phoenixframework.org/), and others. Hyperbole has the following advantages++1. 100% Haskell+2. Type safe views, actions, routes, and forms+3. Elegant interface with little boilerplate+4. VirtualDOM updates over sockets, fallback to HTTP+5. Easy to use++Like [HTMX](https://htmx.org/), Hyperbole extends the capability of UI elements, but it uses Haskell's type-system to prevent common errors and provide default functionality. Specifically, a page has multiple update targets called 'HyperView's. These are automatically targeted by any UI element that triggers an action inside them. The compiler makes sure that actions and targets match++Like [Phoenix LiveView](https://www.phoenixframework.org/), it upgrades the page to a fast WebSocket connection and uses VirtualDOM for live updates++Like [Elm](https://elm-lang.org/), it relies on an update function to 'handle' actions, but greatly simplifies the Elm Architecture by handling state with extensible effects. 'form's are easy to use with minimal boilerplate++Depends heavily on the following frameworks++* [Effectful](https://hackage.haskell.org/package/effectful-core)+* [Web View](https://hackage.haskell.org/package/web-view)+-}+++{- $hello++Hyperbole applications run via [Warp](https://hackage.haskell.org/package/warp) and [WAI](https://hackage.haskell.org/package/wai)++They are divided into top-level 'Page's. We use 'load' to handle the initial page load++@+main = do+ 'run' 3000 $ do+ 'liveApp' ('basicDocument' \"Example\") ('page' messagePage)++messagePage = do+ 'load' $ do+ pure $ do+ 'el' 'bold' "Message Page"+ messageView "Hello World"++messageView m = do+ el_ "Message:"+ el_ (text m)+@+-}+++{- $interactive++Embed 'HyperView's to add type-safe interactivity to subsections of a 'Page'.++To do this, first we connect a view id type to the actions it supports++@+data Message = Message+ deriving (Generic, 'Param')++data MessageAction = Louder Text+ deriving (Generic, 'Param')++instance 'HyperView' Message where+ type Action Message = MessageAction+@+++Next we add a 'handle'r for our view type. It performs side effects, and returns a new view of the same type++@+message :: Message -> MessageAction -> Eff es (View Message ())+message _ (Louder m) = do+ -- side effects+ let new = m <> "!"+ pure $ messageView new+@++We update our parent page view to make the messageView interactive using 'hyper', and add our 'handle'r to the 'Page'++@+messagePage = do+ 'handle' message+ 'load' $ do+ pure $ do+ 'el' 'bold' "Message Page"+ 'hyper' Message $ messageView "Hello World"+@++Finally, let's add a 'button' to our view. When clicked, Hyperbole will run the `message` handler, and update our view, leaving the page header untouched++@+messageView :: Text -> 'View' Message ()+messageView m = do+ 'el_' m+ 'button' (Louder m) id "Change Message"+@+-}+++{- $multi++Multiple views update independently, as long as they have different values for their View Id. Add an Int identifier to Message++@+data Message = Message Int+ deriving (Generic, 'Param')+@++We can embed multiple HyperViews on the same page with different ids. Each button will update its view independently+++@+messagePage = do+ 'handle' message+ 'load' $ do+ pure $ do+ 'el' bold "Message Page"+ 'hyper' (Message 1) $ messageView \"Hello\"+ 'hyper' (Message 2) $ messageView \"World\"+@+-}+++{- $examples+The [example directory](https://github.com/seanhess/hyperbole/blob/main/example/example/README.md) contains an app with pages demonstrating different features++* [Main](https://github.com/seanhess/hyperbole/blob/main/example/Main.hs)+* [Simple](https://github.com/seanhess/hyperbole/blob/main/example/Example/Simple.hs)+* [Counter](https://github.com/seanhess/hyperbole/blob/main/example/Example/Counter.hs)+* [CSS Transitions](https://github.com/seanhess/hyperbole/blob/main/example/Example/Transitions.hs)+* [Forms](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)+* [Sessions](https://github.com/seanhess/hyperbole/blob/main/example/Example/Forms.hs)+* [Redirects](https://github.com/seanhess/hyperbole/blob/main/example/Example/Redirects.hs)+* [Lazy Loading and Polling](https://github.com/seanhess/hyperbole/blob/main/example/Example/LazyLoading.hs)+* [Errors](https://github.com/seanhess/hyperbole/blob/main/example/Example/Errors.hs)+* [Contacts (Advanced)](https://github.com/seanhess/hyperbole/blob/main/example/Example/Contacts.hs)+-}+++{- $effects++Hyperbole is tighly integrated with [Effectful](https://hackage.haskell.org/package/effectful) for extensible effects. It is used to implement the 'Hyperbole' and 'Server' effects.++* See [Effectful.Dispatch.Dynamic](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) for an example of how to create a custom effect+* See [Example.Counter](https://github.com/seanhess/hyperbole/blob/main/example/Example/Counter.hs) for an example of how to compose an existing effect+-}
src/Web/Hyperbole/Application.hs view
@@ -1,142 +1,328 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+ module Web.Hyperbole.Application- ( waiApplication- -- , webSocketApplication- , application+ ( waiApp , websocketsOr+ , defaultConnectionOptions+ , liveApp+ , socketApp+ , runServerSockets+ , runServerWai+ , basicDocument+ , routeRequest ) where import Control.Monad (forever)-import Data.ByteString (ByteString)-import Data.ByteString.Lazy qualified as L+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.List qualified as L+import Data.Maybe (fromMaybe) import Data.String.Conversions (cs)+import Data.String.Interpolate (i) import Data.Text (Text, pack) import Data.Text qualified as T import Effectful+import Effectful.Dispatch.Dynamic import Effectful.Error.Static-import Effectful.Reader.Static-import Network.HTTP.Types (Method, Query, parseQuery, status200, status400, status404)-import Network.HTTP.Types.Header (HeaderName)+import Effectful.State.Static.Local+import Network.HTTP.Types (HeaderName, Method, parseQuery, status200, status400, status401, status404, status500) import Network.Wai qualified as Wai import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.Wai.Internal (ResponseReceived (..)) import Network.WebSockets (Connection, PendingConnection, defaultConnectionOptions) import Network.WebSockets qualified as WS+import Web.Cookie (parseCookies) import Web.Hyperbole.Effect+import Web.Hyperbole.Embed (cssResetEmbed, scriptEmbed) import Web.Hyperbole.Route-import Web.View (View, renderLazyByteString)+import Web.Hyperbole.Session+import Web.View (View, renderLazyByteString, renderUrl) -{- | Start both a websockets and a WAI server. Wai app serves initial pages, and attempt to process actions via sockets- If the socket connection is unavailable, will fall back to the WAI app to process actions+{- | Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets++> main = do+> run 3000 $ do+> liveApp (basicDocument "Example") $ do+> page mainPage -}-application :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff '[Hyperbole, IOE] ()) -> Wai.Application-application toDoc actions =+liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, IOE] Response -> Wai.Application+liveApp toDoc app = websocketsOr defaultConnectionOptions- (socketApplication actions)- (waiApplication toDoc actions)+ (runEff . socketApp app)+ (waiApp toDoc app) -waiApplication :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff '[Hyperbole, IOE] ()) -> Wai.Application-waiApplication toDoc actions request respond = do- req <- fromWaiRequest request- res <- runEff $ runHyperboleRoute req actions- sendResponse res+socketApp :: (IOE :> es) => Eff (Hyperbole : Server : es) Response -> PendingConnection -> Eff es ()+socketApp actions pend = do+ conn <- liftIO $ WS.acceptRequest pend+ forever $ do+ runServerSockets conn $ runHyperbole actions+++waiApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, IOE] Response -> Wai.Application+waiApp toDoc actions req res = do+ rr <- runEff $ runServerWai toDoc req res $ runHyperbole actions+ case rr of+ Nothing -> error "Missing required response in handler"+ Just r -> pure r+++errNotHandled :: Event Text Text -> String+errNotHandled ev =+ L.intercalate+ "\n"+ [ "No Handler for Event viewId: " <> cs ev.viewId <> " action: " <> cs ev.action+ , "<p>Remember to add a `hyper` handler in your page function</p>"+ , "<pre>"+ , "page :: (Hyperbole :> es) => Page es Response"+ , "page = do"+ , " handle contentsHandler"+ , " load $ do"+ , " pure $ hyper Contents contentsView"+ , "</pre>"+ ]+++runServerWai+ :: (IOE :> es)+ => (BL.ByteString -> BL.ByteString)+ -> Wai.Request+ -> (Wai.Response -> IO ResponseReceived)+ -> Eff (Server : es) a+ -> Eff es (Maybe Wai.ResponseReceived)+runServerWai toDoc req respond =+ reinterpret runLocal $ \_ -> \case+ LoadRequest -> do+ fromWaiRequest req+ SendResponse sess r -> do+ rr <- liftIO $ sendResponse sess r+ put (Just rr) where- fromWaiRequest wr = do- bd <- liftIO $ Wai.consumeRequestBodyLazy wr- pure $ Request (Wai.pathInfo wr) (Wai.queryString wr) bd+ runLocal :: (IOE :> es) => Eff (State (Maybe ResponseReceived) : es) a -> Eff es (Maybe ResponseReceived)+ runLocal = execState Nothing - -- TODO: logging?- sendResponse :: Response -> IO Wai.ResponseReceived- sendResponse (ErrParse e) = respBadRequest ("Parse Error: " <> cs e)- sendResponse ErrNoHandler = respBadRequest "No Handler Found"- sendResponse NotFound = respNotFound- sendResponse (Response vw) = do- let body = addDocument (Wai.requestMethod request) (renderLazyByteString vw)- respHtml body+ sendResponse :: Session -> Response -> IO Wai.ResponseReceived+ sendResponse sess r =+ respond $ response r+ where+ response :: Response -> Wai.Response+ response NotFound = respError status404 "Not Found"+ response Empty = respError status500 "Empty Response"+ response (Err (ErrParse e)) = respError status400 ("Parse Error: " <> cs e)+ response (Err (ErrParam e)) = respError status400 $ "ErrParam: " <> cs e+ response (Err (ErrOther e)) = respError status500 $ "Server Error: " <> cs e+ response (Err ErrAuth) = respError status401 "Unauthorized"+ response (Err (ErrNotHandled e)) = respError status400 $ cs $ errNotHandled e+ response (Response vw) =+ respHtml $+ addDocument (Wai.requestMethod req) (renderLazyByteString vw)+ response (Redirect u) = do+ let url = renderUrl u+ -- We have to use a 200 javascript redirect because javascript+ -- will redirect the fetch(), while we want to redirect the whole page+ -- see index.ts sendAction()+ let headers = ("Location", cs url) : contentType ContentHtml : setCookies+ Wai.responseLBS status200 headers $ "<script>window.location = '" <> cs url <> "'</script>" - respBadRequest e =- respond $ Wai.responseLBS status400 [contentType ContentText] e+ respError s = Wai.responseLBS s [contentType ContentText] - respNotFound =- respond $ Wai.responseLBS status404 [contentType ContentText] "Not Found"+ respHtml body =+ -- always set the session...+ let headers = contentType ContentHtml : setCookies+ in Wai.responseLBS status200 headers body - respHtml body = do- let headers = [contentType ContentHtml]- respond $ Wai.responseLBS status200 headers body+ setCookies =+ [("Set-Cookie", sessionSetCookie sess)] - -- convert to document if GET. Subsequent POST requests will only include fragments- addDocument :: Method -> L.ByteString -> L.ByteString+ -- convert to document if full page request. Subsequent POST requests will only include fragments+ addDocument :: Method -> BL.ByteString -> BL.ByteString addDocument "GET" bd = toDoc bd addDocument _ bd = bd + fromWaiRequest :: (MonadIO m) => Wai.Request -> m Request+ fromWaiRequest wr = do+ body <- liftIO $ Wai.consumeRequestBodyLazy wr+ let path = Wai.pathInfo wr+ query = Wai.queryString wr+ headers = Wai.requestHeaders wr+ cookie = fromMaybe "" $ L.lookup "Cookie" headers+ host = Host $ fromMaybe "" $ L.lookup "Host" headers+ cookies = parseCookies cookie+ method = Wai.requestMethod wr+ pure $ Request{body, path, query, method, cookies, host} ++runServerSockets+ :: (IOE :> es)+ => Connection+ -> Eff (Server : es) Response+ -> Eff es Response+runServerSockets conn = reinterpret runLocal $ \_ -> \case+ LoadRequest -> receiveRequest+ SendResponse sess res -> do+ case res of+ (Response vw) -> sendView (addMetadata sess) vw+ (Err r) -> sendError r+ Empty -> sendError $ ErrOther "Empty"+ NotFound -> sendError $ ErrOther "NotFound"+ (Redirect url) -> sendRedirect (addMetadata sess) url+ where+ runLocal = runErrorNoCallStackWith @SocketError onSocketError++ onSocketError :: (IOE :> es) => SocketError -> Eff es Response+ onSocketError e = do+ let r = ErrOther $ cs $ show e+ sendError r+ pure $ Err r++ sendError :: (IOE :> es) => ResponseError -> Eff es ()+ sendError r = do+ -- conn <- ask @Connection+ -- TODO: better error handling!+ liftIO $ WS.sendTextData conn $ "|ERROR|" <> pack (show r)++ sendView :: (IOE :> es) => (BL.ByteString -> BL.ByteString) -> View () () -> Eff es ()+ sendView addMeta vw = do+ -- conn <- ask @Connection+ liftIO $ WS.sendTextData conn $ addMeta $ renderLazyByteString vw++ sendRedirect :: (IOE :> es) => (BL.ByteString -> BL.ByteString) -> Url -> Eff es ()+ sendRedirect addMeta u = do+ -- conn <- ask @Connection+ liftIO $ WS.sendTextData conn $ addMeta $ "|REDIRECT|" <> cs (renderUrl u)++ addMetadata :: Session -> BL.ByteString -> BL.ByteString+ addMetadata sess cont =+ -- you may have 1 or more lines containing metadata followed by a view+ -- \|SESSION| key=value; another=woot;+ -- <div ...>+ sessionLine <> "\n" <> cont+ where+ metaLine name value = "|" <> name <> "|" <> value++ sessionLine :: BL.ByteString+ sessionLine = metaLine "SESSION" $ cs (sessionSetCookie sess)++ receiveRequest :: (IOE :> es, Error SocketError :> es) => Eff es Request+ receiveRequest = do+ t <- receiveText+ case parseMessage t of+ Left e -> throwError e+ Right r -> pure r++ receiveText :: (IOE :> es) => Eff es Text+ receiveText = do+ -- c <- ask @Connection+ liftIO $ WS.receiveData conn++ parseMessage :: Text -> Either SocketError Request+ parseMessage t = do+ case T.splitOn "\n" t of+ [url, host, cook, body] -> parse url cook host (Just body)+ [url, host, cook] -> parse url cook host Nothing+ _ -> Left $ InvalidMessage t+ where+ parseUrl :: Text -> Either SocketError (Text, Text)+ parseUrl u =+ case T.splitOn "?" u of+ [url, query] -> pure (url, query)+ _ -> Left $ InvalidMessage u++ parse :: Text -> Text -> Text -> Maybe Text -> Either SocketError Request+ parse url cook hst mbody = do+ (u, q) <- parseUrl url+ let path = paths u+ query = parseQuery (cs q)+ cookies = parseCookies $ cs $ header cook+ host = Host $ cs $ header hst+ method = "POST"+ body = cs $ fromMaybe "" mbody+ pure $ Request{path, host, query, body, method, cookies}++ paths p = filter (/= "") $ T.splitOn "/" p++ -- drop up to the colon, then ': '+ header = T.drop 2 . T.dropWhile (/= ':')+++data SocketError+ = InvalidMessage Text+ deriving (Show, Eq)++ data ContentType = ContentHtml | ContentText -contentType :: ContentType -> (HeaderName, ByteString)+contentType :: ContentType -> (HeaderName, BS.ByteString) contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8") contentType ContentText = ("Content-Type", "text/plain; charset=utf-8") -socketApplication :: (Route route) => (route -> Eff '[Hyperbole, IOE] ()) -> PendingConnection -> IO ()-socketApplication actions pending = do- conn <- WS.acceptRequest pending- forever $ talk conn- where- talk :: Connection -> IO ()- talk conn = do- res <- runSocket $ do- req <- request- liftIO $ print (req.path, req.query, req.body)- liftIO $ runEff $ runHyperboleRoute req actions+{- | wrap HTML fragments in a simple document with a custom title and include required embeds - case res of- Right (Response vw) -> sendView vw- Right (ErrParse t) -> sendError $ "ErrParse " <> t- Right ErrNoHandler -> sendError @Text "ErrNoHandler"- Right NotFound -> sendError @Text "NotFound"- Left err -> sendError err- where- runSocket :: Eff '[Error SocketError, Reader Connection, IOE] Response -> IO (Either SocketError Response)- runSocket = runEff . runReader conn . runErrorNoCallStack @SocketError+@+'liveApp' (basicDocument "App Title") ('routeRequest' router)+@ - request :: (IOE :> es, Reader Connection :> es, Error SocketError :> es) => Eff es Request- request = do- t <- receive- case parseMessage t of- Left e -> throwError e- Right r -> pure r+You may want to specify a custom document function instead: - receive :: (Reader Connection :> es, IOE :> es) => Eff es Text- receive = do- c <- ask @Connection- liftIO $ WS.receiveData c+> myDocument :: ByteString -> ByteString+> myDocument content =+> [i|<html>+> <head>+> <title>#{title}</title>+> <script type="text/javascript">#{scriptEmbed}</script>+> <style type type="text/css">#{cssResetEmbed}</style>+> </head>+> <body>#{content}</body>+> </html>|]+-}+basicDocument :: Text -> BL.ByteString -> BL.ByteString+basicDocument title cnt =+ [i|<html>+ <head>+ <title>#{title}</title>+ <script type="text/javascript">#{scriptEmbed}</script>+ <style type type="text/css">#{cssResetEmbed}</style>+ </head>+ <body>#{cnt}</body>+ </html>|] - parseMessage :: Text -> Either SocketError Request- parseMessage t = do- (path, query, body) <- messageParts t- pure $ Request path query (cs body) - messageParts :: Text -> Either SocketError ([Text], Query, Text)- messageParts t = do- case T.splitOn "\n" t of- [url, q, body] -> pure (paths url, query q, body)- [url, q] -> pure (paths url, query q, "")- _ -> Left $ InvalidMessage t- where- paths p = filter (/= "") $ T.splitOn "/" p- query q = parseQuery (cs q)+{- | Route URL patterns to different pages - sendView :: View () () -> IO ()- sendView vw = WS.sendTextData conn $ renderLazyByteString vw - sendError :: (Show e) => e -> IO ()- sendError e = WS.sendTextData conn $ pack (show e)+@+import Page.Messages qualified as Messages+import Page.Users qualified as Users +data AppRoute+ = Main+ | Messages+ | Users UserId+ deriving (Eq, Generic, 'Route') -data SocketError- = InvalidMessage Text- deriving (Show, Eq)+router :: ('Hyperbole' :> es) => AppRoute -> 'Eff' es 'Response'+router Messages = 'page' Messages.page+router (Users uid) = 'page' $ Users.page uid+router Main = do+ 'view' $ do+ 'el_' "click a link below to visit a page"+ 'route' Messages id \"Messages\"++main = do+ 'run' 3000 $ do+ 'liveApp' ('basicDocument' \"Example\") (routeRequest router)+@+-}+routeRequest :: (Hyperbole :> es, Route route) => (route -> Eff es Response) -> Eff es Response+routeRequest actions = do+ path <- reqPath+ case findRoute path of+ Nothing -> send $ RespondEarly NotFound+ Just rt -> actions rt
src/Web/Hyperbole/Effect.hs view
@@ -1,161 +1,395 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE NoFieldSelectors #-} module Web.Hyperbole.Effect where import Control.Monad (join)+import Data.Bifunctor (first) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL+import Data.List qualified as List import Data.String.Conversions import Data.Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static-import Effectful.Reader.Static-import Network.HTTP.Types (Query)+import Effectful.State.Static.Local+import Network.HTTP.Types hiding (Query) import Web.FormUrlEncoded (Form, urlDecodeForm)+import Web.HttpApiData (FromHttpApiData, ToHttpApiData (..), parseQueryParam) import Web.Hyperbole.HyperView import Web.Hyperbole.Route+import Web.Hyperbole.Session as Session import Web.View +newtype Host = Host {text :: BS.ByteString}+ deriving (Show)++ data Request = Request- { path :: [Text]+ { host :: Host+ , path :: [Segment] , query :: Query , body :: BL.ByteString+ , method :: Method+ , cookies :: [(BS.ByteString, BS.ByteString)] } deriving (Show) +{- | Valid responses for a 'Hyperbole' effect. Use 'notFound', etc instead. Reminds you to use 'load' in your 'Page'++> myPage :: (Hyperbole :> es) => Page es Response+> myPage = do+> -- compiler error: () does not equal Response+> pure ()+-} data Response- = ErrParse Text- | ErrNoHandler- | Response (View () ())+ = Response (View () ()) | NotFound+ | Redirect Url+ | Err ResponseError+ | Empty +data ResponseError+ = ErrParse Text+ | ErrParam Text+ | ErrOther Text+ | ErrNotHandled (Event Text Text)+ | ErrAuth+ deriving (Show)+++{- | Hyperbole applications are divided into Pages. Each Page must 'load' the whole page , and 'handle' each /type/ of 'HyperView'++@+myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'+myPage = do+ 'handle' messages+ 'load' pageView++pageView = do+ el_ "My Page"+ 'hyper' (Message 1) $ messageView "Starting Message"+@+-} newtype Page es a = Page (Eff es a) deriving newtype (Applicative, Monad, Functor) -data Event act id = Event+-- | An action, with its corresponding id+data Event id act = Event { viewId :: id , action :: act } -data Hyperbole :: Effect where- GetForm :: Hyperbole m Form- GetEvent :: (HyperView id) => Hyperbole m (Maybe (Event (Action id) id))- Respond :: Response -> Hyperbole m a+instance (Show act, Show id) => Show (Event id act) where+ show e = "Event " <> show e.viewId <> " " <> show e.action --- ParseError :: HyperError -> Hyperbole m a+-- | Low level effect mapping request/response to either HTTP or WebSockets+data Server :: Effect where+ LoadRequest :: Server m Request+ SendResponse :: Session -> Response -> Server m () ++type instance DispatchOf Server = 'Dynamic+++{- | In any 'load' or 'handle', you can use this Effect to get extra request information or control the response manually.++For most 'Page's, you won't need to use this effect directly. Use custom 'Route's for request info, and return 'View's to respond+-}+data Hyperbole :: Effect where+ GetRequest :: Hyperbole m Request+ RespondEarly :: Response -> Hyperbole m a+ SetSession :: (ToHttpApiData a) => Text -> a -> Hyperbole m ()+ DelSession :: Text -> Hyperbole m ()+ GetSession :: (FromHttpApiData a) => Text -> Hyperbole m (Maybe a)++ type instance DispatchOf Hyperbole = 'Dynamic -runHyperboleRoute- :: (Route route)- => Request- -> (route -> Eff (Hyperbole : es) ())- -> Eff es Response-runHyperboleRoute req actions = do- case findRoute req.path of- Nothing -> pure NotFound- Just rt -> do- er <- runHyperbole req (actions rt)- case er of- Left r -> pure r- Right _ -> pure ErrNoHandler+data HyperState = HyperState+ { request :: Request+ , session :: Session+ } +-- | Run the 'Hyperbole' effect to 'Server' runHyperbole- :: Request- -> Eff (Hyperbole : es) a- -> Eff es (Either Response a)-runHyperbole req =- reinterpret runLocal $ \_ -> \case- GetForm -> getForm- GetEvent -> getEvent- Respond r -> respond r+ :: (Server :> es)+ => Eff (Hyperbole : es) Response+ -> Eff es Response+runHyperbole = fmap combine $ reinterpret runLocal $ \_ -> \case+ GetRequest -> do+ gets @HyperState (.request)+ RespondEarly r -> do+ s <- gets @HyperState (.session)+ send $ SendResponse s r+ throwError r+ SetSession k a -> do+ modify $ \st -> st{session = sessionSet k a st.session} :: HyperState+ DelSession k -> do+ modify $ \st -> st{session = sessionDel k st.session} :: HyperState+ GetSession k -> do+ s <- gets @HyperState (.session)+ pure $ sessionLookup k s where- respond :: (Error Response :> es) => Response -> Eff es a- respond = throwError+ runLocal :: (Server :> es) => Eff (State HyperState : Error Response : es) a -> Eff es (Either Response (a, HyperState))+ runLocal eff = do+ -- Load the request ONCE right when we start+ r <- send LoadRequest+ let st = HyperState r (sessionFromCookies r.cookies)+ runErrorNoCallStack @Response . runState st $ eff - runLocal =- runErrorNoCallStack @Response- . runReader req+ combine :: (Server :> es) => Eff es (Either Response (Response, HyperState)) -> Eff es Response+ combine eff = do+ er <- eff+ case er of+ Left res ->+ -- responded early, don't need to respond again+ pure res+ Right (res, st) -> do+ send $ SendResponse st.session res+ pure res - getForm :: (Reader Request :> es, Error Response :> es) => Eff es Form- getForm = do- bd <- asks @Request (.body)- let ef = urlDecodeForm bd- either (respond . ErrParse) pure ef - getEvent :: (Reader Request :> es, HyperView id) => Eff es (Maybe (Event (Action id) id))- getEvent = do- q <- asks @Request (.query)- pure $ do- Event ti ta <- lookupEvent q- vid <- parseParam ti- act <- parseParam ta- pure $ Event vid act+-- | Return all information about the 'Request'+request :: (Hyperbole :> es) => Eff es Request+request = send GetRequest - lookupParam :: BS.ByteString -> Query -> Maybe Text- lookupParam p q =- fmap cs <$> join $ lookup p q - lookupEvent :: Query -> Maybe (Event Text Text)- lookupEvent q =- Event- <$> lookupParam "id" q- <*> lookupParam "action" q+{- | Return the request path +>>> reqPath+["users", "100"]+-}+reqPath :: (Hyperbole :> es) => Eff es [Segment]+reqPath = (.path) <$> request ++{- | Return the request body as a Web.FormUrlEncoded.Form++Prefer using Type-Safe 'Form's when possible+-} formData :: (Hyperbole :> es) => Eff es Form-formData = send GetForm+formData = do+ b <- (.body) <$> request+ let ef = urlDecodeForm b+ -- not going to work. we need a way to `throwError` or it doesn't work...+ either (send . RespondEarly . Err . ErrParse) pure ef +getEvent :: (HyperView id, Hyperbole :> es) => Eff es (Maybe (Event id (Action id)))+getEvent = do+ q <- reqParams+ pure $ parseEvent q+++parseEvent :: (HyperView id) => Query -> Maybe (Event id (Action id))+parseEvent q = do+ Event ti ta <- lookupEvent q+ vid <- parseParam ti+ act <- parseParam ta+ pure $ Event vid act+++lookupEvent :: Query -> Maybe (Event Text Text)+lookupEvent q' =+ Event+ <$> lookupParam "id" q'+ <*> lookupParam "action" q'+++{- | Lookup a session variable by keyword++> load $ do+> tok <- session "token"+> ...+-}+session :: (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es (Maybe a)+session k = send $ GetSession k+++{- | Set a session variable by keyword++> load $ do+> t <- reqParam "token"+> setSession "token" t+> ...+-}+setSession :: (Hyperbole :> es, ToHttpApiData a) => Text -> a -> Eff es ()+setSession k v = send $ SetSession k v+++-- | Clear the user's session+clearSession :: (Hyperbole :> es) => Text -> Eff es ()+clearSession k = send $ DelSession k+++{- | Return the entire 'Query'++@+myPage :: 'Page' es 'Response'+myPage = do+ 'load' $ do+ q <- reqParams+ case 'lookupParam' "token" q of+ Nothing -> pure $ errorView "Missing Token in Query String"+ Just t -> do+ sideEffectUsingToken token+ pure myPageView+@+-}+reqParams :: (Hyperbole :> es) => Eff es Query+reqParams = (.query) <$> request+++-- | Lookup the query param in the 'Query'+lookupParam :: BS.ByteString -> Query -> Maybe Text+lookupParam p q =+ fmap cs <$> join $ lookup p q+++{- | Require a given parameter from the 'Query' arguments++@+myPage :: 'Page' es 'Response'+myPage = do+ 'load' $ do+ token <- reqParam "token"+ sideEffectUsingToken token+ pure myPageView+@+-}+reqParam :: (Hyperbole :> es, FromHttpApiData a) => Text -> Eff es a+reqParam p = do+ q <- reqParams+ (er :: Either Response a) <- pure $ do+ mv <- require $ List.lookup (encodeUtf8 p) q+ v <- require mv+ first (Err . ErrParam) $ parseQueryParam (decodeUtf8 v)+ case er of+ Left e -> send $ RespondEarly e+ Right a -> pure a+ where+ require :: Maybe x -> Either Response x+ require Nothing = Left $ Err $ ErrParam $ "Missing: " <> p+ require (Just a) = pure a+++{- | Respond immediately with 404 Not Found++@+userLoad :: (Hyperbole :> es, Users :> es) => UserId -> Eff es User+userLoad uid = do+ mu <- send (LoadUser uid)+ maybe notFound pure mu++myPage :: (Hyperbole :> es, Users :> es) => Eff es View+myPage = do+ load $ do+ u <- userLoad 100+ -- skipped if user = Nothing+ pure $ userView u+@+-} notFound :: (Hyperbole :> es) => Eff es a-notFound = send $ Respond NotFound+notFound = send $ RespondEarly NotFound +-- | Respond immediately with a parse error parseError :: (Hyperbole :> es) => Text -> Eff es a-parseError e = send $ Respond $ ErrParse e+parseError = send . RespondEarly . Err . ErrParse --- | Set the response to the view. Note that `page` already expects a view to be returned from the effect-view :: (Hyperbole :> es) => View () () -> Eff es ()-view vw = send $ Respond $ Response vw+-- | Redirect immediately to the 'Url'+redirect :: (Hyperbole :> es) => Url -> Eff es a+redirect = send . RespondEarly . Redirect --- | Load the entire page when no HyperViews match+-- | Respond with the given view, and stop execution+respondEarly :: (Hyperbole :> es, HyperView id) => id -> View id () -> Eff es ()+respondEarly vid vw = do+ let res = Response $ hyper vid vw+ send $ RespondEarly res+++-- | Manually set the response to the given view. Normally you return a 'View' from 'load' or 'handle' instead of using this+view :: (Hyperbole :> es) => View () () -> Eff es Response+view vw = do+ pure $ Response vw+++{- | The load handler is run when the page is first loaded. Run any side effects needed, then return a view of the full page++@+myPage :: (Hyperbole :> es) => UserId -> Page es Response+myPage userId = do+ 'load' $ do+ user <- loadUserFromDatabase userId+ pure $ userPageView user+@+-} load :: (Hyperbole :> es) => Eff es (View () ())- -> Page es ()+ -> Page es Response load run = Page $ do- vw <- run- view vw+ r <- request+ case lookupEvent r.query of+ -- Are id and action set to sometjhing?+ Just e ->+ pure $ Err $ ErrNotHandled e+ Nothing -> do+ vw <- run+ view vw --- | Handle a HyperView. If the event matches our handler, respond with the fragment-hyper- :: (Hyperbole :> es, HyperView id)+{- | A handler is run when an action for that 'HyperView' is triggered. Run any side effects needed, then return a view of the corresponding type++@+myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'+myPage = do+ 'handle' messages+ 'load' pageView++messages :: ('Hyperbole' :> es, MessageDatabase) => Message -> MessageAction -> 'Eff' es ('View' Message ())+messages (Message mid) ClearMessage = do+ deleteMessageSideEffect mid+ pure $ messageView ""++messages (Message mid) (Louder m) = do+ let new = m <> "!"+ saveMessageSideEffect mid new+ pure $ messageView new+@+-}+handle+ :: forall id es+ . (Hyperbole :> es, HyperView id) => (id -> Action id -> Eff es (View id ())) -> Page es ()-hyper run = Page $ do+handle run = Page $ do -- Get an event matching our type. If it doesn't match, skip to the next handler- mev <- send GetEvent+ mev <- getEvent @id case mev of Just event -> do vw <- run event.viewId event.action- view $ viewId event.viewId vw+ send $ RespondEarly $ Response $ hyper event.viewId vw _ -> pure () +-- | Run a 'Page' in 'Hyperbole' page :: (Hyperbole :> es)- => Page es ()- -> Eff es ()+ => Page es Response+ -> Eff es Response page (Page eff) = eff
src/Web/Hyperbole/Forms.hs view
@@ -1,37 +1,72 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DefaultSignatures #-} -module Web.Hyperbole.Forms where+module Web.Hyperbole.Forms+ ( FormFields (..)+ , InputType (..)+ , Label+ , Invalid+ , Input (..)+ , field+ , label+ , input+ , form+ , placeholder+ , submit+ , parseForm+ , formField+ , Form (..)+ , defaultFormOptions+ , FormOptions (..)+ , genericFromForm+ , Validation (..)+ , FormField (..)+ , lookupInvalid+ , invalidStyle+ , invalidText+ , validate+ , validation + -- * Re-exports+ , FromHttpApiData+ , Generic+ )+where+ import Data.Functor.Identity (Identity) import Data.Kind (Type)+import Data.Maybe (catMaybes) import Data.Text import Effectful import GHC.Generics import Text.Casing (kebab) import Web.FormUrlEncoded qualified as FE+import Web.HttpApiData (FromHttpApiData (..)) import Web.Hyperbole.Effect import Web.Hyperbole.HyperView (HyperView (..), Param (..), dataTarget)-import Web.Internal.FormUrlEncoded (GFromForm, defaultFormOptions, genericFromForm)-import Web.View hiding (form, input)+import Web.Internal.FormUrlEncoded (FormOptions (..), GFromForm, defaultFormOptions, genericFromForm)+import Web.View hiding (form, input, label) -- | The only time we can use Fields is inside a form-newtype FormFields f id = FormFields id- deriving newtype (Show)+data FormFields id = FormFields id Validation -instance (Param id, Show id) => Param (FormFields f id) where- parseParam t = FormFields <$> parseParam t- toParam (FormFields i) = toParam i+instance (Param id) => Param (FormFields id) where+ parseParam t = do+ i <- parseParam t+ pure $ FormFields i mempty+ toParam (FormFields i _) = toParam i -instance (HyperView id, Show id) => HyperView (FormFields f id) where- type Action (FormFields f id) = Action id+instance (HyperView id, Param id) => HyperView (FormFields id) where+ type Action (FormFields id) = Action id --- | TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete-data FieldInput- = NewPassword+-- | Choose one for 'input's to give the browser autocomplete hints+data InputType+ = -- TODO: there are many more of these: https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/autocomplete+ NewPassword | CurrentPassword | Username | Email@@ -48,97 +83,279 @@ deriving (Show) +{- | Validation results for a 'form'++@+validateUser :: User -> Age -> Validation+validateUser (User u) (Age a) =+ validation+ [ 'validate' \@Age (a < 20) "User must be at least 20 years old"+ , 'validate' \@User (T.elem ' ' u) "Username must not contain spaces"+ , 'validate' \@User (T.length u < 4) "Username must be at least 4 chars"+ ]++formAction :: ('Hyperbole' :> es, 'UserDB' :> es) => FormView -> FormAction -> 'Eff' es ('View' FormView ())+formAction _ SignUp = do+ a <- 'formField' \@Age+ u <- 'formField' \@User++ case validateUser u a of+ 'Validation' [] -> successView+ errs -> userForm v+@+@+-}+newtype Validation = Validation [(Text, Text)]+ deriving newtype (Semigroup, Monoid)+++-- | Create a 'Validation' from list of validators+validation :: [Maybe (Text, Text)] -> Validation+validation = Validation . catMaybes+++invalidStyle :: forall a. (FormField a) => Mod -> Validation -> Mod+invalidStyle f errs =+ case lookupInvalid @a errs of+ Nothing -> id+ Just _ -> f+++lookupInvalid :: forall a. (FormField a) => Validation -> Maybe Text+lookupInvalid (Validation es) = lookup (inputName @a) es+++{- | Display any validation error for the 'FormField' from the 'Validation' passed to 'form'++@+'field' \@User id Style.invalid $ do+ 'label' \"Username\"+ 'input' Username ('placeholder' "username")+ el_ 'invalidText'+@+-}+invalidText :: forall a id. (FormField a) => View (Input id a) ()+invalidText = do+ Input _ v <- context+ maybe none text $ lookupInvalid @a v+++-- | specify a check for a 'Validation'+validate :: forall a. (FormField a) => Bool -> Text -> Maybe (Text, Text)+validate True t = Just (inputName @a, t)+validate False _ = Nothing++ data Label a -data Input a = Input+data Invalid a -newtype InputName = InputName Text+data Input id a = Input Text Validation -field :: Mod -> View (Input id) () -> View (FormFields form id) ()-field f cnt =- tag "label" (f . flexCol)- $ addContext Input cnt+{- | Display a 'FormField' +@+data Age = Age Int deriving (Generic, FormField) -label :: Text -> View (Input id) ()+myForm = do+ 'form' SignUp mempty id $ do+ field @Age id id $ do+ 'label' "Age"+ 'input' Number (value "0")+@+-}+field :: forall a id. (FormField a) => Mod -> Mod -> View (Input id a) () -> View (FormFields id) ()+field f inv cnt = do+ let n = inputName @a+ FormFields _ v <- context+ tag "label" (f . flexCol . invalidStyle @a inv v) $+ addContext (Input n v) cnt+++-- | label for a 'field'+label :: Text -> View (Input id a) () label = text -input :: FieldInput -> Mod -> InputName -> View (Input id) ()-input fi f (InputName n) = tag "input" (f . name n . att "type" (typ fi) . att "autocomplete" (auto fi)) none+-- | input for a 'field'+input :: InputType -> Mod -> View (Input id a) ()+input ft f = do+ Input nm _ <- context+ tag "input" (f . name nm . att "type" (inpType ft) . att "autocomplete" (auto ft)) none where- typ NewPassword = "password"- typ CurrentPassword = "password"- typ Number = "number"- typ Email = "email"- typ Search = "search"- typ _ = "text"+ inpType NewPassword = "password"+ inpType CurrentPassword = "password"+ inpType Number = "number"+ inpType Email = "email"+ inpType Search = "search"+ inpType _ = "text" - auto :: FieldInput -> Text+ auto :: InputType -> Text auto = pack . kebab . show -form :: forall form id. (Form form, HyperView id) => Action id -> Mod -> (form Label -> View (FormFields form id) ()) -> View id ()-form a f fcnt = do+placeholder :: Text -> Mod+placeholder = att "placeholder"+++{- | Type-safe \<form\>. Calls (Action id) on submit++@+userForm :: 'Validation' -> 'View' FormView ()+userForm v = do+ form Signup v id $ do+ el Style.h1 "Sign Up"++ 'field' \@User id Style.invalid $ do+ 'label' \"Username\"+ 'input' Username ('placeholder' "username")+ el_ 'invalidText'++ 'field' \@Age id Style.invalid $ do+ 'label' \"Age\"+ 'input' Number ('placeholder' "age" . value "0")+ el_ 'invalidText'++ 'submit' (border 1) \"Submit\"+@+-}+form :: forall id. (HyperView id) => Action id -> Validation -> Mod -> View (FormFields id) () -> View id ()+form a v f cnt = do vid <- context- let frm = formLabels :: form Label- let cnt = fcnt frm- tag "form" (onSubmit a . dataTarget vid . f . flexCol) $ addContext (FormFields vid) cnt+ -- let frm = formLabels :: form Label+ -- let cnt = fcnt frm+ tag "form" (onSubmit a . dataTarget vid . f . flexCol) $ addContext (FormFields vid v) cnt where onSubmit :: (Param a) => a -> Mod onSubmit = att "data-on-submit" . toParam -submit :: Mod -> View (FormFields form id) () -> View (FormFields form id) ()+-- | Button that submits the 'form'. Use 'button' to specify actions other than submit+submit :: Mod -> View (FormFields id) () -> View (FormFields id) () submit f = tag "button" (att "type" "submit" . f) +type family Field' (context :: Type -> Type) a+type instance Field' Identity a = a+type instance Field' Label a = Text+type instance Field' Invalid a = Maybe Text++ parseForm :: forall form es. (Form form, Hyperbole :> es) => Eff es (form Identity) parseForm = do- (f :: FE.Form) <- formData+ f <- formData let ef = fromForm f :: Either Text (form Identity) either parseError pure ef +{- | Parse a 'FormField' from the request++@+formAction :: ('Hyperbole' :> es, 'UserDB' :> es) => FormView -> FormAction -> 'Eff' es ('View' FormView ())+formAction _ SignUp = do+ a <- formField \@Age+ u <- formField \@User+ saveUserToDB u a+ pure $ el_ "Saved!"+@+-}+formField :: forall a es. (FormField a, Hyperbole :> es) => Eff es a+formField = do+ f <- formData+ case fieldParse (inputName @a) f of+ Left e -> parseError e+ Right a -> pure a++ class Form (form :: (Type -> Type) -> Type) where formLabels :: form Label- default formLabels :: (Generic (form Label), GFormLabels (Rep (form Label))) => form Label- formLabels = to gFormLabels+ default formLabels :: (Generic (form Label), GForm (Rep (form Label))) => form Label+ formLabels = to gForm + formInvalid :: form Invalid+ default formInvalid :: (Generic (form Invalid), GForm (Rep (form Invalid))) => form Invalid+ formInvalid = to gForm++ fromForm :: FE.Form -> Either Text (form Identity) default fromForm :: (Generic (form Identity), GFromForm (form Identity) (Rep (form Identity))) => FE.Form -> Either Text (form Identity) fromForm = genericFromForm defaultFormOptions -type family Field (context :: Type -> Type) a-type instance Field Identity a = a-type instance Field Label a = InputName+-- | Automatically derive labels from form field names+class GForm f where+ gForm :: f p --- | Automatically derive labels from form field names-class GFormLabels f where- gFormLabels :: f p+instance GForm U1 where+ gForm = U1 -instance GFormLabels U1 where- gFormLabels = U1+instance (GForm f, GForm g) => GForm (f :*: g) where+ gForm = gForm :*: gForm -instance (GFormLabels f, GFormLabels g) => GFormLabels (f :*: g) where- gFormLabels = gFormLabels :*: gFormLabels+instance (GForm f) => GForm (M1 D d f) where+ gForm = M1 gForm -instance (Selector s) => GFormLabels (M1 S s (K1 R InputName)) where- gFormLabels = M1 . K1 $ InputName $ pack (selName (undefined :: M1 S s (K1 R Text) p))+instance (GForm f) => GForm (M1 C c f) where+ gForm = M1 gForm -instance (GFormLabels f) => GFormLabels (M1 D d f) where- gFormLabels = M1 gFormLabels+instance (Selector s) => GForm (M1 S s (K1 R Text)) where+ gForm = M1 . K1 $ pack (selName (undefined :: M1 S s (K1 R Text) p)) -instance (GFormLabels f) => GFormLabels (M1 C c f) where- gFormLabels = M1 gFormLabels+instance GForm (M1 S s (K1 R (Maybe Text))) where+ gForm = M1 . K1 $ Nothing+++{- | Form Fields are identified by a type++@+data User = User Text deriving (Generic, FormField)+data Age = Age Int deriving (Generic, FormField)+@+-}+class FormField a where+ inputName :: Text+ default inputName :: (Generic a, GDataName (Rep a)) => Text+ inputName = gDataName (from (undefined :: a))+++ fieldParse :: Text -> FE.Form -> Either Text a+ default fieldParse :: (Generic a, GFieldParse (Rep a)) => Text -> FE.Form -> Either Text a+ fieldParse t f = to <$> gFieldParse t f+++class GDataName f where+ gDataName :: f p -> Text+++instance (Datatype d) => GDataName (M1 D d (M1 C c f)) where+ gDataName m1 = pack $ datatypeName m1+++class GFieldParse f where+ gFieldParse :: Text -> FE.Form -> Either Text (f p)+++instance (GFieldParse f) => GFieldParse (M1 D d f) where+ gFieldParse t f = M1 <$> gFieldParse t f+++instance (GFieldParse f) => GFieldParse (M1 C c f) where+ gFieldParse t f = M1 <$> gFieldParse t f+++instance (GFieldParse f) => GFieldParse (M1 S s f) where+ gFieldParse t f = M1 <$> gFieldParse t f+++instance (FromHttpApiData a) => GFieldParse (K1 R a) where+ gFieldParse t f = K1 <$> FE.parseUnique t f
src/Web/Hyperbole/HyperView.hs view
@@ -1,32 +1,113 @@ {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FunctionalDependencies #-} module Web.Hyperbole.HyperView where +import Control.Applicative ((<|>))+import Control.Monad (guard) import Data.Kind (Type)-import Data.Text+import Data.Text (Text, pack, unpack)+import Data.Text qualified as T+import GHC.Generics import Text.Read-import Web.Hyperbole.Route (Route (..), pathUrl)+import Web.Hyperbole.Route (Route (..), routeUrl) import Web.View --- | Associate a live id with a set of actions+{- | HyperViews are interactive subsections of a 'Page'++Create an instance with a unique view id type and a sum type describing the actions the HyperView supports. The View Id can contain context (a database id, for example)++@+data Message = Message Int+ deriving (Generic, 'Param')++data MessageAction+ = Louder Text+ | ClearMessage+ deriving (Generic, 'Param')++instance HyperView Message where+ type Action Message = MessageAction+@+-} class (Param id, Param (Action id)) => HyperView id where type Action id :: Type -viewId :: forall id ctx. (HyperView id) => id -> View id () -> View ctx ()-viewId vid vw = do- el (att "id" (toParam vid) . flexCol)- $ addContext vid vw+{- | Embed HyperViews into the page, or nest them into other views +@+myPage :: ('Hyperbole' :> es) => 'Page' es 'Response'+myPage = do+ 'handle' messages+ 'load' $ do+ pure $ do+ 'el_' "My Page"+ 'hyper' (Message 1) $ messageView "Hello World"+ 'hyper' (Message 2) $ do+ messageView "Another Message"+ 'hyper' OtherView otherView+@ +Views can only trigger actions that match their HyperView++@+messageView :: Text -> View Message ()+messageView m = do+ el_ (text m)+ button (Louder m) "Louder"++otherView :: View OtherView ()+otherView = do+ -- Type Error!+ button (Louder \"Hi\") id "Louder"+@+-}+hyper :: forall id ctx. (HyperView id) => id -> View id () -> View ctx ()+hyper vid vw = do+ el (att "id" (toParam vid) . flexCol) $+ addContext vid vw+++{- | \<button\> HTML tag which sends the action when pressed++> button SomeAction (border 1) "Click Me"+-} button :: (HyperView id) => Action id -> Mod -> View id () -> View id () button a f cd = do c <- context tag "button" (att "data-on-click" (toParam a) . dataTarget c . f) cd +{- | Send the action after N milliseconds. Can be used to implement lazy loading or polling++@+pollMessageView :: Text -> 'View' Message ()+pollMessageView m = do+ onLoad LoadMessage 1000 $ do+ 'el' 'bold' "Current Message. Reloading in 1s"+ 'el_' ('text' m)+@+-}+onLoad :: (HyperView id) => Action id -> DelayMs -> View id () -> View id ()+onLoad a delay initContent = do+ c <- context+ el (att "data-on-load" (toParam a) . att "data-delay" (toParam delay) . dataTarget c) initContent+++type DelayMs = Int+++{- | Give visual feedback when an action is in-flight.++@+myView = do+ onRequest loadingIndicator $ do+ 'el_' \"Loaded\"+ where+ loadingIndicator = 'el_' "Loading..."+@+-} onRequest :: View id () -> View id () -> View id () onRequest a b = do el (parent "hyp-loading" flexCol . hide) a@@ -38,17 +119,46 @@ dataTarget = att "data-target" . toParam --- | Change the target of any code running inside, allowing actions to target other live views on the page+{- | Trigger actions for another view. They will update the view specified++> otherView :: View OtherView ()+> otherView = do+> el_ "This is not a message view"+> button OtherAction id "Do Something"+>+> target (Message 2) $ do+> el_ "Now we can trigger a MessageAction which will update our Message HyperView, not this one"+> button ClearMessage id "Clear Message #2"+-} target :: (HyperView id) => id -> View id () -> View a () target = addContext +{- | Type-safe dropdown. Sends (opt -> Action id) when selected. The selection predicate (opt -> Bool) controls which option is selected. See [Example.Contacts](https://github.com/seanhess/hyperbole/blob/main/example/Example/Contacts.hs)++@+data ContactsAction+ = Reload (Maybe Filter)+ | Delete Int+ deriving (Generic, Param)++allContactsView :: Maybe Filter -> View Contacts ()+allContactsView fil = do+ row (gap 10) $ do+ el (pad 10) "Filter: "+ dropdown Reload (== fil) id $ do+ option Nothing ""+ option (Just Active) "Active!"+ option (Just Inactive) "Inactive"+ ...+@+-} dropdown :: (HyperView id)- => (opt -> action)- -> (opt -> Bool)+ => (opt -> Action id)+ -> (opt -> Bool) -- check if selec -> Mod- -> View (Option opt id action) ()+ -> View (Option opt id (Action id)) () -> View id () dropdown toAction isSel f options = do c <- context@@ -56,6 +166,7 @@ addContext (Option toAction isSel) options +-- | An option for a 'dropdown'. First argument is passed to (opt -> Action id) in the 'dropdown', and to the selected predicate option :: (HyperView id, Eq opt) => opt@@ -66,40 +177,149 @@ tag "option" (att "value" (toParam (os.toAction opt)) . selected (os.selected opt)) cnt +-- | sets selected = true if the 'dropdown' predicate returns True selected :: Bool -> Mod selected b = if b then att "selected" "true" else id +-- | The view context for an 'option' data Option opt id action = Option { toAction :: opt -> action , selected :: opt -> Bool } +{- | Types that can be serialized. 'HyperView' requires this for both its view id and action++> data Message = Message Int+> deriving (Generic, Param)+-} class Param a where+ toParam :: a -> Text+ default toParam :: (Generic a, GParam (Rep a)) => a -> Text+ toParam = gToParam . from++ -- not as flexible as FromHttpApiData, but derivable parseParam :: Text -> Maybe a- default parseParam :: (Read a) => Text -> Maybe a- parseParam = readMaybe . unpack+ default parseParam :: (Generic a, GParam (Rep a)) => Text -> Maybe a+ parseParam t = to <$> gParseParam t - toParam :: a -> Text- default toParam :: (Show a) => a -> Text- toParam = pack . show+class GParam f where+ gToParam :: f p -> Text+ gParseParam :: Text -> Maybe (f p) -instance Param Integer-instance Param Float-instance Param Int-instance Param ()+instance (GParam f, GParam g) => GParam (f :*: g) where+ gToParam (a :*: b) = gToParam a <> "-" <> gToParam b+ gParseParam t = do+ let (at, bt) = breakSegment t+ a <- gParseParam at+ b <- gParseParam bt+ pure $ a :*: b +instance (GParam f, GParam g) => GParam (f :+: g) where+ gToParam (L1 a) = gToParam a+ gToParam (R1 b) = gToParam b+ gParseParam t = do+ (L1 <$> gParseParam @f t) <|> (R1 <$> gParseParam @g t)+++-- do we add the datatypename? no, the constructor name+instance (Datatype d, GParam f) => GParam (M1 D d f) where+ gToParam (M1 a) = gToParam a+ gParseParam t = M1 <$> gParseParam t+++instance (Constructor c, GParam f) => GParam (M1 C c f) where+ gToParam (M1 a) =+ let cn = toSegment (conName (undefined :: M1 C c f p))+ in case gToParam a of+ "" -> cn+ t -> cn <> "-" <> t+ gParseParam t = do+ let (c, rest) = breakSegment t+ guard $ c == toSegment (conName (undefined :: M1 C c f p))+ M1 <$> gParseParam rest+++instance GParam U1 where+ gToParam _ = ""+ gParseParam _ = pure U1+++instance (GParam f) => GParam (M1 S s f) where+ gToParam (M1 a) = gToParam a+ gParseParam t = M1 <$> gParseParam t+++instance GParam (K1 R Text) where+ gToParam (K1 t) = t+ gParseParam t = pure $ K1 t+++instance GParam (K1 R String) where+ gToParam (K1 s) = pack s+ gParseParam t = pure $ K1 $ unpack t+++instance {-# OVERLAPPABLE #-} (Param a) => GParam (K1 R a) where+ gToParam (K1 a) = toParam a+ gParseParam t = K1 <$> parseParam t+++-- instance {-# OVERLAPPABLE #-} (Show a, Read a) => GParam (K1 R a) where+-- gToParam (K1 a) = pack $ show a+-- gParseParam t = do+-- K1 <$> readMaybe (unpack t)++breakSegment :: Text -> (Text, Text)+breakSegment t =+ let (start, rest) = T.breakOn "-" t+ in (start, T.drop 1 rest)+++toSegment :: String -> Text+toSegment = T.toLower . pack+++-- instance (GParam f) => GParam (M1 C c f) where+-- gForm = M1 gForm++-- where+-- toDouble '\'' = '\"'+-- toDouble c = c++instance (Param a) => Param (Maybe a) where+ toParam Nothing = ""+ toParam (Just a) = toParam a+ parseParam "" = pure Nothing+ parseParam t = Just $ parseParam t+instance Param Integer where+ toParam = pack . show+ parseParam = readMaybe . unpack+instance Param Float where+ toParam = pack . show+ parseParam = readMaybe . unpack+instance Param Int where+ toParam = pack . show+ parseParam = readMaybe . unpack+instance Param () where+ toParam = pack . show+ parseParam = readMaybe . unpack++ instance Param Text where parseParam = pure toParam = id -link :: (Route a) => a -> Mod -> View c () -> View c ()-link r f cnt = do- let Url u = pathUrl . routePath $ r- tag "a" (att "href" u . f) cnt+{- | A hyperlink to another route++>>> route (User 100) id "View User"+<a href="/user/100">View User</a>+-}+route :: (Route a) => a -> Mod -> View c () -> View c ()+route r = link (routeUrl r)
src/Web/Hyperbole/Route.hs view
@@ -1,75 +1,81 @@ {-# LANGUAGE DefaultSignatures #-} -module Web.Hyperbole.Route where+module Web.Hyperbole.Route+ ( Route (..)+ , findRoute+ , pathUrl+ , routeUrl+ , GenRoute (..)+ , genRouteRead+ , Url+ ) where import Control.Applicative ((<|>)) import Control.Monad (guard)-import Data.String (IsString (..))-import Data.Text (Text, dropWhile, dropWhileEnd, intercalate, pack, splitOn, toLower, unpack)+import Data.Text (Text, pack, toLower, unpack)+import Data.Text qualified as T import GHC.Generics import Text.Read (readMaybe)-import Web.View.Types (Url (..))+import Web.View.Types.Url (Segment, Url, pathUrl) import Prelude hiding (dropWhile) -type IsAbsolute = Bool-type Segment = Text-data Path = Path- { isAbsolute :: Bool- , segments :: [Segment]- }- deriving (Show)----- what if you want a relative url?-instance IsString Path where- fromString s = Path (isRoot s) [cleanSegment $ pack s]- where- isRoot ('/' : _) = True- isRoot _ = False-+{- | Derive this class to use a sum type as a route. Constructors and Selectors map intuitively to url patterns +> data AppRoute+> = HomePage+> | Users+> | User Int+> deriving (Generic, Route)+>+> / -> HomePage+> /users/ -> Users+> /user/100 -> User 100+-} class Route a where- matchRoute :: Path -> Maybe a- routePath :: a -> Path+ -- | The default route to use if attempting to match on empty segments defRoute :: a - default matchRoute :: (Generic a, GenRoute (Rep a)) => Path -> Maybe a+ -- | Map a route to segments+ routePath :: a -> [Segment]+++ -- | Try to match segments to a route+ matchRoute :: [Segment] -> Maybe a+ default matchRoute :: (Generic a, GenRoute (Rep a)) => [Segment] -> Maybe a -- this will match a trailing slash, but not if it is missing- matchRoute (Path _ [""]) = pure defRoute- matchRoute (Path _ segs) = to <$> genRoute segs+ matchRoute [""] = pure defRoute+ matchRoute [] = pure defRoute+ matchRoute segs = to <$> genRoute segs - default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> Path+ default routePath :: (Generic a, Eq a, GenRoute (Rep a)) => a -> [Segment] routePath p- | p == defRoute = Path True [""]- | otherwise = Path True $ genPaths $ from p+ | p == defRoute = []+ | otherwise = filter (not . T.null) $ genPaths $ from p default defRoute :: (Generic a, GenRoute (Rep a)) => a defRoute = to genFirst --- | Use the default route if it's empty-findRoute :: (Route a) => [Text] -> Maybe a+-- | Try to match a route, use 'defRoute' if it's empty+findRoute :: (Route a) => [Segment] -> Maybe a findRoute [] = Just defRoute-findRoute ps = matchRoute (Path True ps)---pathUrl :: Path -> Url-pathUrl (Path True ss) = Url $ "/" <> intercalate "/" ss-pathUrl (Path False ss) = Url $ intercalate "/" ss+findRoute ps = matchRoute ps -cleanSegment :: Segment -> Segment-cleanSegment = dropWhileEnd (== '/') . dropWhile (== '/')-+{- | Convert a 'Route' to a 'Url' -pathSegments :: Text -> [Segment]-pathSegments path = splitOn "/" $ dropWhile (== '/') path+>>> routeUrl (User 100)+/user/100+-}+routeUrl :: (Route a) => a -> Url+routeUrl = pathUrl . routePath +-- | Automatically derive 'Route' class GenRoute f where genRoute :: [Text] -> Maybe (f p) genPaths :: f p -> [Text]@@ -147,9 +153,9 @@ instance (Route sub) => GenRoute (K1 R sub) where- genRoute ts = K1 <$> matchRoute (Path True ts)+ genRoute ts = K1 <$> matchRoute ts genFirst = K1 defRoute- genPaths (K1 sub) = (routePath sub).segments+ genPaths (K1 sub) = routePath sub genRouteRead :: (Read x) => [Text] -> Maybe (K1 R x a)@@ -159,16 +165,16 @@ instance Route Text where- matchRoute (Path _ [t]) = pure t+ matchRoute [t] = pure t matchRoute _ = Nothing- routePath t = Path False [t]+ routePath t = [t] defRoute = "" instance Route String where- matchRoute (Path _ [t]) = pure (unpack t)+ matchRoute [t] = pure (unpack t) matchRoute _ = Nothing- routePath t = Path False [pack t]+ routePath t = [pack t] defRoute = "" @@ -185,17 +191,17 @@ instance (Route a) => Route (Maybe a) where- matchRoute (Path _ []) = pure Nothing+ matchRoute [] = pure Nothing matchRoute ps = Just <$> matchRoute ps routePath (Just a) = routePath a- routePath Nothing = Path False []+ routePath Nothing = [] defRoute = Nothing -matchRouteRead :: (Read a) => Path -> Maybe a-matchRouteRead (Path _ [t]) = readMaybe (unpack t)+matchRouteRead :: (Read a) => [Segment] -> Maybe a+matchRouteRead [t] = readMaybe (unpack t) matchRouteRead _ = Nothing -routePathShow :: (Show a) => a -> Path-routePathShow a = Path False [pack (show a)]+routePathShow :: (Show a) => a -> [Segment]+routePathShow a = [pack (show a)]
+ src/Web/Hyperbole/Session.hs view
@@ -0,0 +1,68 @@+module Web.Hyperbole.Session where++import Data.ByteString (ByteString)+import Data.List qualified as L+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.String.Conversions (cs)+import Data.Text (Text)+import Network.HTTP.Types+import Web.HttpApiData+import Prelude+++newtype Session = Session (Map Text Text)+ deriving (Show)+++-- | Set the session key to value+sessionSet :: (ToHttpApiData a) => Text -> a -> Session -> Session+sessionSet k a (Session kvs) =+ let val = toQueryParam a+ in Session $ Map.insert k val kvs+++sessionDel :: Text -> Session -> Session+sessionDel k (Session kvs) =+ Session $ Map.delete k kvs+++sessionLookup :: (FromHttpApiData a) => Text -> Session -> Maybe a+sessionLookup k (Session sm) = do+ t <- Map.lookup k sm+ either (const Nothing) pure $ parseQueryParam t+++sessionEmpty :: Session+sessionEmpty = Session Map.empty+++-- | Render a session as a url-encoded query string+sessionRender :: Session -> ByteString+sessionRender (Session sm) =+ urlEncode True $ renderQuery False (toQuery $ Map.toList sm)+++-- | Parse a session as a url-encoded query string+sessionParse :: ByteString -> Session+sessionParse = Session . Map.fromList . map toText . parseQuery . urlDecode True+ where+ toText (k, Nothing) = (cs k, "false")+ toText (k, Just v) = (cs k, cs v)+++sessionFromCookies :: [(ByteString, ByteString)] -> Session+sessionFromCookies cks = fromMaybe sessionEmpty $ do+ bs <- L.lookup "session" cks+ pure $ sessionParse bs+++sessionSetCookie :: Session -> ByteString+sessionSetCookie ss = "session=" <> sessionRender ss <> "; SameSite=None; secure; path=/"++-- sessionKeyParse :: (FromHttpApiData a) => Text -> Session -> Either Text (Maybe a)+-- sessionKeyParse k (Session kvs) =+-- case Map.lookup k kvs of+-- Nothing -> pure Nothing+-- Just t -> Just <$> parseQueryParam t
+ src/Web/Hyperbole/View.hs view
@@ -0,0 +1,6 @@+module Web.Hyperbole.View+ ( module Web.View+ ) where++import Web.View hiding (Query, Segment, button, cssResetEmbed, form, input, label)+
+ test/Spec.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}++
+ test/Test/RouteSpec.hs view
@@ -0,0 +1,51 @@+module Test.RouteSpec (spec) where++import GHC.Generics+import Test.Syd+import Web.Hyperbole.Route+++data Routes+ = MainPage+ | Hello Hello+ | Goodbye+ deriving (Show, Generic, Eq, Route)+++data Hello+ = MainHello+ | World+ | Message String+ deriving (Show, Generic, Eq, Route)+++spec :: Spec+spec = do+ describe "Route" $ do+ describe "routePath" $ do+ it "basic" $+ routePath Goodbye `shouldBe` ["goodbye"]++ it "default" $+ routePath MainPage `shouldBe` []++ it "dynamic" $+ routePath (Hello (Message "woot")) `shouldBe` ["hello", "message", "woot"]++ it "compound" $+ routePath (Hello World) `shouldBe` ["hello", "world"]++ it "compound default" $+ routePath (Hello MainHello) `shouldBe` ["hello"]++ describe "matchRoute" $ do+ it "basic" $ matchRoute ["goodbye"] `shouldBe` Just Goodbye+ it "default empty string" $ matchRoute [""] `shouldBe` Just MainPage+ it "default empty" $ matchRoute [] `shouldBe` Just MainPage+ it "compound" $ matchRoute ["hello", "world"] `shouldBe` Just (Hello World)+ it "compound default" $ matchRoute ["hello"] `shouldBe` Just (Hello MainHello)+ it "compound dynamic" $ matchRoute ["hello", "message", "whatever"] `shouldBe` Just (Hello (Message "whatever"))++ describe "defRoute" $ do+ it "default" $ defRoute `shouldBe` MainPage+ it "compound" $ (defRoute :: Hello) `shouldBe` MainHello
+ test/Test/ViewSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedLists #-}++module Test.ViewSpec where++import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics+import Test.Syd+import Web.Hyperbole.HyperView+import Web.View (att)+import Web.View.Types+++data Thing = Thing+ deriving (Generic, Param, Show, Eq)+++data Custom = Custom+ deriving (Show, Eq)+++data HasString = HasString String+ deriving (Generic, Param, Show, Eq)+++data Compound+ = One+ | Two Thing+ | WithId (Id Thing)+ deriving (Generic, Param, Show, Eq)+++newtype Id a = Id {fromId :: Text}+ deriving newtype (Param, Eq, Ord)+ deriving (Generic, Show)+++instance Param Custom where+ toParam Custom = "something"+ parseParam "something" = Just Custom+ parseParam _ = Nothing+++spec :: Spec+spec = do+ describe "HyperView" $ do+ describe "Param" $ do+ describe "toParam" $ do+ it "basic" $ toParam Thing `shouldBe` "thing"+ it "custom" $ toParam Custom `shouldBe` "something"++ describe "parseParam" $ do+ it "basic" $ parseParam "thing" `shouldBe` Just Thing+ it "basic lowercase" $ parseParam @Thing "Thing" `shouldBe` Nothing+ it "custom" $ parseParam "something" `shouldBe` Just Custom+ it "custom other" $ parseParam @Thing "custom" `shouldBe` Nothing++ describe "has-string" $ do+ it "should not contain single quotes" $ do+ toParam (HasString "woot") `shouldNotSatisfy` containsSingleQuotes++ it "should roundtrip" $ do+ let inp = HasString "woot"+ parseParam (toParam inp) `shouldBe` Just inp++ describe "compound" $ do+ it "should toparam" $ toParam (Two Thing) `shouldBe` "two-thing"+ it "double roundtrip" $ parseParam (toParam (Two Thing)) `shouldBe` Just (Two Thing)++ describe "Param Attributes" $ do+ it "should serialize basic id" $ do+ let atts = mempty :: Attributes+ (setId "woot" atts).other `shouldBe` [("id", "woot")]++ it "should serialize compound id" $ do+ let atts = mempty :: Attributes+ (setId (toParam $ Two Thing) atts).other `shouldBe` [("id", "two-thing")]++ it "should serialize stringy id" $ do+ let atts = mempty :: Attributes+ (setId (toParam $ HasString "woot") atts).other `shouldBe` [("id", "hasstring-woot")]++ it "should serialize with Id" $ do+ let atts = mempty :: Attributes+ (setId (toParam $ WithId (Id "woot")) atts).other `shouldBe` [("id", "withid-woot")]+++containsSingleQuotes :: Text -> Bool+containsSingleQuotes = T.elem '\''+++setId :: Text -> Mod+setId = att "id"