├── ChangeLog.md ├── LICENSE ├── Main.hs ├── Setup.hs ├── alto.cabal ├── client ├── build │ ├── comic.html │ └── right_click.png ├── package.json ├── postcss.config.js ├── src │ ├── Client.js │ ├── StateMachine.js │ ├── config.js │ ├── debug.js │ ├── effects │ │ ├── editMode.js │ │ ├── index.js │ │ ├── spells.js │ │ ├── systemMenu.js │ │ └── viewMenu.js │ ├── flags.js │ ├── index.js │ ├── indicateLoading.js │ └── ui │ │ ├── arrow.js │ │ ├── colors.less │ │ ├── hoverMenuButton.js │ │ ├── menu.js │ │ ├── menuItem.js │ │ └── spinner.js └── webpack.config.babel.js └── src └── Alto ├── Compile.hs ├── Compile ├── BitPuzzle.hs └── Navigations.hs ├── Example.hs ├── Menu.hs └── Web.hs /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for alto 2 | 3 | ## 0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, davean 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of davean nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Alto.Web 4 | import Alto.Menu 5 | import Network.Wai.Handler.Warp 6 | 7 | main :: IO () 8 | main = do 9 | conf <- AltoConfig <$> loadMenus <*> pure (ClientState mempty) 10 | run 8081 (altoApp conf) 11 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /alto.cabal: -------------------------------------------------------------------------------- 1 | name: alto 2 | version: 0 3 | synopsis: Impliment a menu experience fit for web users. 4 | description: 5 | A system for building cloud scale menu systems. 6 | 7 | For an example, see . 8 | homepage: https://oss.xkcd.com/ 9 | license: BSD3 10 | license-file: LICENSE 11 | author: davean 12 | maintainer: davean@xkcd.com 13 | copyright: davean 2018 14 | category: Web 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md 17 | cabal-version: >=1.10 18 | 19 | extra-source-files: 20 | client/src/effects/*.js 21 | client/src/ui/*.js 22 | client/src/*.js 23 | client/build/comic.html 24 | client/build/right_click.png 25 | client/package.json 26 | client/webpack.config.babel.js 27 | client/postcss.config.js 28 | 29 | source-repository head 30 | type: git 31 | location: https://code.xkrd.net/xkcd/alto.git 32 | 33 | library 34 | hs-source-dirs: src 35 | default-language: Haskell2010 36 | exposed-modules: 37 | Alto.Menu 38 | , Alto.Compile 39 | , Alto.Compile.Navigations 40 | , Alto.Example 41 | , Alto.Web 42 | build-depends: 43 | base >=4.10 && <4.12 44 | , mtl == 2.2.* 45 | , text == 1.2.* 46 | , containers == 0.5.* 47 | , bytestring == 0.10.* 48 | , lens == 4.16.* 49 | , cryptohash-sha256 == 0.11.* 50 | , scrypt == 0.5.* 51 | , base64-bytestring == 1.0.* 52 | , aeson == 1.3.* 53 | , servant-server == 0.13.* 54 | , filepath == 1.4.* 55 | , directory == 1.3.* 56 | , random-string == 0.1.* 57 | , list-tries == 0.6.* 58 | , MonadRandom == 0.5.* 59 | , random == 1.1.* 60 | , exceptions == 0.10.* 61 | 62 | executable alto 63 | -- other-modules: 64 | -- other-extensions: 65 | -- hs-source-dirs: src 66 | default-language: Haskell2010 67 | main-is: Main.hs 68 | build-depends: 69 | base >=4.10 && <4.12 70 | , alto 71 | , warp == 3.2.* 72 | -------------------------------------------------------------------------------- /client/build/comic.html: -------------------------------------------------------------------------------- 1 |
2 | -------------------------------------------------------------------------------- /client/build/right_click.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xkcd/alto/33a3c06f8c03174a4c05b26d0c0a59820cea3651/client/build/right_click.png -------------------------------------------------------------------------------- /client/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "alto-client", 3 | "description": "A cloud-based menu system", 4 | "version": "0.0.1", 5 | "license": "MIT", 6 | "private": true, 7 | "scripts": { 8 | "start": "webpack-dev-server --mode development --hot --inline --content-base build/", 9 | "build": "webpack --mode production -p --progress" 10 | }, 11 | "dependencies": { 12 | "babel-runtime": "^6.26.0", 13 | "dom-css": "^2.1.0", 14 | "nanoid": "^1.0.2", 15 | "nanohtml": "^1.2.2", 16 | "nanomorph": "^5.1.3", 17 | "unfetch": "^3.0.0" 18 | }, 19 | "devDependencies": { 20 | "autoprefixer": "^8.2.0", 21 | "babel-core": "^6.26.0", 22 | "babel-loader": "^7.1.4", 23 | "babel-preset-env": "^1.6.1", 24 | "babel-plugin-transform-object-rest-spread": "^6.26.0", 25 | "babel-plugin-transform-runtime": "^6.23.0", 26 | "css-literal-loader": "^0.4.5", 27 | "css-loader": "^0.28.11", 28 | "less": "^3.0.1", 29 | "less-loader": "^4.1.0", 30 | "postcss-loader": "^2.1.3", 31 | "style-loader": "^0.20.3", 32 | "webpack": "^4.2.0", 33 | "webpack-cli": "^2.0.13", 34 | "webpack-dev-server": "^3.1.1" 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /client/postcss.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | plugins: [ 3 | require('autoprefixer') 4 | ] 5 | } 6 | -------------------------------------------------------------------------------- /client/src/Client.js: -------------------------------------------------------------------------------- 1 | import fetch from 'unfetch' 2 | import nanoid from 'nanoid/generate' 3 | import nanoidChars from 'nanoid/url' 4 | 5 | export default class Client { 6 | constructor(baseURL) { 7 | this.baseURL = baseURL 8 | this.cache = new Map() 9 | this.sessionId = nanoid(nanoidChars.substr(2), 22) 10 | } 11 | 12 | async get(id) { 13 | if (this.cache.has(id)) { 14 | return await this.cache.get(id) 15 | } 16 | 17 | let path 18 | if (id === null) { 19 | path = '/root' 20 | } else { 21 | path = `/menu/${id}` 22 | } 23 | 24 | const dataFetch = fetch(this.baseURL + path).then(resp => resp.json()) 25 | this.cache.set(id, dataFetch) 26 | 27 | const data = await dataFetch 28 | if (data.Menu) { 29 | this.cache.set(data.Menu.id, Promise.resolve(data.Menu)) 30 | } 31 | return data 32 | } 33 | 34 | logEnter(parentId, menuId) { 35 | fetch(`${this.baseURL}/enter/${this.sessionId}/${parentId}/${menuId}?${Date.now()}`).catch(e => {}) 36 | } 37 | 38 | logVisit(menuId, entryIdx) { 39 | fetch(`${this.baseURL}/visit/${this.sessionId}/${menuId}/${entryIdx}?${Date.now()}`).catch(e => {}) 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /client/src/StateMachine.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | 3 | import debug from './debug' 4 | 5 | export default class StateMachine { 6 | constructor(client, effectMap) { 7 | this.client = client 8 | this.effectMap = effectMap 9 | this.tags = null 10 | this.rootId = null 11 | } 12 | 13 | async init() { 14 | let root = await this.client.get(null) 15 | this.tags = new Map(Object.entries(root.State.Tags)) 16 | this.rootId = root.Menu.id 17 | this.prefetch(this.rootId, 2) 18 | } 19 | 20 | evalTagLogic(whenTree) { 21 | const evalMap = { 22 | 'Always': () => true, 23 | 'TLAnd': x => x.contents.every(exec), 24 | 'TLOr': x => x.contents.some(exec), 25 | 'TLNot': x => !exec(x.contents), 26 | 'TagSet': x => this.tags.has(x.contents), 27 | 'TagUnset': x => !this.tags.has(x.contents), 28 | } 29 | 30 | function exec(x) { 31 | if (!evalMap.hasOwnProperty(x.tag)) { 32 | throw 'unexpected tag logic operator' 33 | } 34 | return evalMap[x.tag](x) 35 | } 36 | 37 | return exec(whenTree) 38 | } 39 | 40 | evalSubMenuId(reaction) { 41 | if (!reaction.tag === 'SubMenu') { 42 | return 43 | } 44 | 45 | const {subMenu, subIdPostfix} = reaction 46 | if (subIdPostfix) { 47 | return subMenu + this.tags.get(subIdPostfix) 48 | } 49 | return subMenu 50 | } 51 | 52 | async prefetch(id, depth=1) { 53 | let fetches = [] 54 | let data = await this.client.get(id) 55 | for (const entry of data.entries) { 56 | if (!this.evalTagLogic(entry.display)) { 57 | continue 58 | } 59 | 60 | if (entry.reaction.subIdPostfix) { 61 | // don't prefetch ids containing dynamic tags 62 | continue 63 | } 64 | 65 | const subMenuId = this.evalSubMenuId(entry.reaction) 66 | if (!subMenuId) { 67 | continue 68 | } 69 | 70 | fetches.push(this.client.get(subMenuId)) 71 | 72 | if (depth > 1) { 73 | fetches.push(this.prefetch(subMenuId, depth - 1)) 74 | } 75 | } 76 | 77 | return Promise.all(fetches) 78 | } 79 | 80 | async itemGen(id) { 81 | if (id === null) { 82 | const rootData = await this.client.get(this.rootId) 83 | 84 | // the root menu is special. find the first displayed submenu of the root. 85 | for (const entry of rootData.entries) { 86 | const {display, reaction} = entry 87 | if (this.evalTagLogic(display)) { 88 | id = this.evalSubMenuId(reaction) 89 | break 90 | } 91 | } 92 | } 93 | 94 | const data = await this.client.get(id) 95 | 96 | let menuItems = [] 97 | for (let idx = 0; idx < data.entries.length; idx++) { 98 | const entry = data.entries[idx] 99 | const {display, active, reaction} = entry 100 | 101 | if (!this.evalTagLogic(display)) { 102 | continue 103 | } 104 | 105 | menuItems.push({ 106 | menuId: id, 107 | entryIdx: idx, 108 | idx: menuItems.length, 109 | label: entry.label, 110 | disabled: active && !this.evalTagLogic(active), 111 | subMenuId: this.evalSubMenuId(reaction), 112 | }) 113 | } 114 | 115 | this.prefetch(id) 116 | return menuItems 117 | } 118 | 119 | performAction(act) { 120 | if (act.tag === 'Nav') { 121 | window.open(act.url) 122 | } else if (act.tag === 'Download') { 123 | try { 124 | const a = html` 125 | 129 | ` 130 | a.click() 131 | } catch (err) { 132 | window.open(act.url) 133 | } 134 | } else if (act.tag === 'JSCall') { 135 | const effectName = act.jsCall 136 | if (!this.effectMap.has(effectName)) { 137 | debug.warn('missing effect:', effectName) 138 | return 139 | } 140 | this.effectMap.get(effectName)() 141 | } 142 | } 143 | 144 | updateTags(tagChange) { 145 | const {setTags, unsetTags} = tagChange 146 | let changes = {set: [], deleted: []} 147 | 148 | if (setTags) { 149 | for (const [key, value] of Object.entries(setTags)) { 150 | this.tags.set(key, value) 151 | changes.set.push([key, value]) 152 | } 153 | } 154 | 155 | if (unsetTags) { 156 | for (const key of unsetTags) { 157 | this.tags.delete(key) 158 | changes.deleted.push(key) 159 | } 160 | } 161 | 162 | if (changes.set.length || changes.deleted.length) { 163 | debug.log('tags changed:', changes) 164 | } 165 | } 166 | 167 | async handleEnter(menuId, entryIdx, subMenuId) { 168 | const {entries} = await this.client.get(menuId) 169 | const {reaction} = entries[entryIdx] 170 | 171 | if (reaction.onAction) { 172 | this.updateTags(reaction.onAction) 173 | } 174 | 175 | this.client.logEnter(menuId, subMenuId) 176 | } 177 | 178 | async handleSelect(menuId, entryIdx) { 179 | const {entries} = await this.client.get(menuId) 180 | const {reaction} = entries[entryIdx] 181 | 182 | if (reaction.onAction) { 183 | this.updateTags(reaction.onAction) 184 | } 185 | 186 | if (reaction.act) { 187 | this.performAction(reaction.act) 188 | } 189 | 190 | this.client.logVisit(menuId, entryIdx) 191 | } 192 | 193 | async handleLeave(menuId) { 194 | const {onLeave} = await this.client.get(menuId) 195 | 196 | if (onLeave) { 197 | this.updateTags(onLeave) 198 | } 199 | } 200 | } 201 | -------------------------------------------------------------------------------- /client/src/config.js: -------------------------------------------------------------------------------- 1 | export const ALTO_ENDPOINT = 'https://xkcd.com/1975/alto' 2 | -------------------------------------------------------------------------------- /client/src/debug.js: -------------------------------------------------------------------------------- 1 | import {DEBUG} from './flags' 2 | 3 | export default { 4 | log(...args) { 5 | if (!DEBUG) { 6 | return 7 | } 8 | console.log(...args) 9 | }, 10 | 11 | warn(...args) { 12 | if (!DEBUG) { 13 | return 14 | } 15 | console.warn(...args) 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /client/src/effects/editMode.js: -------------------------------------------------------------------------------- 1 | export function editMode() { 2 | 3 | var canvas = document.createElement('canvas'); 4 | canvas.style.position = 'fixed'; 5 | canvas.style.left = '0'; 6 | canvas.style.top = '0'; 7 | canvas.width = window.innerWidth; 8 | canvas.height = window.innerHeight; 9 | document.body.appendChild(canvas); 10 | 11 | var context = canvas.getContext('2d'); 12 | context.strokeStyle = 'black'; 13 | context.lineJoin = 'round'; 14 | context.lineWidth = 3; 15 | 16 | function resumePaint(e) { 17 | context.beginPath(); 18 | context.moveTo(e.clientX, e.clientY); 19 | } 20 | 21 | function paint(e) { 22 | context.lineTo(e.clientX, e.clientY); 23 | context.stroke(); 24 | } 25 | 26 | function startPaint(e) { 27 | if (e.which === 1) { // left button 28 | document.body.addEventListener('mouseover', resumePaint); 29 | document.body.addEventListener('mousemove', paint); 30 | document.body.addEventListener('mouseup', endPaint); 31 | } 32 | } 33 | 34 | function endPaint(e) { 35 | document.body.removeEventListener('mouseover', resumePaint); 36 | document.body.removeEventListener('mousemove', paint); 37 | document.body.removeEventListener('mouseup', endPaint); 38 | } 39 | 40 | window.addEventListener('keyup', function escapeOut(e) { 41 | if (e.which === 27 && window.confirm('Aw, that looks nice though. Really delete?')) { 42 | document.body.style.cursor = 'auto'; 43 | document.body.style.backgroundImage = ''; 44 | document.body.removeChild(canvas); 45 | window.removeEventListener('keyup', escapeOut); 46 | } 47 | }); 48 | 49 | document.body.addEventListener('mousedown', startPaint); 50 | document.body.style.cursor = 'url(//xkcd.com/1975/brush.cur), crosshair'; 51 | document.body.style.backgroundImage = 'url(//xkcd.com/1975/transparency.png)'; 52 | 53 | } -------------------------------------------------------------------------------- /client/src/effects/index.js: -------------------------------------------------------------------------------- 1 | const effectMap = new Map() 2 | 3 | const requireEffectModule = require.context('./', false, /\.js$/) 4 | for (const key of requireEffectModule.keys()) { 5 | if (key === './index.js') { 6 | continue 7 | } 8 | 9 | const module = requireEffectModule(key) 10 | for (const [name, func] of Object.entries(module)) { 11 | if (effectMap.has(name)) { 12 | throw `duplicate name: ${name}` 13 | } 14 | 15 | effectMap.set(name, func) 16 | } 17 | } 18 | 19 | export default effectMap 20 | -------------------------------------------------------------------------------- /client/src/effects/spells.js: -------------------------------------------------------------------------------- 1 | /* themes */ 2 | export function darkTheme () { 3 | document.body.style.background = "#000"; 4 | document.body.style.color = "darkred"; 5 | var s= document.getElementById("comic").childNodes[1].style; 6 | s.webkitFilter = "invert(1)"; 7 | s.filter = "invert(1)"; 8 | // TODO menu colors 9 | } 10 | 11 | /* make screen black */ 12 | export function darkness() { 13 | document.body.style.background = "#000"; 14 | document.body.style.color = "#000"; 15 | var s= document.getElementById("comic").childNodes[1].style; 16 | s.opacity = 0; 17 | s.MozOpacity = 0; 18 | s.KhtmlOpacity = 0; 19 | s.filter = 'alpha(opacity=0)'; 20 | // TODO? this doesn't do anything to the menu 21 | } 22 | 23 | /* grayscale */ 24 | export function darkVision() { 25 | document.body.style.background = "darkgray"; 26 | document.body.style.color = "lightgray"; 27 | var s= document.getElementById("comic").childNodes[1].style; 28 | s.opacity = .25; 29 | s.MozOpacity = .25; 30 | s.KhtmlOpacity = .25; 31 | s.filter = 'alpha(opacity=.25)'; 32 | // TODO grayscale the menu as well 33 | } 34 | 35 | /* explosion */ 36 | export function fireball() { 37 | var reds = ["#ff0000", "#ff0000", "#ff0000", "#ff0000", "#ee0000", "#ee0000", "#dd0000", "#cc0000", "#bb0000", "#aa0000", "#990000", "#880000", "#770000", "#660000", "#550000", "#440000", "#330000", "#220000", "#110000", "#000", "#000" ]; 38 | var timesRun = 0; 39 | var s= document.getElementById("comic").childNodes[1].style; 40 | s.opacity = 0.25; 41 | s.MozOpacity = 0.25; 42 | s.KhtmlOpacity = 0.25; 43 | s.filter = 'alpha(opacity=0.25)'; 44 | document.body.style.background = reds[0]; 45 | var timer = setInterval(function() { 46 | if ( timesRun <= reds.length ) { 47 | document.body.style.background = reds[timesRun]; 48 | timesRun++; 49 | } 50 | else { 51 | document.body.style.background = "#fff"; 52 | s.opacity = 1; 53 | s.MozOpacity = 1; 54 | s.KhtmlOpacity = 1; 55 | s.filter = 'alpha(opacity=1)'; 56 | clearInterval(timer); 57 | } 58 | }, 100); 59 | } 60 | 61 | /* add a bun */ 62 | export function conjureAnimals() { 63 | var img = document.createElement("img"); 64 | img.src = "//xkcd.com/1975/kat-bun-small.png"; 65 | img.height = Math.floor(Math.random()*(100-30+1)+30); 66 | if (Math.floor(Math.random() * 2) == 0) { 67 | img.style.webkitTransform = "scale(-1,1)"; 68 | img.style.mozTransform = "scale(-1,1)"; 69 | img.style.oTransform = "scale(-1,1)"; 70 | img.style.msTransform = "scale(-1,1)"; 71 | img.style.transform = "scale(-1,1)"; 72 | } 73 | document.getElementById("comic").appendChild(img); 74 | } 75 | 76 | /* change the font to a symbol font */ 77 | export function symbol() { 78 | document.body.style.fontFamily = "Wingdings,Webdings,Symbol,Zapf Dingbats"; 79 | var menus = document.getElementsByTagName("li"); 80 | for(i=0; i 0.1; 5 | const shutdownScreen = hasUpdates ? 'pdnpoouym.jpg' : 'e05.jpg'; 6 | const img = new Image(window.innerWidth, window.innerHeight); 7 | img.src = '//xkcd.com/1975/' + shutdownScreen; 8 | document.body.innerHTML = ''; 9 | document.body.appendChild(img); 10 | } -------------------------------------------------------------------------------- /client/src/effects/viewMenu.js: -------------------------------------------------------------------------------- 1 | /* sure, minimize the mouse cursor, that's what we meant */ 2 | /* TODO ask folks how to upload a static asset */ 3 | export function viewMinimize() { 4 | document.body.style.cursor = "url(//xkcd.com/1975/Tiny.cur), default"; 5 | } 6 | 7 | /* full screen it is! */ 8 | export function fullScreen() { 9 | const methodName = [ 10 | "requestFullscreen", 11 | "webkitRequestFullscreen", 12 | "mozRequestFullScreen", 13 | "msRequestFullscreen" 14 | ].find(fname => typeof comic[fname] === "function"); 15 | if (methodName) { 16 | document.body[methodName](); 17 | } 18 | } -------------------------------------------------------------------------------- /client/src/flags.js: -------------------------------------------------------------------------------- 1 | const hash = location.hash.substr(1) 2 | const flags = new Map() 3 | if (hash.length) { 4 | for (const flag of hash.split(',')) { 5 | const parts = flag.split('=', 2) 6 | if (parts.length === 2) { 7 | flags.set(parts[0], parts[1]) 8 | } else { 9 | flags.set(flag, true) 10 | } 11 | } 12 | } 13 | 14 | export const DEBUG = flags.has('debug') 15 | export const ENDPOINT = flags.get('endpoint') 16 | -------------------------------------------------------------------------------- /client/src/index.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | 3 | import {ENDPOINT} from './flags' 4 | import {ALTO_ENDPOINT} from './config' 5 | import Client from './Client' 6 | import effectMap from './effects' 7 | import StateMachine from './StateMachine' 8 | import {attachMenuTo} from './ui/menu' 9 | 10 | async function main() { 11 | const client = new Client(ENDPOINT || ALTO_ENDPOINT) 12 | const state = new StateMachine(client, effectMap) 13 | 14 | await state.init() 15 | 16 | attachMenuTo({ 17 | triggerEl: document.querySelector('#comic'), 18 | id: null, 19 | itemGen: state.itemGen.bind(state), 20 | onMenuSelect: state.handleSelect.bind(state), 21 | onMenuEnter: state.handleEnter.bind(state), 22 | onMenuLeave: state.handleLeave.bind(state), 23 | }) 24 | } 25 | 26 | main() 27 | -------------------------------------------------------------------------------- /client/src/indicateLoading.js: -------------------------------------------------------------------------------- 1 | export default function indicateLoading(updateLoading, waitMs = 200) { 2 | let canceled = false 3 | let finished = false 4 | let loading = false 5 | 6 | setTimeout(() => { 7 | if (!finished && !canceled) { 8 | loading = true 9 | updateLoading(true) 10 | } 11 | }, waitMs) 12 | 13 | return { 14 | get isLoading() { 15 | return loading 16 | }, 17 | 18 | finished() { 19 | finished = true 20 | if (loading && !canceled) { 21 | loading = false 22 | updateLoading(false) 23 | } 24 | }, 25 | 26 | cancel() { 27 | canceled = true 28 | }, 29 | } 30 | } 31 | 32 | -------------------------------------------------------------------------------- /client/src/ui/arrow.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | import style from 'dom-css' 3 | 4 | export const styles = css` 5 | .arrow { 6 | width: 0; 7 | height: 0; 8 | opacity: .65; 9 | border: 5px solid transparent; 10 | 11 | &.up { 12 | border-bottom: 5px solid black; 13 | } 14 | 15 | &.down { 16 | border-top: 5px solid black; 17 | } 18 | 19 | &.left { 20 | border-left: 5px solid black; 21 | } 22 | 23 | &.right { 24 | border-right: 5px solid black; 25 | } 26 | } 27 | ` 28 | 29 | export default function arrow(props) { 30 | const {direction, size = 5, color = 'black'} = props 31 | 32 | const directionStyles = { 33 | 'up': { 34 | borderBottom: `${size}px solid ${color}`, 35 | }, 36 | 'down': { 37 | borderTop: `${size}px solid ${color}`, 38 | }, 39 | 'left': { 40 | borderRight: `${size}px solid ${color}`, 41 | }, 42 | 'right': { 43 | borderLeft: `${size}px solid ${color}`, 44 | }, 45 | } 46 | 47 | if (!directionStyles.hasOwnProperty(direction)) { 48 | throw 'invalid direction' 49 | } 50 | 51 | const el = html`
` 52 | style(el, directionStyles[direction]) 53 | 54 | return el 55 | } 56 | 57 | -------------------------------------------------------------------------------- /client/src/ui/colors.less: -------------------------------------------------------------------------------- 1 | @itemBackgroundColor: #e4e4e4; 2 | @itemHighlightColor: #5544ff; 3 | -------------------------------------------------------------------------------- /client/src/ui/hoverMenuButton.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | import morph from 'nanomorph' 3 | 4 | import arrow from './arrow' 5 | 6 | export default function hoverMenuButton(props) { 7 | const {direction, onTrigger, className, intervalMs = 10} = props 8 | 9 | let el 10 | let hoverInterval 11 | let isHighlighted = false 12 | 13 | function handleMouseEnter(ev) { 14 | hoverInterval = setInterval(() => onTrigger(ev), intervalMs) 15 | isHighlighted = true 16 | morph(el, render()) 17 | } 18 | 19 | function handleMouseLeave() { 20 | clearInterval(hoverInterval) 21 | isHighlighted = false 22 | morph(el, render()) 23 | } 24 | 25 | function render() { 26 | return html` 27 |
33 | ${arrow({direction, color: isHighlighted ? 'white' : 'black'})} 34 |
35 | ` 36 | } 37 | 38 | el = render() 39 | 40 | return el 41 | } 42 | 43 | -------------------------------------------------------------------------------- /client/src/ui/menu.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | import morph from 'nanomorph' 3 | import style from 'dom-css' 4 | 5 | import indicateLoading from '../indicateLoading' 6 | import hoverMenuButton from './hoverMenuButton' 7 | import menuItem from './menuItem' 8 | 9 | const scrollHoverButtonSize = 20 10 | 11 | export const styles = css` 12 | @import "./colors.less"; 13 | 14 | .menu { 15 | position: fixed; 16 | display: flex; 17 | max-width: 250px; 18 | font-family: sans-serif; 19 | font-size: 11.5pt; 20 | font-variant: none; 21 | text-align: left; 22 | background-color: @itemBackgroundColor; 23 | border-radius: 3px; 24 | box-shadow: 0 0 10px rgba(0, 0, 0, .45); 25 | transition: opacity .15s ease-out; 26 | 27 | & > ul { 28 | margin: 0; 29 | padding: 0; 30 | overflow: hidden; 31 | } 32 | 33 | &.scrolling > ul { 34 | margin: ${scrollHoverButtonSize}px 0; 35 | } 36 | } 37 | 38 | .scrollButton { 39 | display: flex; 40 | height: ${scrollHoverButtonSize}px; 41 | align-items: center; 42 | justify-content: center; 43 | background-color: @itemBackgroundColor; 44 | 45 | &:hover{ 46 | background-color: @itemHighlightColor; 47 | } 48 | 49 | 50 | &.top { 51 | position: absolute; 52 | top: 0; 53 | left: 0; 54 | right: 0; 55 | border-bottom: 1px ridge rgba(0, 0, 0, .2); 56 | } 57 | 58 | &.bottom { 59 | position: absolute; 60 | bottom: 0; 61 | left: 0; 62 | right: 0; 63 | border-top: 1px groove rgba(0, 0, 0, .2); 64 | } 65 | } 66 | ` 67 | 68 | export default function menu(props) { 69 | const {items, itemGen, onMenuSelect, onMenuEnter, onMenuLeave, attach, isScrolling} = props 70 | let itemEls 71 | let childMenu 72 | let hoverButtonEls 73 | let highlightedIdx 74 | let loadingIndicator 75 | 76 | const getParentEl = el => el.closest('.' + styles.menu) 77 | 78 | function renderItem(item) { 79 | const isHighlighted = item.idx === highlightedIdx 80 | return menuItem({ 81 | item: item, 82 | showArrows: items.some(x => x.subMenuId), 83 | isHighlighted, 84 | isLoading: isHighlighted && loadingIndicator && loadingIndicator.isLoading, 85 | itemGen, 86 | onMouseEnter: handleItemEnter, 87 | onMouseLeave: handleItemLeave, 88 | onItemSelect: handleItemSelect, 89 | attach, 90 | }) 91 | } 92 | 93 | function closeSubMenu() { 94 | if (!childMenu) { 95 | return 96 | } 97 | childMenu.closeMenu() 98 | childMenu = null 99 | } 100 | 101 | function handleItemEnter(item, itemEl) { 102 | updateHighlighted(item, itemEl) 103 | } 104 | 105 | function handleItemLeave() { 106 | updateHighlighted(null, null) 107 | } 108 | 109 | function handleItemSelect(item) { 110 | onMenuSelect(item.menuId, item.entryIdx) 111 | } 112 | 113 | function updateHighlighted(item, itemEl) { 114 | if (item && item.idx === highlightedIdx) { 115 | return 116 | } 117 | 118 | if (!item && childMenu) { 119 | return 120 | } 121 | 122 | if (loadingIndicator) { 123 | loadingIndicator.cancel() 124 | loadingIndicator = null 125 | } 126 | 127 | const oldHighlightedIdx = highlightedIdx 128 | highlightedIdx = item && item.idx 129 | 130 | if (oldHighlightedIdx != null) { 131 | morph(itemEls[oldHighlightedIdx], renderItem(items[oldHighlightedIdx])) 132 | } 133 | 134 | if (itemEl) { 135 | morph(itemEl, renderItem(item)) 136 | 137 | closeSubMenu() 138 | 139 | const itemBox = itemEl.getBoundingClientRect() 140 | if (item.subMenuId) { 141 | loadingIndicator = indicateLoading(() => { 142 | morph(itemEl, renderItem(item)) 143 | }) 144 | onMenuEnter(item.menuId, item.entryIdx, item.subMenuId) 145 | childMenu = showMenu({ 146 | id: item.subMenuId, 147 | itemGen, 148 | onMenuSelect, 149 | onMenuEnter, 150 | onMenuLeave, 151 | onLoad: loadingIndicator.finished, 152 | parentBox: itemBox, 153 | attach, 154 | }) 155 | } 156 | } 157 | } 158 | 159 | function handleScrollWheel(ev) { 160 | closeSubMenu() 161 | handleItemLeave() 162 | ev.currentTarget.scrollTop += ev.deltaY 163 | ev.preventDefault() 164 | } 165 | 166 | function scrollUp(ev) { 167 | closeSubMenu() 168 | handleItemLeave() 169 | getParentEl(ev.target).querySelector('ul').scrollTop -= 6 170 | } 171 | 172 | function scrollDown(ev) { 173 | closeSubMenu() 174 | handleItemLeave() 175 | getParentEl(ev.target).querySelector('ul').scrollTop += 6 176 | } 177 | 178 | if (items) { 179 | itemEls = items.map(renderItem) 180 | } 181 | 182 | if (isScrolling) { 183 | hoverButtonEls = [ 184 | hoverMenuButton({ 185 | className: `${styles.scrollButton} ${styles.top}`, 186 | onTrigger: scrollUp, 187 | direction: 'up', 188 | }), 189 | hoverMenuButton({ 190 | className: `${styles.scrollButton} ${styles.bottom}`, 191 | onTrigger: scrollDown, 192 | direction: 'down', 193 | }), 194 | ] 195 | } 196 | 197 | const classes = [ 198 | styles.menu, 199 | isScrolling && styles.scrolling, 200 | ].filter(x => x) 201 | 202 | const el = html` 203 |
{ev.preventDefault()}} 206 | > 207 |
    208 | ${itemEls} 209 |
210 | ${hoverButtonEls} 211 |
212 | ` 213 | style(el, { 214 | opacity: items ? 1 : 0, 215 | }) 216 | 217 | return {el, closeSubMenu} 218 | } 219 | 220 | function positionMenu(el, parentBox, attach) { 221 | style(el, { 222 | left: -9999, 223 | top: 0, 224 | }) 225 | document.body.appendChild(el) 226 | const menuWidth = Math.ceil(el.getBoundingClientRect().width) 227 | 228 | // measure position and flip attach direction if necessary 229 | const {innerHeight, innerWidth} = window 230 | const childAttach = {...attach} 231 | 232 | const pos = {} 233 | const parentTop = Math.ceil(parentBox.top) 234 | const parentBottom = Math.ceil(parentBox.bottom) 235 | const parentLeft = Math.ceil(parentBox.left) 236 | const parentRight = Math.ceil(parentBox.right) 237 | const leftUnderHang = parentLeft - menuWidth 238 | const rightOverHang = parentRight + menuWidth - innerWidth 239 | 240 | // if there's x under/overhang swap to side with most space and fill remaining space. 241 | if (attach.x === 'left' && leftUnderHang < 0 && rightOverHang < -leftUnderHang) { 242 | childAttach.x = 'right' 243 | } else if (attach.x === 'right' && rightOverHang > 0 && -leftUnderHang < rightOverHang) { 244 | childAttach.x = 'left' 245 | } 246 | if (childAttach.x === 'left') { 247 | pos.left = Math.max(0, leftUnderHang) 248 | pos.width = Math.min(menuWidth, parentLeft - pos.left) 249 | } else if (childAttach.x === 'right') { 250 | pos.left = parentRight 251 | pos.width = Math.min(menuWidth, innerWidth - pos.left) 252 | } 253 | 254 | // width affects text wrapping which affects height, so we do this now. 255 | style(el, pos) 256 | const menuHeight = Math.ceil(el.getBoundingClientRect().height) 257 | document.body.removeChild(el) 258 | 259 | // y positioning is easier: when it hits the screen edge offset, possibly filling vertical space. 260 | if (attach.y === 'bottom') { 261 | pos.top = parentBottom - menuHeight 262 | if (pos.top < 0) { 263 | pos.top = 0 264 | childAttach.y = 'top' 265 | } 266 | } else if (attach.y === 'top') { 267 | pos.top = parentTop 268 | const overHang = parentTop + menuHeight - innerHeight 269 | if (overHang > 0) { 270 | pos.top = Math.max(0, pos.top - overHang) 271 | childAttach.y = 'bottom' 272 | } 273 | } 274 | pos.maxHeight = innerHeight - pos.top 275 | 276 | const isScrolling = menuHeight > pos.maxHeight 277 | 278 | return {pos, childAttach, isScrolling} 279 | } 280 | 281 | export function showMenu(props) { 282 | const {itemGen, onMenuSelect, onMenuEnter, onMenuLeave, onLoad, id, parentBox, attach} = props 283 | 284 | let menuObj 285 | let menuEl 286 | 287 | async function loadMenu() { 288 | const items = await itemGen(id) 289 | 290 | // render for size measurement 291 | let {el: sizingEl} = menu({ 292 | items, 293 | itemGen, 294 | attach 295 | }) 296 | const {pos, childAttach, isScrolling} = positionMenu(sizingEl, parentBox, attach) 297 | 298 | // render 299 | menuObj = menu({ 300 | items, 301 | itemGen, 302 | onMenuSelect, 303 | onMenuEnter, 304 | onMenuLeave, 305 | attach: childAttach, 306 | isScrolling, 307 | }) 308 | style(menuObj.el, pos) 309 | morph(menuEl, menuObj.el) 310 | 311 | if (onLoad) { 312 | onLoad() 313 | } 314 | } 315 | 316 | function closeMenu() { 317 | menuObj.closeSubMenu() 318 | document.body.removeChild(menuEl) 319 | onMenuLeave(id) 320 | } 321 | 322 | menuObj = menu({}) 323 | menuEl = menuObj.el 324 | document.body.appendChild(menuEl) 325 | 326 | setTimeout(loadMenu, 0) 327 | 328 | return {el: menuEl, closeMenu} 329 | } 330 | 331 | export function attachMenuTo(props) { 332 | const {triggerEl, menuProps, id, itemGen, onMenuSelect, onMenuEnter, onMenuLeave} = props 333 | let menuObj 334 | let isTouching = false 335 | let openedMenu = false 336 | let longPressTimeout 337 | 338 | function closeMenu() { 339 | if (menuObj) { 340 | menuObj.closeMenu() 341 | menuObj = null 342 | } 343 | } 344 | 345 | function closeMenuIfOutside(ev) { 346 | if (menuObj && ev.target.closest('.' + styles.menu)) { 347 | return 348 | } 349 | closeMenu() 350 | } 351 | 352 | function handleMenuSelect(menuId, entryIdx) { 353 | closeMenu() 354 | onMenuSelect(menuId, entryIdx) 355 | } 356 | 357 | async function openMenu(pos) { 358 | closeMenu() 359 | menuObj = await showMenu({ 360 | id, 361 | itemGen, 362 | onMenuSelect: handleMenuSelect, 363 | onMenuEnter, 364 | onMenuLeave, 365 | parentBox: {left: pos.x, right: pos.x, top: pos.y}, 366 | attach: {x: 'right', y: 'top'}, 367 | }) 368 | } 369 | 370 | window.addEventListener('mousedown', closeMenuIfOutside) 371 | 372 | triggerEl.addEventListener('contextmenu', ev => { 373 | ev.preventDefault() 374 | if (!isTouching) { 375 | // prevent contextmenu from double-triggering on long press in Chrome. 376 | openMenu({x: ev.clientX, y: ev.clientY}) 377 | } 378 | }) 379 | 380 | // we have to implement our own long press detection because iOS Safari 381 | // doesn't trigger contextmenu on touch. 382 | triggerEl.addEventListener('touchstart', ev => { 383 | isTouching = true 384 | longPressTimeout = setTimeout(() => { 385 | openMenu({ 386 | x: Math.floor(ev.touches[0].clientX), 387 | y: Math.floor(ev.touches[0].clientY), 388 | }) 389 | openedMenu = true 390 | }, 250) 391 | }) 392 | 393 | triggerEl.addEventListener('touchmove', () => { 394 | clearTimeout(longPressTimeout) 395 | }) 396 | 397 | triggerEl.addEventListener('touchend', ev => { 398 | isTouching = false 399 | clearTimeout(longPressTimeout) 400 | 401 | // prevent mousedown event 402 | if (openedMenu && ev.cancelable) { 403 | ev.preventDefault() 404 | } 405 | openedMenu = false 406 | }) 407 | } 408 | -------------------------------------------------------------------------------- /client/src/ui/menuItem.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | 3 | import arrow from './arrow' 4 | import spinner from './spinner' 5 | 6 | export const styles = css` 7 | @import "./colors.less"; 8 | 9 | .item { 10 | display: flex; 11 | color: black; 12 | border-radius: 2px; 13 | align-items: center; 14 | cursor: default; 15 | padding: 8px 10px; 16 | user-select: none; 17 | -webkit-tap-highlight-color: transparent; 18 | 19 | &.highlight { 20 | background-color: @itemHighlightColor; 21 | color: white; 22 | } 23 | 24 | &.disabled { 25 | opacity: .5; 26 | } 27 | 28 | & > span { 29 | flex: 1; 30 | } 31 | 32 | &.disabled > span { 33 | text-shadow: 0 1px white; 34 | } 35 | } 36 | 37 | &.left { 38 | & > span { 39 | margin-left: 10px; 40 | } 41 | 42 | & > .spacer { 43 | justify-content: flex-start; 44 | } 45 | } 46 | 47 | &.right { 48 | & > .spacer { 49 | justify-content: flex-end; 50 | } 51 | 52 | & > span { 53 | margin-right: 10px; 54 | } 55 | } 56 | 57 | .spacer { 58 | display: flex; 59 | width: 15px; 60 | } 61 | ` 62 | 63 | export default function menuItem(props) { 64 | const {item, showArrows, isLoading, isHighlighted, onItemSelect, onMouseEnter, onMouseLeave, attach} = props 65 | 66 | let preEdgeEl 67 | let postEdgeEl 68 | if (showArrows) { 69 | let edgeEl 70 | if (isLoading) { 71 | edgeEl = spinner({}) 72 | } else if (item.subMenuId) { 73 | edgeEl = arrow({direction: attach.x, color: isHighlighted ? 'white' : 'black'}) 74 | } 75 | 76 | const edgeSpacer = html` 77 |
78 | ${edgeEl} 79 |
80 | ` 81 | if (attach.x === 'left') { 82 | preEdgeEl = edgeSpacer 83 | } else if (attach.x === 'right') { 84 | postEdgeEl = edgeSpacer 85 | } 86 | } 87 | 88 | const classes = [ 89 | styles.item, 90 | showArrows && styles[attach.x], 91 | isHighlighted && styles.highlight, 92 | item.disabled && styles.disabled, 93 | ].filter(x => x) 94 | 95 | const el = html` 96 |
  • onItemSelect(item, ev.target)} 99 | onmouseenter=${item.disabled ? null : ev => onMouseEnter(item, ev.target)} 100 | onmouseleave=${item.disabled ? null : ev => onMouseLeave(item, ev.target)} 101 | > 102 | ${preEdgeEl} 103 | ${item.label} 104 | ${postEdgeEl} 105 |
    • 106 | ` 107 | 108 | return el 109 | } 110 | -------------------------------------------------------------------------------- /client/src/ui/spinner.js: -------------------------------------------------------------------------------- 1 | import html from 'nanohtml' 2 | 3 | export const styles = css` 4 | @keyframes spin { 5 | from { 6 | transform: rotate(0deg); 7 | } 8 | to { 9 | transform: rotate(360deg); 10 | } 11 | } 12 | 13 | .spinner { 14 | display: flex; 15 | margin: 0 -2px; 16 | opacity: .5; 17 | animation: spin 1s linear infinite; 18 | } 19 | ` 20 | 21 | export default function spinner(props) { 22 | const {size = 17, strokeWidth = 2} = props 23 | const r = size / 2 - strokeWidth 24 | 25 | const el = html` 26 | 27 | 37 | 38 | ` 39 | return el 40 | } 41 | -------------------------------------------------------------------------------- /client/webpack.config.babel.js: -------------------------------------------------------------------------------- 1 | import path from 'path' 2 | import webpack from 'webpack' 3 | 4 | export default { 5 | entry: { 6 | comic: './src/index.js', 7 | }, 8 | 9 | output: { 10 | filename: '[name].js', 11 | path: path.join(__dirname, 'build'), 12 | }, 13 | 14 | module: { 15 | rules: [ 16 | { 17 | test: /\.css$/, 18 | use: [ 19 | { loader: 'style-loader', options: { singleton: true } }, 20 | { loader: 'css-loader', options: { modules: true } }, 21 | 'postcss-loader', 22 | 'less-loader', 23 | ], 24 | }, 25 | { 26 | test: /\.js$/, 27 | exclude: /node_modules/, 28 | use: ['babel-loader', 'css-literal-loader'], 29 | }, 30 | ], 31 | }, 32 | 33 | plugins: [ 34 | new webpack.BannerPlugin('alto client by chromako.de'), 35 | ], 36 | } 37 | -------------------------------------------------------------------------------- /src/Alto/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings 2 | , ScopedTypeVariables 3 | , TupleSections 4 | , FlexibleContexts 5 | #-} 6 | module Alto.Compile where 7 | 8 | import Alto.Menu 9 | import Control.Lens 10 | import qualified Control.Monad.Catch as E 11 | import Control.Monad.Writer 12 | import Control.Monad.State 13 | import qualified Crypto.Hash.SHA256 as SHA256 14 | import Crypto.Scrypt (ScryptParams) 15 | import qualified Crypto.Scrypt as Scrypt 16 | import qualified Data.ByteString.Base64.URL as B64 17 | import qualified Data.ByteString as BS 18 | import qualified Data.ByteString.Lazy as BSL 19 | import qualified Data.Map as Map 20 | import Data.Maybe (fromJust) 21 | import qualified Data.Set as Set 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import qualified Data.Text.Encoding as TE 25 | import System.RandomString 26 | 27 | saltDerivingParams :: ScryptParams 28 | saltDerivingParams = Scrypt.defaultParams 29 | 30 | type MenuM a = StateT CompState IO a 31 | type EntryM a = WriterT [MenuEntry] (StateT CompState IO) a 32 | 33 | -- | Loads a subgraph if it exists, otherwise compiles it. 34 | subGraph :: Text -> MenuM Menu -> MenuM Menu 35 | subGraph sgName desc = 36 | E.catch (lift $ refSubGraph sgName) $ \(_::E.SomeException) -> do 37 | ms <- lift $ compileRoot sgName desc 38 | lift $ saveSubGraph sgName ms 39 | return . fromJust $ ms^.menuMap.at (ms^.topMenu.mid) 40 | 41 | -- | Compiles a MenuSystem given a name we produce a salt from. 42 | -- Any menu systems sharing tags must agree on the project name. 43 | compileRoot :: Text -> MenuM Menu -> IO MenuSystem 44 | compileRoot name desc = do 45 | let compSalt = B64.encode . Scrypt.getEncryptedPass . Scrypt.encryptPass 46 | saltDerivingParams (Scrypt.Salt $ TE.encodeUtf8 "Jektulv!OCod3gob6Glaj@") . 47 | Scrypt.Pass . TE.encodeUtf8 $ name 48 | (rm, (CSt _ mnmp _)) <- desc `runStateT` (CSt compSalt mempty mempty) 49 | return $ MenuSystem mnmp rm 50 | 51 | idBytes :: Int 52 | idBytes = 128 `div` 8 53 | 54 | -- | Generate a (hopefully) unique ID based off the name, pseudo-salted from the root name. 55 | -- The root derived pseudo salt is expensively generated to make guessing attacks 56 | -- fairly unreasonable. Truly though this is just to keep the honest honest. 57 | genTagID :: MonadState CompState m => Text -> m Tag 58 | genTagID nm = do 59 | ss <- use salt 60 | -- If our parts encode the same, we are the same. 61 | return . T.init . TE.decodeUtf8 . B64.encode . BS.take idBytes . 62 | SHA256.hashlazy . 63 | BSL.fromChunks $ [TE.encodeUtf8 nm, ss] 64 | 65 | genMenuID :: MenuM MenuID 66 | genMenuID = lift $ randomString (StringOpts Base58 idBytes) 67 | 68 | -- | Import a menu system for use in this menu system. 69 | -- Returns the root of said menu system. 70 | importMenuSystem :: MenuSystem -> MenuM Menu 71 | importMenuSystem ms = do 72 | menus <>= (ms ^. menuMap) 73 | return (ms ^. topMenu) 74 | 75 | runEntryM :: EntryM () -> MenuM [MenuEntry] 76 | runEntryM = execWriterT 77 | 78 | updateEntries :: Menu -> EntryM () -> MenuM () 79 | updateEntries m entry = 80 | void $ updateEntries' m entry 81 | 82 | updateEntries' :: Menu -> EntryM () -> MenuM Menu 83 | updateEntries' m entry = do 84 | ents <- runEntryM entry 85 | let 86 | m' = m & entries <>~ ents 87 | updateMenu m' 88 | return m' 89 | 90 | menu' :: TagChange -> EntryM () -> MenuM Menu 91 | menu' exitTC ents = do 92 | es <- runEntryM ents 93 | cid <- genMenuID 94 | let mn = Menu cid exitTC es 95 | -- Make sure this ID isn't already in use. 96 | omns <- menus <<%= (Map.insert cid mn) 97 | when (cid `Map.member` omns) $ 98 | error ("The menu "<>(show es)<>" was already in used!") 99 | return $ mn 100 | 101 | menu :: EntryM () -> MenuM Menu 102 | menu = menu' mempty 103 | 104 | updateMenu :: Menu -> MenuM () 105 | updateMenu m = 106 | menus #%= (Map.insert (m ^. mid) m) 107 | 108 | uniqueTag :: MonadState CompState m => Text -> m Tag 109 | uniqueTag t = do 110 | tid <- genTagID t 111 | existed <- use $ tags.contains tid 112 | when existed $ error "Tag already existed!" 113 | return tid 114 | 115 | -- | Add an entry to the menu 116 | ent :: MenuEntry -> EntryM () 117 | ent = tell . pure 118 | 119 | mnAction :: Menu -> EntryType 120 | mnAction m = SubMenu mempty (m^.mid) Nothing 121 | 122 | andLogic :: TagLogic -> TagLogic -> TagLogic 123 | andLogic nl Always = nl 124 | andLogic nl (TLAnd ol) = TLAnd $ nl:ol 125 | andLogic nl ol = TLAnd [nl, ol] 126 | 127 | -- | Require a tag to be set for a menu entry to be displayed. 128 | infixl 5 &+ 129 | (&+) :: MenuEntry -> Tag -> MenuEntry 130 | (&+) e t = e & display %~ andLogic (TagSet t) 131 | 132 | -- | Require a tag to be unset for a menu entry to be displayed. 133 | infixl 5 &- 134 | (&-) :: MenuEntry -> Tag -> MenuEntry 135 | (&-) e t = e & display %~ andLogic (TagUnset t) 136 | 137 | -- | Requires a specific tag logic to be true. 138 | infixl 5 &= 139 | (&=) :: MenuEntry -> TagLogic -> MenuEntry 140 | (&=) e tl = e & display %~ andLogic tl 141 | 142 | -- Make a MenuEntry link to a submenu 143 | -- (|-$) :: MenuEntry -> MenuM Menu -> MenuM MenuEntry 144 | 145 | infixl 5 |-> 146 | (|->) :: MenuEntry -> Menu -> MenuEntry 147 | (|->) e m = e & reaction .~ SubMenu (e^.reaction.onAction) (m ^. mid) Nothing 148 | 149 | infixl 5 |-= 150 | (|-=) :: MenuEntry -> Action -> MenuEntry 151 | (|-=) e a = e & reaction .~ Action (e^.reaction.onAction) (Just a) 152 | 153 | infixl 5 |-== 154 | (|-==) :: MenuEntry -> EntryType -> MenuEntry 155 | (|-==) e a = e & reaction .~ (a&onAction.~(e^.reaction.onAction)) 156 | 157 | infixl 5 |-// 158 | (|-//) :: MenuEntry -> Text -> MenuEntry 159 | (|-//) e u = e |-= (Nav u) 160 | 161 | infixl 5 |-# 162 | (|-#) :: MenuEntry -> Text -> EmbedSize -> MenuEntry 163 | (|-#) e u es = e |-= (Embed u es) 164 | 165 | -- | Make a MenuEntry set a tag. 166 | infixl 5 |-+ 167 | (|-+) :: MenuEntry -> Tag -> MenuEntry 168 | (|-+) e t = e & reaction.onAction.setTags <>~ (Map.singleton t "") 169 | 170 | -- | Make a MenuEntry sset a number of tags. 171 | infixl 5 |-+* 172 | (|-+*) :: MenuEntry -> [Tag] -> MenuEntry 173 | (|-+*) e t = e & reaction.onAction.setTags <>~ (Map.fromList . map (,"") $ t) 174 | 175 | -- | Make a MenuEntry set a tag. 176 | infixl 5 |-+= 177 | (|-+=) :: MenuEntry -> Tag -> Text -> MenuEntry 178 | (|-+=) e t v = e & reaction.onAction.setTags <>~ (Map.singleton t v) 179 | 180 | infixl 5 |-<> 181 | (|-<>) :: MenuEntry -> TagChange -> MenuEntry 182 | (|-<>) e tc = e & reaction.onAction <>~ tc 183 | 184 | -- | Make a MenuEntry unset a tag. 185 | infixl 5 |-- 186 | (|--) :: MenuEntry -> Tag -> MenuEntry 187 | (|--) e t = e & reaction.onAction.unsetTags <>~ (Set.singleton t) 188 | 189 | -- | Make a MenuEntry unset a number of tags. 190 | infixl 5 |--* 191 | (|--*) :: MenuEntry -> [Tag] -> MenuEntry 192 | (|--*) e t = e & reaction.onAction.unsetTags <>~ (Set.fromList t) 193 | 194 | -- | Like |-> but generates where it links off the value of a tag. 195 | infixl 5 |=> 196 | (|=>) :: MenuEntry -> Text -> Tag -> MenuEntry 197 | (|=>) e mpre tg = e & reaction .~ SubMenu (e^.reaction.onAction) mpre (Just tg) 198 | -------------------------------------------------------------------------------- /src/Alto/Compile/BitPuzzle.hs: -------------------------------------------------------------------------------- 1 | module Alto.Compile.BitPuzzle where 2 | 3 | -- | Takes a menu, and gates access to it on someone's ability to "unlock" 4 | -- access through pushing switches that fip various bits. 5 | -- Difficulty is based on number of bits, and number of flips done. 6 | genBitLock :: Menu -> Int -> Int -> MenuM Menu 7 | genBitLock m bitCnt flipCnt = do 8 | -------------------------------------------------------------------------------- /src/Alto/Compile/Navigations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Alto.Compile.Navigations where 3 | 4 | import Alto.Menu 5 | import Alto.Compile 6 | import Control.Lens 7 | import Control.Monad 8 | import Control.Monad.Trans 9 | import Data.ListTrie.Patricia.Map (TrieMap) 10 | import qualified Data.ListTrie.Patricia.Map as LTP 11 | import Data.Map (Map) 12 | import qualified Data.Text as T 13 | 14 | -- | Makes a Patricia Trie into a set of actions. 15 | -- Doesn't handle all Tries. 16 | trieMenu :: [(String, EntryType)] -> MenuM Menu 17 | trieMenu = 18 | go . LTP.fromList 19 | where 20 | go :: TrieMap Map Char EntryType -> MenuM Menu 21 | go = menu . breakPre 22 | breakPre :: TrieMap Map Char EntryType -> EntryM () 23 | breakPre t = do 24 | iforM_ (LTP.children1 t) $ \fc st -> do 25 | case LTP.splitPrefix . LTP.addPrefix [fc] $ st of 26 | (pfx, Nothing, st') -> do 27 | sbmn <- lift $ go st' 28 | ent . MEntry Nothing (T.pack pfx) Always Always $ mnAction sbmn 29 | (pfx, Just a, st') -> do 30 | ent . MEntry Nothing (T.pack pfx) Always Always $ a 31 | unless (LTP.null st') $ do 32 | breakPre . LTP.addPrefix pfx $ st' 33 | 34 | -------------------------------------------------------------------------------- /src/Alto/Example.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | module Alto.Example where 3 | 4 | import Alto.Compile 5 | import Alto.Menu 6 | 7 | exampleMenu :: IO MenuSystem 8 | exampleMenu = compileRoot "Example Menu" $ do 9 | de <- menu $ ent "Dead end!" 10 | menu $ do 11 | ent "This is like a header" 12 | ent $ "Sub Menu" |-> de 13 | -- ent "A directly defined submenu" $ do 14 | -- ent "This is an entry in a directly defined submenu." 15 | -- A sometimes hidden menu that 16 | hideIt <- uniqueTag "Hide it" -- Makes sure the tag isn't used by something else 17 | ent $ "Hide me!" &- hideIt |-+ hideIt 18 | ent $ "Unhide it" &+ hideIt |-- hideIt 19 | ent "Final entry" 20 | -------------------------------------------------------------------------------- /src/Alto/Menu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Alto.Menu where 6 | 7 | import Control.Lens 8 | import qualified Control.Monad.Catch as E 9 | import qualified Data.Aeson as JS 10 | import qualified Data.Aeson.TH as JS 11 | import Data.Aeson (FromJSON, ToJSON) 12 | import Data.ByteString (ByteString) 13 | import Data.Char (toLower) 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Set (Set) 17 | import Data.String 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | import qualified Data.Text.IO as TIO 21 | import System.Directory (listDirectory, createDirectory) 22 | import System.FilePath 23 | import GHC.Generics 24 | 25 | type MenuID = Text 26 | 27 | type Tag = Text 28 | 29 | data ClientState = 30 | ClientState 31 | { _clientTags :: Map Tag Text 32 | } 33 | deriving (Read, Show, Eq, Ord, Generic) 34 | 35 | makeLenses ''ClientState 36 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 7, JS.constructorTagModifier = map toLower} ''ClientState 37 | 38 | data TagLogic = 39 | Always 40 | | TagSet Tag 41 | | TagUnset Tag 42 | | TLAnd [TagLogic] 43 | | TLOr [TagLogic] 44 | | TLNot TagLogic 45 | deriving (Read, Show, Eq, Ord, Generic, ToJSON, FromJSON) 46 | 47 | data TagChange = 48 | TagChange 49 | { _setTags :: Map Tag Text 50 | , _unsetTags :: Set Tag 51 | } 52 | deriving (Read, Show, Eq, Ord, Generic) 53 | 54 | instance Semigroup TagChange where 55 | (<>) (TagChange a1 a2) (TagChange b1 b2) = TagChange (a1 <> b1) (a2 <> b2) 56 | 57 | instance Monoid TagChange where 58 | mempty = TagChange mempty mempty 59 | 60 | makeLenses ''TagChange 61 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1, JS.sumEncoding = JS.UntaggedValue} ''TagChange 62 | 63 | data EmbedSize = 64 | EFullPage 65 | | ENative 66 | | ESize { _x :: Int, _y :: Int } 67 | deriving (Read, Show, Eq, Ord, Generic) 68 | 69 | makeLenses ''EmbedSize 70 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''EmbedSize 71 | 72 | data Action = 73 | ColapseMenu 74 | | Nav { _url :: Text } 75 | | Embed { _url :: Text, _size :: EmbedSize } 76 | | Download { _url :: Text, _filename :: Text } 77 | | JSCall { _jsCall :: Text } 78 | deriving (Read, Show, Eq, Ord, Generic) 79 | 80 | makeLenses ''Action 81 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''Action 82 | 83 | data EntryType = 84 | Action { _onAction :: TagChange, _act :: Maybe Action } 85 | -- ^ When the entry is clicked it does the above 86 | | SubMenu { _onAction :: TagChange, _subMenu :: MenuID, _subIdPostfix :: Maybe Tag } 87 | -- ^ When the entry is selected, the submenu is displayed 88 | -- | CallBack SomeHMACedThing 89 | deriving (Read, Show, Eq, Ord, Generic) 90 | 91 | makeLenses ''EntryType 92 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''EntryType 93 | 94 | data MenuEntry = 95 | MEntry 96 | { _icon :: Maybe Text 97 | , _label :: Text 98 | , _display :: TagLogic 99 | , _active :: TagLogic 100 | , _reaction :: EntryType 101 | } 102 | deriving (Read, Show, Eq, Ord, Generic) 103 | 104 | makeLenses ''MenuEntry 105 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''MenuEntry 106 | 107 | instance IsString MenuEntry where 108 | fromString l = MEntry Nothing (T.pack l) Always Always (Action mempty Nothing) 109 | 110 | data Menu = 111 | Menu 112 | { _mid :: MenuID 113 | , _onLeave :: TagChange 114 | , _entries :: [MenuEntry] 115 | } 116 | deriving (Read, Show, Eq, Ord, Generic) 117 | 118 | makeLenses ''Menu 119 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = dropWhile (=='m') . drop 1} ''Menu 120 | 121 | data Root = 122 | MenuRoot 123 | { _rootState :: ClientState 124 | , _rootMenu :: Menu 125 | } 126 | deriving (Read, Show, Eq, Ord, Generic) 127 | 128 | makeLenses ''Root 129 | JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 5} ''Root 130 | 131 | data MenuSystem = 132 | MenuSystem 133 | { _menuMap :: Map MenuID Menu 134 | , _topMenu :: Menu 135 | } 136 | deriving (Read, Show, Eq, Ord, Generic, ToJSON, FromJSON) 137 | 138 | makeLenses ''MenuSystem 139 | 140 | data CompState = 141 | CSt 142 | { _salt :: ByteString 143 | -- ^ A pseudo-salt derived expensively from the overall name. 144 | , _menus :: Map MenuID Menu 145 | , _tags :: Set Tag 146 | } 147 | deriving (Read, Show, Eq, Ord, Generic) 148 | 149 | makeLenses ''CompState 150 | 151 | existDirectory :: FilePath -> IO () 152 | existDirectory fp = E.catch (createDirectory fp) (\(_::E.SomeException) -> return ()) 153 | 154 | -- | Load a menu from a file 155 | loadMenu :: FilePath -> IO Menu 156 | loadMenu fp = do 157 | either error return =<< JS.eitherDecodeFileStrict' fp 158 | 159 | -- | Loads a MenuSystem directory. The format is: 160 | -- FP: 161 | -- - root <- file containing root menu's ID 162 | -- - menus/ <- directory of one file per menu 163 | loadMenus :: IO MenuSystem 164 | loadMenus = do 165 | root <- either error return =<< JS.eitherDecodeFileStrict' ("graph" "root") 166 | mns <- (fmap (("graph""menu")) <$> listDirectory ("graph" "menu")) >>= 167 | (fmap (Map.fromList . map (\a -> (a ^.mid, a))) . mapM loadMenu) 168 | return . MenuSystem mns $ root^.rootMenu 169 | 170 | -- | Save a MenuSystem so it can be reloaded later for serving or use as a 171 | -- subcomponent of another MenuSystem. 172 | saveMenus :: MenuSystem -> IO () 173 | saveMenus ms = do 174 | existDirectory "graph" 175 | JS.encodeFile ("graph""root") . MenuRoot (ClientState mempty) $ ms^.topMenu 176 | storeSubMenus ms 177 | 178 | storeSubMenus :: MenuSystem -> IO () 179 | storeSubMenus ms = do 180 | existDirectory $ "graph" "menu" 181 | ifor_ (ms^.menuMap) $ \i m -> 182 | JS.encodeFile (("graph""menu")(T.unpack i)) m 183 | 184 | saveSubGraph :: Text -> MenuSystem -> IO () 185 | saveSubGraph subname ms = do 186 | existDirectory "graph" 187 | storeSubMenus ms 188 | existDirectory $ "graph" "subgraph" 189 | TIO.writeFile (("graph""subgraph")(T.unpack subname)) (ms^.topMenu.mid) 190 | 191 | refSubGraph :: Text -> IO Menu 192 | refSubGraph subname = do 193 | mnId <- TIO.readFile (("graph""subgraph")(T.unpack subname)) 194 | loadMenu $ ("graph""menu")(T.unpack mnId) 195 | -------------------------------------------------------------------------------- /src/Alto/Web.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Alto.Web where 6 | 7 | import Alto.Menu 8 | import Control.Lens 9 | import Data.Text (Text) 10 | import Servant 11 | 12 | data AltoConfig = 13 | AltoConfig 14 | { _mSys :: MenuSystem 15 | , _initState :: ClientState 16 | } 17 | deriving (Read, Show, Eq, Ord) 18 | 19 | makeLenses ''AltoConfig 20 | 21 | type RootAPI = "root" :> Get '[JSON] Root 22 | type MenuAPI = "menu" :> Capture "menuid" MenuID :> Get '[JSON] (Headers '[Header "Cache-Control" Text] Menu) 23 | -- type CallbackAPI = "callback" :> ReqBody '[PlainText] ByteString :> Post '[JSON] Event 24 | 25 | type API = RootAPI :<|> MenuAPI 26 | 27 | api :: Proxy API 28 | api = Proxy 29 | 30 | serveRoot :: AltoConfig -> Handler Root 31 | serveRoot cfg = return $ MenuRoot (cfg^.initState) (cfg^.mSys.topMenu) 32 | 33 | serveMenu :: AltoConfig -> Text -> Handler Menu 34 | serveMenu cfg i = 35 | case cfg ^. mSys.menuMap.at i of 36 | Nothing -> throwError err404 37 | Just m -> return m 38 | 39 | addCacheHeader :: Handler Menu -> Handler (Headers '[Header "Cache-Control" Text] Menu) 40 | addCacheHeader = fmap (addHeader "public, max-age=1") 41 | 42 | altoServer :: AltoConfig -> Server API 43 | altoServer cfg = serveRoot cfg :<|> (addCacheHeader <$> serveMenu cfg) 44 | 45 | altoApp :: AltoConfig -> Application 46 | altoApp c = serve api (altoServer c) --------------------------------------------------------------------------------