Compare commits

...

16 commits

Author SHA1 Message Date
d0b6ffca7a meow 2024-02-28 11:56:38 +01:00
30ab4497f6 fix flake 2023-08-17 02:31:07 +02:00
b033f4c0b6 it's a kind of magic 2023-07-18 18:57:07 +02:00
0d1d219291 hunting wabbits 2022-09-16 16:37:00 +02:00
889c9e3ad1 fix 2022-09-16 16:18:16 +02:00
42af21820b moar flake 2022-09-16 16:18:08 +02:00
479c359f79 flakify even more 2022-09-16 16:12:27 +02:00
88e95aa613 update shell 2022-09-16 16:11:04 +02:00
8b0713238a flakify more 2022-09-16 16:10:51 +02:00
2a91cb597a flakify 2022-09-16 16:09:48 +02:00
b61a900caf remove haskell.nix remnants 2020-05-10 11:33:10 +02:00
37dab5540b adapt to journal entries with no description string 2020-05-10 11:31:23 +02:00
74a666f092 I did way too much here. Polishing, fixing redirection etc. 2019-12-26 09:41:31 +01:00
f2f9f46c4e beginning polish 2019-12-24 13:17:45 +01:00
f1f0e28b4e starting out polishing things 2019-12-23 14:09:49 +01:00
e80cc68204 fetch and incorporate provided meta information 2019-12-20 08:49:06 +01:00
31 changed files with 677 additions and 945 deletions

2
.gitignore vendored
View file

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

View file

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

View file

@ -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 .././.; }

View file

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

84
flake.lock Normal file
View file

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

51
flake.nix Normal file
View file

@ -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
];
};
});
}

View file

@ -46,8 +46,9 @@ executable matebeamter
, View.Buy , View.Buy
, View.Journal , View.Journal
, View.Product , View.Product
, Paths_matebeamter
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base >=4.12.0.0 && < 5
, mateamt , mateamt
, servant , servant
, servant-server , servant-server
@ -63,6 +64,7 @@ executable matebeamter
, hashable , hashable
, warp , warp
, wai , wai
, wai-app-static
, wai-logger , wai-logger
, wai-session , wai-session
, http-client , http-client
@ -77,10 +79,9 @@ executable matebeamter
, base64-bytestring , base64-bytestring
, cryptonite , cryptonite
, stm , stm
, stm-containers
, either , either
, optparse-applicative , optparse-applicative
, HsYAML , HsYAML ^>=0.2.1.0
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

342
pkgs.nix
View file

@ -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 = {}; };
};
})
];
}

View file

@ -1,6 +1,20 @@
{ pkgs ? import <nixpkgs> {} }: { pkgs ? import <nixpkgs> {}}:
let 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 in
hsPkgs.matebeamter.components.all hpkgs.matebeamter.env

View file

@ -11,7 +11,7 @@ module API where
import Servant.API import Servant.API
import Servant.Links import Servant.Links
-- import Servant.RawM import Servant.RawM
import Servant.HTML.Blaze import Servant.HTML.Blaze
import Data.Proxy import Data.Proxy
@ -27,7 +27,8 @@ import qualified "mateamt" Types as MT
import Types import Types
type UserAPI = 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 :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] UserOverviewPage :> Get '[HTML] UserOverviewPage
:<|> "user" :> Capture "id" Int :> "buy" :<|> "user" :> Capture "id" Int :> "buy"
@ -71,6 +72,7 @@ type UserAPI =
:> ReqBody '[FormUrlEncoded] CashCheck :> ReqBody '[FormUrlEncoded] CashCheck
:> Post '[HTML] JournalPage :> Post '[HTML] JournalPage
:<|> "product" :> "list" :<|> "product" :> "list"
:> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] ProductPriceListPage :> Get '[HTML] ProductPriceListPage
:<|> "product" :> "refill" :<|> "product" :> "refill"
:> Get '[HTML] ProductRefillPage :> Get '[HTML] ProductRefillPage
@ -95,6 +97,7 @@ type UserAPI =
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "auth" :> "logout" :<|> "auth" :> "logout"
:> Post '[HTML] UserOverviewPage :> Post '[HTML] UserOverviewPage
:<|> "static" :> RawM
) )
( userSelectLink :<|> ( userSelectLink :<|>
@ -121,5 +124,6 @@ type UserAPI =
productPostNewLink :<|> productPostNewLink :<|>
authLink :<|> authLink :<|>
authPostLink :<|> authPostLink :<|>
authLogoutLink authLogoutLink :<|>
staticLink
) = allLinks (Proxy :: Proxy UserAPI) ) = allLinks (Proxy :: Proxy UserAPI)

View file

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

View file

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

View file

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

View file

@ -42,14 +42,14 @@ buyControl
-> [MT.PurchaseDetail] -> [MT.PurchaseDetail]
-> Bool -> Bool
-> UserHandler BuyConfirmPage -> 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) if not (null pds)
then do 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 epsovs <- liftIO $ runClientM
(productShortList (Just MT.AllProducts)) (productShortList (Just MT.AllProducts))
backend backend
@ -70,13 +70,29 @@ buyControl mcookie uid pds forceBuy =
) )
0 0
ziptup ziptup
return (buyConfirmPage l10n loc uid ziptup total forceBuy mcookie) return
(buyConfirmPage
l10n
loc
uid
ziptup
total
forceBuy
version
mcookie
symbol
)
Left err -> Left err ->
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
else 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 purchaseControl
:: Maybe T.Text :: Maybe T.Text
@ -168,7 +184,7 @@ purchaseControl mcookie uid pds forceBuy = do
backend backend
throwError throwError
$ addMessage message $ addMessage message
$ redirect303 userSelectLink $ redirect303 (userSelectLink Nothing)
translate l10n locale = localize l10n locale . gettext translate l10n locale = localize l10n locale . gettext
cashBuyOverviewControl cashBuyOverviewControl
@ -176,7 +192,7 @@ cashBuyOverviewControl
-> Maybe MT.ProductRefine -> Maybe MT.ProductRefine
-> UserHandler CashBuyOverviewPage -> UserHandler CashBuyOverviewPage
cashBuyOverviewControl mcookie mrefine = do cashBuyOverviewControl mcookie mrefine = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _ symbol version) <- ask
let loc = localeFromCookie mcookie let loc = localeFromCookie mcookie
eproducts <- liftIO $ runClientM eproducts <- liftIO $ runClientM
(productShortList (productShortList
@ -185,7 +201,7 @@ cashBuyOverviewControl mcookie mrefine = do
backend backend
case eproducts of case eproducts of
Right prods -> Right prods ->
return $ cashBuyOverviewPage l10n loc mcookie prods return $ cashBuyOverviewPage l10n loc version mcookie prods
Left err -> Left err ->
throwError $ err500 throwError $ err500
{ errBody = fromString (show err) { errBody = fromString (show err)
@ -198,6 +214,7 @@ cashBuyPurchaseControl
-> UserHandler UserSelectPage -> UserHandler UserSelectPage
cashBuyPurchaseControl mcookie {-forceBuy-} pds = do cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
l10n <- asks rsL10n l10n <- asks rsL10n
symbol <- asks rsCurrencySymbol
let loc = localeFromCookie mcookie let loc = localeFromCookie mcookie
if not (null pds) if not (null pds)
then do then do
@ -226,8 +243,9 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
(MT.PurchaseResult (MT.PayAmount price) []) -> (MT.PurchaseResult (MT.PayAmount price) []) ->
throwError $ throwError $
addMessage 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 (MT.PurchaseResult (MT.PayAmount price) miss) -> do
eproducts <- liftIO $ runClientM eproducts <- liftIO $ runClientM
(productShortList (productShortList
@ -239,7 +257,7 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
Right prods -> Right prods ->
throwError throwError
$ addMessage (translate l10n loc "Please Pay" <> ": " $ addMessage (translate l10n loc "Please Pay" <> ": "
<> formatMoney price <> formatMoney price <> symbol
<> ". " <> ". "
<> translate l10n loc <> translate l10n loc
"But there seems to be something missing: " "But there seems to be something missing: "
@ -255,13 +273,13 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
[] []
prods prods
)) ))
$ redirect303 userSelectLink $ redirect303 (userSelectLink Nothing)
Left err -> Left err ->
throwError $ err500 throwError $ err500
{ errBody = fromString (show err) { errBody = fromString (show err)
} }
Left err -> Left err ->
handleClientErr err Nothing (Just userSelectLink) handleClientErr err Nothing (Just (userSelectLink Nothing))
else else
throwError throwError
$ addMessage (translate l10n loc "Please choose your product(s)") $ addMessage (translate l10n loc "Please choose your product(s)")

View file

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

View file

@ -30,27 +30,28 @@ import Hash
productGetPriceList productGetPriceList
:: Maybe T.Text :: Maybe T.Text
-> Maybe MT.ProductRefine
-> UserHandler ProductPriceListPage -> UserHandler ProductPriceListPage
productGetPriceList mcookie = do productGetPriceList mcookie mrefine = do
(token, muser, loc, l10n, backend) <- controlInit mcookie (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
elist <- liftIO $ runClientM elist <- liftIO $ runClientM
(productShortList (productShortList
(Just MT.AllProducts) mrefine
) )
backend backend
case elist of case elist of
Right list -> Right list ->
return (productPriceListPage l10n loc mcookie list) return (productPriceListPage l10n loc version mcookie list symbol)
Left err -> Left err ->
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
productGetRefill productGetRefill
:: Maybe T.Text :: Maybe T.Text
-> UserHandler ProductRefillPage -> UserHandler ProductRefillPage
productGetRefill mcookie = do productGetRefill mcookie = do
(token, muser, loc, l10n, backend) <- controlInit mcookie (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
case muser of case muser of
Just _ -> do Just _ -> do
elist <- liftIO $ runClientM elist <- liftIO $ runClientM
@ -58,11 +59,11 @@ productGetRefill mcookie = do
backend backend
case elist of case elist of
Right list -> do Right list -> do
return $ productRefillPage l10n loc mcookie list return $ productRefillPage l10n loc version mcookie list
Left err -> Left err ->
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
Nothing -> Nothing ->
redirectOverAuth Nothing (Just productGetRefillLink) Nothing redirectOverAuth Nothing (Just productGetRefillLink) Nothing
@ -71,7 +72,7 @@ productPostRefill
-> [MT.AmountRefill] -> [MT.AmountRefill]
-> UserHandler ProductRefillPage -> UserHandler ProductRefillPage
productPostRefill mcookie refills = do productPostRefill mcookie refills = do
(token, muser, loc, l10n, backend) <- controlInit mcookie (token, muser, loc, l10n, backend, _, _) <- controlInit mcookie
case muser of case muser of
Just _ -> do Just _ -> do
eresult <- liftIO $ runClientM eresult <- liftIO $ runClientM
@ -86,9 +87,9 @@ productPostRefill mcookie refills = do
addMessage (translate l10n loc "Refill successfull") $ addMessage (translate l10n loc "Refill successfull") $
redirect303 productGetRefillLink redirect303 productGetRefillLink
Left err -> Left err ->
handleClientErr err (read <$> muser) (Just productGetRefillLink) handleClientErr err muser (Just productGetRefillLink)
Nothing -> Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing redirectOverAuth muser (Just productGetRefillLink) Nothing
where where
translate l10n loc = localize l10n loc . gettext translate l10n loc = localize l10n loc . gettext
@ -96,20 +97,20 @@ productGetNew
:: Maybe T.Text :: Maybe T.Text
-> UserHandler ProductNewPage -> UserHandler ProductNewPage
productGetNew mcookie = do productGetNew mcookie = do
(token, muser, loc, l10n, backend) <- controlInit mcookie (token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
case muser of case muser of
Just user -> Just user ->
-- TODO: Fetch avatars and suppliers -- TODO: Fetch avatars and suppliers
return $ productNewPage l10n loc mcookie return $ productNewPage l10n loc version mcookie symbol
Nothing -> Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing redirectOverAuth muser (Just productGetRefillLink) Nothing
productPostNew productPostNew
:: Maybe T.Text :: Maybe T.Text
-> ProductSubmit -> ProductSubmit
-> UserHandler ProductNewPage -> UserHandler ProductNewPage
productPostNew mcookie (ProductSubmit ident flPrice ml max apc ppc artnr) = do productPostNew mcookie (ProductSubmit ident flPrice ml max apc ppc artnr) = do
(token, muser, loc, l10n, backend) <- controlInit mcookie (token, muser, loc, l10n, backend, _, _) <- controlInit mcookie
case muser of case muser of
Just user -> do Just user -> do
eresult <- liftIO $ runClientM eresult <- liftIO $ runClientM
@ -133,8 +134,8 @@ productPostNew mcookie (ProductSubmit ident flPrice ml max apc ppc artnr) = do
Right _ -> Right _ ->
throwError $ throwError $
addMessage (translate l10n loc "Product created successfully") $ addMessage (translate l10n loc "Product created successfully") $
redirect303 (userOverviewLink (read user) Nothing) redirect303 (userOverviewLink user Nothing)
Nothing -> Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing redirectOverAuth muser (Just productGetRefillLink) Nothing
where where
translate l10n loc = localize l10n loc . gettext translate l10n loc = localize l10n loc . gettext

View file

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

View file

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Main where module Main where
import Servant import Servant
@ -20,11 +20,18 @@ import Data.YAML
import Options.Applicative import Options.Applicative
import Network.Wai.Application.Static
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports -- internal imports
import API import API
import Types import Types
import Control import Control
import Client
main :: IO () main :: IO ()
main = do main = do
@ -38,23 +45,32 @@ main = do
Right (Configuration apiHost apiPort apiUri apiSec listenPort locs) -> do Right (Configuration apiHost apiPort apiUri apiSec listenPort locs) -> do
mngr <- newManager defaultManagerSettings mngr <- newManager defaultManagerSettings
(l10n, _) <- getL10n (T.unpack locs) (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 where
opts = info (options <**> helper) opts = info (options <**> helper)
( fullDesc ( fullDesc
@ -93,6 +109,7 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
:<|> authLogoutControl mcookie :<|> authLogoutControl mcookie
:<|> (\_ -> return $ staticApp (defaultFileServerSettings "static")) mcookie
) )
userApi :: Proxy UserAPI userApi :: Proxy UserAPI

View file

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

View file

@ -1,8 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
module Types.Page where module Types.Page where
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
data Page markup attr = Page data Page markup attr = Page
{ pageTitle :: attr -- ^ Page title { pageTitle :: attr -- ^ Page title
@ -34,7 +36,16 @@ initPage title = Page
title title
mempty mempty
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 template
:: Page H.Html T.Text :: Page H.Html T.Text

View file

@ -7,6 +7,7 @@ import Servant.Client (ClientEnv)
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT)
import qualified Data.Text as T
import Data.Text.I18n import Data.Text.I18n
import Crypto.KDF.PBKDF2 import Crypto.KDF.PBKDF2
@ -14,9 +15,11 @@ import Crypto.Hash.Algorithms
data ReadState = ReadState data ReadState = ReadState
-- { rsManager :: Manager -- { 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 type UserHandler = ReaderT ReadState Handler

View file

@ -8,17 +8,15 @@ module Util where
import Servant hiding (addHeader) import Servant hiding (addHeader)
import Servant.Client import Servant.Client
import Servant.Client.Core.Request
import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Html5.Attributes as HA
import Text.Blaze.Internal
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Lazy.Encoding import Data.Text.Encoding
import Data.Text.I18n import Data.Text.I18n
import Data.ByteString.Builder
import Data.List (intercalate) import Data.List (intercalate)
import Data.List.Split (chunksOf) import Data.List.Split (chunksOf)
@ -26,13 +24,11 @@ import Data.String (fromString)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Web.Cookie
import Text.Printf (printf) import Text.Printf (printf)
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import Control.Monad.Reader (asks) import Control.Monad.Reader (ask)
-- imports from "mateamt" -- imports from "mateamt"
@ -83,7 +79,7 @@ addMessage message err =
{ errHeaders = { errHeaders =
( "Set-Cookie" ( "Set-Cookie"
, "message=" <> , "message=" <>
fromString (T.unpack message) <> encodeUtf8 message <>
"; Path=/; Max-Age=5" "; Path=/; Max-Age=5"
) : errHeaders err ) : errHeaders err
} }
@ -97,13 +93,13 @@ parseCookieText = map
parseTokenAndUser parseTokenAndUser
:: Maybe T.Text :: Maybe T.Text
-> (String, Maybe String) -> (String, Maybe Int)
parseTokenAndUser mcookie = parseTokenAndUser mcookie =
(token, mAuthUser) (token, mAuthUser)
where where
token = T.unpack $ fromMaybe "secret" token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie) (lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$> mAuthUser = read . T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
mParsedCookie = fmap parseCookieText mcookie mParsedCookie = fmap parseCookieText mcookie
@ -111,7 +107,7 @@ localeFromCookie
:: Maybe T.Text :: Maybe T.Text
-> Locale -> Locale
localeFromCookie mcookie = Locale localeFromCookie mcookie = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
handleErrors handleErrors
:: (Traversable t, Show (t (Maybe ClientError))) :: (Traversable t, Show (t (Maybe ClientError)))
@ -152,7 +148,7 @@ redirectOverAuth muid mLink mRefine = do
fromString (show $ linkURI (case (mLink, muid) of fromString (show $ linkURI (case (mLink, muid) of
(Just link, _) -> link (Just link, _) -> link
(Nothing, Just uid) -> userOverviewLink uid mRefine (Nothing, Just uid) -> userOverviewLink uid mRefine
_ -> userSelectLink _ -> userSelectLink Nothing
)))) ))))
throwError throwError
(err303 (err303
@ -177,6 +173,9 @@ redirectOverAuth muid mLink mRefine = do
} }
) )
productBgStyle
:: AttributeValue
-> Attribute
productBgStyle aid = HA.style $ mconcat productBgStyle aid = HA.style $ mconcat
[ "background-image: url(#" <> aid <> ");" -- FILLME [ "background-image: url(#" <> aid <> ");" -- FILLME
, "backgronud-color: blue;" , "backgronud-color: blue;"
@ -189,14 +188,18 @@ productBgStyle aid = HA.style $ mconcat
controlInit controlInit
:: Maybe T.Text :: Maybe T.Text
-> UserHandler (String, Maybe String, Locale, L10n, ClientEnv) -> UserHandler (String, Maybe Int, Locale, L10n, ClientEnv, T.Text, T.Text)
controlInit mcookie = do controlInit mcookie = do
let (token, muser) = parseTokenAndUser mcookie let (token, muser) = parseTokenAndUser mcookie
loc = localeFromCookie mcookie loc = localeFromCookie mcookie
l10n <- asks rsL10n (ReadState l10n backend _ symbol version) <- ask
backend <- asks rsBackend return (token, muser, loc, l10n, backend, symbol, version)
return (token, muser, loc, l10n, backend)
handleClientErr
:: ClientError
-> Maybe Int
-> Maybe Link
-> UserHandler UserOverviewPage
handleClientErr err muid authTargetLink = handleClientErr err muid authTargetLink =
case err of case err of
FailureResponse _ resp -> FailureResponse _ resp ->
@ -206,8 +209,8 @@ handleClientErr err muid authTargetLink =
else else
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
othererr -> othererr ->
throwError $ throwError $
addMessage (fromString $ show othererr) $ addMessage (fromString $ show othererr) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)

View file

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

View file

@ -13,7 +13,7 @@ import Data.String (fromString)
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (isJust, fromJust, fromMaybe) import Data.Maybe (isJust, fromJust)
import Control.Monad (when) import Control.Monad (when)
@ -35,10 +35,12 @@ buyConfirmPage
-> [(MT.PurchaseDetail, MT.ProductShortOverview)] -> [(MT.PurchaseDetail, MT.ProductShortOverview)]
-> Int -> Int
-> Bool -> Bool
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> T.Text
-> H.Html -> 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 "Matebeamter" <>
" - " <> " - " <>
translate "Home" translate "Home"
@ -57,8 +59,8 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
H.! HA.enctype "application/x-www-form-urlencoded" H.! HA.enctype "application/x-www-form-urlencoded"
$ do $ do
mapM_ 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.div H.! HA.class_ "form-group required" $ do
H.input H.input
H.! HA.id ("product-select-" <> fromString (show pid)) H.! HA.id ("product-select-" <> fromString (show pid))
@ -88,7 +90,7 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
H.label H.label
H.! HA.for ("product-total-" <> fromString (show pid)) H.! HA.for ("product-total-" <> fromString (show pid))
$ H.toHtml $ $ 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"
@ -111,16 +113,17 @@ buyConfirmPage l10n locale uid ziptups total forceBuy mcookie =
H.! HA.type_ "text" H.! HA.type_ "text"
H.! HA.value (fromString $ T.unpack $ formatMoney total) H.! HA.value (fromString $ T.unpack $ formatMoney total)
H.! HA.disabled "" H.! HA.disabled ""
-- H.toHtml ("€" :: T.Text) -- TODO: ask for currency symbol H.toHtml symbol
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ if forceBuy $ H.toHtml $ if forceBuy
then translate "Buy anyway" then translate "Buy anyway"
else translate "Buy" else translate "Buy"
when forceBuy $ when forceBuy $
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.formnovalidate "formnovalidate" H.! HA.formnovalidate "formnovalidate"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
@ -137,43 +140,44 @@ buyProductsForm
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> H.Html -> H.Html
buyProductsForm l10n locale prods = do 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.div
H.! HA.class_ "form-group optional" H.! HA.class_ "tile"
H.!? H.!?
( isJust maid ( isJust maid
, productBgStyle (fromString $ show $ fromJust 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.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Proceed" $ H.toHtml $ translate "Proceed"
where where
@ -182,11 +186,12 @@ buyProductsForm l10n locale prods = do
cashBuyOverviewPage cashBuyOverviewPage
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> CashBuyOverviewPage -> 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 "Matebeamter" <>
" - " <> " - " <>
translate "Buy with Cash" translate "Buy with Cash"

View file

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

View file

@ -28,11 +28,13 @@ import API
productPriceListPage productPriceListPage
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> T.Text
-> ProductPriceListPage -> ProductPriceListPage
productPriceListPage l10n loc mcookie list = productPriceListPage l10n loc version mcookie list symbol =
scaffold l10n loc mcookie (initPage $ scaffold l10n loc version mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Price List" translate "Price List"
@ -52,7 +54,7 @@ productPriceListPage l10n loc mcookie list =
H.td (H.toHtml ident) H.td (H.toHtml ident)
H.td (H.toHtml $ show amount) H.td (H.toHtml $ show amount)
H.td (H.toHtml $ (fromString $ show ml :: T.Text) <> " ml") H.td (H.toHtml $ (fromString $ show ml :: T.Text) <> " ml")
H.td (H.toHtml $ (formatMoney price)) -- TODO: Add Currency symbol H.td (H.toHtml $ (formatMoney price) <> symbol)
) )
list list
where where
@ -61,11 +63,12 @@ productPriceListPage l10n loc mcookie list =
productRefillPage productRefillPage
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> ProductRefillPage -> ProductRefillPage
productRefillPage l10n loc mcookie prodList = productRefillPage l10n loc version mcookie prodList =
scaffold l10n loc mcookie (initPage $ scaffold l10n loc version mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Refill stock" translate "Refill stock"
@ -78,7 +81,7 @@ productRefillPage l10n loc mcookie prodList =
H.! HA.enctype "application/x-www-form-urlencoded" H.! HA.enctype "application/x-www-form-urlencoded"
$ do $ do
mapM_ mapM_
(\(MT.ProductShortOverview pid ident price amount ml maid) -> do (\(MT.ProductShortOverview pid ident _ _ _ maid) -> do
H.div H.div
H.! HA.class_ "form-group optional" H.! HA.class_ "form-group optional"
H.!? H.!?
@ -151,7 +154,7 @@ productRefillPage l10n loc mcookie prodList =
prodList prodList
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where
@ -160,10 +163,12 @@ productRefillPage l10n loc mcookie prodList =
productNewPage productNewPage
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> T.Text
-> ProductNewPage -> ProductNewPage
productNewPage l10n loc mcookie = productNewPage l10n loc version mcookie symbol =
scaffold l10n loc mcookie (initPage $ scaffold l10n loc version mcookie (initPage $
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Create new product" translate "Create new product"
@ -185,7 +190,8 @@ productNewPage l10n loc mcookie =
H.! HA.value "" H.! HA.value ""
H.! HA.required "" H.! HA.required ""
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "price" $ H.toHtml $ translate "Product price" H.label H.! HA.for "price" $ H.toHtml $
translate "Product price in" <> " " <> symbol
H.input H.input
H.! HA.id "price" H.! HA.id "price"
H.! HA.class_ "form-control" H.! HA.class_ "form-control"
@ -282,7 +288,7 @@ productNewPage l10n loc mcookie =
-} -}
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where

View file

@ -14,8 +14,12 @@ import Data.Text.I18n
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.Version (showVersion)
import Control.Monad (when) import Control.Monad (when)
import qualified Paths_matebeamter as MyPath (version)
-- internal imports -- internal imports
import Types.Page import Types.Page
@ -25,13 +29,14 @@ import Util
scaffold scaffold
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> Page H.Html T.Text -> Page H.Html T.Text
-> H.Html -> H.Html
-> 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 $ do 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 $ translate "Home" H.toHtml $ translate "Home"
maybe maybe
(return ()) (return ())
@ -40,7 +45,7 @@ scaffold l10n locale mcookie page content = template page $ do
(fromString $ show $ linkURI $ userOverviewLink (read uid) Nothing)) $ (fromString $ show $ linkURI $ userOverviewLink (read uid) Nothing)) $
H.toHtml $ translate "User Page" H.toHtml $ translate "User Page"
) )
(getLogin mcookie) (show <$> getLogin mcookie)
H.hr H.hr
when (isJust message) when (isJust message)
(H.div H.! HA.id "message" H.! HA.class_ "message" $ (H.div H.! HA.id "message" H.! HA.class_ "message" $
@ -51,20 +56,29 @@ scaffold l10n locale mcookie page content = template page $ do
H.hr H.hr
H.footer $ H.form $ do H.footer $ H.form $ do
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction ("/" <> H.! HA.formaction ("/" <>
(fromString $ show $ linkURI productGetPriceListLink)) (fromString $ show $ linkURI $ productGetPriceListLink Nothing))
$ H.toHtml $ translate "Price List" $ H.toHtml $ translate "Price List"
maybe -- maybe
(return ()) -- (return ())
(\_ -> -- (\_ ->
H.button -- H.button
H.! HA.formmethod "get" -- H.! HA.class_ "btn btn-primary"
H.! HA.formaction ("/" <> -- H.! HA.formmethod "get"
(fromString $ show $ linkURI $ productGetRefillLink)) -- H.! HA.formaction ("/" <>
$ H.toHtml $ translate "Refill stock" -- (fromString $ show $ linkURI $ productGetRefillLink))
) -- $ H.toHtml $ translate "Refill stock"
(getLogin mcookie) -- )
-- (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 where
message = lookup "message" =<< fmap parseCookieText mcookie message = lookup "message" =<< fmap parseCookieText mcookie
translate = localize l10n locale . gettext translate = localize l10n locale . gettext

View file

@ -31,25 +31,39 @@ userSelectPage
:: L10n :: L10n
-> Locale -> Locale
-> [MT.UserSummary] -> [MT.UserSummary]
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> UserSelectPage -> 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 "Matebeamter" <>
" - " <> " - " <>
translate "Home" 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 where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -59,10 +73,12 @@ userOverviewPage
-> MT.AuthMethod -> MT.AuthMethod
-> MT.UserDetails -> MT.UserDetails
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> T.Text
-> UserOverviewPage -> 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 "Matebeamter") <>
" - " <> " - " <>
localize l10n locale (gettext "User Menu for ") <> 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 $ H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
translate "Your current balance is" <> translate "Your current balance is" <>
": " <> ": " <>
formatMoney (MT.userDetailsBalance ud) formatMoney (MT.userDetailsBalance ud) <> symbol
-- TODO: Add currency symbol
H.p $ H.form H.p $ H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink)) H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.enctype "application/x-www-form-urlencoded" $
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Logout" $ H.toHtml $ translate "Logout"
case method of case method of
@ -97,6 +112,7 @@ userOverviewPage l10n locale method ud pos mcookie =
buyForm = do buyForm = do
H.div $ H.form $ H.div $ H.form $
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction ("/" <> H.! HA.formaction ("/" <>
@ -119,18 +135,21 @@ userSettingsPointer
userSettingsPointer l10n locale uid = userSettingsPointer l10n locale uid =
H.form $ do H.form $ do
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
("/" <> fromString (show $ linkURI $ userManageLink uid)) ("/" <> fromString (show $ linkURI $ userManageLink uid))
$ H.toHtml $ translate "Manage user settings" $ H.toHtml $ translate "Manage user settings"
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
("/" <> fromString (show $ linkURI $ journalLink Nothing)) ("/" <> fromString (show $ linkURI $ journalLink Nothing))
$ H.toHtml $ translate "View Journal" $ H.toHtml $ translate "View Journal"
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
@ -144,74 +163,82 @@ productList
-> H.Html -> H.Html
productList pos = productList pos =
H.p $ H.p $
H.ul H.! HA.class_ "product_list" $ H.ul H.! HA.class_ "tile-list" $
mapM_ mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> (\(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 pos
userNewPage userNewPage
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> UserNewPage -> 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 userRechargePage
:: L10n :: L10n
-> Locale -> Locale
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> Int -> Int
-> T.Text
-> UserRechargePage -> 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 "Matebeamter" <>
" - " <> " - " <>
translate "Recharge account" translate "Recharge account"
@ -230,10 +257,10 @@ userRechargePage l10n locale mcookie uid =
H.! HA.min "0" H.! HA.min "0"
H.! HA.step "0.01" H.! HA.step "0.01"
H.! HA.value "0" 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.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Recharge" $ H.toHtml $ translate "Recharge"
where where
@ -244,10 +271,11 @@ userManagePage
-> Locale -> Locale
-> MT.UserDetails -> MT.UserDetails
-> [MT.AuthOverview] -> [MT.AuthOverview]
-> T.Text
-> Maybe T.Text -> Maybe T.Text
-> UserManagePage -> 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 "Matebeamter" <>
" - " <> " - " <>
translate "Manage user data" translate "Manage user data"
@ -282,13 +310,13 @@ userManagePage l10n locale userDetails authOverviews mcookie =
(MT.userDetailsEmail userDetails)) (MT.userDetailsEmail userDetails))
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
H.p $ do H.p $ do
H.toHtml $ translate "Authentication details" H.toHtml $ translate "Authentication details"
mapM_ mapM_
(\(MT.AuthOverview aoid comment method) -> H.form (\(MT.AuthOverview aoid _ comment method) -> H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> H.! HA.action ("/" <>
fromString (show $ linkURI $ fromString (show $ linkURI $
@ -311,7 +339,7 @@ userManagePage l10n locale userDetails authOverviews mcookie =
H.! HA.value (fromString $ show aoid) H.! HA.value (fromString $ show aoid)
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Delete" $ H.toHtml $ translate "Delete"
) )
@ -360,7 +388,7 @@ userManagePage l10n locale userDetails authOverviews mcookie =
H.toHtml $ translate "Primary password" H.toHtml $ translate "Primary password"
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where

7
static/css/bootstrap.min.css vendored Normal file

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

92
static/css/style.css Normal file
View file

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