hyperbole 0.1.2 → 0.2.0
raw patch · 9 files changed
+245/−327 lines, 9 filesdep +networkdep +wai-websocketsdep +websocketsdep ~casingdep ~http-typesdep ~string-conversions
Dependencies added: network, wai-websockets, websockets
Dependency ranges changed: casing, http-types, string-conversions, string-interpolate, wai, warp
Files
- client/dist/hyperbole.js +21/−1
- example/Main.hs +1/−1
- hyperbole.cabal +19/−15
- src/Effectful/Sockets.hs +0/−74
- src/Effectful/Wai.hs +0/−130
- src/Web/Hyperbole/Application.hs +118/−48
- src/Web/Hyperbole/Effect.hs +79/−56
- src/Web/Hyperbole/Forms.hs +1/−2
- src/Web/Hyperbole/Route.hs +6/−0
client/dist/hyperbole.js view
@@ -10,6 +10,16 @@ /******/ "use strict"; /******/ var __webpack_modules__ = ({ +/***/ "./src/action.ts":+/*!***********************!*\+ !*** ./src/action.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 */ actionMessage: () => (/* binding */ actionMessage),\n/* harmony export */ actionUrl: () => (/* binding */ actionUrl),\n/* harmony export */ toSearch: () => (/* binding */ toSearch)\n/* harmony export */ });\nfunction actionUrl(id, action) {\n var url = new URL(window.location.href);\n url.searchParams.append(\"id\", id);\n url.searchParams.append(\"action\", action);\n return url;\n}\nfunction toSearch(form) {\n if (!form)\n return undefined;\n var params = new URLSearchParams();\n form.forEach(function (value, key) {\n params.append(key, value);\n });\n return params;\n}\nfunction actionMessage(id, action, form) {\n var url = actionUrl(id, action);\n return { url: url, form: toSearch(form) };\n}\n\n\n//# sourceURL=webpack://web-ui/./src/action.ts?");++/***/ }),+ /***/ "./src/events.ts": /*!***********************!*\ !*** ./src/events.ts ***!@@ -26,7 +36,17 @@ \**********************/ /***/ ((__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 _events__WEBPACK_IMPORTED_MODULE_1__ = __webpack_require__(/*! ./events */ \"./src/events.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// 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\n// const CONTENT_ID = \"yeti-root-content\"\n// console.log(\"VERSION 2\", INIT_PAGE, INIT_STATE)\nconsole.log(\"Hyperbole 0.1.4\");\n// const protocol = window.location.protocol === 'https:' ? 'wss:' : 'ws:';\n// const address = `${protocol}//${window.location.host}`\n// const socket = new WebSocket(address)\n//\nvar rootStyles;\n(0,_events__WEBPACK_IMPORTED_MODULE_1__.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_1__.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_1__.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(id, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n var url, res;\n return __generator(this, function (_a) {\n switch (_a.label) {\n case 0:\n url = new URL(window.location.href);\n url.searchParams.append(\"id\", id);\n url.searchParams.append(\"action\", action);\n console.log(\"ACTION\", url.toString());\n return [4 /*yield*/, fetch(url, {\n method: \"POST\",\n headers: { 'Accept': 'text/html', 'Content-Type': 'application/x-www-form-urlencoded' },\n body: toSearch(form)\n })];\n case 1:\n res = _a.sent();\n return [2 /*return*/, res.text()];\n }\n });\n });\n}\nfunction runAction(target, action, form) {\n return __awaiter(this, void 0, void 0, function () {\n var timeout, 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 return [4 /*yield*/, sendAction(target.id, action, form)];\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 toSearch(form) {\n if (!form)\n return undefined;\n var params = new URLSearchParams();\n form.forEach(function (value, key) {\n params.append(key, value);\n });\n return params;\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);\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.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?");++/***/ }),++/***/ "./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?"); /***/ }),
example/Main.hs view
@@ -54,7 +54,7 @@ app :: UserStore -> Application-app users = waiApplication toDocument (runUsersIO users . runHyperbole . runDebugIO . router)+app users = application toDocument (runUsersIO users . runDebugIO . router) where router :: (Hyperbole :> es, Users :> es, Debug :> es) => AppRoute -> Eff es () router (Hello h) = page $ hello h
hyperbole.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hyperbole-version: 0.1.2+version: 0.2.0 synopsis: Web Framework inspired by HTMX description: Web Framework inspired by HTMX. category: Web@@ -28,8 +28,6 @@ library exposed-modules:- Effectful.Sockets- Effectful.Wai Web.Hyperbole Web.Hyperbole.Application Web.Hyperbole.Effect@@ -56,18 +54,21 @@ build-depends: base >=4.16 && <5 , bytestring >=0.11 && <0.13- , casing >0.1.3.0 && <0.2+ , casing >0.1 && <0.2 , containers >=0.6 && <1 , effectful >=2.3 && <3 , file-embed >=0.0.10 && <0.1 , http-api-data ==0.6.*- , http-types >=0.12.3 && <0.13- , string-conversions >=0.4 && <=0.5- , string-interpolate >=0.3.2 && <0.4+ , http-types ==0.12.*+ , network >=3.1 && <4+ , string-conversions ==0.4.*+ , string-interpolate ==0.3.* , text >=1.2 && <3- , wai >=3.2.3 && <3.3- , warp >=3.3.30 && <3.4+ , wai >=3.2 && <4+ , wai-websockets >=3.0 && <4+ , warp >=3.3 && <4 , web-view >=0.3 && <=0.4+ , websockets >=0.12 && <0.14 default-language: GHC2021 executable example@@ -98,18 +99,21 @@ build-depends: base >=4.16 && <5 , bytestring >=0.11 && <0.13- , casing >0.1.3.0 && <0.2+ , casing >0.1 && <0.2 , containers >=0.6 && <1 , effectful >=2.3 && <3 , file-embed >=0.0.10 && <0.1 , http-api-data ==0.6.*- , http-types >=0.12.3 && <0.13+ , http-types ==0.12.* , hyperbole- , string-conversions >=0.4 && <=0.5- , string-interpolate >=0.3.2 && <0.4+ , network >=3.1 && <4+ , string-conversions ==0.4.*+ , string-interpolate ==0.3.* , text >=1.2 && <3- , wai >=3.2.3 && <3.3+ , wai >=3.2 && <4 , wai-middleware-static >=0.9 && <=0.10- , warp >=3.3.30 && <3.4+ , wai-websockets >=3.0 && <4+ , warp >=3.3 && <4 , web-view >=0.3 && <=0.4+ , websockets >=0.12 && <0.14 default-language: GHC2021
− src/Effectful/Sockets.hs
@@ -1,74 +0,0 @@--- {-# LANGUAGE LambdaCase #-}--- {-# LANGUAGE QuasiQuotes #-}--module Effectful.Sockets where----- import Control.Monad (forever)--- import Data.Aeson (ToJSON)--- import Data.Aeson qualified as A--- import Data.ByteString.Lazy qualified as BL--- import Data.String.Interpolate (i)--- import Data.Text (Text)--- import Effectful--- import Effectful.Dispatch.Dynamic--- import Effectful.State.Static.Local--- import Network.WebSockets (Connection, ConnectionOptions, ServerApp, WebSocketsData)--- import Network.WebSockets qualified as WS------ data Command--- = Render [Content]--- | Test Text------ data Socket :: Effect where--- SendMessage :: BL.ByteString -> Socket m ()--- ReceiveData :: (WebSocketsData a) => Socket m a------ type instance DispatchOf Socket = 'Dynamic------ -- we should assume a connection here?--- -- Accept :: PendingConnection -> Sockets m Connection------ data Client = Client--- { counter :: Int--- , contents :: [Content]--- }------ type instance DispatchOf Socket = 'Dynamic------ connectionOptions :: ConnectionOptions--- connectionOptions = WS.defaultConnectionOptions------ socketApplication :: Eff [Socket, IOE] () -> ServerApp--- socketApplication talk pending = do--- conn <- WS.acceptRequest pending--- -- WS.sendTextData conn ("HELLO CLIENT" :: Text)--- let client = Client 0 []--- runEff . runSocket conn client $ forever talk------ runSocket--- :: (IOE :> es)--- => Connection--- -> Client--- -> Eff (Socket : es) a--- -> Eff es a--- runSocket conn client = reinterpret (evalState client) $ \_ -> \case--- SendMessage t -> do--- -- cl :: Client <- get--- liftIO $ WS.sendTextData conn t--- ReceiveData -> do--- a <- liftIO $ WS.receiveData conn--- modify $ \c -> c{counter = c.counter + 1}--- pure a------ sendCommand :: (Socket :> es) => Command -> Eff es ()--- sendCommand (Render cnt) = send $ SendMessage (formatMessage "Render" cnt)--- sendCommand (Test cnt) = send $ SendMessage (formatMessage "Test" cnt)------ receiveData :: (Socket :> es, WebSocketsData a) => Eff es a--- receiveData = send ReceiveData------ formatMessage :: (ToJSON a) => BL.ByteString -> a -> BL.ByteString--- formatMessage flag cnt =--- let content = A.encode cnt--- in [i|#{flag} #{content}|]
− src/Effectful/Wai.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE FieldSelectors #-}-{-# LANGUAGE LambdaCase #-}--module Effectful.Wai where--import Control.Monad (when)-import Data.ByteString (ByteString)-import Data.ByteString.Lazy qualified as L-import Data.Text (Text)-import Effectful-import Effectful.Dispatch.Dynamic-import Effectful.Error.Static-import Effectful.State.Static.Local-import Network.HTTP.Types (Status, status200, status500)-import Network.HTTP.Types.Header (HeaderName)-import Network.Wai as Wai-import Web.FormUrlEncoded-import Web.HttpApiData (FromHttpApiData)-import Web.View---data Wai :: Effect where- ResHeader :: HeaderName -> ByteString -> Wai m ()- ResBody :: ContentType -> L.ByteString -> Wai m ()- ResStatus :: Status -> Wai m ()- ReqBody :: Wai m L.ByteString- Request :: Wai m Request- Continue :: Wai m ()- Interrupt :: Interrupt -> Wai m a---type instance DispatchOf Wai = 'Dynamic---data Handler = Handler- { request :: Request- , cachedRequestBody :: L.ByteString- , status :: Status- , headers :: [(HeaderName, ByteString)]- , contentType :: ContentType- , body :: L.ByteString- }---data ContentType- = ContentHtml- | ContentText---formData :: (Wai :> es) => Eff es Form-formData = do- bd <- send ReqBody- let ef = urlDecodeForm bd- either (send . Interrupt . ParseError) pure ef---parseFormData :: (Wai :> es, FromForm a) => Eff es a-parseFormData = do- f <- formData- either (send . Interrupt . ParseError) pure $ fromForm f---formParam :: (Wai :> es, FromHttpApiData a) => Text -> Eff es a-formParam k = do- f <- formData- either (send . Interrupt . ParseError) pure $ parseUnique k f---requestBody :: (Wai :> es) => Eff es L.ByteString-requestBody = send ReqBody---runWai- :: (IOE :> es)- => Request- -> Eff (Wai : es) a- -> Eff es (Either Interrupt Handler)-runWai req = reinterpret runLocal $ \_ -> \case- Request -> do- gets request- ReqBody -> do- cacheReqBody- gets cachedRequestBody- ResHeader k v -> modify- $ \r -> r{headers = (k, v) : r.headers}- ResStatus s -> modify- $ \r -> r{status = s}- ResBody ct bd -> modify- $ \r -> r{body = bd, contentType = ct, status = status200}- Continue -> do- h <- get- throwError $ RespondNow h- Interrupt e -> do- throwError e- where- runLocal =- runErrorNoCallStack @Interrupt- . execState @Handler (emptyResponse req)-- cacheReqBody :: forall es. (IOE :> es, State Handler :> es) => Eff es ()- cacheReqBody = do- r <- get- when (L.null r.cachedRequestBody) $ do- rb <- liftIO $ Wai.consumeRequestBodyLazy req- put $ r{cachedRequestBody = rb}----- Ends computation with whatever has already been set on the response-continue :: (Wai :> es) => Eff es ()-continue = send Continue---emptyResponse :: Request -> Handler-emptyResponse r = Handler r "" status500 [] ContentText "Response not set"---data Interrupt- = NotFound- | Redirect Url- | ParseError Text- | RespondNow Handler---notFound :: (Wai :> es) => Eff es a-notFound = send $ Interrupt NotFound---redirect :: (Wai :> es) => Url -> Eff es ()-redirect u = do- send $ Interrupt $ Redirect u
src/Web/Hyperbole/Application.hs view
@@ -1,72 +1,142 @@ module Web.Hyperbole.Application ( waiApplication- , Wai+ -- , webSocketApplication+ , application+ , websocketsOr ) where +import Control.Monad (forever) import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as L import Data.String.Conversions (cs)+import Data.Text (Text, pack)+import Data.Text qualified as T import Effectful-import Effectful.Wai-import Network.HTTP.Types (status200, status301, status400, status404)+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 Network.Wai+import Network.Wai qualified as Wai+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.WebSockets (Connection, PendingConnection, defaultConnectionOptions)+import Network.WebSockets qualified as WS+import Web.Hyperbole.Effect import Web.Hyperbole.Route-import Web.View.Types (Url (..))+import Web.View (View, renderLazyByteString) -waiApplication :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff [Wai, IOE] ()) -> Application+{- | 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+-}+application :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff '[Hyperbole, IOE] ()) -> Wai.Application+application toDoc actions =+ websocketsOr+ defaultConnectionOptions+ (socketApplication actions)+ (waiApplication toDoc actions)+++waiApplication :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff '[Hyperbole, IOE] ()) -> Wai.Application waiApplication toDoc actions request respond = do- -- let (method, paths, query) = (requestMethod req, pathInfo req, queryString req)- case findRoute (pathInfo request) of- Nothing -> respond $ responseLBS status404 [contentType ContentText] "Not Found"- Just rt -> do- res <- runEff . runWai request $ actions rt- case res of- Left err -> interrupt err- Right resp -> sendResponse resp+ req <- fromWaiRequest request+ res <- runEff $ runHyperboleRoute req actions+ sendResponse res where- findRoute [] = Just defRoute- findRoute ps = matchRoute (Path True ps)+ fromWaiRequest wr = do+ bd <- liftIO $ Wai.consumeRequestBodyLazy wr+ pure $ Request (Wai.pathInfo wr) (Wai.queryString wr) bd + -- 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++ respBadRequest e =+ respond $ Wai.responseLBS status400 [contentType ContentText] e++ respNotFound =+ respond $ Wai.responseLBS status404 [contentType ContentText] "Not Found"++ respHtml body = do+ let headers = [contentType ContentHtml]+ respond $ Wai.responseLBS status200 headers body+ -- convert to document if GET. Subsequent POST requests will only include fragments+ addDocument :: Method -> L.ByteString -> L.ByteString addDocument "GET" bd = toDoc bd addDocument _ bd = bd - contentType :: ContentType -> (HeaderName, ByteString)- contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8")- contentType ContentText = ("Content-Type", "text/plain; charset=utf-8") - sendResponse :: Handler -> IO ResponseReceived- sendResponse resp = do- let headers = contentType resp.contentType : resp.headers- respBody = addDocument (requestMethod request) resp.body- respond $ responseLBS status200 headers respBody+data ContentType+ = ContentHtml+ | ContentText - interrupt NotFound =- respond $ responseLBS status404 [contentType ContentText] "Not Found"- interrupt (ParseError e) = do- -- TODO: logging!- putStrLn $ "Parse Error: " <> cs e- respond $ responseLBS status400 [contentType ContentText] $ "Parse Error: " <> cs e- interrupt (Redirect (Url u)) =- respond $ responseLBS status301 [("Location", cs u)] ""- interrupt (RespondNow resp) = do- sendResponse resp +contentType :: ContentType -> (HeaderName, ByteString)+contentType ContentHtml = ("Content-Type", "text/html; charset=utf-8")+contentType ContentText = ("Content-Type", "text/plain; charset=utf-8") -{- | Run both the http and ws application-application :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff [Wai, IOE] ()) -> Application-application toDoc actions =- websocketsOr connectionOptions (socketApplication talk)- $ httpApplication toDoc actions--} --- talk :: (Socket :> es) => Eff es ()--- talk = do--- msg :: Text <- receiveData------ -- HANDLE ACTION?--- -- SEND VIEW (possibly multiple times). Need to run action...------ sendCommand $ Render [Text $ "Updated: " <> msg]+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++ 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++ 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++ receive :: (Reader Connection :> es, IOE :> es) => Eff es Text+ receive = do+ c <- ask @Connection+ liftIO $ WS.receiveData c++ 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)++ sendView :: View () () -> IO ()+ sendView vw = WS.sendTextData conn $ renderLazyByteString vw++ sendError :: (Show e) => e -> IO ()+ sendError e = WS.sendTextData conn $ pack (show e)+++data SocketError+ = InvalidMessage Text+ deriving (Show, Eq)
src/Web/Hyperbole/Effect.hs view
@@ -1,66 +1,107 @@-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE QuasiQuotes #-} module Web.Hyperbole.Effect where import Control.Monad (join)-import Data.ByteString+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL import Data.String.Conversions-import Data.String.Interpolate (i) import Data.Text import Effectful import Effectful.Dispatch.Dynamic-import Effectful.Wai (ContentType (..), Wai (..))-import Effectful.Wai qualified as Wai+import Effectful.Error.Static+import Effectful.Reader.Static import Network.HTTP.Types (Query)-import Network.Wai-import Web.FormUrlEncoded (Form)-import Web.FormUrlEncoded qualified as Form+import Web.FormUrlEncoded (Form, urlDecodeForm) import Web.Hyperbole.HyperView+import Web.Hyperbole.Route import Web.View -data Hyperbole :: Effect where- GetForm :: Hyperbole m Form- ParseForm :: (Form.FromForm a) => Hyperbole m a- GetEvent :: (HyperView id) => Hyperbole m (Maybe (Event (Action id) id))- RespondView :: View () () -> Hyperbole m ()- HyperError :: HyperError -> Hyperbole m a+data Request = Request+ { path :: [Text]+ , query :: Query+ , body :: BL.ByteString+ }+ deriving (Show) -type instance DispatchOf Hyperbole = 'Dynamic+data Response+ = ErrParse Text+ | ErrNoHandler+ | Response (View () ())+ | NotFound +newtype Page es a = Page (Eff es a)+ deriving newtype (Applicative, Monad, Functor)++ data Event act id = 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+++-- ParseError :: HyperError -> Hyperbole m 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++ runHyperbole- :: (Wai :> es)- => Eff (Hyperbole : es) a- -> Eff es a-runHyperbole = interpret $ \_ -> \case- RespondView vw -> do- let bd = renderLazyByteString vw- send $ ResHeader "Content-Type" "text/html"- send $ ResBody ContentHtml bd- Wai.continue- GetForm -> Wai.formData- ParseForm -> Wai.parseFormData- HyperError NotFound -> send $ Interrupt Wai.NotFound- HyperError (ParseError e) -> send $ Interrupt $ Wai.ParseError e- GetEvent -> do- q <- fmap queryString <$> send $ Wai.Request+ :: Request+ -> Eff (Hyperbole : es) a+ -> Eff es (Either Response a)+runHyperbole req =+ reinterpret runLocal $ \_ -> \case+ GetForm -> getForm+ GetEvent -> getEvent+ Respond r -> respond r+ where+ respond :: (Error Response :> es) => Response -> Eff es a+ respond = throwError++ runLocal =+ runErrorNoCallStack @Response+ . runReader req++ 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- where- lookupParam :: ByteString -> Query -> Maybe Text++ lookupParam :: BS.ByteString -> Query -> Maybe Text lookupParam p q = fmap cs <$> join $ lookup p q @@ -75,35 +116,17 @@ formData = send GetForm -parseFormData :: (Hyperbole :> es, Form.FromForm a) => Eff es a-parseFormData = send ParseForm----- | Read a required form parameter-param :: (Hyperbole :> es, Param a) => Text -> Form -> Eff es a-param p f = do- -- param is required- either (send . HyperError . ParseError) pure $ do- t <- Form.lookupUnique p f- maybe (Left [i|could not parseParam: '#{t}'|]) pure $ parseParam t+notFound :: (Hyperbole :> es) => Eff es a+notFound = send $ Respond NotFound -notFound :: (Hyperbole :> es) => Eff es a-notFound = send (HyperError NotFound)+parseError :: (Hyperbole :> es) => Text -> Eff es a+parseError e = send $ Respond $ ErrParse e -- | 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 = send . RespondView---data HyperError- = NotFound- | ParseError Text---newtype Page es a = Page (Eff es a)- deriving newtype (Applicative, Monad, Functor)+view vw = send $ Respond $ Response vw -- | Load the entire page when no HyperViews match
src/Web/Hyperbole/Forms.hs view
@@ -6,7 +6,6 @@ import Data.Kind (Type) import Data.Text import Effectful-import Effectful.Dispatch.Dynamic import GHC.Generics import Text.Casing (kebab) import Web.FormUrlEncoded qualified as FE@@ -101,7 +100,7 @@ parseForm = do (f :: FE.Form) <- formData let ef = fromForm f :: Either Text (form Identity)- either (send . HyperError . ParseError) pure ef+ either parseError pure ef class Form (form :: (Type -> Type) -> Type) where
src/Web/Hyperbole/Route.hs view
@@ -51,6 +51,12 @@ defRoute = to genFirst +-- | Use the default route if it's empty+findRoute :: (Route a) => [Text] -> 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