diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -0,0 +1,87 @@ +Hyperbole +========= + +[![Hackage](https://img.shields.io/hackage/v/hyperbole.svg)](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 +------------- + + + National Solar Observatory + diff --git a/client/dist/hyperbole.js b/client/dist/hyperbole.js --- a/client/dist/hyperbole.js +++ b/client/dist/hyperbole.js @@ -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 = \"
\".concat(error.name, \"
\");\n var details = \"
\".concat(error.message, \"
\");\n return [\"\", 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?"); /***/ }), diff --git a/example/Example/Colors.hs b/example/Example/Colors.hs --- a/example/Example/Colors.hs +++ b/example/Example/Colors.hs @@ -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" diff --git a/example/Example/Contacts.hs b/example/Example/Contacts.hs --- a/example/Example/Contacts.hs +++ b/example/Example/Contacts.hs @@ -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 diff --git a/example/Example/Counter.hs b/example/Example/Counter.hs new file mode 100644 --- /dev/null +++ b/example/Example/Counter.hs @@ -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 diff --git a/example/Example/Errors.hs b/example/Example/Errors.hs new file mode 100644 --- /dev/null +++ b/example/Example/Errors.hs @@ -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" diff --git a/example/Example/Forms.hs b/example/Example/Forms.hs --- a/example/Example/Forms.hs +++ b/example/Example/Forms.hs @@ -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 diff --git a/example/Example/LazyLoading.hs b/example/Example/LazyLoading.hs new file mode 100644 --- /dev/null +++ b/example/Example/LazyLoading.hs @@ -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..." diff --git a/example/Example/Redirects.hs b/example/Example/Redirects.hs new file mode 100644 --- /dev/null +++ b/example/Example/Redirects.hs @@ -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" diff --git a/example/Example/Sessions.hs b/example/Example/Sessions.hs new file mode 100644 --- /dev/null +++ b/example/Example/Sessions.hs @@ -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" diff --git a/example/Example/Simple.hs b/example/Example/Simple.hs new file mode 100644 --- /dev/null +++ b/example/Example/Simple.hs @@ -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" diff --git a/example/Example/Style.hs b/example/Example/Style.hs new file mode 100644 --- /dev/null +++ b/example/Example/Style.hs @@ -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 diff --git a/example/Example/Transitions.hs b/example/Example/Transitions.hs --- a/example/Example/Transitions.hs +++ b/example/Example/Transitions.hs @@ -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" diff --git a/example/HelloWorld.hs b/example/HelloWorld.hs new file mode 100644 --- /dev/null +++ b/example/HelloWorld.hs @@ -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" diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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| @@ -88,14 +155,3 @@ #{cnt} |] - --- toDocument :: BL.ByteString -> BL.ByteString --- toDocument cnt = --- [i| --- --- Hyperbole Examples --- --- --- --- #{cnt} --- |] diff --git a/hyperbole.cabal b/hyperbole.cabal --- a/hyperbole.cabal +++ b/hyperbole.cabal @@ -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 diff --git a/src/Web/Hyperbole.hs b/src/Web/Hyperbole.hs --- a/src/Web/Hyperbole.hs +++ b/src/Web/Hyperbole.hs @@ -1,22 +1,297 @@ +{- | +Module: Web.Hyperbole +Copyright: (c) 2024 Sean Hess +License: BSD3 +Maintainer: Sean Hess +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 +-} diff --git a/src/Web/Hyperbole/Application.hs b/src/Web/Hyperbole/Application.hs --- a/src/Web/Hyperbole/Application.hs +++ b/src/Web/Hyperbole/Application.hs @@ -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 + , "

Remember to add a `hyper` handler in your page function

" + , "
"
+    , "page :: (Hyperbole :> es) => Page es Response"
+    , "page = do"
+    , "  handle contentsHandler"
+    , "  load $ do"
+    , "    pure $ hyper Contents contentsView"
+    , "
" + ] + + +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 $ "" - 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; + --
+ 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| +> +> #{title} +> +> +> +> #{content} +> |] +-} +basicDocument :: Text -> BL.ByteString -> BL.ByteString +basicDocument title cnt = + [i| + + #{title} + + + + #{cnt} + |] - 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 diff --git a/src/Web/Hyperbole/Effect.hs b/src/Web/Hyperbole/Effect.hs --- a/src/Web/Hyperbole/Effect.hs +++ b/src/Web/Hyperbole/Effect.hs @@ -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 diff --git a/src/Web/Hyperbole/Forms.hs b/src/Web/Hyperbole/Forms.hs --- a/src/Web/Hyperbole/Forms.hs +++ b/src/Web/Hyperbole/Forms.hs @@ -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 \. 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 diff --git a/src/Web/Hyperbole/HyperView.hs b/src/Web/Hyperbole/HyperView.hs --- a/src/Web/Hyperbole/HyperView.hs +++ b/src/Web/Hyperbole/HyperView.hs @@ -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 + + +{- | \ 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" +View User +-} +route :: (Route a) => a -> Mod -> View c () -> View c () +route r = link (routeUrl r) diff --git a/src/Web/Hyperbole/Route.hs b/src/Web/Hyperbole/Route.hs --- a/src/Web/Hyperbole/Route.hs +++ b/src/Web/Hyperbole/Route.hs @@ -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)] diff --git a/src/Web/Hyperbole/Session.hs b/src/Web/Hyperbole/Session.hs new file mode 100644 --- /dev/null +++ b/src/Web/Hyperbole/Session.hs @@ -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 diff --git a/src/Web/Hyperbole/View.hs b/src/Web/Hyperbole/View.hs new file mode 100644 --- /dev/null +++ b/src/Web/Hyperbole/View.hs @@ -0,0 +1,6 @@ +module Web.Hyperbole.View + ( module Web.View + ) where + +import Web.View hiding (Query, Segment, button, cssResetEmbed, form, input, label) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} + + diff --git a/test/Test/RouteSpec.hs b/test/Test/RouteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/RouteSpec.hs @@ -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 diff --git a/test/Test/ViewSpec.hs b/test/Test/ViewSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/ViewSpec.hs @@ -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"