meow

.gitignore

@@ -8,3 +8,5 @@ dist/
 .ghc*
 cabal.project.*
 *.bak*
+.direnv/
+.envrc

.plan.nix/mateamt.nix

@@ -1,153 +0,0 @@
-let
-  buildDepError = pkg:
-    builtins.throw ''
-      The Haskell package set does not contain the package: ${pkg} (build dependency).
-      
-      If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
-      '';
-  sysDepError = pkg:
-    builtins.throw ''
-      The Nixpkgs package set does not contain the package: ${pkg} (system dependency).
-      
-      You may need to augment the system package mapping in haskell.nix so that it can be found.
-      '';
-  pkgConfDepError = pkg:
-    builtins.throw ''
-      The pkg-conf packages does not contain the package: ${pkg} (pkg-conf dependency).
-      
-      You may need to augment the pkg-conf package mapping in haskell.nix so that it can be found.
-      '';
-  exeDepError = pkg:
-    builtins.throw ''
-      The local executable components do not include the component: ${pkg} (executable dependency).
-      '';
-  legacyExeDepError = pkg:
-    builtins.throw ''
-      The Haskell package set does not contain the package: ${pkg} (executable dependency).
-      
-      If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
-      '';
-  buildToolDepError = pkg:
-    builtins.throw ''
-      Neither the Haskell package set or the Nixpkgs package set contain the package: ${pkg} (build tool dependency).
-      
-      If this is a system dependency:
-      You may need to augment the system package mapping in haskell.nix so that it can be found.
-      
-      If this is a Haskell dependency:
-      If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
-      '';
-in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
-  {
-    flags = { develop = false; };
-    package = {
-      specVersion = "2.4";
-      identifier = { name = "mateamt"; version = "0.0.0.0"; };
-      license = "AGPL-3.0-only";
-      copyright = "";
-      maintainer = "nek0@nek0.eu";
-      author = "nek0";
-      homepage = "";
-      url = "";
-      synopsis = "A whole new matemat";
-      description = "";
-      buildType = "Simple";
-      isLocal = true;
-      detailLevel = "FullDetails";
-      licenseFiles = [ "LICENSE" ];
-      dataDir = "";
-      dataFiles = [];
-      extraSrcFiles = [ "CHANGELOG.md" ];
-      extraTmpFiles = [];
-      extraDocFiles = [];
-      };
-    components = {
-      "library" = {
-        depends = [
-          (hsPkgs."base" or (buildDepError "base"))
-          (hsPkgs."servant" or (buildDepError "servant"))
-          (hsPkgs."servant-server" or (buildDepError "servant-server"))
-          (hsPkgs."servant-rawm" or (buildDepError "servant-rawm"))
-          (hsPkgs."opaleye" or (buildDepError "opaleye"))
-          (hsPkgs."aeson" or (buildDepError "aeson"))
-          (hsPkgs."text" or (buildDepError "text"))
-          (hsPkgs."time" or (buildDepError "time"))
-          (hsPkgs."profunctors" or (buildDepError "profunctors"))
-          (hsPkgs."product-profunctors" or (buildDepError "product-profunctors"))
-          (hsPkgs."postgresql-simple" or (buildDepError "postgresql-simple"))
-          (hsPkgs."warp" or (buildDepError "warp"))
-          (hsPkgs."wai" or (buildDepError "wai"))
-          (hsPkgs."wai-logger" or (buildDepError "wai-logger"))
-          (hsPkgs."http-types" or (buildDepError "http-types"))
-          (hsPkgs."http-api-data" or (buildDepError "http-api-data"))
-          (hsPkgs."bytestring" or (buildDepError "bytestring"))
-          (hsPkgs."base16-bytestring" or (buildDepError "base16-bytestring"))
-          (hsPkgs."base64-bytestring" or (buildDepError "base64-bytestring"))
-          (hsPkgs."random-bytestring" or (buildDepError "random-bytestring"))
-          (hsPkgs."containers" or (buildDepError "containers"))
-          (hsPkgs."stm" or (buildDepError "stm"))
-          (hsPkgs."mtl" or (buildDepError "mtl"))
-          (hsPkgs."pureMD5" or (buildDepError "pureMD5"))
-          ];
-        buildable = true;
-        modules = [
-          "API"
-          "Control"
-          "Control/Buy"
-          "Control/Journal"
-          "Control/User"
-          "Control/Product"
-          "Control/Auth"
-          "Control/Avatar"
-          "Model"
-          "Model/User"
-          "Model/Product"
-          "Model/Auth"
-          "Model/Amount"
-          "Model/Journal"
-          "Model/Avatar"
-          "Types"
-          "Types/Auth"
-          "Types/Product"
-          "Types/Reader"
-          "Types/Refine"
-          "Types/User"
-          "Types/Purchase"
-          "Types/Amount"
-          "Types/Journal"
-          "Types/Avatar"
-          "Util"
-          ];
-        hsSourceDirs = [ "src" ];
-        };
-      exes = {
-        "mateamt" = {
-          depends = [
-            (hsPkgs."base" or (buildDepError "base"))
-            (hsPkgs."mateamt" or (buildDepError "mateamt"))
-            (hsPkgs."text" or (buildDepError "text"))
-            (hsPkgs."bytestring" or (buildDepError "bytestring"))
-            (hsPkgs."base16-bytestring" or (buildDepError "base16-bytestring"))
-            (hsPkgs."containers" or (buildDepError "containers"))
-            (hsPkgs."mtl" or (buildDepError "mtl"))
-            (hsPkgs."opaleye" or (buildDepError "opaleye"))
-            (hsPkgs."postgresql-simple" or (buildDepError "postgresql-simple"))
-            (hsPkgs."stm" or (buildDepError "stm"))
-            (hsPkgs."network" or (buildDepError "network"))
-            (hsPkgs."servant" or (buildDepError "servant"))
-            (hsPkgs."servant-server" or (buildDepError "servant-server"))
-            (hsPkgs."time" or (buildDepError "time"))
-            (hsPkgs."warp" or (buildDepError "warp"))
-            (hsPkgs."wai" or (buildDepError "wai"))
-            (hsPkgs."wai-logger" or (buildDepError "wai-logger"))
-            (hsPkgs."HsYAML" or (buildDepError "HsYAML"))
-            (hsPkgs."optparse-applicative" or (buildDepError "optparse-applicative"))
-            ];
-          buildable = true;
-          modules = [ "AppTypes" "AppTypes/Configuration" "Janitor" ];
-          hsSourceDirs = [ "app" ];
-          mainPath = [ "Main.hs" ];
-          };
-        };
-      };
-    } // rec { src = (pkgs.lib).mkDefault ../../mateamt; }

.plan.nix/matebeamter.nix

@@ -1,135 +0,0 @@
-let
-  buildDepError = pkg:
-    builtins.throw ''
-      The Haskell package set does not contain the package: ${pkg} (build dependency).
-      
-      If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
-      '';
-  sysDepError = pkg:
-    builtins.throw ''
-      The Nixpkgs package set does not contain the package: ${pkg} (system dependency).
-      
-      You may need to augment the system package mapping in haskell.nix so that it can be found.
-      '';
-  pkgConfDepError = pkg:
-    builtins.throw ''
-      The pkg-conf packages does not contain the package: ${pkg} (pkg-conf dependency).
-      
-      You may need to augment the pkg-conf package mapping in haskell.nix so that it can be found.
-      '';
-  exeDepError = pkg:
-    builtins.throw ''
-      The local executable components do not include the component: ${pkg} (executable dependency).
-      '';
-  legacyExeDepError = pkg:
-    builtins.throw ''
-      The Haskell package set does not contain the package: ${pkg} (executable dependency).
-      
-      If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
-      '';
-  buildToolDepError = pkg:
-    builtins.throw ''
-      Neither the Haskell package set or the Nixpkgs package set contain the package: ${pkg} (build tool dependency).
-      
-      If this is a system dependency:
-      You may need to augment the system package mapping in haskell.nix so that it can be found.
-      
-      If this is a Haskell dependency:
-      If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
-      '';
-in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
-  {
-    flags = {};
-    package = {
-      specVersion = "2.4";
-      identifier = { name = "matebeamter"; version = "0.0.0.0"; };
-      license = "AGPL-3.0-only";
-      copyright = "";
-      maintainer = "nek0@nek0.eu";
-      author = "nek0";
-      homepage = "";
-      url = "";
-      synopsis = "A reference frontent to mateamt";
-      description = "";
-      buildType = "Simple";
-      isLocal = true;
-      detailLevel = "FullDetails";
-      licenseFiles = [ "LICENSE" ];
-      dataDir = "";
-      dataFiles = [];
-      extraSrcFiles = [ "CHANGELOG.md" ];
-      extraTmpFiles = [];
-      extraDocFiles = [];
-      };
-    components = {
-      exes = {
-        "matebeamter" = {
-          depends = [
-            (hsPkgs."base" or (buildDepError "base"))
-            (hsPkgs."mateamt" or (buildDepError "mateamt"))
-            (hsPkgs."servant" or (buildDepError "servant"))
-            (hsPkgs."servant-server" or (buildDepError "servant-server"))
-            (hsPkgs."servant-client" or (buildDepError "servant-client"))
-            (hsPkgs."servant-client-core" or (buildDepError "servant-client-core"))
-            (hsPkgs."servant-blaze" or (buildDepError "servant-blaze"))
-            (hsPkgs."servant-rawm" or (buildDepError "servant-rawm"))
-            (hsPkgs."aeson" or (buildDepError "aeson"))
-            (hsPkgs."blaze-html" or (buildDepError "blaze-html"))
-            (hsPkgs."blaze-markup" or (buildDepError "blaze-markup"))
-            (hsPkgs."text" or (buildDepError "text"))
-            (hsPkgs."bytestring" or (buildDepError "bytestring"))
-            (hsPkgs."hashable" or (buildDepError "hashable"))
-            (hsPkgs."warp" or (buildDepError "warp"))
-            (hsPkgs."wai" or (buildDepError "wai"))
-            (hsPkgs."wai-logger" or (buildDepError "wai-logger"))
-            (hsPkgs."wai-session" or (buildDepError "wai-session"))
-            (hsPkgs."http-client" or (buildDepError "http-client"))
-            (hsPkgs."http-api-data" or (buildDepError "http-api-data"))
-            (hsPkgs."http-types" or (buildDepError "http-types"))
-            (hsPkgs."cookie" or (buildDepError "cookie"))
-            (hsPkgs."mtl" or (buildDepError "mtl"))
-            (hsPkgs."i18n" or (buildDepError "i18n"))
-            (hsPkgs."cookie" or (buildDepError "cookie"))
-            (hsPkgs."split" or (buildDepError "split"))
-            (hsPkgs."random-bytestring" or (buildDepError "random-bytestring"))
-            (hsPkgs."base64-bytestring" or (buildDepError "base64-bytestring"))
-            (hsPkgs."cryptonite" or (buildDepError "cryptonite"))
-            (hsPkgs."stm" or (buildDepError "stm"))
-            (hsPkgs."stm-containers" or (buildDepError "stm-containers"))
-            (hsPkgs."either" or (buildDepError "either"))
-            (hsPkgs."optparse-applicative" or (buildDepError "optparse-applicative"))
-            (hsPkgs."HsYAML" or (buildDepError "HsYAML"))
-            ];
-          buildable = true;
-          modules = [
-            "API"
-            "Client"
-            "ClientAuth"
-            "Util"
-            "Hash"
-            "Types"
-            "Types/Auth"
-            "Types/Page"
-            "Types/Reader"
-            "Types/Views"
-            "Types/User"
-            "Types/Orphans"
-            "Types/Configuration"
-            "Control"
-            "Control/Auth"
-            "Control/User"
-            "Control/Buy"
-            "Control/Journal"
-            "View"
-            "View/Scaffold"
-            "View/Auth"
-            "View/User"
-            "View/Buy"
-            "View/Journal"
-            ];
-          hsSourceDirs = [ "src" ];
-          mainPath = [ "Main.hs" ];
-          };
-        };
-      };
-    } // rec { src = (pkgs.lib).mkDefault .././.; }

default.nix

@@ -1,23 +0,0 @@
-let
-  # Import the Haskell.nix library,
-  pkgs = import <nixpkgs> (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz));
-
-  # Import the file you will create in the stack-to-nix or cabal-to-nix step.
-  my-pkgs = import ./pkgs.nix;
-
-  # Cabal projects use this:
-  pkgSet = pkgs.haskell-nix.mkCabalProjectPkgSet {
-    plan-pkgs = my-pkgs;
-    pkg-def-extras = [];
-    modules = [
-      # specific package overrides would go here
-      # example:
-      #  packages.cbors.package.ghcOptions = "-Werror";
-      #  packages.cbors.patches = [ ./one.patch ];
-      #  packages.cbors.flags.optimize-gmp = false;
-      # It may be better to set flags in `cabal.project` instead
-      # (`plan-to-nix` will include them as defaults).
-    ];
-  };
-
-in pkgSet.config.hsPkgs // { _config = pkgSet.config; }

flake.lock

@@ -0,0 +1,84 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1705309234,
+        "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "mateamt-src": {
+      "inputs": {
+        "flake-utils": [
+          "flake-utils"
+        ],
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1709116606,
+        "narHash": "sha256-eFkahVy1E25k2xrozWg8pFuuAZJc9TXU0i7LnnRlp+Y=",
+        "ref": "refs/heads/master",
+        "rev": "f2b7b60231e6f465eb0a28fc30f7b7f73a7b73ae",
+        "revCount": 293,
+        "type": "git",
+        "url": "https://gitea.nek0.eu/nek0/mateamt"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://gitea.nek0.eu/nek0/mateamt"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1709116111,
+        "narHash": "sha256-V7BbC39cGDOzJsCsmg+hCdBu1Tuhqs7kLcPxw86STh4=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "b84d9f029fa675d5ef312f032f322889149daa82",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "mateamt-src": "mateamt-src",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,51 @@
+{
+  description = "A game stub written in Haskell";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+    mateamt-src = {
+      url = "git+https://gitea.nek0.eu/nek0/mateamt";
+      inputs = {
+        nixpkgs.follows = "nixpkgs";
+        flake-utils.follows = "flake-utils";
+      };
+    };
+  };
+
+  outputs = { self, nixpkgs, flake-utils, mateamt-src }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+
+        haskellPackages = pkgs.haskellPackages.override {
+          overrides = hself: hsuper: {
+            i18n = with pkgs.haskell.lib;
+              doJailbreak (unmarkBroken (dontCheck hsuper.i18n));
+          };
+        };
+
+        jailbreakUnbreak = pkg:
+          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+
+        packageName = "matebeamter";
+      in rec {
+        packages.${packageName} = # (ref:haskell-package-def)
+          haskellPackages.callCabal2nix packageName self rec {
+            mateamt = mateamt-src.defaultPackage.${system};
+          };
+
+        defaultPackage = self.packages.${system}.${packageName};
+
+        devShell = haskellPackages.shellFor {
+          packages = p: [ defaultPackage ];
+          withHoogle = true;
+          buildInputs = with haskellPackages; [
+            haskell-language-server
+            ghcid
+            cabal-install
+          ];
+        };
+      });
+}
+

matebeamter.cabal

@@ -30,6 +30,7 @@ executable matebeamter
                      , Types.Views
                      , Types.User
                      , Types.Journal
+                     , Types.Product
                      , Types.Orphans
                      , Types.Configuration
                      , Control
@@ -37,14 +38,17 @@ executable matebeamter
                      , Control.User
                      , Control.Buy
                      , Control.Journal
+                     , Control.Product
                      , View
                      , View.Scaffold
                      , View.Auth
                      , View.User
                      , View.Buy
                      , View.Journal
+                     , View.Product
+                     , Paths_matebeamter
   -- other-extensions:
-  build-depends:       base ^>=4.12.0.0
+  build-depends:       base >=4.12.0.0 && < 5
                      , mateamt
                      , servant
                      , servant-server
@@ -60,6 +64,7 @@ executable matebeamter
                      , hashable
                      , warp
                      , wai
+                     , wai-app-static
                      , wai-logger
                      , wai-session
                      , http-client
@@ -74,10 +79,9 @@ executable matebeamter
                      , base64-bytestring
                      , cryptonite
                      , stm
-                     , stm-containers
                      , either
                      , optparse-applicative
-                     , HsYAML
+                     , HsYAML ^>=0.2.1.0
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall

pkgs.nix

@@ -1,342 +0,0 @@
-{
-  pkgs = hackage:
-    {
-      packages = {
-        "focus".revision = (((hackage."focus")."1.0.1.3").revisions).default;
-        "warp".revision = (((hackage."warp")."3.3.4").revisions).default;
-        "warp".flags.allow-sendfilefd = true;
-        "warp".flags.network-bytestring = false;
-        "warp".flags.warp-debug = false;
-        "http-client".revision = (((hackage."http-client")."0.6.4").revisions).default;
-        "http-client".flags.network-uri = true;
-        "cookie".revision = (((hackage."cookie")."0.4.5").revisions).default;
-        "void".revision = (((hackage."void")."0.7.3").revisions).default;
-        "void".flags.safe = false;
-        "semigroupoids".revision = (((hackage."semigroupoids")."5.3.4").revisions).default;
-        "semigroupoids".flags.comonad = true;
-        "semigroupoids".flags.doctests = true;
-        "semigroupoids".flags.unordered-containers = true;
-        "semigroupoids".flags.distributive = true;
-        "semigroupoids".flags.tagged = true;
-        "semigroupoids".flags.containers = true;
-        "semigroupoids".flags.contravariant = true;
-        "byteorder".revision = (((hackage."byteorder")."1.0.4").revisions).default;
-        "singleton-bool".revision = (((hackage."singleton-bool")."0.1.5").revisions).default;
-        "free".revision = (((hackage."free")."5.1.3").revisions).default;
-        "Only".revision = (((hackage."Only")."0.1").revisions).default;
-        "cereal".revision = (((hackage."cereal")."0.5.8.1").revisions).default;
-        "cereal".flags.bytestring-builder = false;
-        "exceptions".revision = (((hackage."exceptions")."0.10.3").revisions).default;
-        "binary".revision = (((hackage."binary")."0.8.6.0").revisions).default;
-        "attoparsec-iso8601".revision = (((hackage."attoparsec-iso8601")."1.0.1.0").revisions).default;
-        "attoparsec-iso8601".flags.fast = false;
-        "attoparsec-iso8601".flags.developer = false;
-        "product-profunctors".revision = (((hackage."product-profunctors")."0.10.0.0").revisions).default;
-        "stm-hamt".revision = (((hackage."stm-hamt")."1.2.0.4").revisions).default;
-        "ghc-prim".revision = (((hackage."ghc-prim")."0.5.3").revisions).default;
-        "utf8-string".revision = (((hackage."utf8-string")."1.0.1.1").revisions).default;
-        "old-time".revision = (((hackage."old-time")."1.1.0.3").revisions).default;
-        "bifunctors".revision = (((hackage."bifunctors")."5.5.6").revisions).default;
-        "bifunctors".flags.semigroups = true;
-        "bifunctors".flags.tagged = true;
-        "split".revision = (((hackage."split")."0.2.3.3").revisions).default;
-        "stm".revision = (((hackage."stm")."2.5.0.0").revisions).default;
-        "dec".revision = (((hackage."dec")."0.0.3").revisions).default;
-        "unix-time".revision = (((hackage."unix-time")."0.4.7").revisions).default;
-        "http2".revision = (((hackage."http2")."2.0.3").revisions).default;
-        "http2".flags.devel = false;
-        "appar".revision = (((hackage."appar")."0.1.8").revisions).default;
-        "case-insensitive".revision = (((hackage."case-insensitive")."1.2.1.0").revisions).default;
-        "network-byte-order".revision = (((hackage."network-byte-order")."0.1.2.0").revisions).default;
-        "unix".revision = (((hackage."unix")."2.7.2.2").revisions).default;
-        "mtl".revision = (((hackage."mtl")."2.2.2").revisions).default;
-        "network-uri".revision = (((hackage."network-uri")."2.6.1.0").revisions).default;
-        "network-info".revision = (((hackage."network-info")."0.2.0.10").revisions).default;
-        "foldl".revision = (((hackage."foldl")."1.4.5").revisions).default;
-        "zlib".revision = (((hackage."zlib")."0.6.2.1").revisions).default;
-        "zlib".flags.non-blocking-ffi = false;
-        "zlib".flags.pkg-config = false;
-        "rts".revision = (((hackage."rts")."1.0").revisions).default;
-        "mmorph".revision = (((hackage."mmorph")."1.1.3").revisions).default;
-        "cmdargs".revision = (((hackage."cmdargs")."0.10.20").revisions).default;
-        "cmdargs".flags.testprog = false;
-        "cmdargs".flags.quotation = true;
-        "primitive-extras".revision = (((hackage."primitive-extras")."0.8").revisions).default;
-        "easy-file".revision = (((hackage."easy-file")."0.2.2").revisions).default;
-        "servant-rawm".revision = (((hackage."servant-rawm")."0.3.2.0").revisions).default;
-        "servant-rawm".flags.buildexample = false;
-        "cryptonite".revision = (((hackage."cryptonite")."0.26").revisions).default;
-        "cryptonite".flags.support_sse = false;
-        "cryptonite".flags.integer-gmp = true;
-        "cryptonite".flags.support_rdrand = true;
-        "cryptonite".flags.support_aesni = true;
-        "cryptonite".flags.support_deepseq = true;
-        "cryptonite".flags.support_pclmuldq = false;
-        "cryptonite".flags.check_alignment = false;
-        "cryptonite".flags.old_toolchain_inliner = false;
-        "postgresql-simple".revision = (((hackage."postgresql-simple")."0.6.2").revisions).default;
-        "adjunctions".revision = (((hackage."adjunctions")."4.4").revisions).default;
-        "cryptohash-md5".revision = (((hackage."cryptohash-md5")."0.11.100.1").revisions).default;
-        "invariant".revision = (((hackage."invariant")."0.5.3").revisions).default;
-        "http-api-data".revision = (((hackage."http-api-data")."0.4.1.1").revisions).default;
-        "http-api-data".flags.use-text-show = false;
-        "distributive".revision = (((hackage."distributive")."0.6.1").revisions).default;
-        "distributive".flags.semigroups = true;
-        "distributive".flags.tagged = true;
-        "vector-th-unbox".revision = (((hackage."vector-th-unbox")."0.2.1.7").revisions).default;
-        "bytestring-builder".revision = (((hackage."bytestring-builder")."0.10.8.2.0").revisions).default;
-        "bytestring-builder".flags.bytestring_has_builder = true;
-        "QuickCheck".revision = (((hackage."QuickCheck")."2.13.2").revisions).default;
-        "QuickCheck".flags.templatehaskell = true;
-        "scientific".revision = (((hackage."scientific")."0.3.6.2").revisions).default;
-        "scientific".flags.integer-simple = false;
-        "scientific".flags.bytestring-builder = false;
-        "time-manager".revision = (((hackage."time-manager")."0.0.0").revisions).default;
-        "stm-containers".revision = (((hackage."stm-containers")."1.1.0.4").revisions).default;
-        "parallel".revision = (((hackage."parallel")."3.2.2.0").revisions).default;
-        "deepseq".revision = (((hackage."deepseq")."1.4.4.0").revisions).default;
-        "random".revision = (((hackage."random")."1.1").revisions).default;
-        "opaleye".revision = (((hackage."opaleye")."0.6.7004.1").revisions).default;
-        "uuid-types".revision = (((hackage."uuid-types")."1.0.3").revisions).default;
-        "string-conversions".revision = (((hackage."string-conversions")."0.4.0.1").revisions).default;
-        "optparse-applicative".revision = (((hackage."optparse-applicative")."0.15.1.0").revisions).default;
-        "network".revision = (((hackage."network")."3.1.1.1").revisions).default;
-        "word8".revision = (((hackage."word8")."0.1.3").revisions).default;
-        "crypto-api".revision = (((hackage."crypto-api")."0.13.3").revisions).default;
-        "crypto-api".flags.all_cpolys = false;
-        "splitmix".revision = (((hackage."splitmix")."0.0.3").revisions).default;
-        "splitmix".flags.optimised-mixer = false;
-        "splitmix".flags.random = true;
-        "async".revision = (((hackage."async")."2.2.2").revisions).default;
-        "async".flags.bench = false;
-        "dlist".revision = (((hackage."dlist")."0.8.0.7").revisions).default;
-        "semigroups".revision = (((hackage."semigroups")."0.19.1").revisions).default;
-        "semigroups".flags.bytestring = true;
-        "semigroups".flags.unordered-containers = true;
-        "semigroups".flags.text = true;
-        "semigroups".flags.tagged = true;
-        "semigroups".flags.containers = true;
-        "semigroups".flags.binary = true;
-        "semigroups".flags.hashable = true;
-        "semigroups".flags.transformers = true;
-        "semigroups".flags.deepseq = true;
-        "semigroups".flags.bytestring-builder = false;
-        "semigroups".flags.template-haskell = true;
-        "pureMD5".revision = (((hackage."pureMD5")."2.1.3").revisions).default;
-        "pureMD5".flags.test = false;
-        "parsec".revision = (((hackage."parsec")."3.1.13.0").revisions).default;
-        "http-media".revision = (((hackage."http-media")."0.8.0.0").revisions).default;
-        "hsc2hs".revision = (((hackage."hsc2hs")."0.68.6").revisions).default;
-        "hsc2hs".flags.in-ghc-tree = false;
-        "directory".revision = (((hackage."directory")."1.3.3.0").revisions).default;
-        "transformers-compat".revision = (((hackage."transformers-compat")."0.6.5").revisions).default;
-        "transformers-compat".flags.five = false;
-        "transformers-compat".flags.generic-deriving = true;
-        "transformers-compat".flags.two = false;
-        "transformers-compat".flags.five-three = true;
-        "transformers-compat".flags.mtl = true;
-        "transformers-compat".flags.four = false;
-        "transformers-compat".flags.three = false;
-        "template-haskell".revision = (((hackage."template-haskell")."2.14.0.0").revisions).default;
-        "psqueues".revision = (((hackage."psqueues")."0.2.7.2").revisions).default;
-        "vector".revision = (((hackage."vector")."0.12.0.3").revisions).default;
-        "vector".flags.unsafechecks = false;
-        "vector".flags.internalchecks = false;
-        "vector".flags.wall = false;
-        "vector".flags.boundschecks = true;
-        "call-stack".revision = (((hackage."call-stack")."0.2.0").revisions).default;
-        "primitive".revision = (((hackage."primitive")."0.7.0.0").revisions).default;
-        "profunctors".revision = (((hackage."profunctors")."5.5.1").revisions).default;
-        "time-locale-compat".revision = (((hackage."time-locale-compat")."0.1.1.5").revisions).default;
-        "time-locale-compat".flags.old-locale = false;
-        "safe".revision = (((hackage."safe")."0.3.18").revisions).default;
-        "blaze-builder".revision = (((hackage."blaze-builder")."0.4.1.0").revisions).default;
-        "base-compat".revision = (((hackage."base-compat")."0.11.0").revisions).default;
-        "math-functions".revision = (((hackage."math-functions")."0.3.3.0").revisions).default;
-        "math-functions".flags.system-expm1 = true;
-        "math-functions".flags.system-erf = true;
-        "wai-session".revision = (((hackage."wai-session")."0.3.3").revisions).default;
-        "time-compat".revision = (((hackage."time-compat")."1.9.2.2").revisions).default;
-        "time-compat".flags.old-locale = false;
-        "ansi-terminal".revision = (((hackage."ansi-terminal")."0.10.2").revisions).default;
-        "ansi-terminal".flags.example = false;
-        "tagged".revision = (((hackage."tagged")."0.8.6").revisions).default;
-        "tagged".flags.transformers = true;
-        "tagged".flags.deepseq = true;
-        "lens".revision = (((hackage."lens")."4.18.1").revisions).default;
-        "lens".flags.j = false;
-        "lens".flags.test-properties = true;
-        "lens".flags.old-inline-pragmas = false;
-        "lens".flags.test-templates = true;
-        "lens".flags.trustworthy = true;
-        "lens".flags.test-doctests = true;
-        "lens".flags.benchmark-uniplate = false;
-        "lens".flags.inlining = true;
-        "lens".flags.dump-splices = false;
-        "lens".flags.test-hunit = true;
-        "lens".flags.safe = false;
-        "servant-blaze".revision = (((hackage."servant-blaze")."0.9").revisions).default;
-        "unliftio-core".revision = (((hackage."unliftio-core")."0.1.2.0").revisions).default;
-        "containers".revision = (((hackage."containers")."0.6.0.1").revisions).default;
-        "deferred-folds".revision = (((hackage."deferred-folds")."0.9.10.1").revisions).default;
-        "integer-logarithms".revision = (((hackage."integer-logarithms")."1.0.3").revisions).default;
-        "integer-logarithms".flags.check-bounds = false;
-        "integer-logarithms".flags.integer-gmp = true;
-        "servant-docs".revision = (((hackage."servant-docs")."0.11.4").revisions).default;
-        "base-prelude".revision = (((hackage."base-prelude")."1.3").revisions).default;
-        "reflection".revision = (((hackage."reflection")."2.1.5").revisions).default;
-        "reflection".flags.slow = false;
-        "reflection".flags.template-haskell = true;
-        "streaming-commons".revision = (((hackage."streaming-commons")."0.2.1.1").revisions).default;
-        "streaming-commons".flags.use-bytestring-builder = false;
-        "bytestring".revision = (((hackage."bytestring")."0.10.8.2").revisions).default;
-        "ansi-wl-pprint".revision = (((hackage."ansi-wl-pprint")."0.6.9").revisions).default;
-        "ansi-wl-pprint".flags.example = false;
-        "mwc-random".revision = (((hackage."mwc-random")."0.14.0.0").revisions).default;
-        "wai".revision = (((hackage."wai")."3.2.2.1").revisions).default;
-        "basement".revision = (((hackage."basement")."0.0.11").revisions).default;
-        "cryptohash-sha1".revision = (((hackage."cryptohash-sha1")."0.11.100.1").revisions).default;
-        "either".revision = (((hackage."either")."5.0.1.1").revisions).default;
-        "old-locale".revision = (((hackage."old-locale")."1.0.0.7").revisions).default;
-        "StateVar".revision = (((hackage."StateVar")."1.2").revisions).default;
-        "vault".revision = (((hackage."vault")."0.3.1.3").revisions).default;
-        "vault".flags.useghc = true;
-        "mime-types".revision = (((hackage."mime-types")."0.1.0.9").revisions).default;
-        "pcg-random".revision = (((hackage."pcg-random")."0.1.3.6").revisions).default;
-        "contravariant".revision = (((hackage."contravariant")."1.5.2").revisions).default;
-        "contravariant".flags.semigroups = true;
-        "contravariant".flags.tagged = true;
-        "contravariant".flags.statevar = true;
-        "HsYAML".revision = (((hackage."HsYAML")."0.2.1.0").revisions).default;
-        "HsYAML".flags.exe = false;
-        "type-equality".revision = (((hackage."type-equality")."1").revisions).default;
-        "vector-builder".revision = (((hackage."vector-builder")."0.3.8").revisions).default;
-        "blaze-markup".revision = (((hackage."blaze-markup")."0.8.2.3").revisions).default;
-        "postgresql-libpq".revision = (((hackage."postgresql-libpq")."0.9.4.2").revisions).default;
-        "postgresql-libpq".flags.use-pkg-config = false;
-        "uuid".revision = (((hackage."uuid")."1.3.13").revisions).default;
-        "text".revision = (((hackage."text")."1.2.3.1").revisions).default;
-        "Cabal".revision = (((hackage."Cabal")."2.4.0.1").revisions).default;
-        "unordered-containers".revision = (((hackage."unordered-containers")."0.2.10.0").revisions).default;
-        "unordered-containers".flags.debug = false;
-        "base64-bytestring".revision = (((hackage."base64-bytestring")."1.0.0.2").revisions).default;
-        "aeson-pretty".revision = (((hackage."aeson-pretty")."0.8.8").revisions).default;
-        "aeson-pretty".flags.lib-only = false;
-        "base".revision = (((hackage."base")."4.12.0.0").revisions).default;
-        "servant-client".revision = (((hackage."servant-client")."0.16.0.1").revisions).default;
-        "comonad".revision = (((hackage."comonad")."5.0.6").revisions).default;
-        "comonad".flags.distributive = true;
-        "comonad".flags.test-doctests = true;
-        "comonad".flags.containers = true;
-        "time".revision = (((hackage."time")."1.8.0.2").revisions).default;
-        "data-default-class".revision = (((hackage."data-default-class")."0.1.2.0").revisions).default;
-        "universe-base".revision = (((hackage."universe-base")."1.1.1").revisions).default;
-        "base16-bytestring".revision = (((hackage."base16-bytestring")."0.1.1.6").revisions).default;
-        "iproute".revision = (((hackage."iproute")."1.7.8").revisions).default;
-        "transformers".revision = (((hackage."transformers")."0.5.6.2").revisions).default;
-        "hashable".revision = (((hackage."hashable")."1.3.0.0").revisions).default;
-        "hashable".flags.sse2 = true;
-        "hashable".flags.integer-gmp = true;
-        "hashable".flags.sse41 = false;
-        "hashable".flags.examples = false;
-        "wai-extra".revision = (((hackage."wai-extra")."3.0.28").revisions).default;
-        "wai-extra".flags.build-example = false;
-        "attoparsec".revision = (((hackage."attoparsec")."0.13.2.3").revisions).default;
-        "attoparsec".flags.developer = false;
-        "blaze-html".revision = (((hackage."blaze-html")."0.9.1.2").revisions).default;
-        "colour".revision = (((hackage."colour")."2.3.5").revisions).default;
-        "transformers-base".revision = (((hackage."transformers-base")."0.4.5.2").revisions).default;
-        "transformers-base".flags.orphaninstances = true;
-        "file-embed".revision = (((hackage."file-embed")."0.0.11").revisions).default;
-        "entropy".revision = (((hackage."entropy")."0.4.1.5").revisions).default;
-        "entropy".flags.halvm = false;
-        "filepath".revision = (((hackage."filepath")."1.4.2.1").revisions).default;
-        "auto-update".revision = (((hackage."auto-update")."0.1.6").revisions).default;
-        "servant-client-core".revision = (((hackage."servant-client-core")."0.16").revisions).default;
-        "unix-compat".revision = (((hackage."unix-compat")."0.5.2").revisions).default;
-        "unix-compat".flags.old-time = false;
-        "monad-control".revision = (((hackage."monad-control")."1.0.2.3").revisions).default;
-        "process".revision = (((hackage."process")."1.6.5.0").revisions).default;
-        "list-t".revision = (((hackage."list-t")."1.0.4").revisions).default;
-        "kan-extensions".revision = (((hackage."kan-extensions")."5.2").revisions).default;
-        "wai-logger".revision = (((hackage."wai-logger")."2.3.6").revisions).default;
-        "resourcet".revision = (((hackage."resourcet")."1.2.2").revisions).default;
-        "pretty".revision = (((hackage."pretty")."1.1.3.6").revisions).default;
-        "cabal-doctest".revision = (((hackage."cabal-doctest")."1.0.8").revisions).default;
-        "aeson".revision = (((hackage."aeson")."1.4.6.0").revisions).default;
-        "aeson".flags.cffi = false;
-        "aeson".flags.fast = false;
-        "aeson".flags.bytestring-builder = false;
-        "aeson".flags.developer = false;
-        "wai-app-static".revision = (((hackage."wai-app-static")."3.1.6.3").revisions).default;
-        "wai-app-static".flags.print = false;
-        "http-types".revision = (((hackage."http-types")."0.12.3").revisions).default;
-        "ghc-boot-th".revision = (((hackage."ghc-boot-th")."8.6.5").revisions).default;
-        "i18n".revision = (((hackage."i18n")."0.4.0.0").revisions).default;
-        "servant-server".revision = (((hackage."servant-server")."0.16.2").revisions).default;
-        "primitive-unlifted".revision = (((hackage."primitive-unlifted")."0.1.2.0").revisions).default;
-        "base-orphans".revision = (((hackage."base-orphans")."0.8.1").revisions).default;
-        "http-date".revision = (((hackage."http-date")."0.0.8").revisions).default;
-        "random-bytestring".revision = (((hackage."random-bytestring")."0.1.3.2").revisions).default;
-        "random-bytestring".flags.with-pcg = true;
-        "servant".revision = (((hackage."servant")."0.16.2").revisions).default;
-        "th-abstraction".revision = (((hackage."th-abstraction")."0.3.1.0").revisions).default;
-        "memory".revision = (((hackage."memory")."0.15.0").revisions).default;
-        "memory".flags.support_bytestring = true;
-        "memory".flags.support_basement = true;
-        "memory".flags.support_foundation = true;
-        "memory".flags.support_deepseq = true;
-        "fast-logger".revision = (((hackage."fast-logger")."3.0.0").revisions).default;
-        "bsb-http-chunked".revision = (((hackage."bsb-http-chunked")."0.0.0.4").revisions).default;
-        "array".revision = (((hackage."array")."0.5.3.0").revisions).default;
-        "simple-sendfile".revision = (((hackage."simple-sendfile")."0.2.30").revisions).default;
-        "simple-sendfile".flags.allow-bsd = true;
-        "integer-gmp".revision = (((hackage."integer-gmp")."1.0.2.0").revisions).default;
-        };
-      compiler = {
-        version = "8.6.5";
-        nix-name = "ghc865";
-        packages = {
-          "binary" = "0.8.6.0";
-          "ghc-prim" = "0.5.3";
-          "stm" = "2.5.0.0";
-          "unix" = "2.7.2.2";
-          "mtl" = "2.2.2";
-          "rts" = "1.0";
-          "deepseq" = "1.4.4.0";
-          "parsec" = "3.1.13.0";
-          "directory" = "1.3.3.0";
-          "template-haskell" = "2.14.0.0";
-          "containers" = "0.6.0.1";
-          "bytestring" = "0.10.8.2";
-          "text" = "1.2.3.1";
-          "Cabal" = "2.4.0.1";
-          "base" = "4.12.0.0";
-          "time" = "1.8.0.2";
-          "transformers" = "0.5.6.2";
-          "filepath" = "1.4.2.1";
-          "process" = "1.6.5.0";
-          "pretty" = "1.1.3.6";
-          "ghc-boot-th" = "8.6.5";
-          "array" = "0.5.3.0";
-          "integer-gmp" = "1.0.2.0";
-          };
-        };
-      };
-  extras = hackage:
-    {
-      packages = {
-        mateamt = ./.plan.nix/mateamt.nix;
-        matebeamter = ./.plan.nix/matebeamter.nix;
-        };
-      };
-  modules = [
-    ({ lib, ... }:
-      {
-        packages = {
-          "mateamt" = { flags = { "develop" = lib.mkOverride 900 false; }; };
-          "matebeamter" = { flags = {}; };
-          };
-        })
-    ];
-  }

shell.nix

@@ -1,6 +1,20 @@
-{ pkgs ? import <nixpkgs> {} }:
+{ pkgs ? import <nixpkgs> {}}:
 
 let
-  hsPkgs = import ./default.nix;
+  # create a modified haskell package set with my package inside it and broken dependencies
+  # jailbroken.
+  hpkgs = pkgs.haskellPackages.override {
+    overrides = hself: hsuper: {
+      matebeamter = hself.callCabal2nix "matebeamter" (gitignore ./.) {};
+      mateamt = hself.callCabal2nix "mateamt" (gitignore ../mateamt) {};
+      i18n = with pkgs.haskell.lib;
+        doJailbreak (unmarkBroken (dontCheck hsuper.i18n));
+      pg-transact = with pkgs.haskell.lib;
+        doJailbreak (unmarkBroken (dontCheck hsuper.pg-transact));
+      token-bucket = with pkgs.haskell.lib;
+        doJailbreak (unmarkBroken (dontCheck hsuper.token-bucket));
+    };
+  };
+  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
 in
-  hsPkgs.matebeamter.components.all
+  hpkgs.matebeamter.env

src/API.hs

@@ -11,7 +11,7 @@ module API where
 
 import Servant.API
 import Servant.Links
--- import Servant.RawM
+import Servant.RawM
 import Servant.HTML.Blaze
 
 import Data.Proxy
@@ -27,7 +27,8 @@ import qualified "mateamt" Types as MT
 import Types
 
 type UserAPI =
-  Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
+  Header "Cookie" T.Text :> (
+  QueryParam "refine" MT.UserRefine :> Get '[HTML] UserSelectPage
   :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
     :> Get '[HTML] UserOverviewPage
   :<|> "user" :> Capture "id" Int :> "buy"
@@ -70,6 +71,19 @@ type UserAPI =
   :<|> "journal" :> "check"
     :> ReqBody '[FormUrlEncoded] CashCheck
     :> Post '[HTML] JournalPage
+  :<|> "product" :> "list"
+    :> QueryParam "refine" MT.ProductRefine
+    :> Get '[HTML] ProductPriceListPage
+  :<|> "product" :> "refill"
+    :> Get '[HTML] ProductRefillPage
+  :<|> "product" :> "refill"
+    :> ReqBody '[FormUrlEncoded] [MT.AmountRefill]
+    :> Post '[HTML] ProductRefillPage
+  :<|> "product" :> "new"
+    :> Get '[HTML] ProductNewPage
+  :<|> "product" :> "new"
+    :> ReqBody '[FormUrlEncoded] ProductSubmit
+    :> Post '[HTML] UserOverviewPage
   :<|> "auth"
     :> QueryParam "destination" T.Text
     :> Get '[HTML]
@@ -83,6 +97,7 @@ type UserAPI =
     :> Post '[HTML] UserSelectPage
   :<|> "auth" :> "logout"
     :> Post '[HTML] UserOverviewPage
+  :<|> "static" :> RawM
   )
 
 ( userSelectLink :<|>
@@ -102,7 +117,13 @@ type UserAPI =
   journalLink :<|>
   journalGetCheckLink :<|>
   journalPostCheckLink :<|>
+  productGetPriceListLink :<|>
+  productGetRefillLink :<|>
+  productPostRefillLink :<|>
+  productGetNewLink :<|>
+  productPostNewLink :<|>
   authLink :<|>
   authPostLink :<|>
-  authLogoutLink
+  authLogoutLink :<|>
+  staticLink
   ) = allLinks (Proxy :: Proxy UserAPI)

src/Client.hs

@@ -96,6 +96,8 @@ avatarUpdate
   -> ClientM ()
 avatarList :: ClientM [MT.Avatar]
 
+metaGet :: ClientM MT.MetaInformation
+
 ( authGet :<|>
   authSend :<|>
   authLogout :<|>
@@ -126,7 +128,9 @@ avatarList :: ClientM [MT.Avatar]
   avatarGet :<|>
   avatarInsert :<|>
   avatarUpdate :<|>
-  avatarList
+  avatarList :<|>
+
+  metaGet
   ) = client mateApi
 
 getClients clientEnv = hoistClient

src/ClientAuth.hs

@@ -6,10 +6,10 @@ module ClientAuth where
 import Servant.API (AuthProtect)
 import Servant.Client.Core
 
-type instance AuthClientData (AuthProtect "header-auth") = String
+type instance AuthClientData (AuthProtect "Bearer") = String
 
 authenticateReq :: String -> Request -> Request
-authenticateReq = addHeader "Authentication"
+authenticateReq = addHeader "Bearer"
 
 nonAuthenticateRequest :: String -> Request -> Request
 nonAuthenticateRequest _ = id

src/Control.hs

@@ -6,3 +6,4 @@ import Control.Auth as C
 import Control.User as C
 import Control.Buy as C
 import Control.Journal as C
+import Control.Product as C

src/Control/Auth.hs

@@ -64,7 +64,7 @@ authControl mcookie mDestination = do
               Nothing
               )
     (Just authUser, Nothing) -> do
-      (ReadState _ backend _) <- ask
+      (ReadState _ backend _ _ _) <- ask
       let trs = map
             (MT.TicketRequest
               (read (T.unpack authUser) :: Int))
@@ -99,7 +99,7 @@ authControl mcookie mDestination = do
            ]
           AuthPage)
     digestAuthInfo tupAuthInfos = do
-      (ReadState l10n _ _) <- ask
+      (ReadState l10n _ _ _ version) <- ask
       let loc = Locale
             (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
           ticketHeaders = map
@@ -110,19 +110,20 @@ authControl mcookie mDestination = do
       return $
         addHeader (head ticketHeaders) $
           addHeader (ticketHeaders !! 1) $
-            authPage l10n loc mDestination mcookie
+            authPage l10n loc mDestination version mcookie
 
 authPostControl
   :: Maybe T.Text
   -> Maybe T.Text
   -> AuthReturn
   -> UserHandler UserSelectPage
-authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
+authPostControl mcookies@(Just cookies) mDestination (AuthReturn pass method) = do
   let mticket = lookup ("x-ticket-" <> fromString (show method)) $
         parseCookieText cookies
+  (_, _, loc, l10n, _, _, _) <- controlInit mcookies
   case mticket of
     Just ticket -> do
-      (ReadState _ backend _) <- ask
+      (ReadState _ backend _ _ _) <- ask
       hashedPass <- hashPassword pass
       etoken <- liftIO $ runClientM
         (authSend
@@ -145,7 +146,7 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
                       (read $ T.unpack user)
                       Nothing
                       )
-                _ -> errHeaders $ redirect303 userSelectLink
+                _ -> errHeaders $ redirect303 (userSelectLink Nothing)
           throwError $ err303
             { errHeaders = headers ++
               [ ( "Set-Cookie"
@@ -158,15 +159,18 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
                 , "x-method=" <> fromString (show $ fromEnum method) <>";Path=/")
               ]
             }
-        Right MT.Denied -> throwError $ err401
+        Right MT.Denied -> throwError (
-          { errBody = "Authentication failed!"
+          addMessage (translate l10n loc "Authentication failed!") $
-          }
+          redirect303 (userSelectLink Nothing)
+          )
         Left err -> throwError $ err500
           { errBody = fromString $ show err
           }
     Nothing -> throwError $ err400
       { errBody = "No ticket cookie present."
       }
+  where
+    translate l10n locale = localize l10n locale . gettext
 authPostControl Nothing _ _ = throwError $ err400
   { errBody = "No ticket cookie present."
   }
@@ -175,7 +179,7 @@ authLogoutControl
   :: Maybe T.Text
   -> UserHandler UserOverviewPage
 authLogoutControl mcookie = do
-  (ReadState _ backend _) <- ask
+  (ReadState _ backend _ _ _) <- ask
   let mParsedCookie = fmap parseCookieText mcookie
       token = T.unpack $ fromMaybe "secret"
         (lookup "x-token" =<< mParsedCookie)
@@ -184,7 +188,7 @@ authLogoutControl mcookie = do
     backend
   case eReturn of
     Right _ -> do
-      let redirectHeaders = errHeaders (redirect303 userSelectLink)
+      let redirectHeaders = errHeaders (redirect303 $ userSelectLink Nothing)
           unsetCookiesHeaders = map
             (\c ->
               ( "Set-Cookie"

src/Control/Buy.hs

@@ -42,14 +42,14 @@ buyControl
   -> [MT.PurchaseDetail]
   -> Bool
   -> UserHandler BuyConfirmPage
-buyControl mcookie uid pds forceBuy =
+buyControl mcookie uid pds forceBuy = do
+  (ReadState l10n backend _ symbol version) <- ask
+  let (token, _) = parseTokenAndUser mcookie
+      loc = Locale
+        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
   if not (null pds)
   then do
-    (ReadState l10n backend _) <- ask
+    let pids = map MT.purchaseDetailProduct pds
-    let (token, _) = parseTokenAndUser mcookie
-        loc = Locale
-          (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
-        pids = map MT.purchaseDetailProduct pds
     epsovs <- liftIO $ runClientM
       (productShortList (Just MT.AllProducts))
       backend
@@ -66,13 +66,33 @@ buyControl mcookie uid pds forceBuy =
               (\acc
                 ( MT.PurchaseDetail _ amount
                 , MT.ProductShortOverview _ _ price _ _ _) ->
-                  acc + (max 0 amount) * price
+                  acc + max 0 amount * price
                 )
               0
               ziptup
-        return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie)
+        return
+          (buyConfirmPage
+            l10n
+            loc
+            uid
+            ziptup
+            total
+            forceBuy
+            version
+            mcookie
+            symbol
+            )
+      Left err ->
+        throwError $
+          addMessage (fromString $ show err) $
+          redirect303 (userSelectLink Nothing)
   else
-    throwError (redirect303 $ userOverviewLink uid Nothing)
+    throwError (
+      addMessage (translate l10n loc "Please select items for purchase") $
+      redirect303 (userOverviewLink uid Nothing)
+      )
+  where
+    translate l10n locale = localize l10n locale . gettext
 
 purchaseControl
   :: Maybe T.Text
@@ -91,7 +111,7 @@ purchaseControl mcookie uid pds forceBuy = do
     erefres <- if forceBuy
       then do
         let refills = map
-              (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount)
+              (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount 0)
               pds
         liftIO $ runClientM
           (productStockRefill
@@ -154,7 +174,7 @@ purchaseControl mcookie uid pds forceBuy = do
   else
     throwError
       $ addMessage (translate l10n loc "Please choose your product(s)")
-      $ (redirect303 $ userOverviewLink uid Nothing)
+      (redirect303 $ userOverviewLink uid Nothing)
   where
     logoutAndRedirectHome message backend token = do
       void $ liftIO $ runClientM
@@ -164,7 +184,7 @@ purchaseControl mcookie uid pds forceBuy = do
         backend
       throwError
         $ addMessage message
-        $ redirect303 userSelectLink
+        $ redirect303 (userSelectLink Nothing)
     translate l10n locale = localize l10n locale . gettext
 
 cashBuyOverviewControl
@@ -172,7 +192,7 @@ cashBuyOverviewControl
   -> Maybe MT.ProductRefine
   -> UserHandler CashBuyOverviewPage
 cashBuyOverviewControl mcookie mrefine = do
-  (ReadState l10n backend _) <- ask
+  (ReadState l10n backend _ symbol version) <- ask
   let loc = localeFromCookie mcookie
   eproducts <- liftIO $ runClientM
     (productShortList
@@ -181,7 +201,7 @@ cashBuyOverviewControl mcookie mrefine = do
     backend
   case eproducts of
     Right prods ->
-      return $ cashBuyOverviewPage l10n loc mcookie prods
+      return $ cashBuyOverviewPage l10n loc version mcookie prods
     Left err ->
       throwError $ err500
         { errBody = fromString (show err)
@@ -194,6 +214,7 @@ cashBuyPurchaseControl
   -> UserHandler UserSelectPage
 cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
   l10n <- asks rsL10n
+  symbol <- asks rsCurrencySymbol
   let loc = localeFromCookie mcookie
   if not (null pds)
   then do
@@ -222,8 +243,9 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
         (MT.PurchaseResult (MT.PayAmount price) []) ->
           throwError $
             addMessage
-              (translate l10n loc "Please Pay" <> ": " <> formatMoney price) $
+              (translate l10n loc "Please Pay" <>
-            redirect303 userSelectLink
+                ": " <> formatMoney price <> symbol) $
+              redirect303 (userSelectLink Nothing)
         (MT.PurchaseResult (MT.PayAmount price) miss) -> do
           eproducts <- liftIO $ runClientM
             (productShortList
@@ -235,13 +257,13 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
             Right prods ->
               throwError
                 $ addMessage (translate l10n loc "Please Pay" <> ": "
-                  <> formatMoney price
+                  <> formatMoney price <> symbol
                   <> ". "
                   <> translate l10n loc
-                    ("But there seems to be something missing: ")
+                    "But there seems to be something missing: "
                   <> mconcat (reverse $ foldl
                     (\acc (MT.ProductShortOverview psoid ident _ _ _ _) ->
-                      if psoid `elem` fst (unzip missIds)
+                      if psoid `elem` map fst missIds
                       then
                         (fromString (show $ fromJust $ lookup psoid missIds)
                         <> " x "
@@ -251,14 +273,16 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
                     []
                     prods
                   ))
-                $ redirect303 userSelectLink
+                $ redirect303 (userSelectLink Nothing)
             Left err ->
               throwError $ err500
                 { errBody = fromString (show err)
                 }
+      Left err ->
+        handleClientErr err Nothing (Just (userSelectLink Nothing))
   else
     throwError
       $ addMessage (translate l10n loc "Please choose your product(s)")
-      $ (redirect303 $ cashBuyLink Nothing)
+      (redirect303 $ cashBuyLink Nothing)
   where
     translate l10n locale = localize l10n locale . gettext

src/Control/Journal.hs

@@ -15,7 +15,7 @@ import Data.String
 import qualified Data.Text as T
 import Data.Text.I18n
 
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybe, fromJust)
 
 import Network.HTTP.Types.Status (Status(..))
 
@@ -37,22 +37,19 @@ journalControl
   -> Maybe Word
   -> UserHandler JournalPage
 journalControl mcookie mpage = do
-  let (token, muser) = parseTokenAndUser mcookie
+  (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
-      loc = localeFromCookie mcookie
-  l10n <- asks rsL10n
-  backend <- asks rsBackend
   case muser of
     Just user -> do
       eresult <- liftIO $ runClientM
         (journalShow
           (mkAuthenticatedRequest token authenticateReq)
           (Just 50)
-          (Just $ 50 * fromMaybe 0 (fromIntegral <$> mpage))
+          (Just $ 50 * maybe 0 fromIntegral mpage)
           )
         backend
       case eresult of
         Right entries ->
-          return (journalPage l10n loc mcookie mpage entries)
+          return (journalPage l10n loc version mcookie mpage entries)
         Left err ->
           case err of
             FailureResponse _ resp ->
@@ -62,11 +59,11 @@ journalControl mcookie mpage = do
               else
                 throwError $
                   addMessage (fromString $ show err) $
-                  redirect303 userSelectLink
+                  redirect303 (userSelectLink Nothing)
             othererr -> 
               throwError $
                 addMessage (fromString $ show othererr) $
-                redirect303 userSelectLink
+                redirect303 (userSelectLink Nothing)
     Nothing ->
       redirectOverAuth Nothing (Just $ journalLink mpage) Nothing
 
@@ -74,26 +71,21 @@ journalGetCheckControl
   :: Maybe T.Text
   -> UserHandler JournalCheckPage
 journalGetCheckControl mcookie = do
-  let (token, muser) = parseTokenAndUser mcookie
+  (token, muser, loc, l10n, _, symbol, version) <- controlInit mcookie
-      loc = localeFromCookie mcookie
+  return $ journalCheckPage l10n loc version mcookie
-  l10n <- asks rsL10n
-  return $ journalCheckPage l10n loc mcookie
 
 journalPostCheckControl
   :: Maybe T.Text
   -> CashCheck
   -> UserHandler JournalPage
 journalPostCheckControl mcookie (CashCheck floatAmount) = do
-  let (token, muser) = parseTokenAndUser mcookie
+  (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
-      loc = localeFromCookie mcookie
-  l10n <- asks rsL10n
-  backend <- asks rsBackend
   case muser of
     Just user -> do
       eresult <- liftIO $ runClientM
         (journalPostCashCheck
           (mkAuthenticatedRequest token authenticateReq)
-          (MT.JournalCashCheck $ floor $ floatAmount * 100)
+          (MT.JournalCashCheck (fromJust muser) $ floor $ floatAmount * 100)
           )
         backend
       case eresult of
@@ -101,19 +93,7 @@ journalPostCheckControl mcookie (CashCheck floatAmount) = do
           addMessage (translate l10n loc "Cash check received and processed") $
           redirect303 (journalLink Nothing)
         Left err ->
-          case err of
+          handleClientErr err muser (Just journalGetCheckLink)
-            FailureResponse _ resp ->
-              if statusCode (responseStatusCode resp) == 401
-              then
-                redirectOverAuth Nothing (Just $ journalGetCheckLink) Nothing
-              else
-                throwError $
-                  addMessage (fromString $ show err) $
-                  redirect303 userSelectLink
-            otherErr ->
-              throwError $
-                addMessage (fromString $ show otherErr) $
-                redirect303 userSelectLink
     Nothing ->
       redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing
   where

src/Control/Product.hs

@@ -0,0 +1,141 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+module Control.Product where
+
+import Servant
+import Servant.Client
+import Servant.Client.Core.Auth (mkAuthenticatedRequest)
+
+import Data.String (fromString)
+
+import qualified Data.Text as T
+
+import Data.Text.I18n
+
+import Control.Monad.IO.Class (liftIO)
+
+-- imports from "mateamt"
+
+import qualified "mateamt" Types as MT
+
+-- internal imports
+
+import Types
+import View
+import Util
+import Client
+import ClientAuth
+import API
+import Hash
+
+productGetPriceList
+  :: Maybe T.Text
+  -> Maybe MT.ProductRefine
+  -> UserHandler ProductPriceListPage
+productGetPriceList mcookie mrefine = do
+  (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
+  elist <- liftIO $ runClientM
+    (productShortList
+      mrefine
+      )
+    backend
+  case elist of
+    Right list ->
+      return (productPriceListPage l10n loc version mcookie list symbol)
+    Left err ->
+      throwError $
+        addMessage (fromString $ show err) $
+        redirect303 (userSelectLink Nothing)
+
+productGetRefill
+  :: Maybe T.Text
+  -> UserHandler ProductRefillPage
+productGetRefill mcookie = do
+  (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
+  case muser of
+    Just _ -> do
+      elist <- liftIO $ runClientM
+        (productShortList (Just MT.AllProducts))
+        backend
+      case elist of
+        Right list -> do
+          return $ productRefillPage l10n loc version mcookie list
+        Left err ->
+          throwError $
+            addMessage (fromString $ show err) $
+            redirect303 (userSelectLink Nothing)
+    Nothing ->
+      redirectOverAuth Nothing (Just productGetRefillLink) Nothing
+
+productPostRefill
+  :: Maybe T.Text
+  -> [MT.AmountRefill]
+  -> UserHandler ProductRefillPage
+productPostRefill mcookie refills = do
+  (token, muser, loc, l10n, backend, _, _) <- controlInit mcookie
+  case muser of
+    Just _ -> do
+      eresult <- liftIO $ runClientM
+        (productStockRefill
+          (mkAuthenticatedRequest token authenticateReq)
+          refills
+          )
+        backend
+      case eresult of
+        Right _ ->
+          throwError $
+            addMessage (translate l10n loc "Refill successfull") $
+            redirect303 productGetRefillLink
+        Left err ->
+          handleClientErr err muser (Just productGetRefillLink)
+    Nothing ->
+      redirectOverAuth muser (Just productGetRefillLink) Nothing
+  where
+    translate l10n loc = localize l10n loc . gettext
+
+productGetNew
+  :: Maybe T.Text
+  -> UserHandler ProductNewPage
+productGetNew mcookie = do
+  (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
+  case muser of
+    Just user ->
+      -- TODO: Fetch avatars and suppliers
+      return $ productNewPage l10n loc version mcookie symbol
+    Nothing ->
+      redirectOverAuth muser (Just productGetRefillLink) Nothing
+
+productPostNew
+  :: Maybe T.Text
+  -> ProductSubmit
+  -> UserHandler ProductNewPage
+productPostNew mcookie (ProductSubmit ident flPrice ml max apc ppc artnr) = do
+  (token, muser, loc, l10n, backend, _, _) <- controlInit mcookie
+  case muser of
+    Just user -> do
+      eresult <- liftIO $ runClientM
+        (productNew
+          (mkAuthenticatedRequest token authenticateReq)
+          (MT.ProductSubmit
+            ident
+            (floor $ flPrice * 100)
+            ml
+            -- TODO: repleace following two values with real avatar and supplier
+            Nothing
+            Nothing
+            max
+            apc
+            (floor <$> fmap (* 100) ppc)
+            artnr
+            )
+          )
+        backend
+      case eresult of
+        Right _ ->
+          throwError $
+            addMessage (translate l10n loc "Product created successfully") $
+            redirect303 (userOverviewLink user Nothing)
+    Nothing ->
+      redirectOverAuth muser (Just productGetRefillLink) Nothing
+  where
+    translate l10n loc = localize l10n loc . gettext

src/Control/User.hs

@@ -36,40 +36,40 @@ import Hash
 import API
 import Util
 
-userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage
+userSelectControl
-userSelectControl mcookie = do
+  :: Maybe T.Text
-  (ReadState l10n backend _) <- ask
+  -> Maybe MT.UserRefine
+  -> UserHandler UserSelectPage
+userSelectControl mcookie mrefine = do
+  (ReadState l10n backend _ _ version) <- ask
   let loc = Locale
-        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
+        (fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
   euser <- liftIO $ runClientM
-    (userList Nothing)
+    (userList mrefine)
     backend
   case euser of
     Right uss ->
-      return $ userSelectPage l10n loc uss mcookie
+      return $ userSelectPage l10n loc uss version mcookie
     Left err ->
       error $ show err
 
 userNewControl :: Maybe T.Text -> UserHandler UserNewPage
 userNewControl mcookie = do
-  (ReadState l10n _ _) <- ask
+  (ReadState l10n _ _ _ version) <- ask
   let loc = Locale
-        (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
+        (fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
-  return $ userNewPage l10n loc mcookie
+  return $ userNewPage l10n loc version mcookie
 
 userNewPostControl
   :: Maybe T.Text
   -> MT.UserSubmit
   -> UserHandler UserSelectPage
-userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do
+userNewPostControl _ us = do
   backend <- asks rsBackend
-  hashedPass <- hashPassword pass
   void $ liftIO $ runClientM
-    (userNew $us
+    (userNew us)
-      { MT.userSubmitPassHash = hashedPass
-      })
     backend
-  throwError $ redirect303 userSelectLink
+  throwError $ redirect303 (userSelectLink Nothing)
 
 userOverviewControl
   :: Maybe T.Text
@@ -77,7 +77,7 @@ userOverviewControl
   -> Maybe MT.ProductRefine
   -> UserHandler UserOverviewPage
 userOverviewControl mcookie uid mRefine = do
-  (ReadState l10n backend _) <- ask
+  (ReadState l10n backend _ symbol version) <- ask
   let loc = Locale
         (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
       mParsedCookie = fmap parseCookieText mcookie
@@ -91,7 +91,7 @@ userOverviewControl mcookie uid mRefine = do
     runClientM
       (userGet (mkAuthenticatedRequest token authenticateReq))
       backend
-  eproducts <- case fmap toEnum (fmap read mMethod) of
+  eproducts <- case fmap (toEnum . read) mMethod of
     Just MT.PrimaryPass -> return (Right [])
     Just MT.SecondaryPass -> getProducts
     Just MT.ChallengeResponse -> getProducts
@@ -100,17 +100,25 @@ userOverviewControl mcookie uid mRefine = do
     (Right ud, Right prods) ->
       case mMethod of
         Just method ->
-          if fmap read mAuthUser == Just uid
+          if mAuthUser == Just uid
           then
             return $
-              userOverviewPage l10n loc (toEnum $ read method) ud prods mcookie
+              userOverviewPage
+                l10n
+                loc
+                (toEnum $ read method)
+                ud
+                prods
+                version
+                mcookie
+                symbol
           else
             redirectOverAuth
               (Just uid)
               (Just $ userOverviewLink uid mRefine)
               mRefine
         Nothing ->
-          redirectOverAuth (read <$> mAuthUser) Nothing mRefine
+          redirectOverAuth mAuthUser Nothing mRefine
     (Left uerr, Right _) -> case uerr of
       FailureResponse _ resp ->
         if statusCode (responseStatusCode resp) == 401
@@ -138,9 +146,9 @@ userRechargeControl
   -> Int
   -> UserHandler UserRechargePage
 userRechargeControl mcookie uid = do
-  l10n <- asks rsL10n
+  (ReadState l10n _ _ symbol version) <- ask
   let loc = localeFromCookie mcookie
-  return $ userRechargePage l10n loc mcookie uid
+  return $ userRechargePage l10n loc version mcookie uid symbol
 
 userPostRechargeControl
   :: Maybe T.Text
@@ -148,7 +156,7 @@ userPostRechargeControl
   -> UserRecharge
   -> UserHandler UserOverviewPage
 userPostRechargeControl mcookie uid (UserRecharge amount) = do
-  (ReadState l10n backend _) <- ask
+  (ReadState l10n backend _ _ _) <- ask
   let loc = localeFromCookie mcookie
       (token, mauthuser) = parseTokenAndUser mcookie
   eresult <- liftIO $ runClientM
@@ -161,10 +169,10 @@ userPostRechargeControl mcookie uid (UserRecharge amount) = do
   then
     case eresult of
       Right _ -> throwError $
-        (addMessage $ translate l10n loc "Recharge Successful") $
+        addMessage (translate l10n loc "Recharge Successful") $
         redirect303 (userOverviewLink uid Nothing)
       Left err -> throwError $
-        (addMessage $ translate l10n loc ("An error occured. " <>
+        addMessage (translate l10n loc ("An error occured. " <>
           fromString (show err))) $
         redirect303 (userRechargeLink uid)
   else
@@ -177,7 +185,7 @@ userManageControl
   -> Int
   -> UserHandler UserManagePage
 userManageControl mcookie uid = do
-  (ReadState l10n backend _) <- ask
+  (ReadState l10n backend _ _ version) <- ask
   let loc = localeFromCookie mcookie
       (token, mAuthUser) = parseTokenAndUser mcookie
   eUserDetails <- liftIO $
@@ -190,9 +198,10 @@ userManageControl mcookie uid = do
       backend
   case (eUserDetails, eAuthOverviews) of
     (Right userDetails, Right authOverviews) ->
-      if Just uid == fmap read mAuthUser
+      if Just uid == mAuthUser
       then
-        return $ userManagePage l10n loc userDetails authOverviews mcookie
+        return $
+          userManagePage l10n loc userDetails authOverviews version mcookie
       else
         redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing
     err -> handleErrors
@@ -206,7 +215,7 @@ userManageDetailsSubmitControl
   -> MT.UserDetailsSubmit
   -> UserHandler UserOverviewPage
 userManageDetailsSubmitControl mcookie uid uds = do
-  (ReadState _ backend _) <- ask
+  (ReadState _ backend _ _ _) <- ask
   let (token, mAuthUser) = parseTokenAndUser mcookie
   eReturn <- liftIO $ runClientM
     (userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
@@ -214,7 +223,7 @@ userManageDetailsSubmitControl mcookie uid uds = do
   case eReturn of
     Right _ -> throwError $ redirect303 (userManageLink uid)
     Left err ->
-      handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
+      handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
 
 userManageAuthCreateControl
   :: Maybe T.Text
@@ -222,7 +231,7 @@ userManageAuthCreateControl
   -> AuthSubmitReturn
   -> UserHandler UserOverviewPage
 userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
-  (ReadState _ backend _) <- ask
+  (ReadState _ backend _ _ _) <- ask
   let (token, mAuthUser) = parseTokenAndUser mcookie
   hashedPass <- hashPassword pass
   eReturn <- liftIO $ runClientM
@@ -234,7 +243,7 @@ userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) =
   case eReturn of
     Right _ -> throwError $ redirect303 $ userManageLink uid
     Left err ->
-      handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
+      handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
 
 userManageAuthDeleteControl
   :: Maybe T.Text
@@ -255,5 +264,6 @@ userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
         then
           throwError (redirect303 $ userManageLink uid)
         else
-          handleErrors (fmap read mAuthUser) Nothing [Just err]
+          handleErrors mAuthUser Nothing [Just err]
-      _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]
+      _ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
+        [Just err]

src/Main.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-
+{-# LANGUAGE PackageImports #-}
 module Main where
 
 import Servant
@@ -20,11 +20,18 @@ import Data.YAML
 
 import Options.Applicative
 
+import Network.Wai.Application.Static
+
+-- imports from "mateamt"
+
+import qualified "mateamt" Types as MT
+
 -- internal imports
 
 import API
 import Types
 import Control
+import Client
 
 main :: IO ()
 main = do
@@ -38,23 +45,32 @@ main = do
     Right (Configuration apiHost apiPort apiUri apiSec listenPort locs) -> do
       mngr <- newManager defaultManagerSettings
       (l10n, _) <- getL10n (T.unpack locs)
-      withStdoutLogger $ \ilog -> do
+      let backend = mkClientEnv mngr
-        let settings = setPort (fromIntegral listenPort) $
+            (BaseUrl
-              setLogger ilog defaultSettings
+              (if apiSec then Https else Http)
-            initState = ReadState
+              (T.unpack apiHost)
-              -- { rsManager = manager
+              (fromIntegral apiPort)
-              { rsL10n       = l10n
+              (T.unpack apiUri)
-              , rsBackend    = mkClientEnv mngr
+              )
-                (BaseUrl
+      putStrLn "Checking connectivity to backend..."
-                  (if apiSec then Https else Http)
+      emeta <- runClientM metaGet backend
-                  (T.unpack apiHost)
+      case emeta of
-                  (fromIntegral apiPort)
+        Right (MT.MetaInformation version symbol) -> do
-                  (T.unpack apiUri)
+          withStdoutLogger $ \ilog -> do
-                  )
+            let settings = setPort (fromIntegral listenPort) $
-              , rsHashParams = recommendedHashParams
+                  setLogger ilog defaultSettings
-              }
+                initState = ReadState
-        putStrLn "Starting up..."
+                  -- { rsManager = manager
-        runSettings settings (userApp initState)
+                  { rsL10n       = l10n
+                  , rsBackend    = backend
+                  , rsHashParams = recommendedHashParams
+                  , rsCurrencySymbol = symbol
+                  , rsBackendVersion = version
+                  }
+            putStrLn "Starting up..."
+            runSettings settings (userApp initState)
+        Left err ->
+          error $ "Connection with backend failed: " <> (fromString $ show err)
   where
     opts = info (options <**> helper)
       ( fullDesc
@@ -85,9 +101,15 @@ userApp initState = serveWithContext userApi EmptyContext $
     :<|> journalControl mcookie
     :<|> journalGetCheckControl mcookie
     :<|> journalPostCheckControl mcookie
+    :<|> productGetPriceList mcookie
+    :<|> productGetRefill mcookie
+    :<|> productPostRefill mcookie
+    :<|> productGetNew mcookie
+    :<|> productPostNew mcookie
     :<|> authControl mcookie
     :<|> authPostControl mcookie
     :<|> authLogoutControl mcookie
+    :<|> (\_ -> return $ staticApp (defaultFileServerSettings "static")) mcookie
     )
 
 userApi :: Proxy UserAPI

src/Types.hs

@@ -8,5 +8,5 @@ import Types.Reader as T
 import Types.Views as T
 import Types.User as T
 import Types.Journal as T
-import Types.Orphans as T
+import Types.Product as T
 import Types.Configuration as T

src/Types/Orphans.hs

@@ -16,6 +16,8 @@ import Web.Internal.FormUrlEncoded
 import qualified Data.Text as T
 import Data.Maybe (fromJust)
 
+import Debug.Trace
+
 instance MimeUnrender HTML MT.UserSubmit
 instance FromForm MT.UserSubmit
 
@@ -26,7 +28,7 @@ instance MimeUnrender HTML [MT.PurchaseDetail]
 instance FromForm [MT.PurchaseDetail] where
   fromForm form =
     let kvs = toListStable form
-        ks  = fst (unzip kvs)
+        ks  = map fst kvs
         kpids = filter ("productSelect" `T.isPrefixOf`) ks
         prods = filter ((`notElem` kpids) . fst) kvs
         stripPid = snd . T.breakOnEnd "-"
@@ -39,3 +41,27 @@ instance FromForm [MT.PurchaseDetail] where
         res = map digestForm kpids
     in
       Right res
+
+instance MimeUnrender HTML [MT.AmountRefill]
+instance FromForm [MT.AmountRefill] where
+  fromForm form =
+    let kvs = toListStable form
+        ks  = map fst kvs
+        kpids = filter ("amountRefillProductId" `T.isPrefixOf`) ks
+        prods = filter ((`notElem` kpids) . fst) kvs
+        stripPid = snd . T.breakOnEnd "-"
+        digestForm key =
+          let pid = read (T.unpack $ stripPid key)
+              amountSingles = read
+                (T.unpack . fromJust $
+                  lookup ("amountRefillAmountSingles-" <> stripPid key) prods)
+              amountCrates = read
+                (T.unpack . fromJust $
+                  lookup ("amountRefillAmountCrates-" <> stripPid key) prods)
+          in  MT.AmountRefill
+                (trace (show pid) pid)
+                (trace (show amountSingles) amountSingles)
+                (trace (show amountCrates) amountCrates)
+        res = map digestForm (trace (show kvs) kpids)
+    in
+      Right res

src/Types/Page.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Types.Page where
 
 import qualified Data.Text as T
 
 import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as HA
 
 data Page markup attr = Page
   { pageTitle               :: attr   -- ^ Page title
@@ -34,7 +36,16 @@ initPage title = Page
   title
   mempty
   mempty
-  mempty
+  (H.link
+    H.! HA.rel "stylesheet"
+    H.! HA.type_ "text/css"
+    H.! HA.href "/static/css/bootstrap.min.css"
+  <>
+    H.link
+      H.! HA.rel "stylesheet"
+      H.! HA.type_ "text/css"
+      H.! HA.href "/static/css/style.css"
+    )
 
 template
   :: Page H.Html T.Text

src/Types/Product.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Types.Product where
+
+import GHC.Generics
+
+import Servant.API
+import Servant.HTML.Blaze
+import Web.Internal.FormUrlEncoded
+
+import qualified Data.Text as T
+
+data ProductSubmit = ProductSubmit
+  { productSubmitIdent          :: T.Text
+  , productSubmitPrice          :: Float
+  , productSubmitMl             :: Int
+  -- TODO: Create and manage suppliers and avatars
+  -- , productSubmitAvatar         :: Maybe Int
+  -- , productSubmitSupplier       :: Maybe Int
+  , productSubmitMaxAmount      :: Int
+  , productSubmitAmountPerCrate :: Int
+  , productSubmitPricePerCrate  :: Maybe Float
+  , productSubmitArtNr          :: Maybe T.Text
+  } deriving (Generic, Show)
+
+instance MimeUnrender HTML ProductSubmit
+instance FromForm ProductSubmit

src/Types/Reader.hs

@@ -7,6 +7,7 @@ import Servant.Client (ClientEnv)
 
 import Control.Monad.Reader (ReaderT)
 
+import qualified Data.Text as T
 import Data.Text.I18n
 
 import Crypto.KDF.PBKDF2
@@ -14,9 +15,11 @@ import Crypto.Hash.Algorithms
 
 data ReadState = ReadState
   -- { rsManager :: Manager
-  { rsL10n       :: L10n
+  { rsL10n           :: L10n
-  , rsBackend    :: ClientEnv
+  , rsBackend        :: ClientEnv
-  , rsHashParams :: HashParams
+  , rsHashParams     :: HashParams
+  , rsCurrencySymbol :: T.Text
+  , rsBackendVersion :: T.Text
   }
 
 type UserHandler = ReaderT ReadState Handler

src/Types/Views.hs

@@ -25,3 +25,9 @@ type JournalCheckPage = H.Html
 type CashBuyOverviewPage = H.Html
 
 type CashBuyConfirmPage = H.Html
+
+type ProductPriceListPage = H.Html
+
+type ProductRefillPage = H.Html
+
+type ProductNewPage = H.Html

src/Util.hs

@@ -8,17 +8,15 @@ module Util where
 
 import Servant hiding (addHeader)
 import Servant.Client
-import Servant.Client.Core.Request
 
 import qualified Text.Blaze.Html5.Attributes as HA
+import Text.Blaze.Internal
 
 import qualified Data.Text as T
-import Data.Text.Lazy.Encoding
+import Data.Text.Encoding
 
 import Data.Text.I18n
 
-import Data.ByteString.Builder
-
 import Data.List (intercalate)
 import Data.List.Split (chunksOf)
 
@@ -26,12 +24,12 @@ import Data.String (fromString)
 
 import Data.Maybe (fromMaybe)
 
-import Web.Cookie
-
 import Text.Printf (printf)
 
 import Network.HTTP.Types.Status
 
+import Control.Monad.Reader (ask)
+
 -- imports from "mateamt"
 
 import qualified "mateamt" Types as MT
@@ -50,7 +48,7 @@ formatMoney amount = pre <> t <> "," <> c
     t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
     c = fromString $ snd sp
     sp = tail <$>
-      break (== '.') (printf "%.2f" (abs $ (fromIntegral amount / 100) :: Float))
+      break (== '.') (printf "%.2f" (abs (fromIntegral amount / 100) :: Float))
 
 redirect303
   :: Link
@@ -81,7 +79,7 @@ addMessage message err =
     { errHeaders =
       ( "Set-Cookie" 
       , "message=" <>
-        fromString (T.unpack message) <>
+        encodeUtf8 message <>
         "; Path=/; Max-Age=5"
       ) : errHeaders err
     }
@@ -95,13 +93,13 @@ parseCookieText = map
 
 parseTokenAndUser
   :: Maybe T.Text
-  -> (String, Maybe String)
+  -> (String, Maybe Int)
 parseTokenAndUser mcookie =
   (token, mAuthUser)
   where
     token = T.unpack $ fromMaybe "secret"
       (lookup "x-token" =<< mParsedCookie)
-    mAuthUser = T.unpack <$>
+    mAuthUser = read . T.unpack <$>
       (lookup "x-auth-user" =<< mParsedCookie)
     mParsedCookie = fmap parseCookieText mcookie
 
@@ -109,7 +107,7 @@ localeFromCookie
   :: Maybe T.Text
   -> Locale
 localeFromCookie mcookie = Locale
-  (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
+  (fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
 
 handleErrors
   :: (Traversable t, Show (t (Maybe ClientError)))
@@ -145,11 +143,12 @@ redirectOverAuth
   -> UserHandler UserOverviewPage
 redirectOverAuth muid mLink mRefine = do
   let redirectHeaders = errHeaders $
+        -- redirect303 authLink
         redirect303 (authLink (Just $ "/" <>
           fromString (show $ linkURI (case (mLink, muid) of
             (Just link, _) -> link
             (Nothing, Just uid) -> userOverviewLink uid mRefine
-            _ -> userSelectLink
+            _ -> userSelectLink Nothing
             ))))
   throwError
     (err303
@@ -174,6 +173,9 @@ redirectOverAuth muid mLink mRefine = do
       }
       )
 
+productBgStyle
+  :: AttributeValue
+  -> Attribute
 productBgStyle aid = HA.style $ mconcat
   [ "background-image: url(#" <> aid <> ");" -- FILLME
   , "backgronud-color: blue;"
@@ -183,3 +185,32 @@ productBgStyle aid = HA.style $ mconcat
   , "  1px 0 1px black,"
   , "  0 -1px 1px black;"
   ]
+
+controlInit
+  :: Maybe T.Text
+  -> UserHandler (String, Maybe Int, Locale, L10n, ClientEnv, T.Text, T.Text)
+controlInit mcookie = do
+  let (token, muser) = parseTokenAndUser mcookie
+      loc = localeFromCookie mcookie
+  (ReadState l10n backend _ symbol version) <- ask
+  return (token, muser, loc, l10n, backend, symbol, version)
+
+handleClientErr
+  :: ClientError
+  -> Maybe Int
+  -> Maybe Link
+  -> UserHandler UserOverviewPage
+handleClientErr err muid authTargetLink =
+  case err of
+    FailureResponse _ resp ->
+      if statusCode (responseStatusCode resp) == 401
+      then
+        redirectOverAuth muid authTargetLink Nothing
+      else
+        throwError $
+          addMessage (fromString $ show err) $
+          redirect303 (userSelectLink Nothing)
+    othererr ->
+      throwError $
+        addMessage (fromString $ show othererr) $
+        redirect303 (userSelectLink Nothing)

src/View.hs

@@ -6,3 +6,4 @@ import View.Auth as V
 import View.User as V
 import View.Buy as V
 import View.Journal as V
+import View.Product as V

src/View/Auth.hs

@@ -27,11 +27,13 @@ authPage
   :: L10n
   -> Locale
   -> Maybe T.Text
+  -> T.Text
   -> Maybe T.Text
   -> AuthPage
-authPage l10n locale mDestination mcookie = scaffold
+authPage l10n locale mDestination version mcookie = scaffold
   l10n
   locale
+  version
   mcookie
   (initPage $
     translate "Matebeamter" <>
@@ -70,7 +72,7 @@ authPage l10n locale mDestination mcookie = scaffold
             H.! HA.value ""
         H.div H.! HA.class_ "form-group optional" $
           H.button
-            H.! HA.class_ "btn btn-default"
+            H.! HA.class_ "btn btn-primary"
             H.! HA.type_ "submit"
             $ H.toHtml $ translate "Submit"
   where

src/View/Buy.hs

@@ -13,7 +13,7 @@ import Data.String (fromString)
 
 import Data.Text.I18n
 
-import Data.Maybe (isJust, fromJust, fromMaybe)
+import Data.Maybe (isJust, fromJust)
 
 import Control.Monad (when)
 
@@ -35,10 +35,12 @@ buyConfirmPage
   -> [(MT.PurchaseDetail, MT.ProductShortOverview)]
   -> Int
   -> Bool
+  -> T.Text
   -> Maybe T.Text
+  -> T.Text
   -> H.Html
-buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
+buyConfirmPage l10n locale uid ziptups total forceBuy version mcookie symbol =
-  scaffold l10n locale mcookie (initPage $
+  scaffold l10n locale version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Home"
@@ -57,8 +59,8 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
         H.! HA.enctype "application/x-www-form-urlencoded"
         $ do
           mapM_
-            (\( MT.PurchaseDetail pdid amount
+            (\( MT.PurchaseDetail _ _
-              , MT.ProductShortOverview pid ident price _ _ mava) ->
+              , MT.ProductShortOverview pid ident price amount _ mava) ->
                 H.div H.! HA.class_ "form-group required" $ do
                   H.input
                     H.! HA.id ("product-select-" <> fromString (show pid))
@@ -77,7 +79,7 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
                           )
                       H.toHtml ident
                   H.input
-                    H.! HA.id ("product-amount-" <> (fromString (show pid)))
+                    H.! HA.id ("product-amount-" <> fromString (show pid))
                     H.! HA.class_ "form-control"
                     H.! HA.name ("productAmount-" <> fromString (show pid))
                     H.! HA.type_ "number"
@@ -88,16 +90,16 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
                   H.label
                     H.! HA.for ("product-total-" <> fromString (show pid))
                     $ H.toHtml $
-                      " @ " <> formatMoney price <> "€" -- TODO: ask for currency symbol
+                      " @ " <> formatMoney price <> symbol
-                  H.input
+                  -- H.input
-                    H.! HA.id ("product-total-" <> (fromString (show pid)))
+                  --   H.! HA.id ("product-total-" <> fromString (show pid))
-                    H.! HA.class_ "form-control"
+                  --   H.! HA.class_ "form-control"
-                    H.! HA.name ("productTotal-" <> fromString (show pid))
+                  --   H.! HA.name ("productTotal-" <> fromString (show pid))
-                    H.! HA.type_ "text"
+                  --   H.! HA.type_ "text"
-                    H.! HA.value
+                  --   H.! HA.value
-                      (fromString $ T.unpack $ formatMoney $ amount * price)
+                  --     (fromString $ T.unpack $ formatMoney $ amount * price)
-                    H.! HA.disabled ""
+                  --   H.! HA.disabled ""
-                  H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
+                  -- H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
               )
             ziptups
           H.div H.! HA.class_ "form-group required" $ do
@@ -111,16 +113,17 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
               H.! HA.type_ "text"
               H.! HA.value (fromString $ T.unpack $ formatMoney total)
               H.! HA.disabled ""
-            -- H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
+            H.toHtml symbol
           H.div H.! HA.class_ "form-group optional" $
             H.button
-              H.! HA.class_ "btn btn-default"
+              H.! HA.class_ "btn btn-primary"
               H.! HA.type_ "submit"
               $ H.toHtml $ if forceBuy
                 then translate "Buy anyway"
                 else translate "Buy"
           when forceBuy $
             H.button
+              H.! HA.class_ "btn btn-primary"
               H.! HA.formnovalidate "formnovalidate"
               H.! HA.formmethod "get"
               H.! HA.formaction
@@ -137,43 +140,44 @@ buyProductsForm
   -> [MT.ProductShortOverview]
   -> H.Html
 buyProductsForm l10n locale prods = do
-  mapM_ (\(MT.ProductShortOverview pid ident price amount ml maid) ->
+  H.div H.! HA.class_ "tile-list" $
-    H.div $ do
+    mapM_ (\(MT.ProductShortOverview pid ident _ _ _ maid) ->
       H.div
-        H.! HA.class_ "form-group optional"
+        H.! HA.class_ "tile"
         H.!?
           ( isJust maid
           , productBgStyle (fromString $ show $ fromJust maid)
           )
-        $ do
+          $ do
-          H.label
+            H.label
-            H.! HA.for ("product-select-" <> fromString (show pid)) $
+              H.! HA.for ("product-select-" <> fromString (show pid)) $
-              H.toHtml ident
+                H.toHtml ident
-          H.input
+              H.! HA.class_ "tile-content form-group optional"
-            H.! HA.id ("product-select-" <> fromString (show pid))
+            H.input
-            H.! HA.class_ "form-control product-select"
+              H.! HA.id ("product-select-" <> fromString (show pid))
-            H.! HA.name ("productSelect-" <> fromString (show pid))
+              H.! HA.class_ "form-control product-select"
-            H.! HA.type_ "checkbox"
+              H.! HA.class_ "tile-content form-group optional"
-            H.! HA.value "true"
+              H.! HA.name ("productSelect-" <> fromString (show pid))
-      H.div
+              H.! HA.type_ "checkbox"
-        H.! HA.class_ "form-group optional"
+              -- H.! HA.value "true"
-        $ do
+            H.div
-          H.label
+              $ do
-            H.! HA.for ("product-amount-" <> fromString (show pid)) $
+                H.label
-              H.toHtml (translate "Amount")
+                  H.! HA.for ("product-amount-" <> fromString (show pid)) $
-          H.input
+                    H.toHtml (translate "Amount")
-            H.! HA.id ("product-amount-" <> fromString (show pid))
+                H.input
-            H.! HA.class_ "form-control product-amount"
+                  H.! HA.id ("product-amount-" <> fromString (show pid))
-            H.! HA.name ("productAmount-" <> fromString (show pid))
+                  H.! HA.class_ "form-control product-amount"
-            H.! HA.type_ "number"
+                  H.! HA.name ("productAmount-" <> fromString (show pid))
-            H.! HA.min "0"
+                  H.! HA.type_ "number"
-            H.! HA.step "1"
+                  H.! HA.min "0"
-            H.! HA.value "1"
+                  H.! HA.step "1"
-    )
+                  H.! HA.value "1"
-    prods
+      )
+      prods
   H.div H.! HA.class_ "form-group optional" $
     H.button
-      H.! HA.class_ "btn btn-default"
+      H.! HA.class_ "btn btn-primary"
       H.! HA.type_ "submit"
       $ H.toHtml $ translate "Proceed"
   where
@@ -182,11 +186,12 @@ buyProductsForm l10n locale prods = do
 cashBuyOverviewPage
   :: L10n
   -> Locale
+  -> T.Text
   -> Maybe T.Text
   -> [MT.ProductShortOverview]
   -> CashBuyOverviewPage
-cashBuyOverviewPage l10n loc mcookie psos =
+cashBuyOverviewPage l10n loc version mcookie psos =
-  scaffold l10n loc mcookie (initPage $
+  scaffold l10n loc version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Buy with Cash"

src/View/Journal.hs

@@ -31,12 +31,13 @@ import API
 journalPage
   :: L10n
   -> Locale
+  -> T.Text
   -> Maybe T.Text
   -> Maybe Word
   -> [MT.JournalEntry]
   -> JournalPage
-journalPage l10n loc mcookie mpage entries =
+journalPage l10n loc version mcookie mpage entries =
-  scaffold l10n loc mcookie (initPage $
+  scaffold l10n loc version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Journal"
@@ -50,13 +51,14 @@ journalPage l10n loc mcookie mpage entries =
             H.th (H.toHtml $ translate "Amount")
             H.th (H.toHtml $ translate "Total amount")
         mapM_
-          (\(MT.JournalEntry jid desc time amount total check) ->
+          (\(MT.JournalEntry jid time user action amount total) ->
             H.tr
-              H.!? (check, HA.class_ "checked")
+              H.!? (action == MT.CashCheck, HA.class_ "checked")
               $ do
                 H.td (H.toHtml $ show jid)
                 H.td (H.toHtml $ show time)
-                H.td (H.toHtml desc)
+                H.td (H.toHtml $ fromMaybe "" (show <$> user))
+                H.td (H.toHtml $ show action)
                 H.td (H.toHtml $ formatMoney amount)
                 H.td (H.toHtml $ formatMoney total)
             )
@@ -79,10 +81,11 @@ journalPage l10n loc mcookie mpage entries =
             $ H.toHtml $ translate "Next Page"
       H.form $
         H.button
+          H.! HA.class_ "btn btn-primary"
           H.! HA.type_ "submit"
           H.! HA.formmethod "get"
           H.! HA.formaction
-            ("/" <> fromString (show $ linkURI $ journalGetCheckLink))
+            ("/" <> fromString (show $ linkURI journalGetCheckLink))
           $ H.toHtml $ translate "Perform cash check"
   where
     translate = localize l10n loc . gettext
@@ -90,10 +93,11 @@ journalPage l10n loc mcookie mpage entries =
 journalCheckPage
   :: L10n
   -> Locale
+  -> T.Text
   -> Maybe T.Text
   -> JournalCheckPage
-journalCheckPage l10n loc mcookie =
+journalCheckPage l10n loc version mcookie =
-  scaffold l10n loc mcookie (initPage $
+  scaffold l10n loc version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Cash check"
@@ -122,7 +126,7 @@ journalCheckPage l10n loc mcookie =
               H.! HA.value "0"
           H.div H.! HA.class_ "form-group optional" $
             H.button
-              H.! HA.class_ "btn btn-default"
+              H.! HA.class_ "btn btn-primary"
               H.! HA.type_ "submit"
               $ H.toHtml $ translate "Submit"
   where

src/View/Product.hs

@@ -0,0 +1,295 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+module View.Product where
+
+import Servant.Links
+
+import Data.String (fromString)
+
+import qualified Data.Text as T
+import Data.Text.I18n
+
+import Data.Maybe (fromJust, isJust)
+
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as HA
+
+-- imports from "mateamt"
+
+import qualified "mateamt" Types as MT
+
+-- internal imports
+
+import Types
+import Util
+import View.Scaffold
+import API
+
+productPriceListPage
+  :: L10n
+  -> Locale
+  -> T.Text
+  -> Maybe T.Text
+  -> [MT.ProductShortOverview]
+  -> T.Text
+  -> ProductPriceListPage
+productPriceListPage l10n loc version mcookie list symbol =
+  scaffold l10n loc version mcookie (initPage $
+    translate "Matebeamter" <>
+    " - " <>
+    translate "Price List"
+    ) $ do
+      H.table $ do
+        H.thead $
+          H.tr $ do
+            H.th (H.toHtml $ translate "ID")
+            H.th (H.toHtml $ translate "Name")
+            H.th (H.toHtml $ translate "Amount")
+            H.th (H.toHtml $ translate "Volume")
+            H.th (H.toHtml $ translate "Price")
+        mapM_
+          (\(MT.ProductShortOverview pid ident price amount ml _) ->
+            H.tr $ do
+              H.td (H.toHtml $ show pid)
+              H.td (H.toHtml ident)
+              H.td (H.toHtml $ show amount)
+              H.td (H.toHtml $ (fromString $ show ml :: T.Text) <> " ml")
+              H.td (H.toHtml $ (formatMoney price) <> symbol)
+            )
+          list
+  where
+    translate = localize l10n loc . gettext
+
+productRefillPage
+  :: L10n
+  -> Locale
+  -> T.Text
+  -> Maybe T.Text
+  -> [MT.ProductShortOverview]
+  -> ProductRefillPage
+productRefillPage l10n loc version mcookie prodList =
+  scaffold l10n loc version mcookie (initPage $
+    translate "Matebeamter" <>
+    " - " <>
+    translate "Refill stock"
+    ) $
+      H.form
+        H.! HA.method "post"
+        H.! HA.action ("/" <> fromString
+          (show $ linkURI productPostRefillLink)
+          )
+        H.! HA.enctype "application/x-www-form-urlencoded"
+          $ do
+            mapM_
+              (\(MT.ProductShortOverview pid ident _ _ _ maid) -> do
+                H.div
+                  H.! HA.class_ "form-group optional"
+                  H.!?
+                    ( isJust maid
+                    , productBgStyle (fromString $ show $ fromJust maid)
+                    )
+                  $ do
+                    H.label
+                      H.! HA.for (
+                        "amount-refill-product-id-" <>
+                        fromString (show pid)
+                        )
+                      $ H.toHtml ident
+                    H.input
+                      H.! HA.id (
+                        "amount-refill-product-id-" <>
+                        fromString (show pid)
+                        )
+                      H.! HA.class_ "form-control product-select"
+                      H.! HA.name (
+                        "amountRefillProductId-" <>
+                        fromString (show pid)
+                        )
+                      H.! HA.type_ "checkbox"
+                      H.! HA.value "true"
+                H.div
+                  H.! HA.class_ "form-group optional"
+                  $ do
+                    H.label
+                      H.! HA.for (
+                        "amount-refill-amount-singeles-" <>
+                        fromString (show pid)
+                        )
+                      $ H.toHtml (translate "Amount of single items")
+                    H.input
+                      H.! HA.id (
+                        "amount-refill-amount-singles-" <>
+                        fromString (show pid)
+                        )
+                      H.! HA.class_ "form-control product-amount"
+                      H.! HA.name (
+                        "amountRefillAmountSingles-" <>
+                        fromString (show pid)
+                        )
+                      H.! HA.type_ "number"
+                      H.! HA.min "0"
+                      H.! HA.step "1"
+                      H.! HA.value "0"
+                    H.label
+                      H.! HA.for (
+                        "amount-refill-amount-crates-" <>
+                        fromString (show pid)
+                        )
+                      $ H.toHtml (translate "Amount of full crates")
+                    H.input
+                      H.! HA.id (
+                        "amount-refill-amount-crates-" <>
+                        fromString (show pid)
+                        )
+                      H.! HA.class_ "form-control product-amount"
+                      H.! HA.name (
+                        "amountRefillAmountCrates-" <>
+                        fromString (show pid)
+                        )
+                      H.! HA.type_ "number"
+                      H.! HA.min "0"
+                      H.! HA.step "1"
+                      H.! HA.value "0"
+                )
+              prodList
+            H.div H.! HA.class_ "form-group optional" $
+              H.button
+                H.! HA.class_ "btn btn-primary"
+                H.! HA.type_ "submit"
+                $ H.toHtml $ translate "Submit"
+  where
+    translate = localize l10n loc . gettext
+
+productNewPage
+  :: L10n
+  -> Locale
+  -> T.Text
+  -> Maybe T.Text
+  -> T.Text
+  -> ProductNewPage
+productNewPage l10n loc version mcookie symbol =
+  scaffold l10n loc version mcookie (initPage $
+    translate "Matebeamter" <>
+    " - " <>
+    translate "Create new product"
+    ) $
+      H.form
+        H.! HA.method "post"
+        H.! HA.action ("/" <> fromString
+          (show $ linkURI productPostNewLink)
+          )
+        H.! HA.enctype "application/x-www-form-urlencoded"
+          $ do
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "ident" $ H.toHtml $ translate "Product name"
+              H.input
+                H.! HA.id "ident"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitIdent"
+                H.! HA.type_ "text"
+                H.! HA.value ""
+                H.! HA.required ""
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "price" $ H.toHtml $
+                translate "Product price in" <> " " <> symbol
+              H.input
+                H.! HA.id "price"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitPrice"
+                H.! HA.type_ "number"
+                H.! HA.min "0"
+                H.! HA.step "0.01"
+                H.! HA.value "0"
+                H.! HA.required ""
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "ml" $ H.toHtml $
+                translate "Product volume in ml"
+              H.input
+                H.! HA.id "ml"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitMl"
+                H.! HA.type_ "number"
+                H.! HA.min "0"
+                H.! HA.step "1"
+                H.! HA.value "0"
+                H.! HA.required ""
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "max-amount" $ H.toHtml $
+                translate "Product maximum stock amount"
+              H.input
+                H.! HA.id "max-amount"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitMaxAmount"
+                H.! HA.type_ "number"
+                H.! HA.min "0"
+                H.! HA.step "1"
+                H.! HA.value "0"
+                H.! HA.required ""
+            H.div H.! HA.class_ "form-group required" $ do
+              H.label H.! HA.for "amount-per-crate" $ H.toHtml $
+                translate "Product amount per crate"
+              H.input
+                H.! HA.id "amount-per-crate"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitAmountPerCrate"
+                H.! HA.type_ "number"
+                H.! HA.min "0"
+                H.! HA.step "1"
+                H.! HA.value "0"
+                H.! HA.required ""
+            H.div H.! HA.class_ "form-group optional" $ do
+              H.label H.! HA.for "price-per-crate" $ H.toHtml $
+                translate "Product price per crate"
+              H.input
+                H.! HA.id "price-per-crate"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitPricePerCrate"
+                H.! HA.type_ "number"
+                H.! HA.min "0"
+                H.! HA.step "0.01"
+                H.! HA.value "0"
+            H.div H.! HA.class_ "form-group optional" $ do
+              H.label H.! HA.for "article-number" $ H.toHtml $
+                translate "Product article number"
+              H.input
+                H.! HA.id "article-number"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitArtNr"
+                H.! HA.type_ "text"
+                H.! HA.value ""
+                H.! HA.required ""
+            {- -- TODO: Create and manage suppliers and avatars
+            H.div H.! HA.class_ "form-group optional" $ do
+              H.label H.! HA.for "supplier" $ H.toHtml $
+                translate "Product supplier"
+              H.select
+                H.! HA.id "supplier"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitSupplier"
+                $ do
+                  H.option
+                    H.! HA.value ""
+                    H.! HA.selected ""
+                    $ toHtml $ translate "None"
+                  -- TODO: FILL ME!
+            H.div H.! HA.class_ "form-group optional" $ do
+              H.label H.! HA.for "avatar" $ H.toHtml $
+                translate "Product avater"
+              H.select
+                H.! HA.id "avatar"
+                H.! HA.class_ "form-control"
+                H.! HA.name "productSubmitAvatar"
+                $ do
+                  H.option
+                    H.! HA.value ""
+                    H.! HA.selected ""
+                    $ toHtml $ translate "None"
+                  -- TODO: FILL ME!
+            -}
+            H.div H.! HA.class_ "form-group optional" $
+              H.button
+                H.! HA.class_ "btn btn-primary"
+                H.! HA.type_ "submit"
+                $ H.toHtml $ translate "Submit"
+  where
+    translate = localize l10n loc . gettext

src/View/Scaffold.hs

@@ -14,8 +14,12 @@ import Data.Text.I18n
 
 import Data.Maybe (fromJust, isJust)
 
+import Data.Version (showVersion)
+
 import Control.Monad (when)
 
+import qualified Paths_matebeamter as MyPath (version)
+
 -- internal imports
 
 import Types.Page
@@ -25,14 +29,23 @@ import Util
 scaffold
   :: L10n
   -> Locale
+  -> T.Text
   -> Maybe T.Text
   -> Page H.Html T.Text
   -> H.Html
   -> H.Html
-scaffold l10n locale mcookie page content = template page $ do
+scaffold l10n locale version mcookie page content = template page $ do
-  H.header $ H.nav $ H.ul $
+  H.header $ H.nav $ H.ul $ do
-    H.li $ H.a H.! HA.href ("/" <> fromString (show $ linkURI userSelectLink)) $
+    H.li $ H.a H.! HA.href ("/" <> fromString (show $ linkURI (userSelectLink Nothing))) $
-      H.toHtml $ localize l10n locale $ gettext "Home"
+      H.toHtml $ translate "Home"
+    maybe
+      (return ())
+      (\uid ->
+        H.li $ H.a H.! HA.href ("/" <>
+          (fromString $ show $ linkURI $ userOverviewLink (read uid) Nothing)) $
+            H.toHtml $ translate "User Page"
+        )
+      (show <$> getLogin mcookie)
   H.hr
   when (isJust message)
     (H.div H.! HA.id "message" H.! HA.class_ "message" $
@@ -40,5 +53,33 @@ scaffold l10n locale mcookie page content = template page $ do
       )
   H.div H.! HA.id "main" H.! HA.role "main" $
     content
+  H.hr
+  H.footer $ H.form $ do
+    H.button
+      H.! HA.class_ "btn btn-primary"
+      H.! HA.formmethod "get"
+      H.! HA.formaction ("/" <>
+        (fromString $ show $ linkURI $ productGetPriceListLink Nothing))
+      $ H.toHtml $ translate "Price List"
+    -- maybe
+    --   (return ())
+    --   (\_ ->
+    --     H.button
+    --       H.! HA.class_ "btn btn-primary"
+    --       H.! HA.formmethod "get"
+    --       H.! HA.formaction ("/" <>
+    --         (fromString $ show $ linkURI $ productGetRefillLink))
+    --       $ H.toHtml $ translate "Refill stock"
+    --     )
+    --   (getLogin mcookie)
+    H.div
+      H.! HA.class_ "backend-version"
+      $ H.toHtml $
+        (translate "Powered by ") <> "matebeamter " <>
+        (fromString $ showVersion MyPath.version) <> " " <>
+        (translate "connected to ") <> "mateamt " <>
+        version
   where
     message = lookup "message" =<< fmap parseCookieText mcookie
+    translate = localize l10n locale . gettext
+    getLogin = snd . parseTokenAndUser

src/View/User.hs

@@ -31,25 +31,39 @@ userSelectPage
   :: L10n
   -> Locale
   -> [MT.UserSummary]
+  -> T.Text
   -> Maybe T.Text
   -> UserSelectPage
-userSelectPage l10n locale uss mcookie =
+userSelectPage l10n locale uss version mcookie =
-  scaffold l10n locale mcookie (initPage $
+  scaffold l10n locale version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Home"
-    ) $ do
+    ) $ H.ul
-      H.a H.! HA.href ("/" <> fromString
+          H.! HA.class_ "tile-list"
-        (show $ linkURI $ cashBuyLink Nothing)
+      $ do
-        ) $
+        H.li H.! HA.class_ "tile function" $ H.a
-          H.toHtml $ translate "Buy with cash"
+          H.! HA.class_ "tile-content"
-      mapM_ (\(MT.UserSummary uid ident _) ->
+          H.! HA.href ("/" <> fromString
-        H.a H.! HA.href ("/" <> fromString (show $ linkURI $
+            (show $ linkURI $ cashBuyLink Nothing)
-          userOverviewLink uid Nothing)) $
+            ) $
-            H.toHtml ident
+              H.toHtml $ translate "Buy with cash"
-        ) uss
+        mapM_ (\(MT.UserSummary uid ident _) ->
-      H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
+          H.li H.! HA.class_ "tile" $ H.a
-        H.toHtml $ translate "New user"
+            H.! HA.class_ "tile-content"
+            H.! HA.href ("/" <> fromString (show $ linkURI $
+              userOverviewLink uid Nothing)) $
+                H.toHtml ident
+          ) uss
+        H.li H.! HA.class_ "tile function" $ H.a
+          H.! HA.class_ "tile-content"
+          H.! HA.href ("/" <> fromString
+            (show $ linkURI $ userSelectLink (Just MT.OldUsers))) $
+              H.toHtml $ translate "Show inactive users"
+        H.li H.! HA.class_ "tile function" $ H.a
+          H.! HA.class_ "tile-content"
+          H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
+            H.toHtml $ translate "New user"
   where
     translate = localize l10n locale . gettext
 
@@ -59,10 +73,12 @@ userOverviewPage
   -> MT.AuthMethod
   -> MT.UserDetails
   -> [MT.ProductShortOverview]
+  -> T.Text
   -> Maybe T.Text
+  -> T.Text
   -> UserOverviewPage
-userOverviewPage l10n locale method ud pos mcookie =
+userOverviewPage l10n locale method ud pos version mcookie symbol =
-  scaffold l10n locale mcookie (initPage $
+  scaffold l10n locale version mcookie (initPage $
     localize l10n locale (gettext "Matebeamter") <>
     " - " <>
     localize l10n locale (gettext "User Menu for ") <>
@@ -73,15 +89,14 @@ userOverviewPage l10n locale method ud pos mcookie =
       H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
         translate "Your current balance is" <>
         ": " <>
-        formatMoney (MT.userDetailsBalance ud)
+        formatMoney (MT.userDetailsBalance ud) <> symbol
-        -- TODO: Add currency symbol
       H.p $ H.form
         H.! HA.method "post"
         H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
         H.! HA.enctype "application/x-www-form-urlencoded" $
           H.div H.! HA.class_ "form-group optional" $
             H.button
-              H.! HA.class_ "btn btn-default"
+              H.! HA.class_ "btn btn-primary"
               H.! HA.type_ "submit"
               $ H.toHtml $ translate "Logout"
       case method of
@@ -97,6 +112,7 @@ userOverviewPage l10n locale method ud pos mcookie =
     buyForm = do
       H.div $ H.form $
         H.button
+          H.! HA.class_ "btn btn-primary"
           H.! HA.type_ "submit"
           H.! HA.formmethod "get"
           H.! HA.formaction ("/" <>
@@ -105,7 +121,7 @@ userOverviewPage l10n locale method ud pos mcookie =
           $ H.toHtml $ translate "Recharge Credit"
       H.form
         H.! HA.method "post"
-        H.! HA.action ("/" <> (fromString $ show $ linkURI $
+        H.! HA.action ("/" <> fromString (show $ linkURI $
           buyLink (MT.userDetailsId ud) False)
           )
         H.! HA.enctype "application/x-www-form-urlencoded" $
@@ -119,17 +135,26 @@ userSettingsPointer
 userSettingsPointer l10n locale uid =
   H.form $ do
     H.button
+      H.! HA.class_ "btn btn-primary"
       H.! HA.type_ "submit"
       H.! HA.formmethod "get"
       H.! HA.formaction
         ("/" <> fromString (show $ linkURI $ userManageLink uid))
       $ H.toHtml $ translate "Manage user settings"
     H.button
+      H.! HA.class_ "btn btn-primary"
       H.! HA.type_ "submit"
       H.! HA.formmethod "get"
       H.! HA.formaction
         ("/" <> fromString (show $ linkURI $ journalLink Nothing))
       $ H.toHtml $ translate "View Journal"
+    H.button
+      H.! HA.class_ "btn btn-primary"
+      H.! HA.type_ "submit"
+      H.! HA.formmethod "get"
+      H.! HA.formaction
+        ("/" <> fromString (show $ linkURI productGetNewLink))
+      $ H.toHtml $ translate "Add new product"
   where
     translate = localize l10n locale . gettext
 
@@ -138,74 +163,82 @@ productList
   -> H.Html
 productList pos =
   H.p $
-    H.ul H.! HA.class_ "product_list" $
+    H.ul H.! HA.class_ "tile-list" $
       mapM_
         (\(MT.ProductShortOverview pid ident _ _ _ avatarid) ->
-          H.li H.! HA.class_ "product" H.!?
+          H.li
-            (isJust avatarid
+            H.! HA.class_ "tile"
-            , productBgStyle (fromString $ show $ fromJust avatarid)
+            H.!?
-            ) $
+              (isJust avatarid
-              H.a H.! HA.href ("#" <> fromString (show pid)) $
+              , productBgStyle (fromString $ show $ fromJust avatarid)
-                H.toHtml ident
+              ) $
+                H.a
+                  H.! HA.class_ "tile-content"
+                  H.! HA.href ("#" <> fromString (show pid)) $
+                    H.toHtml ident
         )
         pos
 
 userNewPage
   :: L10n
   -> Locale
+  -> T.Text
   -> Maybe T.Text
   -> UserNewPage
-userNewPage l10n locale mcookie = scaffold l10n locale mcookie (initPage $
+userNewPage l10n locale version mcookie =
-  translate "Matebeamter" <>
+  scaffold l10n locale version mcookie (initPage $
-  " - " <>
+    translate "Matebeamter" <>
-  translate "Create new user"
+    " - " <>
-  ) $ H.p $ H.form
+    translate "Create new user"
-    H.! HA.method "post"
+    ) $ H.p $ H.form
-    H.! HA.action ("/" <> fromString (show $ linkURI userNewPostLink))
+      H.! HA.method "post"
-    H.! HA.enctype "application/x-www-form-urlencoded" $ do
+      H.! HA.action ("/" <> fromString (show $ linkURI userNewPostLink))
-      H.div H.! HA.class_ "form-group required" $ do
+      H.! HA.enctype "application/x-www-form-urlencoded" $ do
-        H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
+        H.div H.! HA.class_ "form-group required" $ do
-        H.input
+          H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
-          H.! HA.id "username"
+          H.input
-          H.! HA.class_ "form-control"
+            H.! HA.id "username"
-          H.! HA.name "userSubmitIdent"
+            H.! HA.class_ "form-control"
-          H.! HA.type_ "text"
+            H.! HA.name "userSubmitIdent"
-          H.! HA.required ""
+            H.! HA.type_ "text"
-          H.! HA.value ""
+            H.! HA.required ""
-      H.div H.! HA.class_ "form-group optional" $ do
+            H.! HA.value ""
-        H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
+        H.div H.! HA.class_ "form-group optional" $ do
-        H.input
+          H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
-          H.! HA.id "useremail"
+          H.input
-          H.! HA.class_ "form-control"
+            H.! HA.id "useremail"
-          H.! HA.name "userSubmitEmail"
+            H.! HA.class_ "form-control"
-          H.! HA.type_ "email"
+            H.! HA.name "userSubmitEmail"
-          H.! HA.required ""
+            H.! HA.type_ "email"
-          H.! HA.value ""
+            H.! HA.required ""
-      H.div H.! HA.class_ "form-group required" $ do
+            H.! HA.value ""
-        H.label H.! HA.for "userpass" $ H.toHtml $ translate "Password"
+        H.div H.! HA.class_ "form-group required" $ do
-        H.input
+          H.label H.! HA.for "userpass" $ H.toHtml $ translate "Password"
-          H.! HA.id "userpass"
+          H.input
-          H.! HA.class_ "form-control"
+            H.! HA.id "userpass"
-          H.! HA.name "userSubmitPassHash"
+            H.! HA.class_ "form-control"
-          H.! HA.type_ "password"
+            H.! HA.name "userSubmitPassHash"
-          H.! HA.required ""
+            H.! HA.type_ "password"
-          H.! HA.value ""
+            H.! HA.required ""
-      H.div H.! HA.class_ "form-group optional" $
+            H.! HA.value ""
-        H.button
+        H.div H.! HA.class_ "form-group optional" $
-          H.! HA.class_ "btn btn-default"
+          H.button
-          H.! HA.type_ "submit"
+            H.! HA.class_ "btn btn-primary"
-          $ H.toHtml $ translate "Submit"
+            H.! HA.type_ "submit"
-  where
+            $ H.toHtml $ translate "Submit"
-    translate = localize l10n locale . gettext
+    where
+      translate = localize l10n locale . gettext
 
 userRechargePage
   :: L10n
   -> Locale
+  -> T.Text
   -> Maybe T.Text
   -> Int
+  -> T.Text
   -> UserRechargePage
-userRechargePage l10n locale mcookie uid =
+userRechargePage l10n locale version mcookie uid symbol =
-  scaffold l10n locale mcookie (initPage $
+  scaffold l10n locale version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Recharge account"
@@ -224,10 +257,10 @@ userRechargePage l10n locale mcookie uid =
             H.! HA.min "0"
             H.! HA.step "0.01"
             H.! HA.value "0"
-          -- H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol
+          H.toHtml symbol
         H.div H.! HA.class_ "form-group optional" $
           H.button
-            H.! HA.class_ "btn btn-default"
+            H.! HA.class_ "btn btn-primary"
             H.! HA.type_ "submit"
             $ H.toHtml $ translate "Recharge"
   where
@@ -238,10 +271,11 @@ userManagePage
   -> Locale
   -> MT.UserDetails
   -> [MT.AuthOverview]
+  -> T.Text
   -> Maybe T.Text
   -> UserManagePage
-userManagePage l10n locale userDetails authOverviews mcookie =
+userManagePage l10n locale userDetails authOverviews version mcookie =
-  scaffold l10n locale mcookie (initPage $
+  scaffold l10n locale version mcookie (initPage $
     translate "Matebeamter" <>
     " - " <>
     translate "Manage user data"
@@ -276,13 +310,13 @@ userManagePage l10n locale userDetails authOverviews mcookie =
                   (MT.userDetailsEmail userDetails))
           H.div H.! HA.class_ "form-group optional" $
             H.button
-              H.! HA.class_ "btn btn-default"
+              H.! HA.class_ "btn btn-primary"
               H.! HA.type_ "submit"
               $ H.toHtml $ translate "Submit"
       H.p $ do
         H.toHtml $ translate "Authentication details"
         mapM_
-          (\(MT.AuthOverview aoid comment method) -> H.form
+          (\(MT.AuthOverview aoid _ comment method) -> H.form
             H.! HA.method "post"
             H.! HA.action ("/" <>
               fromString (show $ linkURI $
@@ -305,7 +339,7 @@ userManagePage l10n locale userDetails authOverviews mcookie =
                   H.! HA.value (fromString $ show aoid)
               H.div H.! HA.class_ "form-group optional" $
                 H.button
-                  H.! HA.class_ "btn btn-default"
+                  H.! HA.class_ "btn btn-primary"
                   H.! HA.type_ "submit"
                   $ H.toHtml $ translate "Delete"
             )
@@ -354,7 +388,7 @@ userManagePage l10n locale userDetails authOverviews mcookie =
                       H.toHtml $ translate "Primary password"
             H.div H.! HA.class_ "form-group optional" $
               H.button
-                H.! HA.class_ "btn btn-default"
+                H.! HA.class_ "btn btn-primary"
                 H.! HA.type_ "submit"
                 $ H.toHtml $ translate "Submit"
   where

static/css/style.css

@@ -0,0 +1,92 @@
+:root {
+  --tile-color: #36c30023;
+  --function-tile-color: #c300d223;
+}
+
+body {
+  margin: 30px;
+}
+
+form button, nav ul > li {
+  margin: 5px;
+}
+
+.tile-list, nav ul {
+  list-style: none;
+  padding: 0;
+}
+
+nav ul > li {
+  display: inline-block;
+  border-radius: 6px;
+  background-color: var(--function-tile-color);
+  padding : 10px;
+}
+
+.tile {
+  display: inline-flex;
+  flex-direction: column;
+  align-content: stretch;
+  align-items: stretch;
+  justify-content: center;
+  border-radius: 6px;
+  background-color: var(--tile-color);
+  box-shadow: 0 0 3px #c3c3c3;
+  margin: 30px 30px 0 5px;
+  width: 200px;
+  height: 200px;
+  text-align: center;
+}
+
+.tile > label, .tile > * {
+  flex: 1 1 auto;
+}
+
+.tile-content {
+  flex: 1 1 auto;
+  display: flex;
+  justify-content: center;
+  flex-direction: column;
+  align-content: stretch;
+  align-items: stretch;
+}
+
+.tile-content * {
+  flex: 1 1 auto;
+  display: inline-block;
+  width: 100%;
+  justify-content: center;
+  flex-direction: column;
+  align-content: stretch;
+  align-items: stretch;
+  margin: 0;
+  padding: 0;
+}
+
+.tile input[type="checkbox"] {
+  display: none;
+}
+
+.tile input[type="checkbox"] + * {
+  display: none;
+  opacity: 0;
+  transition: opacity 0.5s;
+}
+
+.tile input[type="checkbox"]:checked + * {
+  display: inline-block;
+  opacity: 1;
+  transition: opacity 0.5s;
+}
+
+.function {
+  background-color: var(--function-tile-color);
+}
+
+.tile-list + * {
+  margin-top: 30px;
+}
+
+hr {
+  margin-top: 30px;
+}