Compare commits

..

No commits in common. "master" and "journal_check" have entirely different histories.

36 changed files with 942 additions and 1238 deletions

2
.gitignore vendored
View file

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

153
.plan.nix/mateamt.nix Normal file
View file

@ -0,0 +1,153 @@
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; }

135
.plan.nix/matebeamter.nix Normal file
View file

@ -0,0 +1,135 @@
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 .././.; }

23
default.nix Normal file
View file

@ -0,0 +1,23 @@
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; }

View file

@ -1,84 +0,0 @@
{
"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
}

View file

@ -1,51 +0,0 @@
{
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

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

342
pkgs.nix Normal file
View file

@ -0,0 +1,342 @@
{
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,20 +1,6 @@
{ pkgs ? import <nixpkgs> {}}:
{ pkgs ? import <nixpkgs> {} }:
let
# 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;
hsPkgs = import ./default.nix;
in
hpkgs.matebeamter.env
hsPkgs.matebeamter.components.all

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

@ -1,92 +0,0 @@
: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;
}