diff --git a/client/dist/hyperbole.js b/client/dist/hyperbole.js --- a/client/dist/hyperbole.js +++ b/client/dist/hyperbole.js @@ -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?"); /***/ }), diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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 diff --git a/hyperbole.cabal b/hyperbole.cabal --- a/hyperbole.cabal +++ b/hyperbole.cabal @@ -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 diff --git a/src/Effectful/Sockets.hs b/src/Effectful/Sockets.hs deleted file mode 100644 --- a/src/Effectful/Sockets.hs +++ /dev/null @@ -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}|] diff --git a/src/Effectful/Wai.hs b/src/Effectful/Wai.hs deleted file mode 100644 --- a/src/Effectful/Wai.hs +++ /dev/null @@ -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 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,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) 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,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 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 @@ -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 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 @@ -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