Merge branch 'master' into front-ps

.gitignore

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

README.md

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

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
+  }

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.*$|^    .*$)|"

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

guidejs/.babelrc

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

guidejs/README.md

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

guidejs/package.json

@@ -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"
+  }
+}

guidejs/rollup.config.js

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

guidejs/src/csrfProtection.js

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

guidejs/src/index.js

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

guidejs/src/jquery-csrf-token/index.js

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

guidejs/src/url-polyfill/index.js

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

official.sh

@@ -0,0 +1,5 @@
+#!/bin/bash
+
+rm -rf state
+git clone --depth 1 https://github.com/aelve/guide-database.git
+mv guide-database state

scripts/buildjs.sh

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

src/Guide/App.hs

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

src/Guide/Diff.hs

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

src/Guide/Diff/Merge.hs

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

src/Guide/Diff/Tokenize.hs

@@ -1,13 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 
-{- |
+-- | Prepare text for diffing or merging by breaking it into tokens (like
-An algorithm for merging users' edits. Specifically, there's just one
+-- links or Markdown elements).
-function – 'merge' – and it simply does a three-way diff.
+module Guide.Diff.Tokenize
--}
-module Guide.Merge
 (
-  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.
+-- | Break text into tokens.
-merge
+tokenize :: Text -> [Text]
-  :: Text    -- ^ Original text
+tokenize = consolidate . map T.toStrict . break' . T.toString
-  -> 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 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
+-- | Consolidate some of the things into tokens.
--- spaces, and Markdown elements).
 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

src/Guide/Handlers.hs

@@ -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 :: GuideM ctx ()
-methods :: SpockM () () ServerState ()
 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

src/Guide/Main.hs

@@ -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
+  oldCtx <- getContext
-  unless (adminPassword == "") $ do
+  let user = findFirst oldCtx
-    let check user pass =
+  if user ^. userIsAdmin
-          unless (user == "admin" && pass == adminPassword) $ do
+    then return (IsAdmin :&: oldCtx)
-            Spock.setStatus HTTP.status401
+    else Spock.text "Not authorized."
-            Spock.text "Wrong password!"
+
-    Spock.requireBasicAuth "Authenticate (login = admin)" check return
+-- |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)

src/Guide/Markdown.hs

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

src/Guide/SafeCopy.hs

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

src/Guide/Session.hs

@@ -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.
+
+-}

src/Guide/State.hs

@@ -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) []
+changelog ''GlobalState (Current 8, Past 7) [
-deriveSafeCopySorted 6 'base ''GlobalState_v6
+  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
   ]

src/Guide/Types.hs

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

src/Guide/Types/Action.hs

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

src/Guide/Types/Core.hs

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

src/Guide/Types/Edit.hs

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

src/Guide/Types/Session.hs

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

src/Guide/Types/User.hs

@@ -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,
+  -- | Unique, pseudorandom identifier for user.
-  userName        :: Text,
+  _userID          :: Uid User,
-  userEmail       :: Text,
+  -- | Unique username for user.
-  userPassword    :: Maybe ByteString
+  _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 ]

src/Guide/Utils.hs

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

src/Guide/Views.hs

@@ -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) |
+          rawVisits = [(r, actionIP d)
-                       (_, d) <- acts',
+                         | d <- map snd acts'
-                       Just (ExternalReferrer r) <- [actionReferrer d]]
+                         , Just (ExternalReferrer r) <- [actionReferrer d]]
-      let visits :: [(Url, (Int, Int))]
+      let sortRefs :: [(Url, Maybe IP)] -> [(ReferrerView, [Maybe IP])]
-          visits = map (over _2 (length &&& length.ordNub)) .
+          sortRefs = map (fst.head &&& map snd)
-                   map (fst.head &&& map snd) .
+                   . groupWith fst
-                   groupWith fst
+                   . map (over _1 toReferrerView)
-                     $ rawVisits
+      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 r))  -- referrer
-          td_ (toHtml (show n))
+          td_ (toHtml (show n))  -- visitors
-          td_ (toHtml (show u))
+          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
+      renderDiff oldNotes newNotes
-        unless (T.null oldNotes) $
-          td_ $ blockquote_ $ toHtml (toMarkdownBlock oldNotes)
-        td_ $ blockquote_ $ toHtml (toMarkdownBlock 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
+      renderDiff oldDescr newDescr
-        unless (T.null oldDescr) $
-          td_ $ blockquote_ $ toHtml (toMarkdownBlock oldDescr)
-        td_ $ blockquote_ $ toHtml (toMarkdownBlock newDescr)
     Edit'SetItemNotes itemId oldNotes newNotes -> do
       p_ $ (if T.null oldNotes then "added" else "changed") >>
            " notes of item " >> printItem itemId
-      table_ $ tr_ $ do
+      renderDiff oldNotes newNotes
-        unless (T.null oldNotes) $
-          td_ $ blockquote_ $ toHtml (toMarkdownBlock oldNotes)
-        td_ $ blockquote_ $ toHtml (toMarkdownBlock newNotes)
     Edit'SetItemEcosystem itemId oldEcosystem newEcosystem -> do
       p_ $ (if T.null oldEcosystem then "added" else "changed") >>
            " ecosystem of item " >> printItem itemId
-      table_ $ tr_ $ do
+      renderDiff oldEcosystem newEcosystem
-        unless (T.null oldEcosystem) $
-          td_ $ blockquote_ $ toHtml (toMarkdownBlock oldEcosystem)
-        td_ $ blockquote_ $ toHtml (toMarkdownBlock 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
+           " trait of item " >> printItem itemId >>
-      table_ $ tr_ $ do
+           " from category " >> printCategory (findItem itemId ^. _1.uid)
-        unless (T.null oldContent) $
+      renderDiff oldContent newContent
-          td_ $ blockquote_ $ p_ (toHtml (toMarkdownInline oldContent))
-        td_ $ blockquote_ $ p_ (toHtml (toMarkdownInline 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
-  h1_ $ mkLink ("Aelve Guide " >> span_ "| Haskell") "/haskell"
+  div_ $ do
-  renderSubtitle
+    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"

src/Guide/Views/Auth/Login.hs

@@ -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 ()
+-- | Creates a digestive functor over the fields in 'UserRegistration'
-loginContent = do
+loginForm :: Monad m => Form (HtmlT (ReaderT Config IO) ()) m Login
-  div_ ""
+loginForm = Login
+  <$> "email" .: text Nothing
+  <*> "password" .: text Nothing
 
-renderLogin :: (MonadIO m, MonadReader Config m) => HtmlT m ()
+-- | Render input elements for a 'Login'
-renderLogin = do
+-- 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 .~ content
-            & pageContent .~ loginContent

src/Guide/Views/Auth/Register.hs

@@ -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 ()
+-- | Creates a digestive functor over the fields in 'UserRegistration'
-registerContent =
+registerForm :: Monad m => Form (HtmlT (ReaderT Config IO) ()) m UserRegistration
-  div_ ""
+registerForm = UserRegistration
+  <$> "name" .: text Nothing
+  <*> "email" .: text Nothing
+  <*> "password" .: text Nothing
+  <*> "passwordValidation" .: text Nothing
 
-renderRegister :: (MonadIO m, MonadReader Config m) => HtmlT m ()
+-- | Render input elements for a 'UserRegistration'
-renderRegister =
+-- 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 .~ content
-            & pageContent .~ registerContent

src/Guide/Views/Page.hs

@@ -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
+  div_ $ do
-        Just name -> span_ (" | " >> toHtml name)
+    let nameHtml = case _pageName page of
-        Nothing -> mempty
+          Just name -> span_ (" | " >> toHtml name)
-  h1_ $ mkLink (toHtml (_pageTitle page) >> nameHtml) (_pageHeaderUrl page)
+          Nothing -> mempty
-  (_pageSubtitle page) page
+    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

src/Guide/Views/Utils.hs

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

src/Guide/Views/Utils/Input.hs

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

src/Imports.hs

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

src/site/Main.hs

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

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
+- text-all-0.4.1.0
-- http-client-0.5.1
+- cmark-sections-0.1.0.3
-- edit-distance-vector-1.0.0.4
 - 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

static/admin.css

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

static/markup.css

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

templates/css.widget

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

tests/MergeSpec.hs

@@ -15,7 +15,7 @@ import Test.Hspec.QuickCheck
 import Test.QuickCheck
 import Data.Text.Arbitrary ()
 
-import Guide.Merge
+import Guide.Diff.Merge
 
 
 tests :: Spec

tests/WebSpec.hs

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

zurihac.md

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