Compare commits

...

15 commits

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

2
.gitignore vendored
View file

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

View file

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

View file

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

View file

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

84
flake.lock Normal file
View file

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

51
flake.nix Normal file
View file

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

View file

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

342
pkgs.nix
View file

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

View file

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

View file

@ -11,7 +11,7 @@ module API where
import Servant.API import Servant.API
import Servant.Links import Servant.Links
-- import Servant.RawM import Servant.RawM
import Servant.HTML.Blaze import Servant.HTML.Blaze
import Data.Proxy import Data.Proxy
@ -27,7 +27,8 @@ import qualified "mateamt" Types as MT
import Types import Types
type UserAPI = type UserAPI =
Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage Header "Cookie" T.Text :> (
QueryParam "refine" MT.UserRefine :> Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] UserOverviewPage :> Get '[HTML] UserOverviewPage
:<|> "user" :> Capture "id" Int :> "buy" :<|> "user" :> Capture "id" Int :> "buy"
@ -96,6 +97,7 @@ type UserAPI =
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "auth" :> "logout" :<|> "auth" :> "logout"
:> Post '[HTML] UserOverviewPage :> Post '[HTML] UserOverviewPage
:<|> "static" :> RawM
) )
( userSelectLink :<|> ( userSelectLink :<|>
@ -122,5 +124,6 @@ type UserAPI =
productPostNewLink :<|> productPostNewLink :<|>
authLink :<|> authLink :<|>
authPostLink :<|> authPostLink :<|>
authLogoutLink authLogoutLink :<|>
staticLink
) = allLinks (Proxy :: Proxy UserAPI) ) = allLinks (Proxy :: Proxy UserAPI)

View file

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

View file

@ -117,9 +117,10 @@ authPostControl
-> Maybe T.Text -> Maybe T.Text
-> AuthReturn -> AuthReturn
-> UserHandler UserSelectPage -> UserHandler UserSelectPage
authPostControl (Just cookies) mDestination (AuthReturn pass method) = do authPostControl mcookies@(Just cookies) mDestination (AuthReturn pass method) = do
let mticket = lookup ("x-ticket-" <> fromString (show method)) $ let mticket = lookup ("x-ticket-" <> fromString (show method)) $
parseCookieText cookies parseCookieText cookies
(_, _, loc, l10n, _, _, _) <- controlInit mcookies
case mticket of case mticket of
Just ticket -> do Just ticket -> do
(ReadState _ backend _ _ _) <- ask (ReadState _ backend _ _ _) <- ask
@ -145,7 +146,7 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
(read $ T.unpack user) (read $ T.unpack user)
Nothing Nothing
) )
_ -> errHeaders $ redirect303 userSelectLink _ -> errHeaders $ redirect303 (userSelectLink Nothing)
throwError $ err303 throwError $ err303
{ errHeaders = headers ++ { errHeaders = headers ++
[ ( "Set-Cookie" [ ( "Set-Cookie"
@ -158,15 +159,18 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
, "x-method=" <> fromString (show $ fromEnum method) <>";Path=/") , "x-method=" <> fromString (show $ fromEnum method) <>";Path=/")
] ]
} }
Right MT.Denied -> throwError $ err401 Right MT.Denied -> throwError (
{ errBody = "Authentication failed!" addMessage (translate l10n loc "Authentication failed!") $
} redirect303 (userSelectLink Nothing)
)
Left err -> throwError $ err500 Left err -> throwError $ err500
{ errBody = fromString $ show err { errBody = fromString $ show err
} }
Nothing -> throwError $ err400 Nothing -> throwError $ err400
{ errBody = "No ticket cookie present." { errBody = "No ticket cookie present."
} }
where
translate l10n locale = localize l10n locale . gettext
authPostControl Nothing _ _ = throwError $ err400 authPostControl Nothing _ _ = throwError $ err400
{ errBody = "No ticket cookie present." { errBody = "No ticket cookie present."
} }
@ -184,7 +188,7 @@ authLogoutControl mcookie = do
backend backend
case eReturn of case eReturn of
Right _ -> do Right _ -> do
let redirectHeaders = errHeaders (redirect303 userSelectLink) let redirectHeaders = errHeaders (redirect303 $ userSelectLink Nothing)
unsetCookiesHeaders = map unsetCookiesHeaders = map
(\c -> (\c ->
( "Set-Cookie" ( "Set-Cookie"

View file

@ -42,14 +42,14 @@ buyControl
-> [MT.PurchaseDetail] -> [MT.PurchaseDetail]
-> Bool -> Bool
-> UserHandler BuyConfirmPage -> UserHandler BuyConfirmPage
buyControl mcookie uid pds forceBuy = buyControl mcookie uid pds forceBuy = do
(ReadState l10n backend _ symbol version) <- ask
let (token, _) = parseTokenAndUser mcookie
loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
if not (null pds) if not (null pds)
then do then do
(ReadState l10n backend _ symbol version) <- ask let pids = map MT.purchaseDetailProduct pds
let (token, _) = parseTokenAndUser mcookie
loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
pids = map MT.purchaseDetailProduct pds
epsovs <- liftIO $ runClientM epsovs <- liftIO $ runClientM
(productShortList (Just MT.AllProducts)) (productShortList (Just MT.AllProducts))
backend backend
@ -85,9 +85,14 @@ buyControl mcookie uid pds forceBuy =
Left err -> Left err ->
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
else else
throwError (redirect303 $ userOverviewLink uid Nothing) throwError (
addMessage (translate l10n loc "Please select items for purchase") $
redirect303 (userOverviewLink uid Nothing)
)
where
translate l10n locale = localize l10n locale . gettext
purchaseControl purchaseControl
:: Maybe T.Text :: Maybe T.Text
@ -179,7 +184,7 @@ purchaseControl mcookie uid pds forceBuy = do
backend backend
throwError throwError
$ addMessage message $ addMessage message
$ redirect303 userSelectLink $ redirect303 (userSelectLink Nothing)
translate l10n locale = localize l10n locale . gettext translate l10n locale = localize l10n locale . gettext
cashBuyOverviewControl cashBuyOverviewControl
@ -240,7 +245,7 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
addMessage addMessage
(translate l10n loc "Please Pay" <> (translate l10n loc "Please Pay" <>
": " <> formatMoney price <> symbol) $ ": " <> formatMoney price <> symbol) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
(MT.PurchaseResult (MT.PayAmount price) miss) -> do (MT.PurchaseResult (MT.PayAmount price) miss) -> do
eproducts <- liftIO $ runClientM eproducts <- liftIO $ runClientM
(productShortList (productShortList
@ -268,13 +273,13 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
[] []
prods prods
)) ))
$ redirect303 userSelectLink $ redirect303 (userSelectLink Nothing)
Left err -> Left err ->
throwError $ err500 throwError $ err500
{ errBody = fromString (show err) { errBody = fromString (show err)
} }
Left err -> Left err ->
handleClientErr err Nothing (Just userSelectLink) handleClientErr err Nothing (Just (userSelectLink Nothing))
else else
throwError throwError
$ addMessage (translate l10n loc "Please choose your product(s)") $ addMessage (translate l10n loc "Please choose your product(s)")

View file

@ -15,7 +15,7 @@ import Data.String
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (fromMaybe, maybe) import Data.Maybe (fromMaybe, maybe, fromJust)
import Network.HTTP.Types.Status (Status(..)) import Network.HTTP.Types.Status (Status(..))
@ -59,11 +59,11 @@ journalControl mcookie mpage = do
else else
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
othererr -> othererr ->
throwError $ throwError $
addMessage (fromString $ show othererr) $ addMessage (fromString $ show othererr) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
Nothing -> Nothing ->
redirectOverAuth Nothing (Just $ journalLink mpage) Nothing redirectOverAuth Nothing (Just $ journalLink mpage) Nothing
@ -85,7 +85,7 @@ journalPostCheckControl mcookie (CashCheck floatAmount) = do
eresult <- liftIO $ runClientM eresult <- liftIO $ runClientM
(journalPostCashCheck (journalPostCashCheck
(mkAuthenticatedRequest token authenticateReq) (mkAuthenticatedRequest token authenticateReq)
(MT.JournalCashCheck $ floor $ floatAmount * 100) (MT.JournalCashCheck (fromJust muser) $ floor $ floatAmount * 100)
) )
backend backend
case eresult of case eresult of
@ -93,7 +93,7 @@ journalPostCheckControl mcookie (CashCheck floatAmount) = do
addMessage (translate l10n loc "Cash check received and processed") $ addMessage (translate l10n loc "Cash check received and processed") $
redirect303 (journalLink Nothing) redirect303 (journalLink Nothing)
Left err -> Left err ->
handleClientErr err (read <$> muser) (Just journalGetCheckLink) handleClientErr err muser (Just journalGetCheckLink)
Nothing -> Nothing ->
redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing
where where

View file

@ -45,7 +45,7 @@ productGetPriceList mcookie mrefine = do
Left err -> Left err ->
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
productGetRefill productGetRefill
:: Maybe T.Text :: Maybe T.Text
@ -63,7 +63,7 @@ productGetRefill mcookie = do
Left err -> Left err ->
throwError $ throwError $
addMessage (fromString $ show err) $ addMessage (fromString $ show err) $
redirect303 userSelectLink redirect303 (userSelectLink Nothing)
Nothing -> Nothing ->
redirectOverAuth Nothing (Just productGetRefillLink) Nothing redirectOverAuth Nothing (Just productGetRefillLink) Nothing
@ -87,9 +87,9 @@ productPostRefill mcookie refills = do
addMessage (translate l10n loc "Refill successfull") $ addMessage (translate l10n loc "Refill successfull") $
redirect303 productGetRefillLink redirect303 productGetRefillLink
Left err -> Left err ->
handleClientErr err (read <$> muser) (Just productGetRefillLink) handleClientErr err muser (Just productGetRefillLink)
Nothing -> Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing redirectOverAuth muser (Just productGetRefillLink) Nothing
where where
translate l10n loc = localize l10n loc . gettext translate l10n loc = localize l10n loc . gettext
@ -103,7 +103,7 @@ productGetNew mcookie = do
-- TODO: Fetch avatars and suppliers -- TODO: Fetch avatars and suppliers
return $ productNewPage l10n loc version mcookie symbol return $ productNewPage l10n loc version mcookie symbol
Nothing -> Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing redirectOverAuth muser (Just productGetRefillLink) Nothing
productPostNew productPostNew
:: Maybe T.Text :: Maybe T.Text
@ -134,8 +134,8 @@ productPostNew mcookie (ProductSubmit ident flPrice ml max apc ppc artnr) = do
Right _ -> Right _ ->
throwError $ throwError $
addMessage (translate l10n loc "Product created successfully") $ addMessage (translate l10n loc "Product created successfully") $
redirect303 (userOverviewLink (read user) Nothing) redirect303 (userOverviewLink user Nothing)
Nothing -> Nothing ->
redirectOverAuth (read <$> muser) (Just productGetRefillLink) Nothing redirectOverAuth muser (Just productGetRefillLink) Nothing
where where
translate l10n loc = localize l10n loc . gettext translate l10n loc = localize l10n loc . gettext

View file

@ -36,13 +36,16 @@ import Hash
import API import API
import Util import Util
userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage userSelectControl
userSelectControl mcookie = do :: Maybe T.Text
(ReadState l10n backend _ symbol version) <- ask -> Maybe MT.UserRefine
-> UserHandler UserSelectPage
userSelectControl mcookie mrefine = do
(ReadState l10n backend _ _ version) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
euser <- liftIO $ runClientM euser <- liftIO $ runClientM
(userList Nothing) (userList mrefine)
backend backend
case euser of case euser of
Right uss -> Right uss ->
@ -52,24 +55,21 @@ userSelectControl mcookie = do
userNewControl :: Maybe T.Text -> UserHandler UserNewPage userNewControl :: Maybe T.Text -> UserHandler UserNewPage
userNewControl mcookie = do userNewControl mcookie = do
(ReadState l10n _ _ symbol version) <- ask (ReadState l10n _ _ _ version) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
return $ userNewPage l10n loc version mcookie return $ userNewPage l10n loc version mcookie
userNewPostControl userNewPostControl
:: Maybe T.Text :: Maybe T.Text
-> MT.UserSubmit -> MT.UserSubmit
-> UserHandler UserSelectPage -> UserHandler UserSelectPage
userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do userNewPostControl _ us = do
backend <- asks rsBackend backend <- asks rsBackend
hashedPass <- hashPassword pass
void $ liftIO $ runClientM void $ liftIO $ runClientM
(userNew $us (userNew us)
{ MT.userSubmitPassHash = hashedPass
})
backend backend
throwError $ redirect303 userSelectLink throwError $ redirect303 (userSelectLink Nothing)
userOverviewControl userOverviewControl
:: Maybe T.Text :: Maybe T.Text
@ -100,7 +100,7 @@ userOverviewControl mcookie uid mRefine = do
(Right ud, Right prods) -> (Right ud, Right prods) ->
case mMethod of case mMethod of
Just method -> Just method ->
if fmap read mAuthUser == Just uid if mAuthUser == Just uid
then then
return $ return $
userOverviewPage userOverviewPage
@ -118,7 +118,7 @@ userOverviewControl mcookie uid mRefine = do
(Just $ userOverviewLink uid mRefine) (Just $ userOverviewLink uid mRefine)
mRefine mRefine
Nothing -> Nothing ->
redirectOverAuth (read <$> mAuthUser) Nothing mRefine redirectOverAuth mAuthUser Nothing mRefine
(Left uerr, Right _) -> case uerr of (Left uerr, Right _) -> case uerr of
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401 if statusCode (responseStatusCode resp) == 401
@ -146,8 +146,7 @@ userRechargeControl
-> Int -> Int
-> UserHandler UserRechargePage -> UserHandler UserRechargePage
userRechargeControl mcookie uid = do userRechargeControl mcookie uid = do
l10n <- asks rsL10n (ReadState l10n _ _ symbol version) <- ask
(ReadState l10n backend _ symbol version) <- ask
let loc = localeFromCookie mcookie let loc = localeFromCookie mcookie
return $ userRechargePage l10n loc version mcookie uid symbol return $ userRechargePage l10n loc version mcookie uid symbol
@ -186,7 +185,7 @@ userManageControl
-> Int -> Int
-> UserHandler UserManagePage -> UserHandler UserManagePage
userManageControl mcookie uid = do userManageControl mcookie uid = do
(ReadState l10n backend _ symbol version) <- ask (ReadState l10n backend _ _ version) <- ask
let loc = localeFromCookie mcookie let loc = localeFromCookie mcookie
(token, mAuthUser) = parseTokenAndUser mcookie (token, mAuthUser) = parseTokenAndUser mcookie
eUserDetails <- liftIO $ eUserDetails <- liftIO $
@ -199,7 +198,7 @@ userManageControl mcookie uid = do
backend backend
case (eUserDetails, eAuthOverviews) of case (eUserDetails, eAuthOverviews) of
(Right userDetails, Right authOverviews) -> (Right userDetails, Right authOverviews) ->
if Just uid == fmap read mAuthUser if Just uid == mAuthUser
then then
return $ return $
userManagePage l10n loc userDetails authOverviews version mcookie userManagePage l10n loc userDetails authOverviews version mcookie
@ -224,7 +223,7 @@ userManageDetailsSubmitControl mcookie uid uds = do
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 (userManageLink uid) Right _ -> throwError $ redirect303 (userManageLink uid)
Left err -> Left err ->
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
userManageAuthCreateControl userManageAuthCreateControl
:: Maybe T.Text :: Maybe T.Text
@ -244,7 +243,7 @@ userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) =
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 $ userManageLink uid Right _ -> throwError $ redirect303 $ userManageLink uid
Left err -> Left err ->
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
userManageAuthDeleteControl userManageAuthDeleteControl
:: Maybe T.Text :: Maybe T.Text
@ -265,5 +264,6 @@ userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
then then
throwError (redirect303 $ userManageLink uid) throwError (redirect303 $ userManageLink uid)
else else
handleErrors (fmap read mAuthUser) Nothing [Just err] handleErrors mAuthUser Nothing [Just err]
_ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err] _ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
[Just err]

View file

@ -20,6 +20,8 @@ import Data.YAML
import Options.Applicative import Options.Applicative
import Network.Wai.Application.Static
-- imports from "mateamt" -- imports from "mateamt"
import qualified "mateamt" Types as MT import qualified "mateamt" Types as MT
@ -107,6 +109,7 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
:<|> authLogoutControl mcookie :<|> authLogoutControl mcookie
:<|> (\_ -> return $ staticApp (defaultFileServerSettings "static")) mcookie
) )
userApi :: Proxy UserAPI userApi :: Proxy UserAPI

View file

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

View file

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

View file

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

View file

@ -72,7 +72,7 @@ authPage l10n locale mDestination version mcookie = scaffold
H.! HA.value "" H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where

View file

@ -13,7 +13,7 @@ import Data.String (fromString)
import Data.Text.I18n import Data.Text.I18n
import Data.Maybe (isJust, fromJust, fromMaybe) import Data.Maybe (isJust, fromJust)
import Control.Monad (when) import Control.Monad (when)
@ -59,8 +59,8 @@ buyConfirmPage l10n locale uid ziptups total forceBuy version mcookie symbol =
H.! HA.enctype "application/x-www-form-urlencoded" H.! HA.enctype "application/x-www-form-urlencoded"
$ do $ do
mapM_ mapM_
(\( MT.PurchaseDetail pdid amount (\( MT.PurchaseDetail _ _
, MT.ProductShortOverview pid ident price _ _ mava) -> , MT.ProductShortOverview pid ident price amount _ mava) ->
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do
H.input H.input
H.! HA.id ("product-select-" <> fromString (show pid)) H.! HA.id ("product-select-" <> fromString (show pid))
@ -116,13 +116,14 @@ buyConfirmPage l10n locale uid ziptups total forceBuy version mcookie symbol =
H.toHtml symbol H.toHtml symbol
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ if forceBuy $ H.toHtml $ if forceBuy
then translate "Buy anyway" then translate "Buy anyway"
else translate "Buy" else translate "Buy"
when forceBuy $ when forceBuy $
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.formnovalidate "formnovalidate" H.! HA.formnovalidate "formnovalidate"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
@ -139,43 +140,44 @@ buyProductsForm
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> H.Html -> H.Html
buyProductsForm l10n locale prods = do buyProductsForm l10n locale prods = do
mapM_ (\(MT.ProductShortOverview pid ident price amount ml maid) -> H.div H.! HA.class_ "tile-list" $
H.div $ do mapM_ (\(MT.ProductShortOverview pid ident _ _ _ maid) ->
H.div H.div
H.! HA.class_ "form-group optional" H.! HA.class_ "tile"
H.!? H.!?
( isJust maid ( isJust maid
, productBgStyle (fromString $ show $ fromJust maid) , productBgStyle (fromString $ show $ fromJust maid)
) )
$ do $ do
H.label H.label
H.! HA.for ("product-select-" <> fromString (show pid)) $ H.! HA.for ("product-select-" <> fromString (show pid)) $
H.toHtml ident H.toHtml ident
H.input H.! HA.class_ "tile-content form-group optional"
H.! HA.id ("product-select-" <> fromString (show pid)) H.input
H.! HA.class_ "form-control product-select" H.! HA.id ("product-select-" <> fromString (show pid))
H.! HA.name ("productSelect-" <> fromString (show pid)) H.! HA.class_ "form-control product-select"
H.! HA.type_ "checkbox" H.! HA.class_ "tile-content form-group optional"
H.! HA.value "true" H.! HA.name ("productSelect-" <> fromString (show pid))
H.div H.! HA.type_ "checkbox"
H.! HA.class_ "form-group optional" -- H.! HA.value "true"
$ do H.div
H.label $ do
H.! HA.for ("product-amount-" <> fromString (show pid)) $ H.label
H.toHtml (translate "Amount") H.! HA.for ("product-amount-" <> fromString (show pid)) $
H.input H.toHtml (translate "Amount")
H.! HA.id ("product-amount-" <> fromString (show pid)) H.input
H.! HA.class_ "form-control product-amount" H.! HA.id ("product-amount-" <> fromString (show pid))
H.! HA.name ("productAmount-" <> fromString (show pid)) H.! HA.class_ "form-control product-amount"
H.! HA.type_ "number" H.! HA.name ("productAmount-" <> fromString (show pid))
H.! HA.min "0" H.! HA.type_ "number"
H.! HA.step "1" H.! HA.min "0"
H.! HA.value "1" H.! HA.step "1"
) H.! HA.value "1"
prods )
prods
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Proceed" $ H.toHtml $ translate "Proceed"
where where

View file

@ -51,13 +51,14 @@ journalPage l10n loc version mcookie mpage entries =
H.th (H.toHtml $ translate "Amount") H.th (H.toHtml $ translate "Amount")
H.th (H.toHtml $ translate "Total amount") H.th (H.toHtml $ translate "Total amount")
mapM_ mapM_
(\(MT.JournalEntry jid desc time amount total check) -> (\(MT.JournalEntry jid time user action amount total) ->
H.tr H.tr
H.!? (check, HA.class_ "checked") H.!? (action == MT.CashCheck, HA.class_ "checked")
$ do $ do
H.td (H.toHtml $ show jid) H.td (H.toHtml $ show jid)
H.td (H.toHtml $ show time) H.td (H.toHtml $ show time)
H.td (H.toHtml desc) H.td (H.toHtml $ fromMaybe "" (show <$> user))
H.td (H.toHtml $ show action)
H.td (H.toHtml $ formatMoney amount) H.td (H.toHtml $ formatMoney amount)
H.td (H.toHtml $ formatMoney total) H.td (H.toHtml $ formatMoney total)
) )
@ -80,6 +81,7 @@ journalPage l10n loc version mcookie mpage entries =
$ H.toHtml $ translate "Next Page" $ H.toHtml $ translate "Next Page"
H.form $ H.form $
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
@ -124,7 +126,7 @@ journalCheckPage l10n loc version mcookie =
H.! HA.value "0" H.! HA.value "0"
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where

View file

@ -81,7 +81,7 @@ productRefillPage l10n loc version mcookie prodList =
H.! HA.enctype "application/x-www-form-urlencoded" H.! HA.enctype "application/x-www-form-urlencoded"
$ do $ do
mapM_ mapM_
(\(MT.ProductShortOverview pid ident price amount ml maid) -> do (\(MT.ProductShortOverview pid ident _ _ _ maid) -> do
H.div H.div
H.! HA.class_ "form-group optional" H.! HA.class_ "form-group optional"
H.!? H.!?
@ -154,7 +154,7 @@ productRefillPage l10n loc version mcookie prodList =
prodList prodList
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where
@ -288,7 +288,7 @@ productNewPage l10n loc version mcookie symbol =
-} -}
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where

View file

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

View file

@ -39,18 +39,31 @@ userSelectPage l10n locale uss version mcookie =
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Home" translate "Home"
) $ do ) $ H.ul
H.a H.! HA.href ("/" <> fromString H.! HA.class_ "tile-list"
(show $ linkURI $ cashBuyLink Nothing) $ do
) $ H.li H.! HA.class_ "tile function" $ H.a
H.toHtml $ translate "Buy with cash" H.! HA.class_ "tile-content"
mapM_ (\(MT.UserSummary uid ident _) -> H.! HA.href ("/" <> fromString
H.a H.! HA.href ("/" <> fromString (show $ linkURI $ (show $ linkURI $ cashBuyLink Nothing)
userOverviewLink uid Nothing)) $ ) $
H.toHtml ident H.toHtml $ translate "Buy with cash"
) uss mapM_ (\(MT.UserSummary uid ident _) ->
H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $ H.li H.! HA.class_ "tile" $ H.a
H.toHtml $ translate "New user" H.! HA.class_ "tile-content"
H.! HA.href ("/" <> fromString (show $ linkURI $
userOverviewLink uid Nothing)) $
H.toHtml ident
) uss
H.li H.! HA.class_ "tile function" $ H.a
H.! HA.class_ "tile-content"
H.! HA.href ("/" <> fromString
(show $ linkURI $ userSelectLink (Just MT.OldUsers))) $
H.toHtml $ translate "Show inactive users"
H.li H.! HA.class_ "tile function" $ H.a
H.! HA.class_ "tile-content"
H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
H.toHtml $ translate "New user"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -83,7 +96,7 @@ userOverviewPage l10n locale method ud pos version mcookie symbol =
H.! HA.enctype "application/x-www-form-urlencoded" $ H.! HA.enctype "application/x-www-form-urlencoded" $
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Logout" $ H.toHtml $ translate "Logout"
case method of case method of
@ -99,6 +112,7 @@ userOverviewPage l10n locale method ud pos version mcookie symbol =
buyForm = do buyForm = do
H.div $ H.form $ H.div $ H.form $
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction ("/" <> H.! HA.formaction ("/" <>
@ -121,18 +135,21 @@ userSettingsPointer
userSettingsPointer l10n locale uid = userSettingsPointer l10n locale uid =
H.form $ do H.form $ do
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
("/" <> fromString (show $ linkURI $ userManageLink uid)) ("/" <> fromString (show $ linkURI $ userManageLink uid))
$ H.toHtml $ translate "Manage user settings" $ H.toHtml $ translate "Manage user settings"
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
("/" <> fromString (show $ linkURI $ journalLink Nothing)) ("/" <> fromString (show $ linkURI $ journalLink Nothing))
$ H.toHtml $ translate "View Journal" $ H.toHtml $ translate "View Journal"
H.button H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
H.! HA.formmethod "get" H.! HA.formmethod "get"
H.! HA.formaction H.! HA.formaction
@ -146,15 +163,19 @@ productList
-> H.Html -> H.Html
productList pos = productList pos =
H.p $ H.p $
H.ul H.! HA.class_ "product_list" $ H.ul H.! HA.class_ "tile-list" $
mapM_ mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> (\(MT.ProductShortOverview pid ident _ _ _ avatarid) ->
H.li H.! HA.class_ "product" H.!? H.li
(isJust avatarid H.! HA.class_ "tile"
, productBgStyle (fromString $ show $ fromJust avatarid) H.!?
) $ (isJust avatarid
H.a H.! HA.href ("#" <> fromString (show pid)) $ , productBgStyle (fromString $ show $ fromJust avatarid)
H.toHtml ident ) $
H.a
H.! HA.class_ "tile-content"
H.! HA.href ("#" <> fromString (show pid)) $
H.toHtml ident
) )
pos pos
@ -202,7 +223,7 @@ userNewPage l10n locale version mcookie =
H.! HA.value "" H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where
@ -239,7 +260,7 @@ userRechargePage l10n locale version mcookie uid symbol =
H.toHtml symbol H.toHtml symbol
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Recharge" $ H.toHtml $ translate "Recharge"
where where
@ -289,13 +310,13 @@ userManagePage l10n locale userDetails authOverviews version mcookie =
(MT.userDetailsEmail userDetails)) (MT.userDetailsEmail userDetails))
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
H.p $ do H.p $ do
H.toHtml $ translate "Authentication details" H.toHtml $ translate "Authentication details"
mapM_ mapM_
(\(MT.AuthOverview aoid comment method) -> H.form (\(MT.AuthOverview aoid _ comment method) -> H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> H.! HA.action ("/" <>
fromString (show $ linkURI $ fromString (show $ linkURI $
@ -318,7 +339,7 @@ userManagePage l10n locale userDetails authOverviews version mcookie =
H.! HA.value (fromString $ show aoid) H.! HA.value (fromString $ show aoid)
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Delete" $ H.toHtml $ translate "Delete"
) )
@ -367,7 +388,7 @@ userManagePage l10n locale userDetails authOverviews version mcookie =
H.toHtml $ translate "Primary password" H.toHtml $ translate "Primary password"
H.div H.! HA.class_ "form-group optional" $ H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit" $ H.toHtml $ translate "Submit"
where where

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

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

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

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