aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-12-23 04:42:24 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #160 from aelve/sessions

Browse Source 
Add sessions and login/logout
This commit is contained in:
Artyom Kazak 2017-05-23 21:34:19 +03:00 committed by GitHub
commit e2860f35ef
32 changed files with 3918 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitignore vendored
View File

@ -1,3 +1,4 @@
# Haskell
dist
cabal-dev
*.o
@ -23,5 +24,9 @@ TAGS
state/
config.json
# IDE/support
.vscode/
tags
tags
# JavaScript
guidejs/node_modules/

1
README.md
View File

@ -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

16
Setup.hs
View File

@ -1,2 +1,16 @@
import Distribution.Simple
main = defaultMain
import System.Process
main = do
hooks <- buildJS simpleUserHooks
defaultMainWithHooks hooks
buildJS hooks = do
let originalpreBuild = preBuild hooks
return $ hooks {
preBuild = \args flags -> do
let npmbuild = proc "sh" ["./scripts/buildjs.sh"]
(_, _, _, buildHandle) <- createProcess npmbuild
waitForProcess buildHandle
originalpreBuild args flags
}

11
guide.cabal
View File

@ -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.App
Guide.Main
Guide.ServerStuff
Guide.Session
Guide.Config
Guide.State
Guide.Types
@ -54,6 +56,7 @@ library
Guide.Types.Edit
Guide.Types.Action
Guide.Types.User
Guide.Types.Session
Guide.Handlers
Guide.Utils
Guide.Merge
@ -68,12 +71,14 @@ library
Guide.Views.Item
Guide.Views.Category
Guide.Views.Utils
Guide.Views.Utils.Input
Guide.Cache
Guide.SafeCopy
other-modules:
Imports
build-depends: Spock
, Spock-lucid == 0.3.*
, Spock-digestive
, acid-state == 0.14.*
, aeson == 1.0.*
, aeson-pretty
@ -87,6 +92,7 @@ library
, containers >= 0.5
, data-default >= 0.5
, deepseq >= 1.2.0.0
, digestive-functors
, directory >= 1.2
, ekg
, ekg-core
@ -103,6 +109,7 @@ library
, haskell-src-meta
, http-api-data
, http-types
, hvect
, ilist
, iproute == 1.7.*
, lucid >= 2.9.5 && < 3
@ -122,8 +129,10 @@ library
, slave-thread
, split
, stache-plus == 0.1.*
, stm
, stm-containers >= 0.2.14 && < 0.3
, template-haskell
, text
, text-all == 0.3.*
, time >= 1.5
, transformers

18
guidejs/.babelrc Normal file
View File

@ -0,0 +1,18 @@
{
"presets": [
[
"env",
{
"targets": {
"browsers": [
"last 2 versions"
]
},
"modules": false
}
]
],
"plugins": [
"transform-runtime"
]
}

37
guidejs/README.md Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

File diff suppressed because it is too large Load Diff

9
scripts/buildjs.sh Executable file
View 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
View 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

25
src/Guide/Handlers.hs
View File

@ -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
@ -33,6 +34,7 @@ import Web.Spock.Lucid
import Lucid hiding (for_)
import qualified Network.HTTP.Types.Status as HTTP
import Guide.App
import Guide.ServerStuff
import Guide.Config
import Guide.Cache
@ -43,15 +45,14 @@ import Guide.Types
import Guide.Utils
import Guide.Views
methods :: SpockM () () ServerState ()
methods :: GuideM ctx ()
methods = do
renderMethods
setMethods
addMethods
otherMethods
renderMethods :: SpockM () () ServerState ()
renderMethods :: GuideM ctx ()
renderMethods = Spock.subcomponent "render" $ do
-- Notes for a category
Spock.get (categoryVar <//> "notes") $ \catId -> do
@ -83,7 +84,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
@ -260,7 +261,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
@ -314,7 +315,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
@ -371,7 +372,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
@ -412,6 +413,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

151
src/Guide/Main.hs
View File

@ -3,7 +3,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE QuasiQuotes #-}
{- |
The main module.
@ -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)
import Guide.Views.Utils (getJS, getCSS, 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,23 +190,49 @@ 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 8080 $ spock spockConfig $ do
runSpock 8080 $ 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.encodeUtf8 (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
-- CSS
Spock.get "/highlight.css" $ do
setHeader "Content-Type" "text/css; charset=utf-8"
@ -215,7 +252,7 @@ mainWith config = do
lucidWithConfig $ renderRoot
-- Admin page
prehook adminHook $ do
prehook authHook $ prehook adminHook $ do
Spock.get "admin" $ do
s <- dbQuery GetGlobalState
lucidIO $ renderAdmin s
@ -273,19 +310,87 @@ mainWith config = do
methods
Spock.subcomponent "auth" $ do
Spock.get "login" $ lucidWithConfig renderLogin
Spock.get "register" $ lucidWithConfig renderRegister
-- 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
adminHook :: ActionCtxT ctx (WebStateM () () ServerState) ()
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.encodeUtf8 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
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.encodeUtf8 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
@ -330,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.encodeUtf8 . _adminPassword <$> getConfig
user <- makeUser "admin" "admin@guide.aelve.com" pass
void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True)

92
src/Guide/Session.hs Normal file
View 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.
-}

108
src/Guide/State.hs
View File

@ -75,6 +75,14 @@ module Guide.State
RestoreItem(..),
RestoreTrait(..),
SetDirty(..), UnsetDirty(..),
LoadSession(..), StoreSession(..),
DeleteSession(..), GetSessions(..),
GetUser(..), CreateUser(..), DeleteUser(..),
LoginUser(..),
GetAdminUsers(..)
)
where
@ -91,6 +99,8 @@ import Data.IP
-- acid-state
import Data.SafeCopy hiding (kind)
import Data.Acid as Acid
--
import Web.Spock.Internal.SessionManager (SessionId)
import Guide.Utils
import Guide.SafeCopy
@ -98,6 +108,8 @@ 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
]

2
src/Guide/Types.hs
View File

@ -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

78
src/Guide/Types/Session.hs Normal file
View File

@ -0,0 +1,78 @@
{-# 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 Guide.SafeCopy
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
}

69
src/Guide/Types/User.hs
View File

@ -6,8 +6,15 @@ A type for users. Currently unused.
-}
module Guide.Types.User
(
User(..),
User,
userID,
userName,
userEmail,
userPassword,
userIsAdmin,
makeUser,
verifyUser,
canCreateUser,
)
where
@ -16,30 +23,54 @@ import Imports
-- acid-state
import Data.SafeCopy hiding (kind)
-- 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 ]

11
src/Guide/Views.hs
View File

@ -506,9 +506,12 @@ renderEdit globalState edit = do
-- | Render the header on the </haskell> subpage: “Aelve Guide | Haskell”.
haskellHeader :: (MonadReader Config m) => HtmlT m ()
haskellHeader = do
h1_ $ mkLink ("Aelve Guide " >> span_ "| Haskell") "/haskell"
renderSubtitle
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 +595,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"

50
src/Guide/Views/Auth/Login.hs
View File

@ -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

66
src/Guide/Views/Auth/Register.hs
View File

@ -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

15
src/Guide/Views/Page.hs
View File

@ -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
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_ $ 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

48
src/Guide/Views/Utils.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{- |
Various HTML utils, Mustache utils, etc.
@ -49,12 +49,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,6 +71,8 @@ import qualified Data.Map as M
-- 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_)
@ -84,6 +94,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
@ -93,6 +104,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_ $
@ -364,3 +377,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
View 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

2
stack.yaml
View File

@ -11,3 +11,5 @@ extra-deps:
- cmark-sections-0.1.0.3
- patches-vector-0.1.5.4
- fmt-0.2.0.0
- Spock-digestive-0.3.0.0
- digestive-functors-0.8.2.0

2
static/js/bundle.js Normal file
View File

File diff suppressed because one or more lines are too long

1
static/js/bundle.js.map Normal file
View File

File diff suppressed because one or more lines are too long

54
templates/css.widget
View File

@ -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%;
}