mirror of
https://github.com/aelve/guide.git
synced 2024-12-22 20:31:31 +03:00
Merge branch 'master' into front-ps
This commit is contained in:
Jens Krause
commit
381145eae6
5
.gitignore
vendored
5
.gitignore
vendored
@ -1,3 +1,4 @@
|
||||
# Haskell
|
||||
dist
|
||||
cabal-dev
|
||||
*.o
|
||||
@ -23,6 +24,7 @@ TAGS
|
||||
state/
|
||||
config.json
|
||||
|
||||
# IDE/support
|
||||
.vscode/
|
||||
tags
|
||||
|
||||
@ -34,3 +36,6 @@ front/build/
|
||||
npm-debug.log*
|
||||
yarn-debug.log*
|
||||
yarn-error.log*
|
||||
|
||||
# JavaScript
|
||||
guidejs/node_modules/
|
||||
|
||||
@ -33,6 +33,7 @@ If you want to contribute but don't know where to start, grep the source for
|
||||
* `templates` – HTML templates for pages and elements of pages
|
||||
* `scripts` – some scripts used by automatic testing
|
||||
* `favicon` – code used to generate a favicon
|
||||
* `guidejs` – client side JavaScript
|
||||
|
||||
### Notes
|
||||
|
||||
@ -46,6 +47,8 @@ it means that there's an extensive comment somewhere else in the code, which you
|
||||
|
||||
### Main modules
|
||||
|
||||
THIS SECTION IS OUTDATED
|
||||
|
||||
There are 4 main modules – `Guide.hs`, `JS.hs`, `View.hs`, and `Types.hs`.
|
||||
|
||||
`Guide.hs` contains:
|
||||
|
||||
16
Setup.hs
16
Setup.hs
@ -1,2 +1,16 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
import System.Process
|
||||
|
||||
main = do
|
||||
hooks <- buildJS simpleUserHooks
|
||||
defaultMainWithHooks hooks
|
||||
|
||||
buildJS hooks = do
|
||||
let originalPostBuild = postBuild hooks
|
||||
return $ hooks {
|
||||
postBuild = \args flags pkgDesc localBuildInfo -> do
|
||||
let npmbuild = proc "sh" ["./scripts/buildjs.sh"]
|
||||
(_, _, _, buildHandle) <- createProcess npmbuild
|
||||
waitForProcess buildHandle
|
||||
originalPostBuild args flags pkgDesc localBuildInfo
|
||||
}
|
||||
|
||||
8
b
8
b
@ -3,15 +3,23 @@ set -e
|
||||
|
||||
args=''
|
||||
test=false
|
||||
with_nix=false
|
||||
|
||||
for var in "$@"
|
||||
do
|
||||
if [[ $var == "-t" ]]; then
|
||||
test=true
|
||||
elif [[ $var == "--nix" ]]; then
|
||||
with_nix=true
|
||||
else
|
||||
args="$args $var"
|
||||
fi
|
||||
done
|
||||
|
||||
if [[ $no_nix == true ]]; then
|
||||
args="$args --nix"
|
||||
fi
|
||||
|
||||
stack build $args --ghc-options="+RTS -A256m -n2m -RTS" --test --no-run-tests --no-haddock-deps --bench --no-run-benchmarks --jobs=4 --dependencies-only
|
||||
|
||||
stack build $args --fast --ghc-options="+RTS -A256m -n2m -RTS" --test --no-run-tests --no-haddock-deps --bench --no-run-benchmarks --jobs=4 2>&1 | perl -pe '$|++; s/(.*) Compiling\s([^\s]+)\s+\(\s+([^\/]+).*/\1 \2/p' | grep -E --color "(^.*warning.*$|^.*error.*$|^ .*$)|"
|
||||
|
||||
32
guide.cabal
32
guide.cabal
@ -12,7 +12,7 @@ maintainer: yom@artyom.me
|
||||
-- copyright:
|
||||
category: Web
|
||||
tested-with: GHC == 8.0.1
|
||||
build-type: Simple
|
||||
build-type: Custom
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
-- Whatever, this won't ever be installed from a .tar package anyway so I
|
||||
@ -44,8 +44,10 @@ executable guide
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Guide.Server
|
||||
Guide.App
|
||||
Guide.Main
|
||||
Guide.ServerStuff
|
||||
Guide.Session
|
||||
Guide.Config
|
||||
Guide.State
|
||||
Guide.Types
|
||||
@ -54,9 +56,12 @@ library
|
||||
Guide.Types.Edit
|
||||
Guide.Types.Action
|
||||
Guide.Types.User
|
||||
Guide.Types.Session
|
||||
Guide.Handlers
|
||||
Guide.Utils
|
||||
Guide.Merge
|
||||
Guide.Diff
|
||||
Guide.Diff.Tokenize
|
||||
Guide.Diff.Merge
|
||||
Guide.Markdown
|
||||
Guide.Search
|
||||
Guide.JS
|
||||
@ -68,15 +73,16 @@ library
|
||||
Guide.Views.Item
|
||||
Guide.Views.Category
|
||||
Guide.Views.Utils
|
||||
Guide.Views.Utils.Input
|
||||
Guide.Cache
|
||||
Guide.SafeCopy
|
||||
Guide.Api.ClientTypes
|
||||
other-modules:
|
||||
Imports
|
||||
build-depends: Spock
|
||||
, Spock-digestive
|
||||
, Spock-lucid == 0.3.*
|
||||
, acid-state == 0.14.*
|
||||
, aeson == 0.11.*
|
||||
, aeson == 1.0.*
|
||||
, aeson-pretty
|
||||
, base >=4.9 && <4.10
|
||||
, base-prelude
|
||||
@ -88,6 +94,7 @@ library
|
||||
, containers >= 0.5
|
||||
, data-default >= 0.5
|
||||
, deepseq >= 1.2.0.0
|
||||
, digestive-functors
|
||||
, directory >= 1.2
|
||||
, ekg
|
||||
, ekg-core
|
||||
@ -102,11 +109,13 @@ library
|
||||
, fsnotify == 0.2.*
|
||||
, hashable
|
||||
, haskell-src-meta
|
||||
, http-api-data
|
||||
, http-types
|
||||
, hvect
|
||||
, ilist
|
||||
, iproute == 1.7.*
|
||||
, lucid >= 2.9.5 && < 3
|
||||
, megaparsec == 5.0.*
|
||||
, megaparsec == 5.*
|
||||
, microlens-platform >= 0.3.2
|
||||
, mmorph == 1.*
|
||||
, mtl >= 2.1.1
|
||||
@ -114,21 +123,22 @@ library
|
||||
, network
|
||||
, network-uri
|
||||
, patches-vector
|
||||
, path-pieces
|
||||
, random >= 1.1
|
||||
, reroute
|
||||
, safecopy
|
||||
, safecopy-migrate
|
||||
, scrypt
|
||||
, shortcut-links >= 0.4.2
|
||||
, slave-thread
|
||||
, split
|
||||
, stache-plus == 0.1.*
|
||||
, stm
|
||||
, stm-containers >= 0.2.14 && < 0.3
|
||||
, template-haskell
|
||||
, text-all == 0.3.*
|
||||
, text
|
||||
, text-all >= 0.4.1.0 && < 0.5
|
||||
, time >= 1.5
|
||||
, transformers
|
||||
, uniplate
|
||||
, unix
|
||||
, utf8-string
|
||||
, vector
|
||||
@ -162,7 +172,7 @@ test-suite tests
|
||||
MergeSpec
|
||||
Selenium
|
||||
type: exitcode-stdio-1.0
|
||||
build-depends: QuickCheck < 2.9
|
||||
build-depends: QuickCheck < 2.10
|
||||
, base < 5
|
||||
, base-prelude
|
||||
, cmark
|
||||
@ -181,7 +191,7 @@ test-suite tests
|
||||
, quickcheck-text < 0.2
|
||||
, slave-thread
|
||||
, tagsoup < 1
|
||||
, text-all < 0.4
|
||||
, text-all
|
||||
, transformers
|
||||
, webdriver >= 0.8.4 && < 0.9
|
||||
hs-source-dirs: tests
|
||||
|
||||
18
guidejs/.babelrc
Normal file
18
guidejs/.babelrc
Normal file
@ -0,0 +1,18 @@
|
||||
{
|
||||
"presets": [
|
||||
[
|
||||
"env",
|
||||
{
|
||||
"targets": {
|
||||
"browsers": [
|
||||
"last 2 versions"
|
||||
]
|
||||
},
|
||||
"modules": false
|
||||
}
|
||||
]
|
||||
],
|
||||
"plugins": [
|
||||
"transform-runtime"
|
||||
]
|
||||
}
|
||||
37
guidejs/README.md
Normal file
37
guidejs/README.md
Normal file
@ -0,0 +1,37 @@
|
||||
# Developing this module
|
||||
|
||||
To work on this module, it's necessary to use either
|
||||
[yarn](https://yarnpkg.com/) or [npm](https://www.npmjs.com/). Yarn is an
|
||||
alternative to npm by Facebook, but they perform the same function here.
|
||||
|
||||
When run in the parent directory, `stack build` will run a build script in the
|
||||
root to install any dependencies and build the output bundle.
|
||||
|
||||
# Motivation for this module
|
||||
|
||||
The situation for handling client-side CSRF token injection was unsatisfying, to
|
||||
say the least. Without performing significant surgery on the types and method
|
||||
the Guide uses to generate JavaScript functions, our best option is to modify
|
||||
the jQuery `$.ajax()` or `$.post()` functions.
|
||||
|
||||
There are a grand total of four packages on [npmjs.com](https://npmjs.com) that
|
||||
show up for "jquery csrf". The most promising is `jquery-csrf-token`. It has two
|
||||
problems, one technical and one contextual.
|
||||
|
||||
1. It does not filter based on the URL, it is a shotgun. Not knowing a lot about
|
||||
how Spock generates and validates CSRF tokens or how that could change, we
|
||||
should defensively program around the worst case: CSRF tokens are valid for a
|
||||
really long time beyond a user's session, and leaking one could be bad.
|
||||
|
||||
2. It gets ~40 downloads a month. Let's not let ourselves be `left-pad`ed.
|
||||
|
||||
So we will include the source (it's relatively short) and add the modifications
|
||||
we need, and _also_ provide a nice path forward for building a
|
||||
single-source-of-truth for client JavaScript for the project. Since
|
||||
`jquery-csrf-token` uses [Rollup](http://rollupjs.org/), we will too.
|
||||
|
||||
We will also use URL parsing to make sure that we only send the CSRF token to
|
||||
the a relative URI. Rollup will come in handy here because IE11 (ugh) and Opera
|
||||
Mini (what?) do not support the URL API and so we'll polyfill it.
|
||||
|
||||
Other features may be added as needed and will be documented here.
|
||||
36
guidejs/package.json
Normal file
36
guidejs/package.json
Normal file
@ -0,0 +1,36 @@
|
||||
{
|
||||
"name": "guidejs",
|
||||
"version": "0.1.0",
|
||||
"description": "Aelve Guide client-side scripts.",
|
||||
"main": "index.js",
|
||||
"scripts": {
|
||||
"build": "npm run build:prod",
|
||||
"build:dev": "npm run clean && rollup -c",
|
||||
"build:prod": "npm run clean && NODE_ENV=\"production\" rollup -c",
|
||||
"test": "echo \"Error: no test specified\" && exit 1",
|
||||
"clean": "rimraf ./dist/*"
|
||||
},
|
||||
"author": "Aaron Friel",
|
||||
"license": "BSD-3-Clause",
|
||||
"dependencies": {
|
||||
"babel-runtime": "^6.23.0",
|
||||
"jquery": "^3.1.1",
|
||||
"url-parse": "^1.1.8"
|
||||
},
|
||||
"devDependencies": {
|
||||
"babel-cli": "^6.24.0",
|
||||
"babel-plugin-transform-runtime": "^6.23.0",
|
||||
"babel-preset-babili": "^0.0.12",
|
||||
"babel-preset-env": "^1.2.2",
|
||||
"rimraf": "^2.6.1",
|
||||
"rollup": "^0.41.6",
|
||||
"rollup-plugin-babel": "^2.7.1",
|
||||
"rollup-plugin-babili": "^1.1.1",
|
||||
"rollup-plugin-commonjs": "^8.0.2",
|
||||
"rollup-plugin-node-resolve": "^2.0.0",
|
||||
"rollup-plugin-replace": "^1.1.1"
|
||||
},
|
||||
"optionalDependencies": {
|
||||
"@types/jquery": "^2.0.41"
|
||||
}
|
||||
}
|
||||
49
guidejs/rollup.config.js
Normal file
49
guidejs/rollup.config.js
Normal file
@ -0,0 +1,49 @@
|
||||
import babel from 'rollup-plugin-babel';
|
||||
import commonjs from 'rollup-plugin-commonjs';
|
||||
import nodeResolve from 'rollup-plugin-node-resolve';
|
||||
import replace from 'rollup-plugin-replace';
|
||||
import babili from 'rollup-plugin-babili';
|
||||
|
||||
const NODE_ENV = process.env.NODE_ENV || 'development';
|
||||
const IS_PRODUCTION = NODE_ENV === 'production';
|
||||
|
||||
let config = {
|
||||
entry: './src/index.js',
|
||||
moduleName: 'guidejs',
|
||||
dest: './dist/bundle.js',
|
||||
format: 'iife',
|
||||
sourceMap: IS_PRODUCTION,
|
||||
plugins: [
|
||||
// TODO: For production, replace with production and minify.
|
||||
nodeResolve({
|
||||
module: true,
|
||||
jsnext: true,
|
||||
main: true,
|
||||
}),
|
||||
commonjs(),
|
||||
replace({
|
||||
'process.env.NODE_ENV': JSON.stringify(NODE_ENV),
|
||||
}),
|
||||
babel({
|
||||
exclude: 'node_modules/**',
|
||||
runtimeHelpers: true,
|
||||
}),
|
||||
]
|
||||
};
|
||||
|
||||
// Reduces the size by about half.
|
||||
if (IS_PRODUCTION) {
|
||||
console.log('Production build');
|
||||
config.plugins.unshift(
|
||||
babili({
|
||||
comments: false,
|
||||
sourceMap: true,
|
||||
mangle: true,
|
||||
evaluate: true
|
||||
})
|
||||
);
|
||||
} else {
|
||||
console.log('Development build');
|
||||
}
|
||||
|
||||
export default config;
|
||||
26
guidejs/src/csrfProtection.js
Normal file
26
guidejs/src/csrfProtection.js
Normal file
@ -0,0 +1,26 @@
|
||||
import URL from './url-polyfill';
|
||||
import { csrfPrefilter as oldPrefilter, enable as jqueryCsrfEnable } from './jquery-csrf-token';
|
||||
|
||||
// Now we patch in our own prefilter from url-parse, and layer it with the one from jqueryCsrfToken.
|
||||
function originFilter(options, ...args) {
|
||||
let docOrigin = document.location.origin;
|
||||
let reqOrigin = (new URL(options.url, document.location)).origin;
|
||||
|
||||
// For now, only test to make sure the origins are the same.
|
||||
// TODO: Filter to say, a /api/ prefix?
|
||||
if (docOrigin === reqOrigin) {
|
||||
oldPrefilter(options, ...args);
|
||||
}
|
||||
}
|
||||
|
||||
function enable(csrfKey, csrfValue) {
|
||||
jqueryCsrfEnable(csrfValue, {
|
||||
key: csrfKey,
|
||||
prefilter: originFilter,
|
||||
retry: null,
|
||||
});
|
||||
};
|
||||
|
||||
export default {
|
||||
enable
|
||||
};
|
||||
9
guidejs/src/index.js
Normal file
9
guidejs/src/index.js
Normal file
@ -0,0 +1,9 @@
|
||||
import jquery from 'jquery';
|
||||
// export jQuery to the globals.
|
||||
window.$ = window.jquery = window.jQuery = jquery;
|
||||
|
||||
import csrfProtection from './csrfProtection.js';
|
||||
|
||||
export default {
|
||||
csrfProtection
|
||||
};
|
||||
160
guidejs/src/jquery-csrf-token/index.js
vendored
Normal file
160
guidejs/src/jquery-csrf-token/index.js
vendored
Normal file
@ -0,0 +1,160 @@
|
||||
|
||||
import jQuery from 'jquery';
|
||||
|
||||
let $ = jQuery;
|
||||
|
||||
const config = {};
|
||||
let token = null;
|
||||
|
||||
// Function ripped from Django docs.
|
||||
// See: https://docs.djangoproject.com/en/dev/ref/csrf/#ajax
|
||||
function csrfSafeMethod(method) {
|
||||
// These HTTP methods do not require CSRF protection.
|
||||
return (/^(GET|HEAD|OPTIONS|TRACE)$/i.test(method));
|
||||
}
|
||||
|
||||
export function csrfPrefilter(options, ...args) {
|
||||
// The header should only be set when the request is local.
|
||||
if (!csrfSafeMethod(options.type) && !options.crossDomain) {
|
||||
const oldBeforeSend = options.beforeSend;
|
||||
options.beforeSend = function (xhr) {
|
||||
// The csrf token is valid for the duration of the session,
|
||||
// so it's safe to use a static token.
|
||||
xhr.setRequestHeader(config.key, token);
|
||||
if (oldBeforeSend) {
|
||||
oldBeforeSend(...args);
|
||||
}
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
export function setToken(newToken) {
|
||||
token = newToken;
|
||||
}
|
||||
|
||||
|
||||
/* Patch $.ajax to support expired CSRF tokens */
|
||||
function addRetrySupport(retryURL, parseResponse, isCSRFFailure) {
|
||||
if (!isCSRFFailure) {
|
||||
isCSRFFailure = xhr => xhr.status === 403;
|
||||
}
|
||||
const originalAjax = $.ajax;
|
||||
|
||||
/**
|
||||
* Copy properties from jqXhrToCopy to fakeJqXhr. This is makes fakeJqXhr
|
||||
* behave properly.
|
||||
*/
|
||||
function fakeJqXhrInheritance(fakeJqXhr, jqXhrToCopy) {
|
||||
Object.keys(jqXhrToCopy).forEach((key) => {
|
||||
if (typeof jqXhrToCopy[key] === 'function') {
|
||||
fakeJqXhr[key] = jqXhrToCopy[key].bind(jqXhrToCopy);
|
||||
} else {
|
||||
fakeJqXhr[key] = jqXhrToCopy[key];
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
/**
|
||||
* Patch $.ajax to support expired csrf tokens. If a request is made and the
|
||||
* token is expired, then a new token is fetched from the server. The original
|
||||
* request will be run again with the new token.
|
||||
*
|
||||
* For the outside world only 1 request is send, but depending on the situation
|
||||
* at most 3 request can be executed.
|
||||
*/
|
||||
$.ajax = function (url, options) {
|
||||
const pResult = $.Deferred(); // eslint-disable-line new-cap
|
||||
const fakeJqXhr = pResult.promise();
|
||||
|
||||
if (typeof url === 'object') {
|
||||
options = url;
|
||||
url = undefined;
|
||||
} else {
|
||||
options.url = url;
|
||||
}
|
||||
|
||||
// The original ajax request might have success or error callbacks. We want
|
||||
// to trigger them manually based on if there is a csrf token mismatch.
|
||||
const success = options.success;
|
||||
const error = options.error;
|
||||
delete options.success;
|
||||
delete options.error;
|
||||
|
||||
// Fire the first try!
|
||||
const xhrFirstTry = originalAjax(options);
|
||||
|
||||
xhrFirstTry.error((jqXHR, textStatus, errorThrown) => {
|
||||
if (isCSRFFailure(jqXHR)) {
|
||||
// We assume that a csrf token mismatch happend, so fetch a new
|
||||
// token and retry with the correct token.
|
||||
originalAjax(retryURL).done((data) => {
|
||||
setToken(parseResponse(data));
|
||||
let xhrSecondTry = null;
|
||||
|
||||
options.success = (dataSecondSuccess, textStatusSecondSuccess, jqXHRSecondSuccess) => {
|
||||
if (typeof success === 'function') success(dataSecondSuccess, textStatusSecondSuccess, jqXHRSecondSuccess);
|
||||
pResult.resolve(dataSecondSuccess, textStatusSecondSuccess, jqXHRSecondSuccess);
|
||||
};
|
||||
|
||||
options.error = (jqXHRSecondError, textStatusSecondError, errorThrownSecondError) => {
|
||||
if (typeof error === 'function') error(jqXHRSecondError, textStatusSecondError, errorThrownSecondError);
|
||||
pResult.reject(jqXHRSecondError, textStatusSecondError, errorThrownSecondError);
|
||||
};
|
||||
|
||||
xhrSecondTry = originalAjax(options);
|
||||
fakeJqXhrInheritance(fakeJqXhr, xhrSecondTry);
|
||||
});
|
||||
} else {
|
||||
// Some other error happend, so just pass it through.
|
||||
fakeJqXhrInheritance(fakeJqXhr, xhrFirstTry);
|
||||
if (typeof error === 'function') error(jqXHR, textStatus, errorThrown);
|
||||
pResult.reject(jqXHR, textStatus, errorThrown);
|
||||
}
|
||||
});
|
||||
|
||||
// Upon success, update our fakeJqXhr and trigger the success callback.
|
||||
xhrFirstTry.success((data, textStatus, jqXHR) => {
|
||||
fakeJqXhrInheritance(fakeJqXhr, xhrFirstTry);
|
||||
if (typeof success === 'function') success(data, textStatus, jqXHR);
|
||||
|
||||
pResult.resolve(data, textStatus, jqXHR);
|
||||
});
|
||||
|
||||
fakeJqXhrInheritance(fakeJqXhr, xhrFirstTry);
|
||||
|
||||
return fakeJqXhr;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
export function enable(newToken, newConfig) {
|
||||
newConfig || (newConfig = {});
|
||||
|
||||
if (!newToken) {
|
||||
console.warn('CSRF token is not set!');
|
||||
}
|
||||
|
||||
if (!newConfig.key) {
|
||||
newConfig.key = 'X-CSRF-TOKEN';
|
||||
}
|
||||
|
||||
if (!newConfig.prefilter) {
|
||||
newConfig.prefilter = csrfPrefilter;
|
||||
}
|
||||
|
||||
config.key = newConfig.key;
|
||||
|
||||
if (newConfig.retry) {
|
||||
addRetrySupport(newConfig.retry.url, newConfig.retry.parseResponse,
|
||||
newConfig.retry.isCSRFFailure);
|
||||
}
|
||||
|
||||
setToken(newToken);
|
||||
|
||||
// Set a header on every request with the current csrf token in it.
|
||||
$.ajaxPrefilter(newConfig.prefilter);
|
||||
}
|
||||
|
||||
export function mockJQuery(mockedJquery) {
|
||||
$ = mockedJquery;
|
||||
}
|
||||
623
guidejs/src/url-polyfill/index.js
Normal file
623
guidejs/src/url-polyfill/index.js
Normal file
@ -0,0 +1,623 @@
|
||||
/// from https://raw.githubusercontent.com/webcomponents/URL/master/url.js
|
||||
|
||||
/* Any copyright is dedicated to the Public Domain.
|
||||
* http://creativecommons.org/publicdomain/zero/1.0/ */
|
||||
var module = {};
|
||||
|
||||
(function(scope) {
|
||||
'use strict';
|
||||
|
||||
// feature detect for URL constructor
|
||||
var hasWorkingUrl = false;
|
||||
if (!scope.forceJURL) {
|
||||
try {
|
||||
var u = new URL('b', 'http://a');
|
||||
u.pathname = 'c%20d';
|
||||
hasWorkingUrl = u.href === 'http://a/c%20d';
|
||||
} catch(e) {}
|
||||
}
|
||||
|
||||
if (hasWorkingUrl)
|
||||
return;
|
||||
|
||||
var relative = Object.create(null);
|
||||
relative['ftp'] = 21;
|
||||
relative['file'] = 0;
|
||||
relative['gopher'] = 70;
|
||||
relative['http'] = 80;
|
||||
relative['https'] = 443;
|
||||
relative['ws'] = 80;
|
||||
relative['wss'] = 443;
|
||||
|
||||
var relativePathDotMapping = Object.create(null);
|
||||
relativePathDotMapping['%2e'] = '.';
|
||||
relativePathDotMapping['.%2e'] = '..';
|
||||
relativePathDotMapping['%2e.'] = '..';
|
||||
relativePathDotMapping['%2e%2e'] = '..';
|
||||
|
||||
function isRelativeScheme(scheme) {
|
||||
return relative[scheme] !== undefined;
|
||||
}
|
||||
|
||||
function invalid() {
|
||||
clear.call(this);
|
||||
this._isInvalid = true;
|
||||
}
|
||||
|
||||
function IDNAToASCII(h) {
|
||||
if ('' == h) {
|
||||
invalid.call(this)
|
||||
}
|
||||
// XXX
|
||||
return h.toLowerCase()
|
||||
}
|
||||
|
||||
function percentEscape(c) {
|
||||
var unicode = c.charCodeAt(0);
|
||||
if (unicode > 0x20 &&
|
||||
unicode < 0x7F &&
|
||||
// " # < > ? `
|
||||
[0x22, 0x23, 0x3C, 0x3E, 0x3F, 0x60].indexOf(unicode) == -1
|
||||
) {
|
||||
return c;
|
||||
}
|
||||
return encodeURIComponent(c);
|
||||
}
|
||||
|
||||
function percentEscapeQuery(c) {
|
||||
// XXX This actually needs to encode c using encoding and then
|
||||
// convert the bytes one-by-one.
|
||||
|
||||
var unicode = c.charCodeAt(0);
|
||||
if (unicode > 0x20 &&
|
||||
unicode < 0x7F &&
|
||||
// " # < > ` (do not escape '?')
|
||||
[0x22, 0x23, 0x3C, 0x3E, 0x60].indexOf(unicode) == -1
|
||||
) {
|
||||
return c;
|
||||
}
|
||||
return encodeURIComponent(c);
|
||||
}
|
||||
|
||||
var EOF = undefined,
|
||||
ALPHA = /[a-zA-Z]/,
|
||||
ALPHANUMERIC = /[a-zA-Z0-9\+\-\.]/;
|
||||
|
||||
function parse(input, stateOverride, base) {
|
||||
function err(message) {
|
||||
errors.push(message)
|
||||
}
|
||||
|
||||
var state = stateOverride || 'scheme start',
|
||||
cursor = 0,
|
||||
buffer = '',
|
||||
seenAt = false,
|
||||
seenBracket = false,
|
||||
errors = [];
|
||||
|
||||
loop: while ((input[cursor - 1] != EOF || cursor == 0) && !this._isInvalid) {
|
||||
var c = input[cursor];
|
||||
switch (state) {
|
||||
case 'scheme start':
|
||||
if (c && ALPHA.test(c)) {
|
||||
buffer += c.toLowerCase(); // ASCII-safe
|
||||
state = 'scheme';
|
||||
} else if (!stateOverride) {
|
||||
buffer = '';
|
||||
state = 'no scheme';
|
||||
continue;
|
||||
} else {
|
||||
err('Invalid scheme.');
|
||||
break loop;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'scheme':
|
||||
if (c && ALPHANUMERIC.test(c)) {
|
||||
buffer += c.toLowerCase(); // ASCII-safe
|
||||
} else if (':' == c) {
|
||||
this._scheme = buffer;
|
||||
buffer = '';
|
||||
if (stateOverride) {
|
||||
break loop;
|
||||
}
|
||||
if (isRelativeScheme(this._scheme)) {
|
||||
this._isRelative = true;
|
||||
}
|
||||
if ('file' == this._scheme) {
|
||||
state = 'relative';
|
||||
} else if (this._isRelative && base && base._scheme == this._scheme) {
|
||||
state = 'relative or authority';
|
||||
} else if (this._isRelative) {
|
||||
state = 'authority first slash';
|
||||
} else {
|
||||
state = 'scheme data';
|
||||
}
|
||||
} else if (!stateOverride) {
|
||||
buffer = '';
|
||||
cursor = 0;
|
||||
state = 'no scheme';
|
||||
continue;
|
||||
} else if (EOF == c) {
|
||||
break loop;
|
||||
} else {
|
||||
err('Code point not allowed in scheme: ' + c)
|
||||
break loop;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'scheme data':
|
||||
if ('?' == c) {
|
||||
this._query = '?';
|
||||
state = 'query';
|
||||
} else if ('#' == c) {
|
||||
this._fragment = '#';
|
||||
state = 'fragment';
|
||||
} else {
|
||||
// XXX error handling
|
||||
if (EOF != c && '\t' != c && '\n' != c && '\r' != c) {
|
||||
this._schemeData += percentEscape(c);
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case 'no scheme':
|
||||
if (!base || !(isRelativeScheme(base._scheme))) {
|
||||
err('Missing scheme.');
|
||||
invalid.call(this);
|
||||
} else {
|
||||
state = 'relative';
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'relative or authority':
|
||||
if ('/' == c && '/' == input[cursor+1]) {
|
||||
state = 'authority ignore slashes';
|
||||
} else {
|
||||
err('Expected /, got: ' + c);
|
||||
state = 'relative';
|
||||
continue
|
||||
}
|
||||
break;
|
||||
|
||||
case 'relative':
|
||||
this._isRelative = true;
|
||||
if ('file' != this._scheme)
|
||||
this._scheme = base._scheme;
|
||||
if (EOF == c) {
|
||||
this._host = base._host;
|
||||
this._port = base._port;
|
||||
this._path = base._path.slice();
|
||||
this._query = base._query;
|
||||
this._username = base._username;
|
||||
this._password = base._password;
|
||||
break loop;
|
||||
} else if ('/' == c || '\\' == c) {
|
||||
if ('\\' == c)
|
||||
err('\\ is an invalid code point.');
|
||||
state = 'relative slash';
|
||||
} else if ('?' == c) {
|
||||
this._host = base._host;
|
||||
this._port = base._port;
|
||||
this._path = base._path.slice();
|
||||
this._query = '?';
|
||||
this._username = base._username;
|
||||
this._password = base._password;
|
||||
state = 'query';
|
||||
} else if ('#' == c) {
|
||||
this._host = base._host;
|
||||
this._port = base._port;
|
||||
this._path = base._path.slice();
|
||||
this._query = base._query;
|
||||
this._fragment = '#';
|
||||
this._username = base._username;
|
||||
this._password = base._password;
|
||||
state = 'fragment';
|
||||
} else {
|
||||
var nextC = input[cursor+1]
|
||||
var nextNextC = input[cursor+2]
|
||||
if (
|
||||
'file' != this._scheme || !ALPHA.test(c) ||
|
||||
(nextC != ':' && nextC != '|') ||
|
||||
(EOF != nextNextC && '/' != nextNextC && '\\' != nextNextC && '?' != nextNextC && '#' != nextNextC)) {
|
||||
this._host = base._host;
|
||||
this._port = base._port;
|
||||
this._username = base._username;
|
||||
this._password = base._password;
|
||||
this._path = base._path.slice();
|
||||
this._path.pop();
|
||||
}
|
||||
state = 'relative path';
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'relative slash':
|
||||
if ('/' == c || '\\' == c) {
|
||||
if ('\\' == c) {
|
||||
err('\\ is an invalid code point.');
|
||||
}
|
||||
if ('file' == this._scheme) {
|
||||
state = 'file host';
|
||||
} else {
|
||||
state = 'authority ignore slashes';
|
||||
}
|
||||
} else {
|
||||
if ('file' != this._scheme) {
|
||||
this._host = base._host;
|
||||
this._port = base._port;
|
||||
this._username = base._username;
|
||||
this._password = base._password;
|
||||
}
|
||||
state = 'relative path';
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'authority first slash':
|
||||
if ('/' == c) {
|
||||
state = 'authority second slash';
|
||||
} else {
|
||||
err("Expected '/', got: " + c);
|
||||
state = 'authority ignore slashes';
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'authority second slash':
|
||||
state = 'authority ignore slashes';
|
||||
if ('/' != c) {
|
||||
err("Expected '/', got: " + c);
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'authority ignore slashes':
|
||||
if ('/' != c && '\\' != c) {
|
||||
state = 'authority';
|
||||
continue;
|
||||
} else {
|
||||
err('Expected authority, got: ' + c);
|
||||
}
|
||||
break;
|
||||
|
||||
case 'authority':
|
||||
if ('@' == c) {
|
||||
if (seenAt) {
|
||||
err('@ already seen.');
|
||||
buffer += '%40';
|
||||
}
|
||||
seenAt = true;
|
||||
for (var i = 0; i < buffer.length; i++) {
|
||||
var cp = buffer[i];
|
||||
if ('\t' == cp || '\n' == cp || '\r' == cp) {
|
||||
err('Invalid whitespace in authority.');
|
||||
continue;
|
||||
}
|
||||
// XXX check URL code points
|
||||
if (':' == cp && null === this._password) {
|
||||
this._password = '';
|
||||
continue;
|
||||
}
|
||||
var tempC = percentEscape(cp);
|
||||
(null !== this._password) ? this._password += tempC : this._username += tempC;
|
||||
}
|
||||
buffer = '';
|
||||
} else if (EOF == c || '/' == c || '\\' == c || '?' == c || '#' == c) {
|
||||
cursor -= buffer.length;
|
||||
buffer = '';
|
||||
state = 'host';
|
||||
continue;
|
||||
} else {
|
||||
buffer += c;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'file host':
|
||||
if (EOF == c || '/' == c || '\\' == c || '?' == c || '#' == c) {
|
||||
if (buffer.length == 2 && ALPHA.test(buffer[0]) && (buffer[1] == ':' || buffer[1] == '|')) {
|
||||
state = 'relative path';
|
||||
} else if (buffer.length == 0) {
|
||||
state = 'relative path start';
|
||||
} else {
|
||||
this._host = IDNAToASCII.call(this, buffer);
|
||||
buffer = '';
|
||||
state = 'relative path start';
|
||||
}
|
||||
continue;
|
||||
} else if ('\t' == c || '\n' == c || '\r' == c) {
|
||||
err('Invalid whitespace in file host.');
|
||||
} else {
|
||||
buffer += c;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'host':
|
||||
case 'hostname':
|
||||
if (':' == c && !seenBracket) {
|
||||
// XXX host parsing
|
||||
this._host = IDNAToASCII.call(this, buffer);
|
||||
buffer = '';
|
||||
state = 'port';
|
||||
if ('hostname' == stateOverride) {
|
||||
break loop;
|
||||
}
|
||||
} else if (EOF == c || '/' == c || '\\' == c || '?' == c || '#' == c) {
|
||||
this._host = IDNAToASCII.call(this, buffer);
|
||||
buffer = '';
|
||||
state = 'relative path start';
|
||||
if (stateOverride) {
|
||||
break loop;
|
||||
}
|
||||
continue;
|
||||
} else if ('\t' != c && '\n' != c && '\r' != c) {
|
||||
if ('[' == c) {
|
||||
seenBracket = true;
|
||||
} else if (']' == c) {
|
||||
seenBracket = false;
|
||||
}
|
||||
buffer += c;
|
||||
} else {
|
||||
err('Invalid code point in host/hostname: ' + c);
|
||||
}
|
||||
break;
|
||||
|
||||
case 'port':
|
||||
if (/[0-9]/.test(c)) {
|
||||
buffer += c;
|
||||
} else if (EOF == c || '/' == c || '\\' == c || '?' == c || '#' == c || stateOverride) {
|
||||
if ('' != buffer) {
|
||||
var temp = parseInt(buffer, 10);
|
||||
if (temp != relative[this._scheme]) {
|
||||
this._port = temp + '';
|
||||
}
|
||||
buffer = '';
|
||||
}
|
||||
if (stateOverride) {
|
||||
break loop;
|
||||
}
|
||||
state = 'relative path start';
|
||||
continue;
|
||||
} else if ('\t' == c || '\n' == c || '\r' == c) {
|
||||
err('Invalid code point in port: ' + c);
|
||||
} else {
|
||||
invalid.call(this);
|
||||
}
|
||||
break;
|
||||
|
||||
case 'relative path start':
|
||||
if ('\\' == c)
|
||||
err("'\\' not allowed in path.");
|
||||
state = 'relative path';
|
||||
if ('/' != c && '\\' != c) {
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
|
||||
case 'relative path':
|
||||
if (EOF == c || '/' == c || '\\' == c || (!stateOverride && ('?' == c || '#' == c))) {
|
||||
if ('\\' == c) {
|
||||
err('\\ not allowed in relative path.');
|
||||
}
|
||||
var tmp;
|
||||
if (tmp = relativePathDotMapping[buffer.toLowerCase()]) {
|
||||
buffer = tmp;
|
||||
}
|
||||
if ('..' == buffer) {
|
||||
this._path.pop();
|
||||
if ('/' != c && '\\' != c) {
|
||||
this._path.push('');
|
||||
}
|
||||
} else if ('.' == buffer && '/' != c && '\\' != c) {
|
||||
this._path.push('');
|
||||
} else if ('.' != buffer) {
|
||||
if ('file' == this._scheme && this._path.length == 0 && buffer.length == 2 && ALPHA.test(buffer[0]) && buffer[1] == '|') {
|
||||
buffer = buffer[0] + ':';
|
||||
}
|
||||
this._path.push(buffer);
|
||||
}
|
||||
buffer = '';
|
||||
if ('?' == c) {
|
||||
this._query = '?';
|
||||
state = 'query';
|
||||
} else if ('#' == c) {
|
||||
this._fragment = '#';
|
||||
state = 'fragment';
|
||||
}
|
||||
} else if ('\t' != c && '\n' != c && '\r' != c) {
|
||||
buffer += percentEscape(c);
|
||||
}
|
||||
break;
|
||||
|
||||
case 'query':
|
||||
if (!stateOverride && '#' == c) {
|
||||
this._fragment = '#';
|
||||
state = 'fragment';
|
||||
} else if (EOF != c && '\t' != c && '\n' != c && '\r' != c) {
|
||||
this._query += percentEscapeQuery(c);
|
||||
}
|
||||
break;
|
||||
|
||||
case 'fragment':
|
||||
if (EOF != c && '\t' != c && '\n' != c && '\r' != c) {
|
||||
this._fragment += c;
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
cursor++;
|
||||
}
|
||||
}
|
||||
|
||||
function clear() {
|
||||
this._scheme = '';
|
||||
this._schemeData = '';
|
||||
this._username = '';
|
||||
this._password = null;
|
||||
this._host = '';
|
||||
this._port = '';
|
||||
this._path = [];
|
||||
this._query = '';
|
||||
this._fragment = '';
|
||||
this._isInvalid = false;
|
||||
this._isRelative = false;
|
||||
}
|
||||
|
||||
// Does not process domain names or IP addresses.
|
||||
// Does not handle encoding for the query parameter.
|
||||
function jURL(url, base /* , encoding */) {
|
||||
if (base !== undefined && !(base instanceof jURL))
|
||||
base = new jURL(String(base));
|
||||
|
||||
this._url = url;
|
||||
clear.call(this);
|
||||
|
||||
var input = url.replace(/^[ \t\r\n\f]+|[ \t\r\n\f]+$/g, '');
|
||||
// encoding = encoding || 'utf-8'
|
||||
|
||||
parse.call(this, input, null, base);
|
||||
}
|
||||
|
||||
jURL.prototype = {
|
||||
toString: function() {
|
||||
return this.href;
|
||||
},
|
||||
get href() {
|
||||
if (this._isInvalid)
|
||||
return this._url;
|
||||
|
||||
var authority = '';
|
||||
if ('' != this._username || null != this._password) {
|
||||
authority = this._username +
|
||||
(null != this._password ? ':' + this._password : '') + '@';
|
||||
}
|
||||
|
||||
return this.protocol +
|
||||
(this._isRelative ? '//' + authority + this.host : '') +
|
||||
this.pathname + this._query + this._fragment;
|
||||
},
|
||||
set href(href) {
|
||||
clear.call(this);
|
||||
parse.call(this, href);
|
||||
},
|
||||
|
||||
get protocol() {
|
||||
return this._scheme + ':';
|
||||
},
|
||||
set protocol(protocol) {
|
||||
if (this._isInvalid)
|
||||
return;
|
||||
parse.call(this, protocol + ':', 'scheme start');
|
||||
},
|
||||
|
||||
get host() {
|
||||
return this._isInvalid ? '' : this._port ?
|
||||
this._host + ':' + this._port : this._host;
|
||||
},
|
||||
set host(host) {
|
||||
if (this._isInvalid || !this._isRelative)
|
||||
return;
|
||||
parse.call(this, host, 'host');
|
||||
},
|
||||
|
||||
get hostname() {
|
||||
return this._host;
|
||||
},
|
||||
set hostname(hostname) {
|
||||
if (this._isInvalid || !this._isRelative)
|
||||
return;
|
||||
parse.call(this, hostname, 'hostname');
|
||||
},
|
||||
|
||||
get port() {
|
||||
return this._port;
|
||||
},
|
||||
set port(port) {
|
||||
if (this._isInvalid || !this._isRelative)
|
||||
return;
|
||||
parse.call(this, port, 'port');
|
||||
},
|
||||
|
||||
get pathname() {
|
||||
return this._isInvalid ? '' : this._isRelative ?
|
||||
'/' + this._path.join('/') : this._schemeData;
|
||||
},
|
||||
set pathname(pathname) {
|
||||
if (this._isInvalid || !this._isRelative)
|
||||
return;
|
||||
this._path = [];
|
||||
parse.call(this, pathname, 'relative path start');
|
||||
},
|
||||
|
||||
get search() {
|
||||
return this._isInvalid || !this._query || '?' == this._query ?
|
||||
'' : this._query;
|
||||
},
|
||||
set search(search) {
|
||||
if (this._isInvalid || !this._isRelative)
|
||||
return;
|
||||
this._query = '?';
|
||||
if ('?' == search[0])
|
||||
search = search.slice(1);
|
||||
parse.call(this, search, 'query');
|
||||
},
|
||||
|
||||
get hash() {
|
||||
return this._isInvalid || !this._fragment || '#' == this._fragment ?
|
||||
'' : this._fragment;
|
||||
},
|
||||
set hash(hash) {
|
||||
if (this._isInvalid)
|
||||
return;
|
||||
this._fragment = '#';
|
||||
if ('#' == hash[0])
|
||||
hash = hash.slice(1);
|
||||
parse.call(this, hash, 'fragment');
|
||||
},
|
||||
|
||||
get origin() {
|
||||
var host;
|
||||
if (this._isInvalid || !this._scheme) {
|
||||
return '';
|
||||
}
|
||||
// javascript: Gecko returns String(""), WebKit/Blink String("null")
|
||||
// Gecko throws error for "data://"
|
||||
// data: Gecko returns "", Blink returns "data://", WebKit returns "null"
|
||||
// Gecko returns String("") for file: mailto:
|
||||
// WebKit/Blink returns String("SCHEME://") for file: mailto:
|
||||
switch (this._scheme) {
|
||||
case 'data':
|
||||
case 'file':
|
||||
case 'javascript':
|
||||
case 'mailto':
|
||||
return 'null';
|
||||
}
|
||||
host = this.host;
|
||||
if (!host) {
|
||||
return '';
|
||||
}
|
||||
return this._scheme + '://' + host;
|
||||
}
|
||||
};
|
||||
|
||||
// Copy over the static methods
|
||||
var OriginalURL = scope.URL;
|
||||
if (OriginalURL) {
|
||||
jURL.createObjectURL = function(blob) {
|
||||
// IE extension allows a second optional options argument.
|
||||
// http://msdn.microsoft.com/en-us/library/ie/hh772302(v=vs.85).aspx
|
||||
return OriginalURL.createObjectURL.apply(OriginalURL, arguments);
|
||||
};
|
||||
jURL.revokeObjectURL = function(url) {
|
||||
OriginalURL.revokeObjectURL(url);
|
||||
};
|
||||
}
|
||||
|
||||
scope.URL = jURL;
|
||||
|
||||
})(module);
|
||||
|
||||
var urlpoly = module.URL || URL;
|
||||
|
||||
export default urlpoly;
|
||||
2005
guidejs/yarn.lock
Normal file
2005
guidejs/yarn.lock
Normal file
File diff suppressed because it is too large
Load Diff
5
official.sh
Executable file
5
official.sh
Executable file
@ -0,0 +1,5 @@
|
||||
#!/bin/bash
|
||||
|
||||
rm -rf state
|
||||
git clone --depth 1 https://github.com/aelve/guide-database.git
|
||||
mv guide-database state
|
||||
9
scripts/buildjs.sh
Executable file
9
scripts/buildjs.sh
Executable file
@ -0,0 +1,9 @@
|
||||
#!/bin/bash -xe
|
||||
|
||||
cd guidejs
|
||||
echo "PWD is $PWD"
|
||||
npm install
|
||||
npm run build
|
||||
rm -rf ../static/js
|
||||
cp -r ./dist/ ../static/js
|
||||
cd ..
|
||||
41
src/Guide/App.hs
Normal file
41
src/Guide/App.hs
Normal file
@ -0,0 +1,41 @@
|
||||
{-# LANGUAGE ConstraintKinds, TypeFamilies #-}
|
||||
|
||||
{- |
|
||||
App module defines types used by the Spock framework.
|
||||
|
||||
-}
|
||||
module Guide.App
|
||||
where
|
||||
|
||||
-- hvect
|
||||
import Data.HVect
|
||||
-- Spock
|
||||
import Web.Spock
|
||||
|
||||
import Guide.Types.User (User)
|
||||
import Guide.Types.Session (GuideData)
|
||||
import Guide.ServerStuff (ServerState)
|
||||
|
||||
-- | Type of connection, currently unused. (Acid-State DB stored in 'ServerState')
|
||||
type GuideConn = ()
|
||||
-- | Type of user session payload.
|
||||
type GuideSessionData = GuideData
|
||||
-- | Type of server state, accessed with 'getState'.
|
||||
type GuideState = ServerState
|
||||
|
||||
-- | The fully qualified type of a Spock application/route.
|
||||
type GuideM ctx r = SpockCtxM ctx GuideConn GuideData ServerState r
|
||||
|
||||
-- | Type of a root application.
|
||||
type GuideApp ctx = GuideM ctx ()
|
||||
|
||||
-- | Type of a Guide action with a generic context.
|
||||
type GuideAction ctx r = ActionCtxT ctx (WebStateM GuideConn GuideData ServerState) r
|
||||
|
||||
data IsAdmin = IsAdmin
|
||||
|
||||
type AuthM ctx r = forall n xs. (ctx ~ HVect xs, ListContains n User xs) => GuideM ctx r
|
||||
type AuthAction ctx r = forall n xs. (ctx ~ HVect xs, ListContains n User xs) => GuideAction ctx r
|
||||
|
||||
type AdminM ctx r = forall n xs. (ctx ~ HVect xs, ListContains n IsAdmin xs) => GuideM ctx r
|
||||
type AdminAction ctx r = forall n xs. (ctx ~ HVect xs, ListContains n IsAdmin xs) => GuideAction ctx r
|
||||
162
src/Guide/Diff.hs
Normal file
162
src/Guide/Diff.hs
Normal file
@ -0,0 +1,162 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
{- | Diff- and merge-related things.
|
||||
-}
|
||||
module Guide.Diff
|
||||
(
|
||||
-- * Diffing
|
||||
Diff(..),
|
||||
DiffChunk(..),
|
||||
diff,
|
||||
|
||||
-- * Merging
|
||||
merge,
|
||||
|
||||
-- * Tokenizing
|
||||
tokenize,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Imports
|
||||
|
||||
-- Vector
|
||||
import qualified Data.Vector as V
|
||||
import Data.Vector (Vector)
|
||||
-- Diffing
|
||||
import qualified Data.Patch as PV
|
||||
|
||||
import Guide.Diff.Tokenize (tokenize)
|
||||
import Guide.Diff.Merge (merge)
|
||||
|
||||
|
||||
-- | Result of a diff.
|
||||
data Diff = Diff {
|
||||
diffContextAbove :: [Text], -- ^ Context (unchanged parts)
|
||||
-- above the differing part
|
||||
diffContextBelow :: [Text], -- ^ Context below the differing part
|
||||
diffLeft :: [DiffChunk], -- ^ Will contain only 'Deleted' and 'Plain'
|
||||
diffRight :: [DiffChunk] -- ^ Will contain only 'Added' and 'Plain'
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data DiffChunk
|
||||
= Deleted Text -- ^ Something was deleted (from the left side)
|
||||
| Added Text -- ^ Something was added (to the right side)
|
||||
| Plain Text -- ^ This part should be rendered as not modified
|
||||
deriving (Eq, Show)
|
||||
|
||||
flip makeLensesFor ''Diff
|
||||
[ ("diffContextAbove", "_diffContextAbove")
|
||||
, ("diffContextBelow", "_diffContextBelow") ]
|
||||
|
||||
diff
|
||||
:: Text -- ^ Original text
|
||||
-> Text -- ^ Edited text
|
||||
-> Diff
|
||||
diff (tokenize -> orig) (tokenize -> edit) =
|
||||
trimDiff (diffL (PV.hunks diffBA (V.fromList edit')))
|
||||
(diffR (PV.hunks diffAB (V.fromList orig')))
|
||||
& _diffContextAbove %~ (prefix <>)
|
||||
& _diffContextBelow %~ (<> suffix)
|
||||
where
|
||||
-- we find common parts in advance because diffs are O(mn) and removing
|
||||
-- big unchanged parts in advance helps us
|
||||
(prefix, (orig', edit'), suffix) = commonParts orig edit
|
||||
-- then we compute orig→edit and edit→orig diffs
|
||||
diffAB = PV.diff (V.fromList orig') (V.fromList edit')
|
||||
diffBA = PV.inverse diffAB
|
||||
|
||||
-- | Create a diff for the right (edited) part. We only want to highlight
|
||||
-- parts which were inserted or replaced.
|
||||
diffR :: PV.Hunks Text -> [DiffChunk]
|
||||
diffR = removeExtraAdded . concatMap hunkToChunk
|
||||
where
|
||||
hunkToChunk (v, PV.Inserted) = [Added (tconcat v)]
|
||||
hunkToChunk (v, PV.Replaced) = [Added (tconcat v)]
|
||||
hunkToChunk (v, PV.Unchanged) = map Plain (toList v)
|
||||
-- it's useful to report deleted things as well because then we can mark
|
||||
-- them with tiny rectangles like “insert here”
|
||||
hunkToChunk (_, PV.Deleted) = [Added ""]
|
||||
-- however, we don't need them if there's already an addition marked there
|
||||
removeExtraAdded (Added "" : Added x : xs) =
|
||||
removeExtraAdded (Added x : xs)
|
||||
removeExtraAdded (Added x : Added "" : xs) =
|
||||
removeExtraAdded (Added x : xs)
|
||||
removeExtraAdded (x : xs) =
|
||||
x : removeExtraAdded xs
|
||||
removeExtraAdded [] = []
|
||||
|
||||
-- | Create a diff for the left (original) part. We only want to highlight
|
||||
-- parts which were deleted or replaced.
|
||||
--
|
||||
-- This function should receive a diff that goes in reverse (i.e. from edited
|
||||
-- text to original text)
|
||||
diffL :: PV.Hunks Text -> [DiffChunk]
|
||||
diffL = removeExtraDeleted . concatMap hunkToChunk
|
||||
where
|
||||
-- Since the diff is edit→orig, this code might make not much sense at
|
||||
-- first. When something was “inserted” to original text when going
|
||||
-- edit→orig, it actually means that it was deleted from the original
|
||||
-- text when going orig→edit, and thus we want to render it as deleted.
|
||||
hunkToChunk (v, PV.Inserted) = [Deleted (tconcat v)]
|
||||
hunkToChunk (v, PV.Replaced) = [Deleted (tconcat v)]
|
||||
hunkToChunk (v, PV.Unchanged) = map Plain (toList v)
|
||||
hunkToChunk (_, PV.Deleted) = [Deleted ""]
|
||||
removeExtraDeleted (Deleted "" : Deleted x : xs) =
|
||||
removeExtraDeleted (Deleted x : xs)
|
||||
removeExtraDeleted (Deleted x : Deleted "" : xs) =
|
||||
removeExtraDeleted (Deleted x : xs)
|
||||
removeExtraDeleted (x : xs) =
|
||||
x : removeExtraDeleted xs
|
||||
removeExtraDeleted [] = []
|
||||
|
||||
-- | In a bunch of chunks, find only the part that was changed
|
||||
trimDiff
|
||||
:: [DiffChunk] -- ^ The diff after 'diffL'
|
||||
-> [DiffChunk] -- ^ The diff after 'diffR'
|
||||
-> Diff
|
||||
trimDiff a b =
|
||||
Diff {
|
||||
diffContextAbove = map getPlain prefix,
|
||||
diffContextBelow = map getPlain suffix,
|
||||
diffLeft = a',
|
||||
diffRight = b'
|
||||
}
|
||||
where
|
||||
(prefix, (a', b'), suffix) = commonParts a b
|
||||
-- since chunks in 'a' contain Deleted and Plain, and chunks in 'b'
|
||||
-- contain Added and Plain, the only equal parts will be Plain
|
||||
getPlain (Plain x) = x
|
||||
getPlain x = error ("trimDiff: impossible: " ++ show x)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Utils
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
tconcat :: Vector Text -> Text
|
||||
tconcat = mconcat . toList
|
||||
|
||||
-- | Find longest common prefix
|
||||
commonPrefix :: Eq a => [a] -> [a] -> ([a], ([a], [a]))
|
||||
commonPrefix = go []
|
||||
where
|
||||
go p [] bs = (reverse p, ([], bs))
|
||||
go p as [] = (reverse p, (as, []))
|
||||
go p (a:as) (b:bs)
|
||||
| a == b = go (a:p) as bs
|
||||
| otherwise = (reverse p, (a:as, b:bs))
|
||||
|
||||
-- | Find longest common suffix
|
||||
commonSuffix :: Eq a => [a] -> [a] -> (([a], [a]), [a])
|
||||
commonSuffix a b = ((reverse neqA, reverse neqB), reverse eq)
|
||||
where
|
||||
(eq, (neqA, neqB)) = commonPrefix (reverse a) (reverse b)
|
||||
|
||||
-- | Find longest common prefix and suffix
|
||||
commonParts :: Eq a => [a] -> [a] -> ([a], ([a], [a]), [a])
|
||||
commonParts a b = (prefix, (a'', b''), suffix)
|
||||
where
|
||||
(prefix, (a', b')) = commonPrefix a b
|
||||
((a'', b''), suffix) = commonSuffix a' b'
|
||||
41
src/Guide/Diff/Merge.hs
Normal file
41
src/Guide/Diff/Merge.hs
Normal file
@ -0,0 +1,41 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
{- | An algorithm for merging users' edits. Specifically, there's just one
|
||||
function – 'merge' – and it simply does a three-way diff.
|
||||
-}
|
||||
module Guide.Diff.Merge
|
||||
(
|
||||
merge,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Imports
|
||||
|
||||
-- Text
|
||||
import qualified Data.Text.All as T
|
||||
-- Vector
|
||||
import qualified Data.Vector as V
|
||||
-- Diffing
|
||||
import qualified Data.Patch as PV
|
||||
|
||||
import Guide.Diff.Tokenize
|
||||
|
||||
|
||||
-- | An implementation of a 3-way diff and merge.
|
||||
merge
|
||||
:: Text -- ^ Original text
|
||||
-> Text -- ^ Variant A (preferred)
|
||||
-> Text -- ^ Variant B
|
||||
-> Text -- ^ Merged text
|
||||
merge (V.fromList . tokenize -> orig)
|
||||
(V.fromList . tokenize -> a)
|
||||
(V.fromList . tokenize -> b) =
|
||||
T.concat . toList $ PV.apply (pa <> pb') orig
|
||||
where
|
||||
-- 1. diff
|
||||
pa = PV.diff orig a
|
||||
pb = PV.diff orig b
|
||||
-- 2. merge
|
||||
(_, pb') = PV.transformWith PV.ours pa pb
|
||||
@ -1,13 +1,12 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
|
||||
{- |
|
||||
An algorithm for merging users' edits. Specifically, there's just one
|
||||
function – 'merge' – and it simply does a three-way diff.
|
||||
-}
|
||||
module Guide.Merge
|
||||
-- | Prepare text for diffing or merging by breaking it into tokens (like
|
||||
-- links or Markdown elements).
|
||||
module Guide.Diff.Tokenize
|
||||
(
|
||||
merge,
|
||||
tokenize,
|
||||
)
|
||||
where
|
||||
|
||||
@ -17,34 +16,29 @@ import Imports
|
||||
-- Text
|
||||
import qualified Data.Text.All as T
|
||||
import Data.List.Split
|
||||
-- Vector
|
||||
import qualified Data.Vector as V
|
||||
-- Diffing
|
||||
import qualified Data.Patch as PV
|
||||
|
||||
|
||||
-- | An implementation of a 3-way diff and merge.
|
||||
merge
|
||||
:: Text -- ^ Original text
|
||||
-> Text -- ^ Variant A (preferred)
|
||||
-> Text -- ^ Variant B
|
||||
-> Text -- ^ Merged text
|
||||
merge orig a b = T.concat . V.toList $ PV.apply (pa <> pb') orig'
|
||||
where
|
||||
(orig', a', b') = (orig, a, b) & each %~
|
||||
V.fromList . consolidate . map T.toStrict . break' . T.toString
|
||||
pa = PV.diff orig' a'
|
||||
pb = PV.diff orig' b'
|
||||
(_, pb') = PV.transformWith PV.ours pa pb
|
||||
-- | Break text into tokens.
|
||||
tokenize :: Text -> [Text]
|
||||
tokenize = consolidate . map T.toStrict . break' . T.toString
|
||||
|
||||
-- | Break a string into words, spaces, and special characters.
|
||||
break' :: String -> [String]
|
||||
break' = split . dropInitBlank . dropFinalBlank . dropInnerBlanks . whenElt $
|
||||
\c -> not (isAlphaNum c) && c /= '\''
|
||||
|
||||
-- | Consolidate some of the things into tokens (like links, consecutive
|
||||
-- spaces, and Markdown elements).
|
||||
-- | Consolidate some of the things into tokens.
|
||||
consolidate :: [Text] -> [Text]
|
||||
-- a word followed by a space, dot, or comma (this is needed to prevent
|
||||
-- spaces from being detected as “unchanged parts” and also to make diffs
|
||||
-- faster)
|
||||
consolidate (w:c:r)
|
||||
| T.all (\t -> isLetter t || t == '\'') w && c `elem` [" ",".",","] =
|
||||
(w <> c) : consolidate r
|
||||
-- glue newlines to ends of their lines
|
||||
consolidate (w:"\n":r)
|
||||
| not ("\n" `T.isSuffixOf` w) =
|
||||
(w <> "\n") : consolidate r
|
||||
-- spaces
|
||||
consolidate s@(" ":_) =
|
||||
let (l, r) = span (== " ") s
|
||||
@ -74,6 +68,23 @@ consolidate s@("https":":":"/":"/":_) =
|
||||
let (l, r) = span (\x -> x /= ")" && not (isSpace (T.head x))) s
|
||||
in T.concat l : consolidate r
|
||||
consolidate ("(":"@":"hk":")":xs) = "(" : "@hk" : ")" : consolidate xs
|
||||
|
||||
-- Haskell operators
|
||||
consolidate (op -> (x, xs))
|
||||
| not (T.null x) = x : consolidate xs
|
||||
-- Haskell tokens
|
||||
consolidate ("[":"]":xs) = "[]" : consolidate xs
|
||||
consolidate ("(":")":xs) = "()" : consolidate xs
|
||||
consolidate ("[":"|":xs) = "[|" : consolidate xs
|
||||
consolidate ("|":"]":xs) = "|]" : consolidate xs
|
||||
|
||||
-- the rest
|
||||
consolidate (x:xs) = x : consolidate xs
|
||||
consolidate [] = []
|
||||
|
||||
-- | Helpful view pattern for matching operators
|
||||
op :: [Text] -> (Text, [Text])
|
||||
op = over _1 mconcat . span (isOpToken . T.unpack)
|
||||
where
|
||||
isOpToken [c] = c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String)
|
||||
isOpToken _ = False
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{- |
|
||||
All rest API handlers.
|
||||
@ -10,6 +10,7 @@ module Guide.Handlers
|
||||
(
|
||||
methods,
|
||||
adminMethods,
|
||||
getLoggedInUser,
|
||||
)
|
||||
where
|
||||
|
||||
@ -34,10 +35,11 @@ import Network.Wai.Middleware.Cors
|
||||
import Lucid hiding (for_)
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
|
||||
import Guide.App
|
||||
import Guide.ServerStuff
|
||||
import Guide.Config
|
||||
import Guide.Cache
|
||||
import Guide.Merge
|
||||
import Guide.Diff (merge)
|
||||
import Guide.Markdown
|
||||
import Guide.State
|
||||
import Guide.Types
|
||||
@ -45,8 +47,7 @@ import Guide.Api.ClientTypes (toCGrandCategory, toCCategoryDetail)
|
||||
import Guide.Utils
|
||||
import Guide.Views
|
||||
|
||||
|
||||
methods :: SpockM () () ServerState ()
|
||||
methods :: GuideM ctx ()
|
||||
methods = do
|
||||
apiMethods
|
||||
renderMethods
|
||||
@ -54,7 +55,7 @@ methods = do
|
||||
addMethods
|
||||
otherMethods
|
||||
|
||||
apiMethods :: SpockM () () ServerState ()
|
||||
apiMethods :: GuideM ctx ()
|
||||
apiMethods = Spock.subcomponent "api" $ do
|
||||
middleware simpleCors
|
||||
Spock.get "all-categories" $ do
|
||||
@ -65,7 +66,7 @@ apiMethods = Spock.subcomponent "api" $ do
|
||||
cat <- dbQuery (GetCategory catId)
|
||||
json $ toCCategoryDetail cat
|
||||
|
||||
renderMethods :: SpockM () () ServerState ()
|
||||
renderMethods :: GuideM ctx ()
|
||||
renderMethods = Spock.subcomponent "render" $ do
|
||||
-- Notes for a category
|
||||
Spock.get (categoryVar <//> "notes") $ \catId -> do
|
||||
@ -97,7 +98,7 @@ renderMethods = Spock.subcomponent "render" $ do
|
||||
category <- dbQuery (GetCategoryByItem itemId)
|
||||
lucidIO $ renderItemNotes category item
|
||||
|
||||
setMethods :: SpockM () () ServerState ()
|
||||
setMethods :: GuideM ctx ()
|
||||
setMethods = Spock.subcomponent "set" $ do
|
||||
Spock.post (categoryVar <//> "info") $ \catId -> do
|
||||
-- TODO: [easy] add a cross-link saying where the form is handled in the
|
||||
@ -274,7 +275,7 @@ setMethods = Spock.subcomponent "set" $ do
|
||||
("modified" :: Text, modified),
|
||||
("merged" :: Text, merge original content' modified)]
|
||||
|
||||
addMethods :: SpockM () () ServerState ()
|
||||
addMethods :: GuideM ctx ()
|
||||
addMethods = Spock.subcomponent "add" $ do
|
||||
-- New category
|
||||
Spock.post "category" $ do
|
||||
@ -328,7 +329,7 @@ addMethods = Spock.subcomponent "add" $ do
|
||||
addEdit edit
|
||||
lucidIO $ renderTrait itemId newTrait
|
||||
|
||||
otherMethods :: SpockM () () ServerState ()
|
||||
otherMethods :: GuideM ctx ()
|
||||
otherMethods = do
|
||||
-- Moving things
|
||||
Spock.subcomponent "move" $ do
|
||||
@ -385,7 +386,7 @@ otherMethods = do
|
||||
Atom.feedEntries = entries,
|
||||
Atom.feedLinks = [Atom.nullLink (T.unpack feedUrl)] }
|
||||
|
||||
adminMethods :: SpockM () () ServerState ()
|
||||
adminMethods :: AdminM ctx ()
|
||||
adminMethods = Spock.subcomponent "admin" $ do
|
||||
-- Accept an edit
|
||||
Spock.post ("edit" <//> var <//> "accept") $ \n -> do
|
||||
@ -426,6 +427,14 @@ adminMethods = Spock.subcomponent "admin" $ do
|
||||
-- Utils
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
-- | Retrieve the User based on the current session
|
||||
getLoggedInUser :: GuideAction ctx (Maybe User)
|
||||
getLoggedInUser = do
|
||||
sess <- readSession
|
||||
case sess ^. sessionUserID of
|
||||
Nothing -> return Nothing
|
||||
Just uid -> dbQuery $ GetUser uid
|
||||
|
||||
itemToFeedEntry
|
||||
:: (MonadIO m)
|
||||
=> Url -> Category -> Item -> m Atom.Entry
|
||||
|
||||
@ -3,7 +3,8 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{- |
|
||||
The main module.
|
||||
@ -11,7 +12,7 @@ The main module.
|
||||
* Run 'main' to actually start the server.
|
||||
* Run 'mainWith' to run it with a custom config.
|
||||
-}
|
||||
module Guide.Server
|
||||
module Guide.Main
|
||||
(
|
||||
main,
|
||||
mainWith,
|
||||
@ -21,10 +22,13 @@ where
|
||||
|
||||
import Imports
|
||||
|
||||
-- Containers
|
||||
import qualified Data.Map as M
|
||||
-- Monads and monad transformers
|
||||
import Control.Monad.Morph
|
||||
-- Text
|
||||
import qualified Data.Text.All as T
|
||||
import NeatInterpolation (text)
|
||||
-- Web
|
||||
import Web.Spock hiding (head, get, text)
|
||||
import qualified Web.Spock as Spock
|
||||
@ -32,7 +36,8 @@ import Web.Spock.Config
|
||||
import Web.Spock.Lucid
|
||||
import Lucid hiding (for_)
|
||||
import Network.Wai.Middleware.Static (staticPolicy, addBase)
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
-- Spock-digestive
|
||||
import Web.Spock.Digestive (runForm)
|
||||
-- Highlighting
|
||||
import CMark.Highlight (styleToCss, pygments)
|
||||
-- Monitoring
|
||||
@ -48,17 +53,21 @@ import qualified SlaveThread as Slave
|
||||
import System.Posix.Signals
|
||||
-- Watching the templates directory
|
||||
import qualified System.FSNotify as FSNotify
|
||||
-- HVect
|
||||
import Data.HVect hiding (length)
|
||||
|
||||
import Guide.App
|
||||
import Guide.ServerStuff
|
||||
import Guide.Handlers
|
||||
import Guide.Config
|
||||
import Guide.State
|
||||
import Guide.Types
|
||||
import Guide.Views
|
||||
import Guide.Views.Utils (getJS, getCSS, fromCategorySlug)
|
||||
import Guide.Views.Utils (getJS, getCSS, fromCategorySlug, protectForm, getCsrfHeader)
|
||||
import Guide.JS (JS(..), allJSFunctions)
|
||||
import Guide.Utils
|
||||
import Guide.Cache
|
||||
import Guide.Session
|
||||
|
||||
|
||||
{- Note [acid-state]
|
||||
@ -136,6 +145,8 @@ mainWith config = do
|
||||
_actions = [],
|
||||
_pendingEdits = [],
|
||||
_editIdCounter = 0,
|
||||
_sessionStore = M.empty,
|
||||
_users = M.empty,
|
||||
_dirty = True }
|
||||
do args <- getArgs
|
||||
when (args == ["--dry-run"]) $ do
|
||||
@ -179,43 +190,69 @@ mainWith config = do
|
||||
EKG.Gauge.set categoryGauge (fromIntegral (length allCategories))
|
||||
EKG.Gauge.set itemGauge (fromIntegral (length allItems))
|
||||
threadDelay (1000000 * 60)
|
||||
-- Create an admin user
|
||||
-- Run the server
|
||||
let serverState = ServerState {
|
||||
_config = config,
|
||||
_db = db }
|
||||
spockConfig <- do
|
||||
cfg <- defaultSpockCfg () PCNoDatabase serverState
|
||||
store <- newAcidSessionStore db
|
||||
let sessionCfg = SessionCfg {
|
||||
sc_cookieName = "spockcookie",
|
||||
sc_sessionTTL = 3600,
|
||||
sc_sessionIdEntropy = 64,
|
||||
sc_sessionExpandTTL = True,
|
||||
sc_emptySession = emptyGuideData,
|
||||
sc_store = store,
|
||||
sc_housekeepingInterval = 60 * 10,
|
||||
sc_hooks = defaultSessionHooks
|
||||
}
|
||||
return cfg {
|
||||
spc_maxRequestSize = Just (1024*1024) }
|
||||
spc_maxRequestSize = Just (1024*1024),
|
||||
spc_csrfProtection = True,
|
||||
spc_sessionCfg = sessionCfg }
|
||||
when (_prerender config) $ prerenderPages config db
|
||||
runSpock 3080 $ spock spockConfig $ do
|
||||
runSpock 3080 $ spock spockConfig $ guideApp waiMetrics
|
||||
|
||||
-- TODO: Fix indentation after rebasing.
|
||||
guideApp :: EKG.WaiMetrics -> GuideApp ()
|
||||
guideApp waiMetrics = do
|
||||
createAdminUser -- TODO: perhaps it needs to be inside of “prehook
|
||||
-- initHook”? (I don't actually know what “prehook
|
||||
-- initHook” does, feel free to edit.)
|
||||
prehook initHook $ do
|
||||
middleware (EKG.metrics waiMetrics)
|
||||
middleware (staticPolicy (addBase "static"))
|
||||
-- Javascript
|
||||
Spock.get "/js.js" $ do
|
||||
setHeader "Content-Type" "application/javascript; charset=utf-8"
|
||||
(csrfTokenName, csrfTokenValue) <- getCsrfHeader
|
||||
let jqueryCsrfProtection = [text|
|
||||
guidejs.csrfProtection.enable("$csrfTokenName", "$csrfTokenValue");
|
||||
|]
|
||||
js <- getJS
|
||||
Spock.bytes $ T.encodeUtf8 (fromJS allJSFunctions <> js)
|
||||
Spock.bytes $ T.toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
|
||||
-- CSS
|
||||
Spock.get "/highlight.css" $ do
|
||||
setHeader "Content-Type" "text/css; charset=utf-8"
|
||||
Spock.bytes $ T.encodeUtf8 (T.pack (styleToCss pygments))
|
||||
Spock.bytes $ T.toByteString (styleToCss pygments)
|
||||
Spock.get "/css.css" $ do
|
||||
setHeader "Content-Type" "text/css; charset=utf-8"
|
||||
css <- getCSS
|
||||
Spock.bytes $ T.encodeUtf8 css
|
||||
Spock.bytes $ T.toByteString css
|
||||
Spock.get "/admin.css" $ do
|
||||
setHeader "Content-Type" "text/css; charset=utf-8"
|
||||
css <- getCSS
|
||||
admincss <- liftIO $ T.readFile "static/admin.css"
|
||||
Spock.bytes $ T.encodeUtf8 (css <> admincss)
|
||||
Spock.bytes $ T.toByteString (css <> admincss)
|
||||
|
||||
-- Main page
|
||||
Spock.get root $
|
||||
lucidWithConfig $ renderRoot
|
||||
|
||||
-- Admin page
|
||||
prehook adminHook $ do
|
||||
prehook authHook $ prehook adminHook $ do
|
||||
Spock.get "admin" $ do
|
||||
s <- dbQuery GetGlobalState
|
||||
lucidIO $ renderAdmin s
|
||||
@ -271,19 +308,89 @@ mainWith config = do
|
||||
methods
|
||||
|
||||
Spock.subcomponent "auth" $ do
|
||||
Spock.get "login" $ lucidWithConfig renderLogin
|
||||
-- plain "/auth" logs out a logged-in user and lets a logged-out user
|
||||
-- log in (this is not the best idea, granted, and we should just
|
||||
-- shot logged-in users a “logout” link and logged-out users a
|
||||
-- “login” link instead)
|
||||
Spock.get root $ do
|
||||
user <- getLoggedInUser
|
||||
if isJust user
|
||||
then Spock.redirect "auth/logout"
|
||||
else Spock.redirect "auth/login"
|
||||
Spock.getpost "login" $ authRedirect "/" $ loginAction
|
||||
Spock.get "logout" $ logoutAction
|
||||
Spock.getpost "register" $ authRedirect "/" $ signupAction
|
||||
|
||||
Spock.get "register" $ lucidWithConfig renderRegister
|
||||
loginAction :: GuideAction ctx ()
|
||||
loginAction = do
|
||||
r <- runForm "login" loginForm
|
||||
case r of
|
||||
(v, Nothing) -> do
|
||||
formHtml <- protectForm loginFormView v
|
||||
lucidWithConfig $ renderRegister formHtml
|
||||
(v, Just Login {..}) -> do
|
||||
loginAttempt <- dbQuery $
|
||||
LoginUser loginEmail (T.toByteString loginUserPassword)
|
||||
case loginAttempt of
|
||||
Just user -> do
|
||||
modifySession (sessionUserID .~ Just (user ^. userID))
|
||||
Spock.redirect "/"
|
||||
-- TODO: show error message/validation of input
|
||||
Nothing -> do
|
||||
formHtml <- protectForm loginFormView v
|
||||
lucidWithConfig $ renderRegister formHtml
|
||||
|
||||
adminHook :: ActionCtxT ctx (WebStateM () () ServerState) ()
|
||||
logoutAction :: GuideAction ctx ()
|
||||
logoutAction = do
|
||||
modifySession (sessionUserID .~ Nothing)
|
||||
Spock.redirect "/"
|
||||
|
||||
signupAction :: GuideAction ctx ()
|
||||
signupAction = do
|
||||
r <- runForm "register" registerForm
|
||||
case r of
|
||||
(v, Nothing) -> do
|
||||
formHtml <- protectForm registerFormView v
|
||||
lucidWithConfig $ renderRegister formHtml
|
||||
(v, Just UserRegistration {..}) -> do
|
||||
user <- makeUser registerUserName registerUserEmail
|
||||
(T.toByteString registerUserPassword)
|
||||
success <- dbUpdate $ CreateUser user
|
||||
if success
|
||||
then do
|
||||
modifySession (sessionUserID .~ Just (user ^. userID))
|
||||
Spock.redirect ""
|
||||
else do
|
||||
formHtml <- protectForm registerFormView v
|
||||
lucidWithConfig $ renderRegister formHtml
|
||||
|
||||
initHook :: GuideAction () (HVect '[])
|
||||
initHook = return HNil
|
||||
|
||||
authHook :: GuideAction (HVect xs) (HVect (User ': xs))
|
||||
authHook = do
|
||||
oldCtx <- getContext
|
||||
maybeUser <- getLoggedInUser
|
||||
case maybeUser of
|
||||
Nothing -> Spock.text "Not logged in."
|
||||
Just user -> return (user :&: oldCtx)
|
||||
|
||||
adminHook :: ListContains n User xs => GuideAction (HVect xs) (HVect (IsAdmin ': xs))
|
||||
adminHook = do
|
||||
adminPassword <- _adminPassword <$> getConfig
|
||||
unless (adminPassword == "") $ do
|
||||
let check user pass =
|
||||
unless (user == "admin" && pass == adminPassword) $ do
|
||||
Spock.setStatus HTTP.status401
|
||||
Spock.text "Wrong password!"
|
||||
Spock.requireBasicAuth "Authenticate (login = admin)" check return
|
||||
oldCtx <- getContext
|
||||
let user = findFirst oldCtx
|
||||
if user ^. userIsAdmin
|
||||
then return (IsAdmin :&: oldCtx)
|
||||
else Spock.text "Not authorized."
|
||||
|
||||
-- |Redirect the user to a given path if they are logged in.
|
||||
authRedirect :: Text -> GuideAction ctx a -> GuideAction ctx a
|
||||
authRedirect path action = do
|
||||
user <- getLoggedInUser
|
||||
case user of
|
||||
Just _ -> do
|
||||
Spock.redirect path
|
||||
Nothing -> action
|
||||
|
||||
-- TODO: a function to find all links to Hackage that have version in them
|
||||
|
||||
@ -328,3 +435,13 @@ installTerminationCatcher :: ThreadId -> IO ()
|
||||
installTerminationCatcher thread = void $ do
|
||||
installHandler sigINT (CatchOnce (throwTo thread CtrlC)) Nothing
|
||||
installHandler sigTERM (CatchOnce (throwTo thread ServiceStop)) Nothing
|
||||
|
||||
-- | Create an admin user (with login “admin”, email “admin@guide.aelve.com”
|
||||
-- and password specified in the config).
|
||||
--
|
||||
-- The user won't be added if it exists already.
|
||||
createAdminUser :: GuideApp ()
|
||||
createAdminUser = do
|
||||
pass <- T.toByteString . _adminPassword <$> getConfig
|
||||
user <- makeUser "admin" "admin@guide.aelve.com" pass
|
||||
void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True)
|
||||
@ -97,9 +97,9 @@ renderMD :: [MD.Node] -> ByteString
|
||||
renderMD ns
|
||||
-- See https://github.com/jgm/cmark/issues/147
|
||||
| any isInlineNode ns =
|
||||
T.encodeUtf8 . sanitize . T.concat . map (nodeToHtml []) $ ns
|
||||
T.toByteString . sanitize . T.concat . map (nodeToHtml []) $ ns
|
||||
| otherwise =
|
||||
T.encodeUtf8 . sanitize . nodeToHtml [] $ MD.Node Nothing DOCUMENT ns
|
||||
T.toByteString . sanitize . nodeToHtml [] $ MD.Node Nothing DOCUMENT ns
|
||||
|
||||
isInlineNode :: MD.Node -> Bool
|
||||
isInlineNode (MD.Node _ tp _) = case tp of
|
||||
@ -301,11 +301,11 @@ instance Show MarkdownTree where
|
||||
instance A.ToJSON MarkdownInline where
|
||||
toJSON md = A.object [
|
||||
"text" A..= (md^.mdText),
|
||||
"html" A..= T.decodeUtf8 (md^.mdHtml) ]
|
||||
"html" A..= T.toStrict (md^.mdHtml) ]
|
||||
instance A.ToJSON MarkdownBlock where
|
||||
toJSON md = A.object [
|
||||
"text" A..= (md^.mdText),
|
||||
"html" A..= T.decodeUtf8 (md^.mdHtml) ]
|
||||
"html" A..= T.toStrict (md^.mdHtml) ]
|
||||
instance A.ToJSON MarkdownTree where
|
||||
toJSON md = A.object [
|
||||
"text" A..= (md^.mdText),
|
||||
|
||||
@ -1,156 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
|
||||
-- Hack for bug in older Cabal versions
|
||||
#ifndef MIN_VERSION_template_haskell
|
||||
#define MIN_VERSION_template_haskell(x,y,z) 1
|
||||
#endif
|
||||
|
||||
|
||||
{- |
|
||||
Safecopy utilities.
|
||||
-}
|
||||
module Guide.SafeCopy
|
||||
(
|
||||
deriveSafeCopySorted,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import BasePrelude hiding (Version)
|
||||
import Data.Serialize (getWord8, putWord8, label)
|
||||
import Data.SafeCopy
|
||||
import Data.SafeCopy.Internal
|
||||
import Language.Haskell.TH.Syntax
|
||||
#if MIN_VERSION_template_haskell(2,8,0)
|
||||
import Language.Haskell.TH hiding (Kind)
|
||||
#else
|
||||
import Language.Haskell.TH hiding (Kind(..))
|
||||
#endif
|
||||
|
||||
-- | Sorts fields (but not constructors), uses 'Simple' encoding, only works
|
||||
-- on records.
|
||||
deriveSafeCopySorted :: Version a -> Name -> Name -> Q [Dec]
|
||||
deriveSafeCopySorted = internalDeriveSafeCopySorted
|
||||
|
||||
internalDeriveSafeCopySorted :: Version a -> Name -> Name -> Q [Dec]
|
||||
internalDeriveSafeCopySorted versionId kindName tyName = do
|
||||
info <- reify tyName
|
||||
internalDeriveSafeCopySorted' versionId kindName tyName info
|
||||
|
||||
internalDeriveSafeCopySorted' :: Version a -> Name -> Name -> Info -> Q [Dec]
|
||||
internalDeriveSafeCopySorted' versionId kindName tyName info =
|
||||
case info of
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
TyConI (DataD context _name tyvars _kind cons _derivs)
|
||||
#else
|
||||
TyConI (DataD context _name tyvars cons _derivs)
|
||||
#endif
|
||||
| length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++
|
||||
". The datatype must have less than 256 constructors."
|
||||
| otherwise -> worker context tyvars (zip [0..] cons)
|
||||
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
TyConI (NewtypeD context _name tyvars _kind con _derivs) ->
|
||||
#else
|
||||
TyConI (NewtypeD context _name tyvars con _derivs) ->
|
||||
#endif
|
||||
worker context tyvars [(0, con)]
|
||||
|
||||
FamilyI _ insts -> do
|
||||
decs <- forM insts $ \inst ->
|
||||
case inst of
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
DataInstD context _name ty _kind cons _derivs ->
|
||||
#else
|
||||
DataInstD context _name ty cons _derivs ->
|
||||
#endif
|
||||
worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons)
|
||||
|
||||
#if MIN_VERSION_template_haskell(2,11,0)
|
||||
NewtypeInstD context _name ty _kind con _derivs ->
|
||||
#else
|
||||
NewtypeInstD context _name ty con _derivs ->
|
||||
#endif
|
||||
worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)]
|
||||
_ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst)
|
||||
return $ concat decs
|
||||
_ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info)
|
||||
where
|
||||
worker = worker' (conT tyName)
|
||||
worker' tyBase context tyvars cons =
|
||||
let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ]
|
||||
#if MIN_VERSION_template_haskell(2,10,0)
|
||||
safeCopyClass args = foldl appT (conT ''SafeCopy) args
|
||||
#else
|
||||
safeCopyClass args = classP ''SafeCopy args
|
||||
#endif
|
||||
in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context)
|
||||
(conT ''SafeCopy `appT` ty)
|
||||
[ mkPutCopySorted cons
|
||||
, mkGetCopySorted (show tyName) cons
|
||||
, valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) []
|
||||
, valD (varP 'kind) (normalB (varE kindName)) []
|
||||
, funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []]
|
||||
]
|
||||
|
||||
mkPutCopySorted :: [(Integer, Con)] -> DecQ
|
||||
mkPutCopySorted cons =
|
||||
funD 'putCopy (map mkPutClause cons)
|
||||
where
|
||||
manyConstructors = length cons > 1
|
||||
mkPutClause (conNumber, RecC recName (sortFields -> fields)) = do
|
||||
arg <- newName "arg"
|
||||
let putConNumber = [|putWord8 $(lift conNumber)|]
|
||||
putField (field, _, _) = [|safePut ($(varE field) $(varE arg))|]
|
||||
putCopyBody = varE 'contain `appE` doE (
|
||||
[ noBindS putConNumber | manyConstructors ] ++
|
||||
[ noBindS (putField f) | f <- fields ] )
|
||||
clause [asP arg (recP recName [])] (normalB putCopyBody) []
|
||||
mkPutClause (_, con) =
|
||||
fail ("Only record constructors are supported: " ++ show (conName con))
|
||||
|
||||
mkGetCopySorted :: String -> [(Integer, Con)] -> DecQ
|
||||
mkGetCopySorted tyName cons =
|
||||
valD (varP 'getCopy) (normalB [|contain $mkLabel|]) []
|
||||
where
|
||||
mkLabel = [|label $(lift labelString) $getCopyBody|]
|
||||
labelString = tyName ++ ":"
|
||||
getCopyBody = case cons of
|
||||
[(_, con)] -> mkGetBody con
|
||||
_ -> do
|
||||
tagVar <- newName "tag"
|
||||
let conMatch (i, con) =
|
||||
match (litP $ IntegerL i) (normalB $ mkGetBody con) []
|
||||
let noConMatch =
|
||||
match wildP (normalB [|fail $(errorMsg tagVar)|]) []
|
||||
doE [ bindS (varP tagVar) [|getWord8|]
|
||||
, noBindS $ caseE (varE tagVar)
|
||||
(map conMatch cons ++ [noConMatch]) ]
|
||||
mkGetBody (RecC recName (sortFields -> fields)) = do
|
||||
fieldVars <- mapM newName [nameBase f | (f, _, _) <- fields]
|
||||
let getField fieldVar = bindS (varP fieldVar) [|safeGet|]
|
||||
let makeRecord = recConE recName
|
||||
[(f,) <$> varE v | ((f, _, _), v) <- zip fields fieldVars]
|
||||
doE ([ getField v | v <- fieldVars ] ++
|
||||
[ noBindS [|return $makeRecord|] ])
|
||||
mkGetBody con =
|
||||
fail ("Only record constructors are supported: " ++ show (conName con))
|
||||
errorMsg tagVar = [|$(lift s1) ++ show $(varE tagVar) ++ $(lift s2)|]
|
||||
where
|
||||
s1, s2 :: String
|
||||
s1 = "Could not identify tag \""
|
||||
s2 = concat [ "\" for type "
|
||||
, show tyName
|
||||
, " that has only "
|
||||
, show (length cons)
|
||||
, " constructors. Maybe your data is corrupted?" ]
|
||||
|
||||
sortFields :: [VarStrictType] -> [VarStrictType]
|
||||
-- We sort by length and then lexicographically, so that relative ordering
|
||||
-- would be preserved when version suffix is added – otherwise these fields
|
||||
-- would be sorted in different order after adding a suffix:
|
||||
--
|
||||
-- foo fooBar_v3
|
||||
-- fooBar foo_v3
|
||||
sortFields = sortOn (\(n, _, _) -> (length (nameBase n), nameBase n))
|
||||
92
src/Guide/Session.hs
Normal file
92
src/Guide/Session.hs
Normal file
@ -0,0 +1,92 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Guide.Session
|
||||
(
|
||||
newAcidSessionStore
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
-- Spock
|
||||
import Web.Spock.Config
|
||||
-- acid-state
|
||||
import Data.Acid as Acid
|
||||
|
||||
import Guide.State
|
||||
import Guide.Types.Session
|
||||
|
||||
-- |Queries for all user sessions and then removes sessions unless predicate matches.
|
||||
filterSessions :: AcidState GlobalState -> (SpockSession conn st -> Bool) -> IO ()
|
||||
filterSessions db p = do
|
||||
sessions <- Acid.query db GetSessions
|
||||
for_ sessions $ \sess -> do
|
||||
unless (p $ unwrapSession sess) $
|
||||
Acid.update db $ DeleteSession (sess ^. sess_id)
|
||||
|
||||
-- |Queries for all user sessions and then performs an operation over all.
|
||||
mapSessions :: MonadIO m => AcidState GlobalState -> (SpockSession conn st -> m (SpockSession conn st)) -> m ()
|
||||
mapSessions db f = do
|
||||
sessions <- liftIO $ Acid.query db GetSessions
|
||||
for_ sessions $ \sess -> do
|
||||
newSess <- f (unwrapSession sess)
|
||||
liftIO $ Acid.update db $ StoreSession (wrapSession newSess)
|
||||
|
||||
-- |Wraps an STM session store and periodically commits session to the database.
|
||||
newAcidSessionStore' :: AcidState GlobalState -> IO (SessionStore (SpockSession conn st) IO)
|
||||
newAcidSessionStore' db = do
|
||||
-- See Note [Session Linearizability]
|
||||
lock <- newMVar ()
|
||||
return $ SessionStore {
|
||||
ss_runTx = withMVar lock . const,
|
||||
ss_loadSession = \sessId -> do
|
||||
sess <- Acid.query db $ LoadSession sessId
|
||||
return $ unwrapSession <$> sess,
|
||||
ss_deleteSession = Acid.update db . DeleteSession,
|
||||
ss_storeSession = Acid.update db . StoreSession . wrapSession,
|
||||
ss_toList = do
|
||||
sessions <- Acid.query db GetSessions
|
||||
return $ map unwrapSession sessions,
|
||||
ss_filterSessions = filterSessions db,
|
||||
ss_mapSessions = mapSessions db
|
||||
}
|
||||
|
||||
newAcidSessionStore :: AcidState GlobalState -> IO (SessionStoreInstance (SpockSession conn st))
|
||||
newAcidSessionStore db = SessionStoreInstance <$> newAcidSessionStore' db
|
||||
|
||||
{- Note [Session Linearizability]
|
||||
|
||||
Acid-State transactions are, I believe, serializable by default.
|
||||
Updates can be issued in parallel, and the temporal ordering of each update
|
||||
can vary, but each atomic update can be executed in arbitrary order.
|
||||
|
||||
Acid-state may also be sequentially consistent, not sure. It's definitely
|
||||
not linearizable, which is a property we really want for session data
|
||||
types. In other words, we can have data races.
|
||||
|
||||
Consider two actions taken by an administrator:
|
||||
|
||||
* Administrator updates user profiles to remove access rights,
|
||||
running GetSession and then StoreSession, via filterSessions or mapSessions.
|
||||
|
||||
* Eve at the same time updates their user profile to change their user name,
|
||||
running LoadSession and then StoreSession.
|
||||
|
||||
Since filterSession is not atomic, this sequence could occur:
|
||||
|
||||
| Process | Command | Context
|
||||
| Admin | GetSessions | mapSessions runs GetSessions, obtaining a list of all sessions
|
||||
| Eve | LoadSession | user profile page view
|
||||
| Admin | StoreSession | mapSessions runs StoreSession for Eve, removing permissions
|
||||
| Eve | StoreSession | Eve clicks "save profile" which refreshes her session
|
||||
|
||||
This is a classic race condition. So we use a lock on the Session Store.
|
||||
|
||||
-}
|
||||
@ -75,6 +75,14 @@ module Guide.State
|
||||
RestoreItem(..),
|
||||
RestoreTrait(..),
|
||||
SetDirty(..), UnsetDirty(..),
|
||||
|
||||
LoadSession(..), StoreSession(..),
|
||||
DeleteSession(..), GetSessions(..),
|
||||
|
||||
GetUser(..), CreateUser(..), DeleteUser(..),
|
||||
LoginUser(..),
|
||||
|
||||
GetAdminUsers(..)
|
||||
)
|
||||
where
|
||||
|
||||
@ -90,14 +98,18 @@ import qualified Data.Text.All as T
|
||||
import Data.IP
|
||||
-- acid-state
|
||||
import Data.SafeCopy hiding (kind)
|
||||
import Data.SafeCopy.Migrate
|
||||
import Data.Acid as Acid
|
||||
--
|
||||
import Web.Spock.Internal.SessionManager (SessionId)
|
||||
|
||||
import Guide.Utils
|
||||
import Guide.SafeCopy
|
||||
import Guide.Markdown
|
||||
import Guide.Types.Core
|
||||
import Guide.Types.Edit
|
||||
import Guide.Types.Action
|
||||
import Guide.Types.Session
|
||||
import Guide.Types.User
|
||||
|
||||
|
||||
{- Note [extending types]
|
||||
@ -172,15 +184,22 @@ data GlobalState = GlobalState {
|
||||
_pendingEdits :: [(Edit, EditDetails)],
|
||||
-- | ID of next edit that will be made
|
||||
_editIdCounter :: Int,
|
||||
-- | Sessions
|
||||
_sessionStore :: Map SessionId GuideSession,
|
||||
-- | Users
|
||||
_users :: Map (Uid User) User,
|
||||
-- | The dirty bit (needed to choose whether to make a checkpoint or not)
|
||||
_dirty :: Bool }
|
||||
deriving (Show)
|
||||
|
||||
deriveSafeCopySorted 7 'extension ''GlobalState
|
||||
deriveSafeCopySorted 8 'extension ''GlobalState
|
||||
makeLenses ''GlobalState
|
||||
|
||||
changelog ''GlobalState (Current 7, Past 6) []
|
||||
deriveSafeCopySorted 6 'base ''GlobalState_v6
|
||||
changelog ''GlobalState (Current 8, Past 7) [
|
||||
Added "_sessionStore" [hs|M.empty|],
|
||||
Added "_users" [hs|M.empty|]
|
||||
]
|
||||
deriveSafeCopySorted 7 'base ''GlobalState_v7
|
||||
|
||||
addGroupIfDoesNotExist :: Text -> Map Text Hue -> Map Text Hue
|
||||
addGroupIfDoesNotExist g gs
|
||||
@ -683,6 +702,78 @@ setDirty = dirty .= True
|
||||
unsetDirty :: Acid.Update GlobalState Bool
|
||||
unsetDirty = dirty <<.= False
|
||||
|
||||
-- | Retrieves a session by 'SessionID'.
|
||||
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
|
||||
loadSession :: SessionId -> Acid.Query GlobalState (Maybe GuideSession)
|
||||
loadSession key = view (sessionStore . at key)
|
||||
|
||||
-- | Stores a session object.
|
||||
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
|
||||
storeSession :: GuideSession -> Acid.Update GlobalState ()
|
||||
storeSession sess = do
|
||||
sessionStore %= M.insert (sess ^. sess_id) sess
|
||||
setDirty
|
||||
|
||||
-- | Deletes a session by 'SessionID'.
|
||||
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
|
||||
deleteSession :: SessionId -> Acid.Update GlobalState ()
|
||||
deleteSession key = do
|
||||
sessionStore %= M.delete key
|
||||
setDirty
|
||||
|
||||
-- | Retrieves all sessions.
|
||||
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
|
||||
getSessions :: Acid.Query GlobalState [GuideSession]
|
||||
getSessions = do
|
||||
m <- view sessionStore
|
||||
return . map snd $ M.toList m
|
||||
|
||||
-- | Retrieves a user by their unique identifier.
|
||||
getUser :: Uid User -> Acid.Query GlobalState (Maybe User)
|
||||
getUser key = view (users . at key)
|
||||
|
||||
-- | Creates a user, maintaining unique constraints on certain fields.
|
||||
createUser :: User -> Acid.Update GlobalState Bool
|
||||
createUser user = do
|
||||
m <- toList <$> use users
|
||||
if all (canCreateUser user) (m ^.. each)
|
||||
then do
|
||||
users %= M.insert (user ^. userID) user
|
||||
return True
|
||||
else
|
||||
return False
|
||||
|
||||
-- | Remove a user completely. Unsets all user sessions with this user ID.
|
||||
deleteUser :: Uid User -> Acid.Update GlobalState ()
|
||||
deleteUser key = do
|
||||
users %= M.delete key
|
||||
logoutUserGlobally key
|
||||
setDirty
|
||||
|
||||
-- | Given an email address and a password, return the user if it exists
|
||||
-- and the password is correct.
|
||||
loginUser :: Text -> ByteString -> Acid.Query GlobalState (Maybe User)
|
||||
loginUser email password = do
|
||||
matches <- filter (\u -> u ^. userEmail == email) . toList <$> view users
|
||||
case matches of
|
||||
[user] ->
|
||||
if verifyUser user password
|
||||
then return $ Just user
|
||||
else return $ Nothing
|
||||
_ -> return Nothing
|
||||
|
||||
-- | Global logout of all of a user's active sessions
|
||||
logoutUserGlobally :: Uid User -> Acid.Update GlobalState ()
|
||||
logoutUserGlobally key = do
|
||||
sessions <- use sessionStore
|
||||
for_ (M.toList sessions) $ \(sessID, sess) -> do
|
||||
when ((sess ^. sess_data.sessionUserID) == Just key) $ do
|
||||
sessionStore . ix sessID . sess_data . sessionUserID .= Nothing
|
||||
|
||||
-- | Retrieve all users with the 'userIsAdmin' field set to True.
|
||||
getAdminUsers :: Acid.Query GlobalState [User]
|
||||
getAdminUsers = filter (^. userIsAdmin) . toList <$> view users
|
||||
|
||||
makeAcidic ''GlobalState [
|
||||
-- queries
|
||||
'getGlobalState,
|
||||
@ -715,5 +806,14 @@ makeAcidic ''GlobalState [
|
||||
-- other
|
||||
'moveItem, 'moveTrait,
|
||||
'restoreCategory, 'restoreItem, 'restoreTrait,
|
||||
'setDirty, 'unsetDirty
|
||||
'setDirty, 'unsetDirty,
|
||||
|
||||
-- sessions
|
||||
'loadSession, 'storeSession, 'deleteSession, 'getSessions,
|
||||
|
||||
-- users
|
||||
'getUser, 'createUser, 'deleteUser,
|
||||
'loginUser,
|
||||
|
||||
'getAdminUsers
|
||||
]
|
||||
|
||||
@ -9,6 +9,7 @@ module Guide.Types
|
||||
module Guide.Types.Edit,
|
||||
module Guide.Types.Action,
|
||||
module Guide.Types.User,
|
||||
module Guide.Types.Session,
|
||||
)
|
||||
where
|
||||
|
||||
@ -17,3 +18,4 @@ import Guide.Types.Core
|
||||
import Guide.Types.Edit
|
||||
import Guide.Types.Action
|
||||
import Guide.Types.User
|
||||
import Guide.Types.Session
|
||||
@ -28,9 +28,9 @@ import Imports
|
||||
import Data.IP
|
||||
-- acid-state
|
||||
import Data.SafeCopy hiding (kind)
|
||||
import Data.SafeCopy.Migrate
|
||||
|
||||
import Guide.Utils
|
||||
import Guide.SafeCopy
|
||||
import Guide.Types.Core
|
||||
import Guide.Types.Edit
|
||||
|
||||
|
||||
@ -67,8 +67,8 @@ import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Types as A
|
||||
-- acid-state
|
||||
import Data.SafeCopy hiding (kind)
|
||||
import Data.SafeCopy.Migrate
|
||||
|
||||
import Guide.SafeCopy
|
||||
import Guide.Markdown
|
||||
import Guide.Utils
|
||||
import Guide.Types.Hue
|
||||
|
||||
@ -25,9 +25,9 @@ import qualified Data.Set as S
|
||||
import Data.IP
|
||||
-- acid-state
|
||||
import Data.SafeCopy hiding (kind)
|
||||
import Data.SafeCopy.Migrate
|
||||
|
||||
import Guide.Utils
|
||||
import Guide.SafeCopy
|
||||
import Guide.Types.Core
|
||||
|
||||
|
||||
|
||||
79
src/Guide/Types/Session.hs
Normal file
79
src/Guide/Types/Session.hs
Normal file
@ -0,0 +1,79 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
module Guide.Types.Session
|
||||
(
|
||||
GuideData (..),
|
||||
sessionUserID,
|
||||
emptyGuideData,
|
||||
SpockSession,
|
||||
GuideSession,
|
||||
sess_id,
|
||||
sess_csrfToken,
|
||||
sess_validUntil,
|
||||
sess_data,
|
||||
unwrapSession,
|
||||
wrapSession,
|
||||
SessionId,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
-- Spock
|
||||
import Web.Spock.Internal.SessionManager (SessionId)
|
||||
import qualified Web.Spock.Internal.SessionManager as Spock
|
||||
-- Spock Session wrapper
|
||||
import Data.Time.Clock ( UTCTime(..) )
|
||||
import qualified Data.Text as T
|
||||
-- acid-state
|
||||
import Data.SafeCopy hiding (kind)
|
||||
import Data.SafeCopy.Migrate
|
||||
|
||||
import Guide.Utils
|
||||
import Guide.Types.User
|
||||
|
||||
|
||||
type SpockSession conn st = Spock.Session conn GuideData st
|
||||
|
||||
-- | GuideData is the session data exposed by Spock.SessionAction operations.
|
||||
data GuideData = GuideData {
|
||||
-- | If logged in, must be a valid userID
|
||||
_sessionUserID :: Maybe (Uid User)
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
deriveSafeCopySorted 0 'base ''GuideData
|
||||
makeLenses ''GuideData
|
||||
|
||||
emptyGuideData :: GuideData
|
||||
emptyGuideData = GuideData {
|
||||
_sessionUserID = Nothing }
|
||||
|
||||
data GuideSession = GuideSession {
|
||||
_sess_id :: !SessionId,
|
||||
_sess_csrfToken :: !T.Text,
|
||||
_sess_validUntil :: !UTCTime,
|
||||
_sess_data :: !GuideData }
|
||||
deriving (Show, Eq)
|
||||
|
||||
deriveSafeCopySorted 0 'base ''GuideSession
|
||||
makeLenses ''GuideSession
|
||||
|
||||
unwrapSession :: GuideSession -> SpockSession conn st
|
||||
unwrapSession (GuideSession {..}) = Spock.Session {
|
||||
sess_id = _sess_id,
|
||||
sess_csrfToken = _sess_csrfToken,
|
||||
sess_validUntil = _sess_validUntil,
|
||||
sess_data = _sess_data
|
||||
}
|
||||
|
||||
wrapSession :: SpockSession conn st -> GuideSession
|
||||
wrapSession (Spock.Session {..}) = GuideSession {
|
||||
_sess_id = sess_id,
|
||||
_sess_csrfToken = sess_csrfToken,
|
||||
_sess_validUntil = sess_validUntil,
|
||||
_sess_data = sess_data
|
||||
}
|
||||
@ -6,40 +6,73 @@ A type for users. Currently unused.
|
||||
-}
|
||||
module Guide.Types.User
|
||||
(
|
||||
User(..),
|
||||
User,
|
||||
userID,
|
||||
userName,
|
||||
userEmail,
|
||||
userPassword,
|
||||
userIsAdmin,
|
||||
makeUser,
|
||||
verifyUser,
|
||||
canCreateUser,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Imports
|
||||
|
||||
-- acid-state
|
||||
import Data.SafeCopy hiding (kind)
|
||||
import Data.SafeCopy.Migrate
|
||||
-- scrypt
|
||||
import Crypto.Scrypt (Pass, encryptPassIO', getEncryptedPass)
|
||||
import Crypto.Scrypt (Pass (..), EncryptedPass (..), encryptPassIO', getEncryptedPass, verifyPass')
|
||||
|
||||
import Guide.Utils
|
||||
import Guide.SafeCopy
|
||||
-- import Guide.Types.Core
|
||||
-- import Guide.Types.Edit
|
||||
|
||||
|
||||
data User = User {
|
||||
userID :: Uid User,
|
||||
userName :: Text,
|
||||
userEmail :: Text,
|
||||
userPassword :: Maybe ByteString
|
||||
-- | Unique, pseudorandom identifier for user.
|
||||
_userID :: Uid User,
|
||||
-- | Unique username for user.
|
||||
_userName :: Text,
|
||||
-- | Unique email address for user.
|
||||
_userEmail :: Text,
|
||||
-- | Scrypt generated password field, contains salt + hash.
|
||||
_userPassword :: Maybe ByteString,
|
||||
-- | Flag set if user is an administrator.
|
||||
_userIsAdmin :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
makeUser :: MonadIO m => Text -> Text -> Pass -> m User
|
||||
makeUser username email password = do
|
||||
encPass <- liftIO $ encryptPassIO' password
|
||||
userID <- randomLongUid
|
||||
return User {
|
||||
userID = userID,
|
||||
userName = username,
|
||||
userEmail = email,
|
||||
userPassword = Just $ getEncryptedPass encPass
|
||||
}
|
||||
|
||||
deriveSafeCopySorted 0 'base ''User
|
||||
makeLenses ''User
|
||||
|
||||
-- | Creates a user object with an SCrypt encrypted password.
|
||||
makeUser :: MonadIO m => Text -> Text -> ByteString -> m User
|
||||
makeUser username email password = do
|
||||
encPass <- liftIO $ encryptPassIO' (Pass password)
|
||||
userid <- randomLongUid
|
||||
return User {
|
||||
_userID = userid,
|
||||
_userName = username,
|
||||
_userEmail = email,
|
||||
_userPassword = Just $ getEncryptedPass encPass,
|
||||
_userIsAdmin = False }
|
||||
|
||||
-- | Verifies a given password corresponds to a user's encrypted password.
|
||||
verifyUser :: User -> ByteString -> Bool
|
||||
verifyUser user password =
|
||||
case user ^. userPassword of
|
||||
Just encPass -> verifyPass' (Pass password) (EncryptedPass encPass)
|
||||
Nothing -> False
|
||||
|
||||
-- | Looks at two users, and returns true if all unique fields are different.
|
||||
canCreateUser :: User -> User -> Bool
|
||||
canCreateUser userFoo userBar =
|
||||
all (\f -> f userFoo userBar) fieldTests
|
||||
where
|
||||
fieldNotEq field a b = a ^. field /= b ^. field
|
||||
fieldTests = [
|
||||
fieldNotEq userID,
|
||||
fieldNotEq userName,
|
||||
fieldNotEq userEmail ]
|
||||
|
||||
@ -31,6 +31,10 @@ module Guide.Utils
|
||||
makeSlug,
|
||||
(//),
|
||||
|
||||
-- * Referrers
|
||||
ReferrerView (..),
|
||||
toReferrerView,
|
||||
|
||||
-- * IP
|
||||
sockAddrToIP,
|
||||
|
||||
@ -50,18 +54,7 @@ module Guide.Utils
|
||||
getRequestDetails,
|
||||
|
||||
-- * Template Haskell
|
||||
hs,
|
||||
dumpSplices,
|
||||
bangNotStrict,
|
||||
|
||||
-- * Safecopy
|
||||
Change(..),
|
||||
TypeVersion(..),
|
||||
changelog,
|
||||
GenConstructor(..),
|
||||
genVer,
|
||||
MigrateConstructor(..),
|
||||
migrateVer,
|
||||
|
||||
-- * STM
|
||||
liftSTM,
|
||||
@ -74,15 +67,10 @@ where
|
||||
|
||||
import Imports
|
||||
|
||||
-- Lists
|
||||
import Data.List.Extra (stripSuffix)
|
||||
-- Monads
|
||||
import Control.Monad.Extra
|
||||
-- Monads and monad transformers
|
||||
import Control.Monad.Catch
|
||||
-- Containers
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
-- Randomness
|
||||
import System.Random
|
||||
-- Text
|
||||
@ -96,7 +84,7 @@ import Data.IP
|
||||
import Lucid hiding (for_)
|
||||
import Web.Spock as Spock
|
||||
import Text.HTML.SanitizeXSS (sanitaryURI)
|
||||
import Web.PathPieces
|
||||
import Web.HttpApiData
|
||||
import qualified Network.Wai as Wai
|
||||
-- Feeds
|
||||
import qualified Text.Atom.Feed as Atom
|
||||
@ -106,14 +94,11 @@ import qualified Text.XML.Light.Output as XML
|
||||
import Data.SafeCopy
|
||||
-- Template Haskell
|
||||
import Language.Haskell.TH
|
||||
import qualified Language.Haskell.TH.Syntax as TH (lift)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
||||
import Language.Haskell.Meta (parseExp)
|
||||
import Data.Generics.Uniplate.Data (transform)
|
||||
-- needed for 'sanitiseUrl'
|
||||
import qualified Codec.Binary.UTF8.String as UTF8
|
||||
import qualified Network.URI as URI
|
||||
|
||||
-- needed for parsing urls
|
||||
import Network.HTTP.Types (Query, parseQuery)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Lists
|
||||
@ -215,6 +200,83 @@ appends backslashes (@\@) and not slashes (@/@).
|
||||
(//) x y = fromMaybe x (T.stripSuffix "/" x) <> "/" <>
|
||||
fromMaybe y (T.stripPrefix "/" y)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- ReferrerView
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
data SearchEngine
|
||||
= Google
|
||||
| Yandex
|
||||
| Yahoo
|
||||
| Bing
|
||||
| Ecosia
|
||||
| DuckDuckGo
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Check whether a domain is one of known search engines.
|
||||
--
|
||||
-- TODO: this gives some false positives, e.g. @google.wordpress.com@ or
|
||||
-- @blog.google@ will be erroneously detected as search engines.
|
||||
toSearchEngine
|
||||
:: Text -- ^ Domain
|
||||
-> Maybe SearchEngine
|
||||
toSearchEngine t
|
||||
| "google" `elem` lst = Just Google
|
||||
| "yandex" `elem` lst = Just Yandex
|
||||
| "yahoo" `elem` lst = Just Yahoo
|
||||
| "bing" `elem` lst = Just Bing
|
||||
| "ecosia" `elem` lst = Just Ecosia
|
||||
| "duckduckgo" `elem` lst = Just DuckDuckGo
|
||||
| otherwise = Nothing
|
||||
where lst = T.splitOn "." t
|
||||
|
||||
-- | A (lossy) representation of referrers that is better for analytics.
|
||||
data ReferrerView
|
||||
= RefSearchEngine { searchEngine :: SearchEngine
|
||||
, keyword :: Text } -- No keyword = empty keyword
|
||||
| RefUrl Url
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Show ReferrerView where
|
||||
show (RefSearchEngine searchEngine keyword)
|
||||
= show searchEngine <> showKeyword keyword
|
||||
show (RefUrl url) = T.toString url
|
||||
|
||||
showKeyword :: Text -> String
|
||||
showKeyword "" = ""
|
||||
showKeyword kw = " (\"" <> T.toString kw <> "\")"
|
||||
|
||||
extractQuery :: Url -> Maybe Query
|
||||
extractQuery url = getQuery <$> parse url
|
||||
where
|
||||
getQuery = parseQuery . T.toByteString . URI.uriQuery
|
||||
parse = URI.parseURI . T.toString
|
||||
|
||||
-- TODO: different search engines have different parameters, we should use
|
||||
-- right ones instead of just trying “whatever fits”
|
||||
extractKeyword :: Url -> Maybe Text
|
||||
extractKeyword url
|
||||
= case extractQuery url of
|
||||
Just query -> T.toStrict <$> lookupQuery query
|
||||
Nothing -> Nothing
|
||||
where
|
||||
lookupQuery :: [(ByteString, Maybe ByteString)] -> Maybe ByteString
|
||||
lookupQuery query = join $
|
||||
lookup "q" query <|> -- Google, Bing, Ecosia, DDG
|
||||
lookup "p" query <|> -- Yahoo
|
||||
lookup "text" query -- Yandex
|
||||
|
||||
toReferrerView :: Url -> ReferrerView
|
||||
toReferrerView url
|
||||
= case toSearchEngine =<< domain of
|
||||
Just se -> RefSearchEngine se (fromMaybe "" keyword)
|
||||
Nothing -> RefUrl url
|
||||
where
|
||||
uri = URI.parseURI $ T.toString url
|
||||
uriAuth = URI.uriAuthority =<< uri
|
||||
domain = T.toStrict . URI.uriRegName <$> uriAuth
|
||||
keyword = extractKeyword url
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- IP
|
||||
----------------------------------------------------------------------------
|
||||
@ -234,7 +296,9 @@ sockAddrToIP _ = Nothing
|
||||
|
||||
-- | Unique id, used for many things – categories, items, and anchor ids.
|
||||
newtype Uid a = Uid {uidToText :: Text}
|
||||
deriving (Eq, Ord, Show, PathPiece, T.Buildable, Hashable, A.ToJSON)
|
||||
deriving (Eq, Ord, Show,
|
||||
ToHttpApiData, FromHttpApiData,
|
||||
T.Buildable, Hashable, A.ToJSON)
|
||||
|
||||
-- This instance is written manually because otherwise it produces a warning:
|
||||
-- • Redundant constraint: SafeCopy a
|
||||
@ -246,7 +310,7 @@ instance SafeCopy (Uid a) where
|
||||
kind = base
|
||||
|
||||
instance IsString (Uid a) where
|
||||
fromString = Uid . T.pack
|
||||
fromString = Uid . T.toStrict
|
||||
|
||||
-- | Generate a random text of given length from characters @a-z@ and digits.
|
||||
randomText :: MonadIO m => Int -> m Text
|
||||
@ -260,7 +324,7 @@ randomText n = liftIO $ do
|
||||
return $ if i < 10 then toEnum (fromEnum '0' + i)
|
||||
else toEnum (fromEnum 'a' + i - 10)
|
||||
xs <- replicateM (n-1) randomChar
|
||||
return (T.pack (x:xs))
|
||||
return (T.toStrict (x:xs))
|
||||
|
||||
-- For probability tables, see
|
||||
-- https://en.wikipedia.org/wiki/Birthday_problem#Probability_table
|
||||
@ -315,7 +379,7 @@ includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url]
|
||||
atomFeed :: MonadIO m => Atom.Feed -> ActionCtxT ctx m ()
|
||||
atomFeed feed = do
|
||||
setHeader "Content-Type" "application/atom+xml; charset=utf-8"
|
||||
bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed)))
|
||||
bytes $ T.toByteString (XML.ppElement (Atom.xmlFeed feed))
|
||||
|
||||
-- | Get details of the request:
|
||||
--
|
||||
@ -353,17 +417,6 @@ getRequestDetails = do
|
||||
-- Template Haskell
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
-- | Parse a Haskell expression with haskell-src-meta. The difference between
|
||||
-- @[|exp|]@ and @[hs|exp|]@ is the the former requires all variables in
|
||||
-- @exp@ to be present in scope at the moment of generation, but the latter
|
||||
-- doesn't. This makes 'hs' useful for 'changelog'.
|
||||
hs :: QuasiQuoter
|
||||
hs = QuasiQuoter {
|
||||
quoteExp = either fail TH.lift . parseExp,
|
||||
quotePat = fail "hs: can't parse patterns",
|
||||
quoteType = fail "hs: can't parse types",
|
||||
quoteDec = fail "hs: can't parse declarations" }
|
||||
|
||||
-- | Print splices generated by a TH splice (the printing will happen during
|
||||
-- compilation, as a GHC warning). Useful for debugging.
|
||||
--
|
||||
@ -379,351 +432,6 @@ dumpSplices x = do
|
||||
reportWarning ("\n" ++ unlines (map (" " ++) code))
|
||||
return ds
|
||||
|
||||
bangNotStrict :: Q Bang
|
||||
bangNotStrict = bang noSourceUnpackedness noSourceStrictness
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- SafeCopy
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
{- |
|
||||
A change from one version of a record (one constructor, several fields) to
|
||||
another version. We only record the latest version, so we have to be able to
|
||||
reconstruct the previous version knowing the current version and a list of
|
||||
'Change's.
|
||||
-}
|
||||
data Change
|
||||
-- | A field with a particular name and type was removed
|
||||
= Removed String (Q Type)
|
||||
-- | A field with a particular name and default value was added. We don't
|
||||
-- have to record the type since it's already known (remember, we know what
|
||||
-- the final version of the record is)
|
||||
| Added String Exp
|
||||
|
||||
-- | An ADT for versions. Only used in invocations of 'changelog'.
|
||||
data TypeVersion = Current Int | Past Int
|
||||
deriving (Show)
|
||||
|
||||
{- |
|
||||
Generate previous version of the type.
|
||||
|
||||
Assume that the new type and the changelog are, respectively:
|
||||
|
||||
-- version 4
|
||||
data Foo = FooRec {
|
||||
b :: Bool,
|
||||
c :: Int }
|
||||
|
||||
changelog ''Foo (Current 4, Past 3) [
|
||||
Removed "a" [t|String|],
|
||||
Added "c" [|if null a then 0 else 1|] ]
|
||||
|
||||
Then we will generate a type called Foo_v3:
|
||||
|
||||
data Foo_v3 = FooRec_v3 {
|
||||
a_v3 :: String,
|
||||
b_v3 :: Bool }
|
||||
|
||||
We'll also generate a migration instance:
|
||||
|
||||
instance Migrate Foo where
|
||||
type MigrateFrom Foo = Foo_v3
|
||||
migrate old = FooRec {
|
||||
b = b_v3 old,
|
||||
c = if null (a_v3 old) then 0 else 1 }
|
||||
|
||||
Note that you must use 'deriveSafeCopySorted' for types that use 'changelog'
|
||||
because otherwise fields will be parsed in the wrong order. Specifically,
|
||||
imagine that you have created a type with fields “b” and “a” and then removed
|
||||
“b”. 'changelog' has no way of knowing from “the current version has field
|
||||
“a”” and “the previous version also had field “b”” that the previous version
|
||||
had fields “b, a” and not “a, b”. Usual 'deriveSafeCopy' or
|
||||
'deriveSafeCopySimple' care about field order and thus will treat “b, a” and
|
||||
“a, b” as different types.
|
||||
-}
|
||||
changelog
|
||||
:: Name -- ^ Type (without version suffix)
|
||||
-> (TypeVersion, TypeVersion) -- ^ New version, old version
|
||||
-> [Change] -- ^ List of changes between this version
|
||||
-- and previous one
|
||||
-> DecsQ
|
||||
changelog _ (_newVer, Current _) _ =
|
||||
-- We could've just changed the second element of the tuple to be 'Int'
|
||||
-- instead of 'TypeVersion' but that would lead to worse-looking changelogs
|
||||
fail "changelog: old version can't be 'Current'"
|
||||
changelog bareTyName (newVer, Past oldVer) changes = do
|
||||
-- ------------------------------------------------------------------------
|
||||
-- Name and version business
|
||||
-- ------------------------------------------------------------------------
|
||||
-- First, we can define functions for removing a new-version prefix and for
|
||||
-- adding a new/old-version prefix to a bare name. We'll be working with
|
||||
-- bare names everywhere.
|
||||
let mkBare :: Name -> String
|
||||
mkBare n = case newVer of
|
||||
Current _ -> nameBase n
|
||||
Past v ->
|
||||
let suff = ("_v" ++ show v)
|
||||
in case stripSuffix suff (nameBase n) of
|
||||
Just n' -> n'
|
||||
Nothing -> error $
|
||||
printf "changelog: %s doesn't have suffix %s"
|
||||
(show n) (show suff)
|
||||
let mkOld, mkNew :: String -> Name
|
||||
mkOld n = mkName (n ++ "_v" ++ show oldVer)
|
||||
mkNew n = case newVer of
|
||||
Current _ -> mkName n
|
||||
Past v -> mkName (n ++ "_v" ++ show v)
|
||||
-- We know the “base” name (tyName) of the type and we know the
|
||||
-- versions. From this we can get actual new/old names:
|
||||
let newTyName = mkNew (nameBase bareTyName)
|
||||
let oldTyName = mkOld (nameBase bareTyName)
|
||||
-- We should also check that the new version exists and that the old one
|
||||
-- doesn't.
|
||||
whenM (isNothing <$> lookupTypeName (nameBase newTyName)) $
|
||||
fail (printf "changelog: %s not found" (show newTyName))
|
||||
whenM (isJust <$> lookupTypeName (nameBase oldTyName)) $
|
||||
fail (printf "changelog: %s is already present" (show oldTyName))
|
||||
|
||||
-- -----------------------------------------------------------------------
|
||||
-- Process the changelog
|
||||
-- -----------------------------------------------------------------------
|
||||
-- Make separate lists of added and removed fields
|
||||
let added :: Map String Exp
|
||||
added = M.fromList [(n, e) | Added n e <- changes]
|
||||
let removed :: Map String (Q Type)
|
||||
removed = M.fromList [(n, t) | Removed n t <- changes]
|
||||
|
||||
-- -----------------------------------------------------------------------
|
||||
-- Get information about the new version of the datatype
|
||||
-- -----------------------------------------------------------------------
|
||||
-- First, 'reify' it. See documentation for 'reify' to understand why we
|
||||
-- use 'lookupValueName' here (if we just do @reify newTyName@, we might
|
||||
-- get the constructor instead).
|
||||
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- do
|
||||
mbReallyTyName <- lookupTypeName (nameBase newTyName)
|
||||
case mbReallyTyName of
|
||||
Just reallyTyName -> reify reallyTyName
|
||||
Nothing -> fail $ printf "changelog: type %s not found" (show newTyName)
|
||||
-- Do some checks first – we only have to handle simple types for now, but
|
||||
-- if/when we need to handle more complex ones, we want to be warned.
|
||||
unless (null _cxt) $
|
||||
fail "changelog: can't yet work with types with context"
|
||||
unless (null _vars) $
|
||||
fail "changelog: can't yet work with types with variables"
|
||||
unless (isNothing _kind) $
|
||||
fail "changelog: can't yet work with types with kinds"
|
||||
-- We assume that the type is a single-constructor record.
|
||||
con <- case cons of
|
||||
[x] -> return x
|
||||
[] -> fail "changelog: the type has to have at least one constructor"
|
||||
_ -> fail "changelog: the type has to have only one constructor"
|
||||
-- Check that the type is actually a record and that there are no strict
|
||||
-- fields (which we cannot handle yet); when done, make a list of fields
|
||||
-- that is easier to work with. We strip names to their bare form.
|
||||
let normalBang = Bang NoSourceUnpackedness NoSourceStrictness
|
||||
(recName :: String, fields :: [(String, Type)]) <- case con of
|
||||
RecC cn fs
|
||||
| all (== normalBang) (fs^..each._2) ->
|
||||
return (mkBare cn, [(mkBare n, t) | (n,_,t) <- fs])
|
||||
| otherwise -> fail "changelog: can't work with strict/unpacked fields"
|
||||
_ -> fail "changelog: the type must be a record"
|
||||
-- Check that all 'Added' fields are actually present in the new type
|
||||
-- and that all 'Removed' fields aren't there
|
||||
for_ (M.keys added) $ \n ->
|
||||
unless (n `elem` map fst fields) $ fail $
|
||||
printf "changelog: field %s isn't present in %s"
|
||||
(show (mkNew n)) (show newTyName)
|
||||
for_ (M.keys removed) $ \n ->
|
||||
when (n `elem` map fst fields) $ fail $
|
||||
printf "changelog: field %s is present in %s \
|
||||
\but was supposed to be removed"
|
||||
(show (mkNew n)) (show newTyName)
|
||||
|
||||
-- -----------------------------------------------------------------------
|
||||
-- Generate the old type
|
||||
-- -----------------------------------------------------------------------
|
||||
-- Now we can generate the old type based on the new type and the
|
||||
-- changelog. First we determine the list of fields (and types) we'll have
|
||||
-- by taking 'fields' from the new type, adding 'Removed' fields and
|
||||
-- removing 'Added' fields. We still use bare names everywhere.
|
||||
let oldFields :: Map String (Q Type)
|
||||
oldFields = fmap return (M.fromList fields)
|
||||
`M.union` removed
|
||||
`M.difference` added
|
||||
|
||||
-- Then we construct the record constructor:
|
||||
-- FooRec_v3 { a_v3 :: String, b_v3 :: Bool }
|
||||
let oldRec = recC (mkOld recName)
|
||||
[varBangType (mkOld fName)
|
||||
(bangType bangNotStrict fType)
|
||||
| (fName, fType) <- M.toList oldFields]
|
||||
-- And the data type:
|
||||
-- data Foo_v3 = FooRec_v3 {...}
|
||||
let oldTypeDecl = dataD (cxt []) -- no context
|
||||
oldTyName -- name of old type
|
||||
[] -- no variables
|
||||
Nothing -- no explicit kind
|
||||
[oldRec] -- one constructor
|
||||
(cxt []) -- not deriving anything
|
||||
|
||||
-- Next we generate the migration instance. It has two inner declarations.
|
||||
-- First declaration – “type MigrateFrom Foo = Foo_v3”:
|
||||
let migrateFromDecl =
|
||||
tySynInstD ''MigrateFrom (tySynEqn [conT newTyName] (conT oldTyName))
|
||||
-- Second declaration:
|
||||
-- migrate old = FooRec {
|
||||
-- b = b_v3 old,
|
||||
-- c = if null (a_v3 old) then 0 else 1 }
|
||||
migrateArg <- newName "old"
|
||||
-- This function replaces accessors in an expression – “a” turns into
|
||||
-- “(a_vN old)” if 'a' is one of the fields in the old type
|
||||
let replaceAccessors = transform f
|
||||
where f (VarE x) | nameBase x `elem` M.keys oldFields =
|
||||
AppE (VarE (mkOld (nameBase x))) (VarE migrateArg)
|
||||
f x = x
|
||||
let migrateDecl = funD 'migrate [
|
||||
clause [varP migrateArg]
|
||||
(normalB $ recConE (mkNew recName) $ do
|
||||
(field, _) <- fields
|
||||
let content = case M.lookup field added of
|
||||
-- the field was present in old type
|
||||
Nothing -> appE (varE (mkOld field)) (varE migrateArg)
|
||||
-- wasn't
|
||||
Just e -> return (replaceAccessors e)
|
||||
return $ (mkNew field,) <$> content)
|
||||
[]
|
||||
]
|
||||
|
||||
let migrateInstanceDecl =
|
||||
instanceD
|
||||
(cxt []) -- no context
|
||||
[t|Migrate $(conT newTyName)|] -- Migrate Foo
|
||||
[migrateFromDecl, migrateDecl] -- associated type & migration func
|
||||
|
||||
-- Return everything
|
||||
sequence [oldTypeDecl, migrateInstanceDecl]
|
||||
|
||||
-- | A type for specifying what constructors existed in an old version of a
|
||||
-- sum datatype.
|
||||
data GenConstructor
|
||||
= Copy Name -- ^ Just reuse the constructor
|
||||
-- existing now.
|
||||
| Custom String [(String, Q Type)] -- ^ The previous version had a
|
||||
-- constructor with such-and-such
|
||||
-- name and such-and-such fields.
|
||||
|
||||
-- | Generate an old version of a sum type (used for 'SafeCopy').
|
||||
genVer
|
||||
:: Name -- ^ Name of type to generate old version for
|
||||
-> Int -- ^ Version to generate
|
||||
-> [GenConstructor] -- ^ List of constructors in the version we're
|
||||
-- generating
|
||||
-> Q [Dec]
|
||||
genVer tyName ver constructors = do
|
||||
-- Get information about the new version of the datatype
|
||||
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName
|
||||
-- Let's do some checks first
|
||||
unless (null _cxt) $
|
||||
fail "genVer: can't yet work with types with context"
|
||||
unless (null _vars) $
|
||||
fail "genVer: can't yet work with types with variables"
|
||||
unless (isNothing _kind) $
|
||||
fail "genVer: can't yet work with types with kinds"
|
||||
|
||||
let oldName n = mkName (nameBase n ++ "_v" ++ show ver)
|
||||
|
||||
let copyConstructor conName =
|
||||
case [c | c@(RecC n _) <- cons, n == conName] of
|
||||
[] -> fail ("genVer: couldn't find a record constructor " ++
|
||||
show conName)
|
||||
[RecC _ fields] ->
|
||||
recC (oldName conName)
|
||||
(map return (fields & each._1 %~ oldName))
|
||||
other -> fail ("genVer: copyConstructor: got " ++ show other)
|
||||
|
||||
let customConstructor conName fields =
|
||||
recC (oldName (mkName conName))
|
||||
[varBangType (oldName (mkName fName))
|
||||
(bangType bangNotStrict fType)
|
||||
| (fName, fType) <- fields]
|
||||
|
||||
cons' <- for constructors $ \genCons ->
|
||||
case genCons of
|
||||
Copy conName -> copyConstructor conName
|
||||
Custom conName fields -> customConstructor conName fields
|
||||
|
||||
decl <- dataD
|
||||
-- no context
|
||||
(cxt [])
|
||||
-- name of our type (e.g. SomeType_v3 if the previous version was 3)
|
||||
(oldName tyName)
|
||||
-- no variables
|
||||
[]
|
||||
-- no explicit kind
|
||||
Nothing
|
||||
-- constructors
|
||||
(map return cons')
|
||||
-- not deriving anything
|
||||
(cxt [])
|
||||
return [decl]
|
||||
|
||||
-- | A type for migrating constructors from an old version of a sum datatype.
|
||||
data MigrateConstructor
|
||||
= CopyM Name -- ^ Copy constructor without changes
|
||||
| CustomM String ExpQ -- ^ The old constructor with such-and-such name
|
||||
-- should be turned into a value of the new type
|
||||
-- (i.e. type of current version) using
|
||||
-- such-and-such code.
|
||||
|
||||
-- | Generate 'SafeCopy' migration code for a sum datatype.
|
||||
--
|
||||
-- See @instance Migrate Edit@ for an example.
|
||||
migrateVer
|
||||
:: Name -- ^ Type we're migrating to
|
||||
-> Int -- ^ Version we're migrating from
|
||||
-> [MigrateConstructor] -- ^ For each constructor existing in the (old
|
||||
-- version of) type, a specification of how to
|
||||
-- migrate it.
|
||||
-> Q Exp
|
||||
migrateVer tyName ver constructors = do
|
||||
-- Get information about the new version of the datatype
|
||||
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName
|
||||
-- Let's do some checks first
|
||||
unless (null _cxt) $
|
||||
fail "migrateVer: can't yet work with types with context"
|
||||
unless (null _vars) $
|
||||
fail "migrateVer: can't yet work with types with variables"
|
||||
unless (isNothing _kind) $
|
||||
fail "migrateVer: can't yet work with types with kinds"
|
||||
|
||||
let oldName n = mkName (nameBase n ++ "_v" ++ show ver)
|
||||
|
||||
arg <- newName "x"
|
||||
|
||||
let copyConstructor conName =
|
||||
case [c | c@(RecC n _) <- cons, n == conName] of
|
||||
[] -> fail ("migrateVer: couldn't find a record constructor " ++
|
||||
show conName)
|
||||
[RecC _ fields] -> do
|
||||
-- SomeConstr_v3{} -> SomeConstr (field1 x) (field2 x) ...
|
||||
let getField f = varE (oldName (f ^. _1)) `appE` varE arg
|
||||
match (recP (oldName conName) [])
|
||||
(normalB (appsE (conE conName : map getField fields)))
|
||||
[]
|
||||
other -> fail ("migrateVer: copyConstructor: got " ++ show other)
|
||||
|
||||
let customConstructor conName res =
|
||||
match (recP (oldName (mkName conName)) [])
|
||||
(normalB (res `appE` varE arg))
|
||||
[]
|
||||
|
||||
branches' <- for constructors $ \genCons ->
|
||||
case genCons of
|
||||
CopyM conName -> copyConstructor conName
|
||||
CustomM conName res -> customConstructor conName res
|
||||
|
||||
lam1E (varP arg) (caseE (varE arg) (map return branches'))
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- STM
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
@ -55,10 +55,11 @@ import Guide.Utils
|
||||
import Guide.JS (JS(..))
|
||||
import qualified Guide.JS as JS
|
||||
import Guide.Markdown
|
||||
import Guide.Diff hiding (DiffChunk)
|
||||
import qualified Guide.Diff as Diff
|
||||
import Guide.Cache
|
||||
import Guide.Views.Utils
|
||||
|
||||
|
||||
{- Note [autosize]
|
||||
~~~~~~~~~~~~~~~~~~
|
||||
|
||||
@ -236,7 +237,8 @@ renderStats globalState acts = do
|
||||
th_ "Visits"
|
||||
th_ "Unique visitors"
|
||||
tbody_ $ do
|
||||
let rawVisits :: [(Uid Category, Maybe IP)]
|
||||
let rawVisits :: [(Uid Category, Maybe IP
|
||||
)]
|
||||
rawVisits = [(catId, actionIP d) |
|
||||
(Action'CategoryVisit catId, d) <- acts']
|
||||
let visits :: [(Uid Category, (Int, Int))]
|
||||
@ -267,19 +269,21 @@ renderStats globalState acts = do
|
||||
th_ "Unique visitors"
|
||||
tbody_ $ do
|
||||
let rawVisits :: [(Url, Maybe IP)]
|
||||
rawVisits = [(r, actionIP d) |
|
||||
(_, d) <- acts',
|
||||
Just (ExternalReferrer r) <- [actionReferrer d]]
|
||||
let visits :: [(Url, (Int, Int))]
|
||||
visits = map (over _2 (length &&& length.ordNub)) .
|
||||
map (fst.head &&& map snd) .
|
||||
groupWith fst
|
||||
$ rawVisits
|
||||
rawVisits = [(r, actionIP d)
|
||||
| d <- map snd acts'
|
||||
, Just (ExternalReferrer r) <- [actionReferrer d]]
|
||||
let sortRefs :: [(Url, Maybe IP)] -> [(ReferrerView, [Maybe IP])]
|
||||
sortRefs = map (fst.head &&& map snd)
|
||||
. groupWith fst
|
||||
. map (over _1 toReferrerView)
|
||||
let visits :: [(ReferrerView, (Int, Int))]
|
||||
visits = map (over _2 (length &&& length.ordNub))
|
||||
(sortRefs rawVisits)
|
||||
for_ (reverse $ sortWith (fst.snd) visits) $ \(r, (n, u)) -> do
|
||||
tr_ $ do
|
||||
td_ (toHtml r)
|
||||
td_ (toHtml (show n))
|
||||
td_ (toHtml (show u))
|
||||
td_ (toHtml (show r)) -- referrer
|
||||
td_ (toHtml (show n)) -- visitors
|
||||
td_ (toHtml (show u)) -- unique visitors
|
||||
table_ $ do
|
||||
thead_ $ tr_ $ do
|
||||
th_ "Action"
|
||||
@ -391,14 +395,15 @@ renderEdit globalState edit = do
|
||||
Edit'AddCategory _catId title' -> p_ $ do
|
||||
"added category " >> quote (toHtml title')
|
||||
Edit'AddItem catId _itemId name' -> p_ $ do
|
||||
"added item " >> quote (toHtml name')
|
||||
"added item " >> printItem _itemId
|
||||
" (initially called " >> quote (toHtml name') >> ")"
|
||||
" to category " >> printCategory catId
|
||||
Edit'AddPro itemId _traitId content' -> do
|
||||
p_ $ "added pro to item " >> printItem itemId
|
||||
blockquote_ $ p_ $ toHtml (toMarkdownInline content')
|
||||
pre_ $ code_ $ toHtml content'
|
||||
Edit'AddCon itemId _traitId content' -> do
|
||||
p_ $ "added con to item " >> printItem itemId
|
||||
blockquote_ $ p_ $ toHtml (toMarkdownInline content')
|
||||
pre_ $ code_ $ toHtml content'
|
||||
|
||||
-- Change category properties
|
||||
Edit'SetCategoryTitle _catId oldTitle newTitle -> p_ $ do
|
||||
@ -415,10 +420,7 @@ renderEdit globalState edit = do
|
||||
Edit'SetCategoryNotes catId oldNotes newNotes -> do
|
||||
p_ $ (if T.null oldNotes then "added" else "changed") >>
|
||||
" notes of category " >> printCategory catId
|
||||
table_ $ tr_ $ do
|
||||
unless (T.null oldNotes) $
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock oldNotes)
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock newNotes)
|
||||
renderDiff oldNotes newNotes
|
||||
Edit'ChangeCategoryEnabledSections catId toEnable toDisable -> do
|
||||
let sectName ItemProsConsSection = "pros/cons"
|
||||
sectName ItemEcosystemSection = "ecosystem"
|
||||
@ -452,33 +454,22 @@ renderEdit globalState edit = do
|
||||
Edit'SetItemDescription itemId oldDescr newDescr -> do
|
||||
p_ $ (if T.null oldDescr then "added" else "changed") >>
|
||||
" description of item " >> printItem itemId
|
||||
table_ $ tr_ $ do
|
||||
unless (T.null oldDescr) $
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock oldDescr)
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock newDescr)
|
||||
renderDiff oldDescr newDescr
|
||||
Edit'SetItemNotes itemId oldNotes newNotes -> do
|
||||
p_ $ (if T.null oldNotes then "added" else "changed") >>
|
||||
" notes of item " >> printItem itemId
|
||||
table_ $ tr_ $ do
|
||||
unless (T.null oldNotes) $
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock oldNotes)
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock newNotes)
|
||||
renderDiff oldNotes newNotes
|
||||
Edit'SetItemEcosystem itemId oldEcosystem newEcosystem -> do
|
||||
p_ $ (if T.null oldEcosystem then "added" else "changed") >>
|
||||
" ecosystem of item " >> printItem itemId
|
||||
table_ $ tr_ $ do
|
||||
unless (T.null oldEcosystem) $
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock oldEcosystem)
|
||||
td_ $ blockquote_ $ toHtml (toMarkdownBlock newEcosystem)
|
||||
renderDiff oldEcosystem newEcosystem
|
||||
|
||||
-- Change trait properties
|
||||
Edit'SetTraitContent itemId _traitId oldContent newContent -> do
|
||||
p_ $ (if T.null oldContent then "added" else "changed") >>
|
||||
" trait of item " >> printItem itemId
|
||||
table_ $ tr_ $ do
|
||||
unless (T.null oldContent) $
|
||||
td_ $ blockquote_ $ p_ (toHtml (toMarkdownInline oldContent))
|
||||
td_ $ blockquote_ $ p_ (toHtml (toMarkdownInline newContent))
|
||||
" trait of item " >> printItem itemId >>
|
||||
" from category " >> printCategory (findItem itemId ^. _1.uid)
|
||||
renderDiff oldContent newContent
|
||||
|
||||
-- Delete
|
||||
Edit'DeleteCategory catId _pos -> p_ $ do
|
||||
@ -490,7 +481,7 @@ renderEdit globalState edit = do
|
||||
Edit'DeleteTrait itemId traitId _pos -> do
|
||||
let (_, item, trait) = findTrait itemId traitId
|
||||
p_ $ "deleted trait from item " >> quote (toHtml (item^.name))
|
||||
blockquote_ $ p_ $ toHtml (trait^.content)
|
||||
pre_ $ code_ $ toHtml $ trait^.content
|
||||
|
||||
-- Other
|
||||
Edit'MoveItem itemId direction -> p_ $ do
|
||||
@ -500,15 +491,54 @@ renderEdit globalState edit = do
|
||||
let (_, item, trait) = findTrait itemId traitId
|
||||
p_ $ "moved trait of item " >> quote (toHtml (item^.name)) >>
|
||||
if direction then " up" else " down"
|
||||
blockquote_ $ p_ $ toHtml (trait^.content)
|
||||
pre_ $ code_ $ toHtml $ trait^.content
|
||||
|
||||
renderDiff :: Monad m => Text -> Text -> HtmlT m ()
|
||||
renderDiff old new =
|
||||
table_ $ tr_ $
|
||||
if | T.null old -> renderOne new
|
||||
| T.null new -> renderOne old
|
||||
| otherwise -> renderBoth
|
||||
where
|
||||
cell = td_ . pre_ . code_
|
||||
renderOne s = cell (toHtml s)
|
||||
renderBoth = do
|
||||
let Diff{..} = diff old new
|
||||
cell $ do
|
||||
"[...] " >> toHtml (mconcat (takeEnd 10 diffContextAbove))
|
||||
mapM_ renderChunk diffLeft
|
||||
toHtml (mconcat (take 10 diffContextBelow)) >> " [...]"
|
||||
cell $ do
|
||||
"[...] " >> toHtml (mconcat (takeEnd 10 diffContextAbove))
|
||||
mapM_ renderChunk diffRight
|
||||
toHtml (mconcat (take 10 diffContextBelow)) >> " [...]"
|
||||
--
|
||||
renderChunk (Diff.Added "") = ins_ [class_ "empty-chunk"] ""
|
||||
renderChunk (Diff.Added x) = ins_ (toHtml (showNewlines x))
|
||||
renderChunk (Diff.Deleted "") = del_ [class_ "empty-chunk"] ""
|
||||
renderChunk (Diff.Deleted x) = del_ (toHtml (showNewlines x))
|
||||
renderChunk (Diff.Plain x) = toHtml x
|
||||
--
|
||||
showNewlines x =
|
||||
let
|
||||
(pref, x') = T.span (== '\n') x
|
||||
(x'', suff) = tSpanEnd (== '\n') x'
|
||||
in
|
||||
T.replicate (T.length pref) "⏎\n" <> x'' <>
|
||||
T.replicate (T.length suff) "⏎\n"
|
||||
--
|
||||
tSpanEnd p = over both T.reverse . swap . T.span p . T.reverse
|
||||
|
||||
-- TODO: use “data Direction = Up | Down” for directions instead of Bool
|
||||
|
||||
-- | Render the header on the </haskell> subpage: “Aelve Guide | Haskell”.
|
||||
haskellHeader :: (MonadReader Config m) => HtmlT m ()
|
||||
haskellHeader = do
|
||||
haskellHeader = div_ [id_ "header"] $ do
|
||||
div_ $ do
|
||||
h1_ $ mkLink ("Aelve Guide " >> span_ "| Haskell") "/haskell"
|
||||
renderSubtitle
|
||||
div_ [class_ "auth-link-container"] $ do
|
||||
a_ [href_ "/auth"] "login/logout"
|
||||
|
||||
-- | Render </haskell>.
|
||||
renderHaskellRoot
|
||||
@ -592,7 +622,7 @@ wrapPage pageTitle' page = doctypehtml_ $ do
|
||||
"https://github.com/aelve/guide/issues");
|
||||
return false; };
|
||||
|]
|
||||
includeJS "/jquery.js"
|
||||
includeJS "/js/bundle.js"
|
||||
-- for modal dialogs
|
||||
includeJS "/magnific-popup.js"
|
||||
includeCSS "/magnific-popup.css"
|
||||
|
||||
@ -10,19 +10,55 @@ module Guide.Views.Auth.Login where
|
||||
|
||||
import Imports
|
||||
|
||||
-- digestive-functors
|
||||
import Text.Digestive
|
||||
-- lucid
|
||||
import Lucid hiding (for_)
|
||||
|
||||
import Guide.Views.Page
|
||||
import Guide.Views.Utils
|
||||
import Guide.Config
|
||||
import Guide.Types.User
|
||||
|
||||
-- | Fields used by this form.
|
||||
data Login = Login {
|
||||
loginEmail :: Text,
|
||||
loginUserPassword :: Text }
|
||||
|
||||
loginContent :: (MonadIO m) => HtmlT m ()
|
||||
loginContent = do
|
||||
div_ ""
|
||||
-- | Creates a digestive functor over the fields in 'UserRegistration'
|
||||
loginForm :: Monad m => Form (HtmlT (ReaderT Config IO) ()) m Login
|
||||
loginForm = Login
|
||||
<$> "email" .: text Nothing
|
||||
<*> "password" .: text Nothing
|
||||
|
||||
renderLogin :: (MonadIO m, MonadReader Config m) => HtmlT m ()
|
||||
renderLogin = do
|
||||
-- | Render input elements for a 'Login'
|
||||
-- Note: This does not include the 'Form' element.
|
||||
--
|
||||
-- Use 'Guide.Server.protectForm' to render the appropriate form element with CSRF protection.
|
||||
loginFormView :: MonadIO m => View (HtmlT m ()) -> HtmlT m ()
|
||||
loginFormView view = do
|
||||
div_ $ do
|
||||
errorList "email" view
|
||||
label "email" view "Email: "
|
||||
inputText "email" view
|
||||
|
||||
div_ $ do
|
||||
errorList "password" view
|
||||
label "password" view "Password: "
|
||||
inputPassword "password" view
|
||||
|
||||
inputSubmit "Log in"
|
||||
|
||||
-- | Dummy for now.
|
||||
loginView :: (MonadIO m) => User -> HtmlT m ()
|
||||
loginView user = do
|
||||
div_ $ do
|
||||
-- TODO: Make nicer.
|
||||
"You are registered and logged in as "
|
||||
toHtml (user ^. userName)
|
||||
|
||||
renderLogin :: (MonadIO m, MonadReader Config m) => HtmlT m () -> HtmlT m ()
|
||||
renderLogin content = do
|
||||
renderPage $
|
||||
pageDef & pageTitle .~ "Aelve Guide"
|
||||
& pageName .~ Just "Login"
|
||||
& pageContent .~ loginContent
|
||||
& pageContent .~ content
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
{- |
|
||||
Views for user registration.
|
||||
@ -10,19 +10,69 @@ module Guide.Views.Auth.Register where
|
||||
|
||||
import Imports
|
||||
|
||||
-- digestive-functors
|
||||
import Text.Digestive
|
||||
-- lucid
|
||||
import Lucid hiding (for_)
|
||||
|
||||
import Guide.Views.Page
|
||||
import Guide.Views.Utils
|
||||
import Guide.Config
|
||||
import Guide.Types.User
|
||||
|
||||
-- | Fields used by this form/view.
|
||||
data UserRegistration = UserRegistration {
|
||||
registerUserName :: Text,
|
||||
registerUserEmail :: Text,
|
||||
registerUserPassword :: Text,
|
||||
registerUserPasswordValidation :: Text }
|
||||
|
||||
registerContent :: (MonadIO m) => HtmlT m ()
|
||||
registerContent =
|
||||
div_ ""
|
||||
-- | Creates a digestive functor over the fields in 'UserRegistration'
|
||||
registerForm :: Monad m => Form (HtmlT (ReaderT Config IO) ()) m UserRegistration
|
||||
registerForm = UserRegistration
|
||||
<$> "name" .: text Nothing
|
||||
<*> "email" .: text Nothing
|
||||
<*> "password" .: text Nothing
|
||||
<*> "passwordValidation" .: text Nothing
|
||||
|
||||
renderRegister :: (MonadIO m, MonadReader Config m) => HtmlT m ()
|
||||
renderRegister =
|
||||
-- | Render input elements for a 'UserRegistration'
|
||||
-- Note: This does not include the 'Form' element.
|
||||
--
|
||||
-- Use 'Guide.Server.protectForm' to render the appropriate form element with CSRF protection.
|
||||
registerFormView :: MonadIO m => View (HtmlT m ()) -> HtmlT m ()
|
||||
registerFormView view = do
|
||||
div_ $ do
|
||||
errorList "name" view
|
||||
label "name" view "Name: "
|
||||
inputText "name" view
|
||||
|
||||
div_ $ do
|
||||
errorList "email" view
|
||||
label "email" view "Email: "
|
||||
inputText "email" view
|
||||
|
||||
div_ $ do
|
||||
errorList "password" view
|
||||
label "password" view "Password: "
|
||||
inputPassword "password" view
|
||||
|
||||
div_ $ do
|
||||
errorList "passwordValidation" view
|
||||
label "passwordValidation" view "Re-enter password: "
|
||||
inputPassword "passwordValidation" view
|
||||
|
||||
inputSubmit "Register"
|
||||
|
||||
-- | Dummy for now.
|
||||
registerView :: (MonadIO m) => User -> HtmlT m ()
|
||||
registerView user = do
|
||||
div_ $ do
|
||||
-- TODO: Make nicer.
|
||||
"You are registered and logged in as "
|
||||
toHtml (user ^. userName)
|
||||
|
||||
renderRegister :: (MonadIO m, MonadReader Config m) => HtmlT m () -> HtmlT m ()
|
||||
renderRegister content = do
|
||||
renderPage $
|
||||
pageDef & pageTitle .~ "Aelve Guide"
|
||||
& pageName .~ Just "Register"
|
||||
& pageContent .~ registerContent
|
||||
& pageContent .~ content
|
||||
|
||||
@ -96,6 +96,7 @@ pageDef = Page {
|
||||
[ "/jquery.js"
|
||||
, "/magnific-popup.js"
|
||||
, "/autosize.js"
|
||||
, "/js/bundle.js"
|
||||
, "/js.js"
|
||||
],
|
||||
_pageHeadTag = headTagDef,
|
||||
@ -160,12 +161,14 @@ headerDef
|
||||
=> Page m
|
||||
-> HtmlT m ()
|
||||
headerDef page = do
|
||||
div_ $ do
|
||||
let nameHtml = case _pageName page of
|
||||
Just name -> span_ (" | " >> toHtml name)
|
||||
Nothing -> mempty
|
||||
h1_ $ mkLink (toHtml (_pageTitle page) >> nameHtml) (_pageHeaderUrl page)
|
||||
(_pageSubtitle page) page
|
||||
|
||||
div_ [class_ "auth-link-container"] $ do
|
||||
a_ [href_ "/auth"] "login/logout"
|
||||
|
||||
footerDef
|
||||
:: MonadIO m
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{- |
|
||||
Various HTML utils, Mustache utils, etc.
|
||||
@ -50,12 +50,20 @@ module Guide.Views.Utils
|
||||
readWidgets,
|
||||
getJS,
|
||||
getCSS,
|
||||
|
||||
protectForm,
|
||||
getCsrfHeader,
|
||||
|
||||
module Guide.Views.Utils.Input
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Imports
|
||||
|
||||
-- Web
|
||||
import Web.Spock
|
||||
import Web.Spock.Config
|
||||
-- Lists
|
||||
import Data.List.Split
|
||||
-- Containers
|
||||
@ -63,7 +71,8 @@ import qualified Data.Map as M
|
||||
-- import Data.Tree
|
||||
-- Text
|
||||
import qualified Data.Text.All as T
|
||||
import qualified Data.Text.Lazy.All as TL
|
||||
-- digestive-functors
|
||||
import Text.Digestive (View)
|
||||
-- import NeatInterpolation
|
||||
-- Web
|
||||
import Lucid hiding (for_)
|
||||
@ -78,6 +87,7 @@ import qualified System.FilePath.Find as F
|
||||
-- Mustache (templates)
|
||||
import Text.Mustache.Plus
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Text as A
|
||||
import qualified Data.Aeson.Encode.Pretty as A
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS
|
||||
import qualified Data.Semigroup as Semigroup
|
||||
@ -85,6 +95,7 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Text
|
||||
|
||||
import Guide.App
|
||||
-- import Guide.Config
|
||||
-- import Guide.State
|
||||
import Guide.Types
|
||||
@ -94,6 +105,8 @@ import qualified Guide.JS as JS
|
||||
import Guide.Markdown
|
||||
-- import Guide.Cache
|
||||
|
||||
import Guide.Views.Utils.Input
|
||||
|
||||
-- | Add a script that does something on page load.
|
||||
onPageLoad :: Monad m => JS -> HtmlT m ()
|
||||
onPageLoad js = script_ $
|
||||
@ -289,7 +302,7 @@ mustache f v = do
|
||||
then return (A.String "selected")
|
||||
else return A.Null),
|
||||
("js", \[x] -> return $
|
||||
A.String . T.toStrict . TL.decodeUtf8 . A.encode $ x),
|
||||
A.String . T.toStrict . A.encodeToLazyText $ x),
|
||||
("trace", \xs -> do
|
||||
mapM_ (BS.putStrLn . A.encodePretty) xs
|
||||
return A.Null) ]
|
||||
@ -369,3 +382,36 @@ getCSS = do
|
||||
widgets <- readWidgets
|
||||
let css = [t | (CSS_, t) <- widgets]
|
||||
return (T.concat css)
|
||||
|
||||
-- | 'protectForm' renders a set of input fields within a CSRF-protected form.
|
||||
--
|
||||
-- This sets the method (POST) of submission and includes a server-generated
|
||||
-- token to help prevent cross-site request forgery (CSRF) attacks.
|
||||
--
|
||||
-- Briefly: this is necessary to prevent third party sites from impersonating
|
||||
-- logged in users, because a POST to the right URL is not sufficient to
|
||||
-- submit the form and perform an action. The CSRF token is only displayed
|
||||
-- when viewing the page.
|
||||
protectForm :: MonadIO m
|
||||
=> (View (HtmlT m ()) -> HtmlT m ())
|
||||
-> View (HtmlT m ())
|
||||
-> GuideAction ctx (HtmlT m ())
|
||||
protectForm render formView = do
|
||||
(name, value) <- getCsrfTokenPair
|
||||
return $ form formView "" [id_ "login-form"] $ do
|
||||
input_ [ type_ "hidden", name_ name, value_ value ]
|
||||
render formView
|
||||
|
||||
getCsrfTokenPair :: GuideAction ctx (Text, Text)
|
||||
getCsrfTokenPair = do
|
||||
csrfTokenName <- spc_csrfPostName <$> getSpockCfg
|
||||
csrfTokenValue <- getCsrfToken
|
||||
return (csrfTokenName, csrfTokenValue)
|
||||
|
||||
getCsrfHeader :: GuideAction ctx (Text, Text)
|
||||
getCsrfHeader = do
|
||||
csrfTokenName <- spc_csrfHeaderName <$> getSpockCfg
|
||||
csrfTokenValue <- getCsrfToken
|
||||
return (csrfTokenName, csrfTokenValue)
|
||||
|
||||
|
||||
|
||||
177
src/Guide/Views/Utils/Input.hs
Normal file
177
src/Guide/Views/Utils/Input.hs
Normal file
@ -0,0 +1,177 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
{- |
|
||||
Lucid rendering for inputs and form fields.
|
||||
-}
|
||||
module Guide.Views.Utils.Input
|
||||
(
|
||||
inputText,
|
||||
inputTextArea,
|
||||
inputPassword,
|
||||
inputHidden,
|
||||
inputSelect,
|
||||
inputRadio,
|
||||
inputCheckbox,
|
||||
inputFile,
|
||||
inputSubmit,
|
||||
label,
|
||||
form,
|
||||
errorList,
|
||||
childErrorList,
|
||||
ifSingleton
|
||||
)
|
||||
where
|
||||
|
||||
import Imports hiding (for_)
|
||||
|
||||
import Control.Monad (forM_, when)
|
||||
import Data.Text (Text, pack)
|
||||
import Lucid
|
||||
|
||||
import Text.Digestive.View
|
||||
|
||||
ifSingleton :: Bool -> a -> [a]
|
||||
ifSingleton False _ = []
|
||||
ifSingleton True a = [a]
|
||||
|
||||
inputText :: Monad m => Text -> View v -> HtmlT m ()
|
||||
inputText ref view = input_
|
||||
[ type_ "text"
|
||||
, id_ ref'
|
||||
, name_ ref'
|
||||
, value_ $ fieldInputText ref view
|
||||
]
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
|
||||
|
||||
inputTextArea :: ( Monad m
|
||||
) => Maybe Int -- ^ Rows
|
||||
-> Maybe Int -- ^ Columns
|
||||
-> Text -- ^ Form path
|
||||
-> View (HtmlT m ()) -- ^ View
|
||||
-> HtmlT m () -- ^ Resulting HTML
|
||||
inputTextArea r c ref view = textarea_
|
||||
([ id_ ref'
|
||||
, name_ ref'
|
||||
] ++ rows' r ++ cols' c) $
|
||||
toHtmlRaw $ fieldInputText ref view
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
rows' (Just x) = [rows_ $ pack $ show x]
|
||||
rows' _ = []
|
||||
cols' (Just x) = [cols_ $ pack $ show x]
|
||||
cols' _ = []
|
||||
|
||||
|
||||
inputPassword :: Monad m => Text -> View v -> HtmlT m ()
|
||||
inputPassword ref view = input_
|
||||
[ type_ "password"
|
||||
, id_ ref'
|
||||
, name_ ref'
|
||||
, value_ $ fieldInputText ref view
|
||||
]
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
|
||||
|
||||
inputHidden :: Monad m => Text -> View v -> HtmlT m ()
|
||||
inputHidden ref view = input_
|
||||
[ type_ "hidden"
|
||||
, id_ ref'
|
||||
, name_ ref'
|
||||
, value_ $ fieldInputText ref view
|
||||
]
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
|
||||
|
||||
inputSelect :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
|
||||
inputSelect ref view = select_
|
||||
[ id_ ref'
|
||||
, name_ ref'
|
||||
] $ forM_ choices $ \(i, c, sel) -> option_
|
||||
(value_ (value i) : ifSingleton sel (selected_ "selected")) c
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
value i = ref' `mappend` "." `mappend` i
|
||||
choices = fieldInputChoice ref view
|
||||
|
||||
|
||||
inputRadio :: ( Monad m
|
||||
) => Bool -- ^ Add @br@ tags?
|
||||
-> Text -- ^ Form path
|
||||
-> View (HtmlT m ()) -- ^ View
|
||||
-> HtmlT m () -- ^ Resulting HTML
|
||||
inputRadio brs ref view = forM_ choices $ \(i, c, sel) -> do
|
||||
let val = value i
|
||||
input_ $ [type_ "radio", value_ val, id_ val, name_ ref']
|
||||
++ ifSingleton sel checked_
|
||||
label_ [for_ val] c
|
||||
when brs (br_ [])
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
value i = ref' `mappend` "." `mappend` i
|
||||
choices = fieldInputChoice ref view
|
||||
|
||||
|
||||
inputCheckbox :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
|
||||
inputCheckbox ref view = input_ $
|
||||
[ type_ "checkbox"
|
||||
, id_ ref'
|
||||
, name_ ref'
|
||||
] ++ ifSingleton selected checked_
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
selected = fieldInputBool ref view
|
||||
|
||||
|
||||
inputFile :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
|
||||
inputFile ref view = input_
|
||||
[ type_ "file"
|
||||
, id_ ref'
|
||||
, name_ ref'
|
||||
]
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
|
||||
|
||||
inputSubmit :: Monad m => Text -> HtmlT m ()
|
||||
inputSubmit value = input_
|
||||
[ type_ "submit"
|
||||
, value_ value
|
||||
]
|
||||
|
||||
|
||||
label :: Monad m => Text -> View v -> HtmlT m () -> HtmlT m ()
|
||||
label ref view = label_
|
||||
[ for_ ref'
|
||||
]
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
|
||||
|
||||
form
|
||||
:: Monad m
|
||||
=> View (HtmlT m ()) -> Text -> [Attribute] -> HtmlT m () -> HtmlT m ()
|
||||
form view action attributes = form_ $
|
||||
[ method_ "POST"
|
||||
, enctype_ (pack $ show $ viewEncType view)
|
||||
, action_ action
|
||||
]
|
||||
++ attributes
|
||||
|
||||
|
||||
errorList :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
|
||||
errorList ref view = case errors ref view of
|
||||
[] -> mempty
|
||||
errs -> ul_ [class_ "digestive-functors-error-list"] $ forM_ errs $ \e ->
|
||||
li_ [class_ "digestive-functors-error"] e
|
||||
|
||||
|
||||
childErrorList :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
|
||||
childErrorList ref view = case childErrors ref view of
|
||||
[] -> mempty
|
||||
errs -> ul_ [class_ "digestive-functors-error-list"] $ forM_ errs $ \e ->
|
||||
li_ [class_ "digestive-functors-error"] e
|
||||
@ -16,6 +16,7 @@ where
|
||||
import BasePrelude as X hiding (Category, GeneralCategory, lazy, (&))
|
||||
-- Lists
|
||||
import Data.List.Index as X
|
||||
import Data.List.Extra as X (takeEnd, dropEnd)
|
||||
-- Lenses
|
||||
import Lens.Micro.Platform as X
|
||||
-- Monads and monad transformers
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module Main where
|
||||
|
||||
import qualified Guide.Server
|
||||
import qualified Guide.Main
|
||||
import Prelude (IO)
|
||||
|
||||
main :: IO ()
|
||||
main = Guide.Server.main
|
||||
main = Guide.Main.main
|
||||
|
||||
15
stack.yaml
15
stack.yaml
@ -1,16 +1,21 @@
|
||||
resolver: lts-7.9
|
||||
resolver: lts-8.13
|
||||
|
||||
packages:
|
||||
- location: .
|
||||
- location:
|
||||
git: https://github.com/aelve/stache-plus
|
||||
commit: e8e7967d561148167eb1fe4112c6ad0e091490ab
|
||||
commit: 789aeabbf8069dec80647160f127d047e8f5a330
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/aelve/safecopy-migrate
|
||||
commit: 26e5f8c7f62ebce66ef19e5bd573af21c16fe2b1
|
||||
extra-dep: true
|
||||
|
||||
extra-deps:
|
||||
- cmark-sections-0.1.0.2
|
||||
- http-client-0.5.1
|
||||
- edit-distance-vector-1.0.0.4
|
||||
- text-all-0.4.1.0
|
||||
- cmark-sections-0.1.0.3
|
||||
- patches-vector-0.1.5.4
|
||||
- fmt-0.2.0.0
|
||||
- purescript-bridge-0.11.0.0
|
||||
- Spock-digestive-0.3.0.0
|
||||
- digestive-functors-0.8.2.0
|
||||
|
||||
@ -73,6 +73,16 @@ textarea:focus {
|
||||
padding-right: 0;
|
||||
}
|
||||
|
||||
#edits pre {
|
||||
white-space: pre-wrap;
|
||||
}
|
||||
|
||||
#edits .empty-chunk {
|
||||
padding-right: 5px;
|
||||
border: 1px dashed black;
|
||||
border-radius: 4px;
|
||||
}
|
||||
|
||||
#stats table {
|
||||
border-collapse: collapse;
|
||||
border-spacing: 0;
|
||||
|
||||
@ -45,3 +45,21 @@ a:link {color: #008ACE; text-decoration: none;}
|
||||
a:visited {color: #B40EB4; text-decoration: none;}
|
||||
a:hover {text-decoration: underline;}
|
||||
a:active {text-decoration: underline;}
|
||||
|
||||
del {
|
||||
text-decoration: none;
|
||||
background-color: rgba(240, 16, 27, 0.38)
|
||||
}
|
||||
ins {
|
||||
text-decoration: none;
|
||||
background-color: rgba(16, 240, 27, 0.38)
|
||||
}
|
||||
|
||||
.category-status-banner {
|
||||
background-color: #FFF694;
|
||||
text-align: center;
|
||||
border: 2px solid #202020;
|
||||
padding: 0.5em;
|
||||
margin-left: 10%;
|
||||
margin-right: 10%;
|
||||
}
|
||||
|
||||
@ -17,21 +17,40 @@ body {
|
||||
flex-direction: column;
|
||||
}
|
||||
|
||||
#header > h1 {
|
||||
#header h1 {
|
||||
font-size: 250%;
|
||||
font-weight: 600;
|
||||
margin-bottom: 0px;
|
||||
}
|
||||
|
||||
#header > h1 span {
|
||||
#header h1 span {
|
||||
font-weight: 200;
|
||||
}
|
||||
|
||||
#header > h1 a {
|
||||
#header h1 a {
|
||||
color: inherit;
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
#header {
|
||||
display: flex;
|
||||
}
|
||||
|
||||
#header > div {
|
||||
flex: 1;
|
||||
}
|
||||
|
||||
#header .auth-link-container {
|
||||
flex-grow: 0;
|
||||
position: relative;
|
||||
}
|
||||
|
||||
#header .auth-link-container a {
|
||||
position: absolute;
|
||||
bottom: 32px;
|
||||
right: 0px;
|
||||
}
|
||||
|
||||
#main {
|
||||
flex: 1;
|
||||
}
|
||||
@ -370,3 +389,32 @@ textarea.fullwidth {
|
||||
.markdown-supported {
|
||||
height: 1em;
|
||||
}
|
||||
|
||||
#login-form {
|
||||
margin: 0px auto;
|
||||
width: 430px;
|
||||
border: 1px solid #aaa;
|
||||
border-radius: 3px;
|
||||
padding: 40px 50px;
|
||||
padding-bottom: 35px;
|
||||
margin-top: 60px;
|
||||
font-size: 120%;
|
||||
}
|
||||
|
||||
#login-form > div {
|
||||
margin-bottom: 25px;
|
||||
}
|
||||
|
||||
#login-form [type='text'], #login-form [type='password'] {
|
||||
float: right;
|
||||
margin-top: -5px;
|
||||
padding: 2px 3px;
|
||||
width: 220px;
|
||||
}
|
||||
|
||||
#login-form [type='submit'] {
|
||||
width: 100px;
|
||||
height: 30px;
|
||||
margin-top: 10px;
|
||||
font-size: 90%;
|
||||
}
|
||||
|
||||
@ -15,7 +15,7 @@ import Test.Hspec.QuickCheck
|
||||
import Test.QuickCheck
|
||||
import Data.Text.Arbitrary ()
|
||||
|
||||
import Guide.Merge
|
||||
import Guide.Diff.Merge
|
||||
|
||||
|
||||
tests :: Spec
|
||||
|
||||
@ -28,7 +28,7 @@ import Selenium
|
||||
import qualified Test.WebDriver.Common.Keys as Key
|
||||
|
||||
-- Site
|
||||
import qualified Guide.Server
|
||||
import qualified Guide.Main
|
||||
import Guide.Config (Config(..))
|
||||
|
||||
|
||||
@ -611,7 +611,7 @@ run ts = do
|
||||
--
|
||||
-- Using 'Slave.fork' in 'Guide.mainWith' ensures that threads started
|
||||
-- inside of 'mainWith' will be killed too when the thread dies.
|
||||
tid <- Slave.fork $ Guide.Server.mainWith Config {
|
||||
tid <- Slave.fork $ Guide.Main.mainWith Config {
|
||||
_baseUrl = "/",
|
||||
_googleToken = "some-google-token",
|
||||
_adminPassword = "123",
|
||||
|
||||
92
zurihac.md
Normal file
92
zurihac.md
Normal file
@ -0,0 +1,92 @@
|
||||
# Zurihac 2017
|
||||
|
||||
## How to build the project
|
||||
|
||||
You will need [Stack][] and [npm][].
|
||||
|
||||
```
|
||||
$ stack build # build the project
|
||||
$ ./official.sh # download the database from https://guide.aelve.com
|
||||
$ stack exec guide # start Guide
|
||||
```
|
||||
|
||||
After that, the site will be running at <http://localhost:8080/>.
|
||||
|
||||
## What to hack on
|
||||
|
||||
There's a bunch of issues at <https://github.com/aelve/guide/issues>, but I
|
||||
recommend taking one of issues listed below.
|
||||
|
||||
### Non-coding issues
|
||||
|
||||
* You can write content. Take any of the “To be written” categories
|
||||
at <https://guide.aelve.com/haskell> and list libraries, write about
|
||||
already listed libraries, or give examples. You can look
|
||||
at <https://guide.aelve.com/haskell/lenses-sth6l9jl> for an example of a
|
||||
more-or-less finished category.
|
||||
|
||||
* You can improve the design. This is mostly about CSS and HTML, though, but
|
||||
it would still be appreciated. The HTML is mostly generated with [Lucid][],
|
||||
though there are some bits written as Mustache templates in the
|
||||
`templates/` folder. The styles can be found in `templates/css.widget`.
|
||||
|
||||
### Easy issues
|
||||
|
||||
* Add a special page listing all broken links (i.e. links returning 400 or
|
||||
500).
|
||||
|
||||
* Improve analytics. Currently we've got lots of useless referrers (like
|
||||
`encrypted.google.com` – see this [analytics screenshot][]). It'd be nice
|
||||
if duplicated links were lumped together, Google/Yandex links were parsed
|
||||
nicely, etc.
|
||||
|
||||
### Medium issues
|
||||
|
||||
* We've got search – for instance, here's how [searching for “lens”][] looks.
|
||||
However, at the moment the search is somewhat dumb (if you look
|
||||
at [`Guide.Search`][] you'll see that it simply does full-text search in
|
||||
titles and doesn't do fuzzy matching).
|
||||
|
||||
* One way to improve it would be to add fuzzy matching of some kind, e.g.
|
||||
take English morphology into account so that “lenses” would find
|
||||
`lens`-the-library.
|
||||
|
||||
* Another thing you can do is implement highlighting for found terms. See
|
||||
how GHC User's Guide does highlighting in this [search for “kinds”][].
|
||||
|
||||
* Currently, if you edit something and somebody else also edits (and saves
|
||||
it) in the process, Guide will show you a popup saying “merge conflict,
|
||||
please resolve it”. Unfortunately, it doesn't show the diff between the
|
||||
conflicting versions; it'd be nice to highlight differences in them. This
|
||||
is a pretty easy task.
|
||||
|
||||
* Guide also tries to resolve the merge confict by itself, but the algorithm
|
||||
it uses is pretty dumb (see <https://github.com/aelve/guide/issues/91> for
|
||||
details). If you want to research merge algorithms and implement a better
|
||||
one, it'll be cool.
|
||||
|
||||
* Since the database is publicly accessible, it should be possible to write
|
||||
an Electron wrapper that would download it and serve it offline. That's a
|
||||
pretty good issue in terms of power-to-weight ratio (i.e. it's useful *and*
|
||||
easy to do).
|
||||
|
||||
* If you look at e.g. [notes for lens][], you'll find that editing them is a
|
||||
pain because you can only edit the whole thing at the time. It'd be better
|
||||
to allow editing subsections directly (and also code snippets). This is
|
||||
somewhat complicated because if someone else edits the section that you
|
||||
were also editing, the backend would have to somehow recognize which
|
||||
subsection you were editing. This can be done, for instance, by sending two
|
||||
pieces of text to the backend – `(original text, modified text)` – and then
|
||||
the backend would find the subsection that matches the original text and
|
||||
(try to) apply the changes to it.
|
||||
|
||||
[Stack]: https://haskellstack.org
|
||||
[npm]: https://www.npmjs.com/
|
||||
[Lucid]: https://hackage.haskell.org/package/lucid
|
||||
|
||||
[`Guide.Search`]: src/Guide/Search.hs
|
||||
|
||||
[search for “kinds”]: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/using.html?highlight=kinds#ghc-flag--fprint-explicit-kinds
|
||||
[searching for “lens”]: https://guide.aelve.com/haskell?q=lens
|
||||
[notes for lens]: https://guide.aelve.com/haskell/lenses-sth6l9jl#item-notes-ov2yi6mf
|
||||
[analytics screenshot]: https://github.com/aelve/guide/issues/85#issuecomment-307368459
|
||||
Loading…
Reference in New Issue
Block a user