Compare commits
No commits in common. "master" and "auth2" have entirely different histories.
3
.gitignore
vendored
3
.gitignore
vendored
|
@ -7,6 +7,3 @@ dist/
|
|||
*.prof
|
||||
.ghc*
|
||||
cabal.project.*
|
||||
*.bak*
|
||||
.direnv/
|
||||
.envrc
|
||||
|
|
|
@ -1,6 +0,0 @@
|
|||
api_host: "localhost"
|
||||
api_port: 8000
|
||||
#api_uri: ""
|
||||
#api_secure: false
|
||||
listen_port: 3000
|
||||
locales_location: "./locales"
|
84
flake.lock
84
flake.lock
|
@ -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
|
||||
}
|
51
flake.nix
51
flake.nix
|
@ -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
|
||||
];
|
||||
};
|
||||
});
|
||||
}
|
||||
|
|
@ -28,27 +28,16 @@ executable matebeamter
|
|||
, Types.Page
|
||||
, Types.Reader
|
||||
, Types.Views
|
||||
, Types.User
|
||||
, Types.Journal
|
||||
, Types.Product
|
||||
, Types.Orphans
|
||||
, Types.Configuration
|
||||
, Control
|
||||
, Control.Auth
|
||||
, 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 +53,6 @@ executable matebeamter
|
|||
, hashable
|
||||
, warp
|
||||
, wai
|
||||
, wai-app-static
|
||||
, wai-logger
|
||||
, wai-session
|
||||
, http-client
|
||||
|
@ -79,9 +67,8 @@ executable matebeamter
|
|||
, base64-bytestring
|
||||
, cryptonite
|
||||
, stm
|
||||
, either
|
||||
, optparse-applicative
|
||||
, HsYAML ^>=0.2.1.0
|
||||
, stm-containers
|
||||
, vault
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
|
20
shell.nix
20
shell.nix
|
@ -1,20 +0,0 @@
|
|||
{ 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;
|
||||
in
|
||||
hpkgs.matebeamter.env
|
89
src/API.hs
89
src/API.hs
|
@ -1,8 +1,10 @@
|
|||
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
@ -27,103 +29,28 @@ import qualified "mateamt" Types as MT
|
|||
import Types
|
||||
|
||||
type UserAPI =
|
||||
Header "Cookie" T.Text :> (
|
||||
QueryParam "refine" MT.UserRefine :> Get '[HTML] UserSelectPage
|
||||
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
|
||||
Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
|
||||
:<|> "user" :> Capture "id" Int
|
||||
:> Get '[HTML] UserOverviewPage
|
||||
:<|> "user" :> Capture "id" Int :> "buy"
|
||||
:> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
|
||||
:> QueryFlag "force"
|
||||
:> Post '[HTML] BuyConfirmPage
|
||||
:<|> "user" :> Capture "id" Int :> "purchasecomplete"
|
||||
:> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
|
||||
:> QueryFlag "force"
|
||||
:> Post '[HTML] UserSelectPage
|
||||
:<|> "user" :> Capture "id" Int :> "recharge"
|
||||
:> Get '[HTML] UserRechargePage
|
||||
:<|> "user" :> Capture "id" Int :> "recharge"
|
||||
:> ReqBody '[FormUrlEncoded] UserRecharge
|
||||
:> Post '[HTML] UserOverviewPage
|
||||
:<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage
|
||||
:<|> "user" :> Capture "id" Int :> "manage"
|
||||
:> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
|
||||
:> Post '[HTML] UserManagePage
|
||||
:<|> "user" :> Capture "id" Int :> "manage" :> "authcreate"
|
||||
:> ReqBody '[FormUrlEncoded] AuthSubmitReturn
|
||||
:> Post '[HTML] UserManagePage
|
||||
:<|> "user" :> Capture "id" Int :> "manage" :> "authdelete"
|
||||
:> ReqBody '[FormUrlEncoded] AuthDetailId
|
||||
:> Post '[HTML] UserManagePage
|
||||
:<|> "user" :> "create" :> Get '[HTML] UserNewPage
|
||||
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
|
||||
:> Post '[HTML] UserSelectPage
|
||||
:<|> "buy"
|
||||
:> QueryParam "refine" MT.ProductRefine
|
||||
:> Get '[HTML] CashBuyOverviewPage
|
||||
:<|> "buy"
|
||||
-- :> QueryFlag "force"
|
||||
:> ReqBody '[FormUrlEncoded] [MT.PurchaseDetail]
|
||||
:> Post '[HTML] CashBuyConfirmPage
|
||||
:<|> "journal" :> QueryParam "page" Word
|
||||
:> Get '[HTML] JournalPage
|
||||
:<|> "journal" :> "check"
|
||||
:> Get '[HTML] JournalCheckPage
|
||||
:<|> "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]
|
||||
(Headers
|
||||
'[ Header "Set-Cookie" T.Text
|
||||
, Header "Set-Cookie" T.Text
|
||||
, Header "Set-Cookie" T.Text
|
||||
]
|
||||
AuthPage)
|
||||
:<|> "auth" :> QueryParam "destination" T.Text
|
||||
:> ReqBody '[FormUrlEncoded] AuthReturn
|
||||
:<|> "auth" :> ReqBody '[FormUrlEncoded] AuthReturn
|
||||
:> Post '[HTML] UserSelectPage
|
||||
:<|> "auth" :> "logout"
|
||||
:> Post '[HTML] UserOverviewPage
|
||||
:<|> "static" :> RawM
|
||||
)
|
||||
|
||||
( userSelectLink :<|>
|
||||
userOverviewLink :<|>
|
||||
buyLink :<|>
|
||||
purchaseCompleteLink :<|>
|
||||
userRechargeLink :<|>
|
||||
userPostRechargeLink :<|>
|
||||
userManageLink :<|>
|
||||
userManageDetailsSubmitLink :<|>
|
||||
userManageAuthCreateLink :<|>
|
||||
userManageAuthDeleteLink :<|>
|
||||
userNewLink :<|>
|
||||
userNewPostLink :<|>
|
||||
cashBuyLink :<|>
|
||||
cashBuyPostLink :<|>
|
||||
journalLink :<|>
|
||||
journalGetCheckLink :<|>
|
||||
journalPostCheckLink :<|>
|
||||
productGetPriceListLink :<|>
|
||||
productGetRefillLink :<|>
|
||||
productPostRefillLink :<|>
|
||||
productGetNewLink :<|>
|
||||
productPostNewLink :<|>
|
||||
authLink :<|>
|
||||
authPostLink :<|>
|
||||
authLogoutLink :<|>
|
||||
staticLink
|
||||
authPostLink
|
||||
) = allLinks (Proxy :: Proxy UserAPI)
|
||||
|
|
111
src/Client.hs
111
src/Client.hs
|
@ -1,103 +1,35 @@
|
|||
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
module Client where
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core.Auth
|
||||
import Servant.Client.Core.Request
|
||||
|
||||
import Network.HTTP.Client hiding (Proxy)
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
-- imports from mateamt
|
||||
|
||||
import qualified "mateamt" API as MA
|
||||
import qualified "mateamt" Types as MT
|
||||
import qualified "mateamt" API as MT
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
-- internal imports
|
||||
|
||||
mateApi :: Proxy MA.MateAPI
|
||||
import Types
|
||||
|
||||
mateApi :: Proxy MT.MateAPI
|
||||
mateApi = Proxy
|
||||
|
||||
authGet :: MT.TicketRequest -> ClientM MT.AuthInfo
|
||||
authSend :: MT.AuthRequest -> ClientM MT.AuthResult
|
||||
authLogout :: AuthenticatedRequest (AuthProtect "header-auth") -> ClientM ()
|
||||
authManageList
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> ClientM [MT.AuthOverview]
|
||||
authManageNewAuth
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> MT.AuthSubmit
|
||||
-> ClientM Int
|
||||
authManageDeleteAuth
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> Int
|
||||
-> ClientM ()
|
||||
userNew :: MT.UserSubmit -> ClientM Int
|
||||
userGet
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> ClientM MT.UserDetails
|
||||
userUpdate
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> MT.UserDetailsSubmit
|
||||
-> ClientM ()
|
||||
userList :: Maybe MT.UserRefine -> ClientM [MT.UserSummary]
|
||||
userRecharge
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> MT.UserRecharge
|
||||
-> ClientM ()
|
||||
userTransfer
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> MT.UserTransfer
|
||||
-> ClientM ()
|
||||
productNew
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> MT.ProductSubmit
|
||||
-> ClientM Int
|
||||
productOverview :: Int -> ClientM MT.ProductOverview
|
||||
productStockRefill
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> [MT.AmountRefill]
|
||||
-> ClientM ()
|
||||
productStockUpdate
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> [MT.AmountUpdate]
|
||||
-> ClientM ()
|
||||
productList :: Maybe MT.ProductRefine -> ClientM [MT.ProductOverview]
|
||||
productShortList :: Maybe MT.ProductRefine -> ClientM [MT.ProductShortOverview]
|
||||
buy
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> [MT.PurchaseDetail]
|
||||
-> ClientM MT.PurchaseResult
|
||||
journalShow
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> ClientM [MT.JournalEntry]
|
||||
avatarGet
|
||||
:: Int
|
||||
-> (Servant.Client.Core.Request.Request
|
||||
-> Servant.Client.Core.Request.Request)
|
||||
-> ClientM Response
|
||||
avatarInsert
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> MT.AvatarData
|
||||
-> ClientM Int
|
||||
avatarUpdate
|
||||
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||
-> Int
|
||||
-> MT.AvatarData
|
||||
-> ClientM ()
|
||||
avatarList :: ClientM [MT.Avatar]
|
||||
|
||||
metaGet :: ClientM MT.MetaInformation
|
||||
|
||||
( authGet :<|>
|
||||
authSend :<|>
|
||||
authLogout :<|>
|
||||
|
@ -123,14 +55,11 @@ metaGet :: ClientM MT.MetaInformation
|
|||
buy :<|>
|
||||
|
||||
journalShow :<|>
|
||||
journalPostCashCheck :<|>
|
||||
|
||||
avatarGet :<|>
|
||||
avatarInsert :<|>
|
||||
avatarUpdate :<|>
|
||||
avatarList :<|>
|
||||
|
||||
metaGet
|
||||
avatarList
|
||||
) = client mateApi
|
||||
|
||||
getClients clientEnv = hoistClient
|
||||
|
|
|
@ -6,10 +6,7 @@ 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"
|
||||
|
||||
nonAuthenticateRequest :: String -> Request -> Request
|
||||
nonAuthenticateRequest _ = id
|
||||
authenticateReq s req = addHeader "Authentication" s req
|
||||
|
|
|
@ -4,6 +4,3 @@ module Control
|
|||
|
||||
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
|
||||
|
|
|
@ -7,7 +7,6 @@ module Control.Auth where
|
|||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core.Auth (mkAuthenticatedRequest)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
@ -18,6 +17,7 @@ import Data.String (fromString)
|
|||
import Data.Maybe (fromMaybe)
|
||||
import Data.Either (isRight, rights, lefts)
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
|
@ -31,40 +31,23 @@ import Types
|
|||
import View
|
||||
import Util
|
||||
import Client
|
||||
import ClientAuth
|
||||
import API
|
||||
import Hash
|
||||
|
||||
authControl
|
||||
:: Maybe T.Text
|
||||
-> Maybe T.Text
|
||||
-> UserHandler
|
||||
(Headers
|
||||
'[ Header "Set-Cookie" T.Text
|
||||
, Header "Set-Cookie" T.Text
|
||||
, Header "Set-Cookie" T.Text
|
||||
]
|
||||
AuthPage)
|
||||
authControl mcookie mDestination = do
|
||||
let mParsedCookie = fmap parseCookieText mcookie
|
||||
mAuthUser = lookup "x-auth-user" =<< mParsedCookie
|
||||
mToken = lookup "x-token" =<< mParsedCookie
|
||||
case (mAuthUser, mToken) of
|
||||
(Just authUser, Just _) ->
|
||||
throwError $ case mDestination of
|
||||
Just destination ->
|
||||
err303
|
||||
{ errHeaders =
|
||||
[ ("Location", fromString (T.unpack destination))
|
||||
]
|
||||
}
|
||||
Nothing ->
|
||||
redirect303
|
||||
(userOverviewLink
|
||||
(read $ T.unpack authUser)
|
||||
Nothing
|
||||
)
|
||||
(Just authUser, Nothing) -> do
|
||||
(ReadState _ backend _ _ _) <- ask
|
||||
authControl mcookie@(Just cookie) = do
|
||||
let mauthUser = lookup "x-auth-user" (parseCookieText cookie)
|
||||
case mauthUser of
|
||||
Just authUser -> do
|
||||
(ReadState _ backend _) <- ask
|
||||
let trs = map
|
||||
(MT.TicketRequest
|
||||
(read (T.unpack authUser) :: Int))
|
||||
|
@ -74,7 +57,7 @@ authControl mcookie mDestination = do
|
|||
, MT.SecondaryPass
|
||||
]
|
||||
eAuthInfos <- zip passes <$>
|
||||
liftIO (mapM
|
||||
(liftIO $ mapM
|
||||
(\req -> runClientM
|
||||
(authGet req)
|
||||
backend
|
||||
|
@ -85,45 +68,52 @@ authControl mcookie mDestination = do
|
|||
then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $
|
||||
unzip eAuthInfos)
|
||||
else throwError $ err400
|
||||
{ errBody = fromString $ show $ lefts $ map snd eAuthInfos
|
||||
{ errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos
|
||||
}
|
||||
(Nothing, _) ->
|
||||
error "Error handling not yet implemented properly."
|
||||
Nothing ->
|
||||
error $ "Error handling not yet implemented properly, but here's your user: "
|
||||
<> (fromString $ T.unpack $ fromMaybe "" $
|
||||
lookup "x-auth-user" (parseCookieText cookie)
|
||||
)
|
||||
where
|
||||
digestAuthInfo
|
||||
:: [(MT.AuthMethod, MT.AuthInfo)]
|
||||
-> UserHandler
|
||||
(Headers
|
||||
'[ Header "Set-Cookie" T.Text
|
||||
, Header "Set-Cookie" T.Text
|
||||
, Header "Set-Cookie" T.Text
|
||||
]
|
||||
AuthPage)
|
||||
digestAuthInfo tupAuthInfos = do
|
||||
(ReadState l10n _ _ _ version) <- ask
|
||||
(ReadState l10n _ _) <- ask
|
||||
let loc = Locale
|
||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
||||
ticketHeaders = map
|
||||
(\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) ->
|
||||
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
|
||||
fromString (T.unpack ticket) <> ";Path=/")
|
||||
(fromString $ T.unpack ticket) <> ";Path=/")
|
||||
tupAuthInfos
|
||||
return $
|
||||
addHeader (head ticketHeaders) $
|
||||
addHeader (ticketHeaders !! 1) $
|
||||
authPage l10n loc mDestination version mcookie
|
||||
return $ addHeader
|
||||
"x-auth-user=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" $
|
||||
addHeader (ticketHeaders !! 0) $
|
||||
addHeader (ticketHeaders !! 1) $
|
||||
authPage l10n loc
|
||||
authControl Nothing =
|
||||
throwError $ err400
|
||||
{ errBody = "No cookie present."
|
||||
}
|
||||
|
||||
authPostControl
|
||||
:: Maybe T.Text
|
||||
-> Maybe T.Text
|
||||
-> AuthReturn
|
||||
-> UserHandler UserSelectPage
|
||||
authPostControl mcookies@(Just cookies) mDestination (AuthReturn pass method) = do
|
||||
authPostControl (Just cookies) (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
|
||||
|
@ -135,69 +125,23 @@ authPostControl mcookies@(Just cookies) mDestination (AuthReturn pass method) =
|
|||
backend
|
||||
case etoken of
|
||||
Right (MT.Granted (MT.AuthToken token)) -> do
|
||||
let mUser = lookup "x-auth-user" $ parseCookieText cookies
|
||||
headers = case (mDestination, mUser) of
|
||||
(Just destination, _) ->
|
||||
[ ("Location", fromString (T.unpack destination))
|
||||
]
|
||||
(Nothing, Just user) -> errHeaders $
|
||||
redirect303
|
||||
(userOverviewLink
|
||||
(read $ T.unpack user)
|
||||
Nothing
|
||||
)
|
||||
_ -> errHeaders $ redirect303 (userSelectLink Nothing)
|
||||
let headers = errHeaders $ redirect303 userSelectLink -- FIXME: redirect to product select
|
||||
throwError $ err303
|
||||
{ errHeaders = headers ++
|
||||
[ ( "Set-Cookie"
|
||||
, "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
|
||||
, ( "Set-Cookie"
|
||||
, "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
|
||||
, ( "Set-Cookie"
|
||||
, "x-token=" <> fromString (T.unpack token) <>";Path=/")
|
||||
, ( "Set-Cookie"
|
||||
, "x-method=" <> fromString (show $ fromEnum method) <>";Path=/")
|
||||
[ ("Set-Cookie", "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
|
||||
, ("Set-Cookie", "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
|
||||
, ("Set-Cookie", "x-token=" <> fromString (T.unpack token) <>";Path=/")
|
||||
]
|
||||
}
|
||||
Right MT.Denied -> throwError (
|
||||
addMessage (translate l10n loc "Authentication failed!") $
|
||||
redirect303 (userSelectLink Nothing)
|
||||
)
|
||||
Right MT.Denied -> throwError $ err401
|
||||
{ errBody = "Authentication failed! " <> fromString (T.unpack hashedPass)
|
||||
}
|
||||
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
|
||||
authPostControl Nothing _ = throwError $ err400
|
||||
{ errBody = "No ticket cookie present."
|
||||
}
|
||||
|
||||
authLogoutControl
|
||||
:: Maybe T.Text
|
||||
-> UserHandler UserOverviewPage
|
||||
authLogoutControl mcookie = do
|
||||
(ReadState _ backend _ _ _) <- ask
|
||||
let mParsedCookie = fmap parseCookieText mcookie
|
||||
token = T.unpack $ fromMaybe "secret"
|
||||
(lookup "x-token" =<< mParsedCookie)
|
||||
eReturn <- liftIO $ runClientM
|
||||
(authLogout (mkAuthenticatedRequest token authenticateReq))
|
||||
backend
|
||||
case eReturn of
|
||||
Right _ -> do
|
||||
let redirectHeaders = errHeaders (redirect303 $ userSelectLink Nothing)
|
||||
unsetCookiesHeaders = map
|
||||
(\c ->
|
||||
( "Set-Cookie"
|
||||
, c <> "=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
|
||||
)
|
||||
["x-auth-user", "x-method", "x-token"]
|
||||
throwError $ err303
|
||||
{ errHeaders = redirectHeaders ++ unsetCookiesHeaders
|
||||
}
|
||||
Left err -> throwError $ err500
|
||||
{ errBody = fromString (show err)
|
||||
}
|
||||
|
|
|
@ -1,288 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Control.Buy where
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core.Auth (mkAuthenticatedRequest)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
import Data.Maybe (fromMaybe, fromJust, isJust)
|
||||
|
||||
import Data.List (sortOn)
|
||||
|
||||
import Control.Monad (void, when)
|
||||
import Control.Monad.Reader (ask, asks)
|
||||
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
|
||||
|
||||
buyControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> [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)
|
||||
if not (null pds)
|
||||
then do
|
||||
let pids = map MT.purchaseDetailProduct pds
|
||||
epsovs <- liftIO $ runClientM
|
||||
(productShortList (Just MT.AllProducts))
|
||||
backend
|
||||
case epsovs of
|
||||
Right psovs -> do
|
||||
let currentPsovs = filter
|
||||
((`elem` pids) . MT.productShortOverviewId)
|
||||
psovs
|
||||
ziptup = sortOn (MT.productShortOverviewIdent . snd) (zip
|
||||
(sortOn MT.purchaseDetailProduct pds)
|
||||
(sortOn MT.productShortOverviewId currentPsovs)
|
||||
)
|
||||
total = foldl
|
||||
(\acc
|
||||
( MT.PurchaseDetail _ amount
|
||||
, MT.ProductShortOverview _ _ 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)
|
||||
else
|
||||
throwError (
|
||||
addMessage (translate l10n loc "Please select items for purchase") $
|
||||
redirect303 (userOverviewLink uid Nothing)
|
||||
)
|
||||
where
|
||||
translate l10n locale = localize l10n locale . gettext
|
||||
|
||||
purchaseControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> [MT.PurchaseDetail]
|
||||
-> Bool
|
||||
-> UserHandler UserSelectPage
|
||||
purchaseControl mcookie uid pds forceBuy = do
|
||||
l10n <- asks rsL10n
|
||||
let loc = Locale
|
||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
||||
if not (null pds)
|
||||
then do
|
||||
backend <- asks rsBackend
|
||||
let (token, _) = parseTokenAndUser mcookie
|
||||
erefres <- if forceBuy
|
||||
then do
|
||||
let refills = map
|
||||
(\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount 0)
|
||||
pds
|
||||
liftIO $ runClientM
|
||||
(productStockRefill
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
refills
|
||||
)
|
||||
backend
|
||||
else
|
||||
return $ Right ()
|
||||
case erefres of
|
||||
Right _ ->
|
||||
return ()
|
||||
Left err ->
|
||||
throwError
|
||||
$ addMessage (fromString $ show err)
|
||||
$ redirect303 (userOverviewLink uid Nothing)
|
||||
eresult <- liftIO $ runClientM
|
||||
(buy
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
pds
|
||||
)
|
||||
backend
|
||||
case eresult of
|
||||
Right result -> case result of
|
||||
(MT.PurchaseResult MT.PurchaseOK []) ->
|
||||
logoutAndRedirectHome
|
||||
(translate l10n loc "Purchase successful")
|
||||
backend
|
||||
token
|
||||
(MT.PurchaseResult MT.PurchaseDebtful []) ->
|
||||
logoutAndRedirectHome
|
||||
(translate l10n loc "Purchase successful")
|
||||
backend
|
||||
token
|
||||
(MT.PurchaseResult (MT.PayAmount _) _) ->
|
||||
throwError $ err500
|
||||
{ errBody = "You can't buy with cash while logged in"
|
||||
}
|
||||
-- (MT.PurchaseResult (MT.PayAmount price) []) ->
|
||||
-- logoutAndRedirectHome
|
||||
-- (translate l10n loc "Please Pay" <> ": " <> formatMoney price)
|
||||
-- backend
|
||||
-- token
|
||||
-- (MT.PurchaseResult (MT.PayAmount price) miss) ->
|
||||
-- throwError
|
||||
-- $ addMessage (translate l10n loc "Please Pay" <> ": "
|
||||
-- <> formatMoney price
|
||||
-- <> "\n"
|
||||
-- <> translate l10n loc ("But there seems to be something missing:")
|
||||
-- )
|
||||
-- $ redirect307 (buyLink uid True)
|
||||
(MT.PurchaseResult _ miss) ->
|
||||
throwError
|
||||
$ addMessage (translate l10n loc "Purchase partly successful.")
|
||||
$ redirect307 (buyLink uid True)
|
||||
Left err ->
|
||||
throwError
|
||||
$ addMessage (fromString (show err))
|
||||
$ redirect303 (userOverviewLink uid Nothing)
|
||||
else
|
||||
throwError
|
||||
$ addMessage (translate l10n loc "Please choose your product(s)")
|
||||
(redirect303 $ userOverviewLink uid Nothing)
|
||||
where
|
||||
logoutAndRedirectHome message backend token = do
|
||||
void $ liftIO $ runClientM
|
||||
(authLogout
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
)
|
||||
backend
|
||||
throwError
|
||||
$ addMessage message
|
||||
$ redirect303 (userSelectLink Nothing)
|
||||
translate l10n locale = localize l10n locale . gettext
|
||||
|
||||
cashBuyOverviewControl
|
||||
:: Maybe T.Text
|
||||
-> Maybe MT.ProductRefine
|
||||
-> UserHandler CashBuyOverviewPage
|
||||
cashBuyOverviewControl mcookie mrefine = do
|
||||
(ReadState l10n backend _ symbol version) <- ask
|
||||
let loc = localeFromCookie mcookie
|
||||
eproducts <- liftIO $ runClientM
|
||||
(productShortList
|
||||
mrefine
|
||||
)
|
||||
backend
|
||||
case eproducts of
|
||||
Right prods ->
|
||||
return $ cashBuyOverviewPage l10n loc version mcookie prods
|
||||
Left err ->
|
||||
throwError $ err500
|
||||
{ errBody = fromString (show err)
|
||||
}
|
||||
|
||||
cashBuyPurchaseControl
|
||||
:: Maybe T.Text
|
||||
-- -> Bool
|
||||
-> [MT.PurchaseDetail]
|
||||
-> UserHandler UserSelectPage
|
||||
cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
|
||||
l10n <- asks rsL10n
|
||||
symbol <- asks rsCurrencySymbol
|
||||
let loc = localeFromCookie mcookie
|
||||
if not (null pds)
|
||||
then do
|
||||
backend <- asks rsBackend
|
||||
-- erefres <- if forceBuy
|
||||
-- then do
|
||||
-- let refills = map
|
||||
-- (\(MT.PurchaseDetail pid amount) -> MT.AmountRefill pid amount)
|
||||
-- pds
|
||||
-- liftIO $ runClientM
|
||||
-- (productStockRefill
|
||||
-- (mkAuthenticatedRequest token authenticateReq)
|
||||
-- refills
|
||||
-- )
|
||||
-- backend
|
||||
-- else
|
||||
-- return $ Right ()
|
||||
eresult <- liftIO $ runClientM
|
||||
(buy
|
||||
(mkAuthenticatedRequest "secret" nonAuthenticateRequest)
|
||||
pds
|
||||
)
|
||||
backend
|
||||
case eresult of
|
||||
Right result -> case result of
|
||||
(MT.PurchaseResult (MT.PayAmount price) []) ->
|
||||
throwError $
|
||||
addMessage
|
||||
(translate l10n loc "Please Pay" <>
|
||||
": " <> formatMoney price <> symbol) $
|
||||
redirect303 (userSelectLink Nothing)
|
||||
(MT.PurchaseResult (MT.PayAmount price) miss) -> do
|
||||
eproducts <- liftIO $ runClientM
|
||||
(productShortList
|
||||
(Just MT.AllProducts)
|
||||
)
|
||||
backend
|
||||
let missIds = map (\(MT.PurchaseDetail pid amount) -> (pid, amount)) miss
|
||||
case eproducts of
|
||||
Right prods ->
|
||||
throwError
|
||||
$ addMessage (translate l10n loc "Please Pay" <> ": "
|
||||
<> formatMoney price <> symbol
|
||||
<> ". "
|
||||
<> translate l10n loc
|
||||
"But there seems to be something missing: "
|
||||
<> mconcat (reverse $ foldl
|
||||
(\acc (MT.ProductShortOverview psoid ident _ _ _ _) ->
|
||||
if psoid `elem` map fst missIds
|
||||
then
|
||||
(fromString (show $ fromJust $ lookup psoid missIds)
|
||||
<> " x "
|
||||
<> fromString (T.unpack ident)) : acc
|
||||
else acc
|
||||
)
|
||||
[]
|
||||
prods
|
||||
))
|
||||
$ redirect303 (userSelectLink Nothing)
|
||||
Left err ->
|
||||
throwError $ err500
|
||||
{ errBody = fromString (show err)
|
||||
}
|
||||
Left err ->
|
||||
handleClientErr err Nothing (Just (userSelectLink Nothing))
|
||||
else
|
||||
throwError
|
||||
$ addMessage (translate l10n loc "Please choose your product(s)")
|
||||
(redirect303 $ cashBuyLink Nothing)
|
||||
where
|
||||
translate l10n locale = localize l10n locale . gettext
|
|
@ -1,100 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Control.Journal where
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core.Auth (mkAuthenticatedRequest)
|
||||
|
||||
import Control.Monad.Reader (asks)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import Data.String
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.Maybe (fromMaybe, maybe, fromJust)
|
||||
|
||||
import Network.HTTP.Types.Status (Status(..))
|
||||
|
||||
-- imports from "Mateamt"
|
||||
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
import View
|
||||
import Util
|
||||
import Client
|
||||
import ClientAuth
|
||||
import API
|
||||
|
||||
journalControl
|
||||
:: Maybe T.Text
|
||||
-> Maybe Word
|
||||
-> UserHandler JournalPage
|
||||
journalControl mcookie mpage = do
|
||||
(token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
|
||||
case muser of
|
||||
Just user -> do
|
||||
eresult <- liftIO $ runClientM
|
||||
(journalShow
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
(Just 50)
|
||||
(Just $ 50 * maybe 0 fromIntegral mpage)
|
||||
)
|
||||
backend
|
||||
case eresult of
|
||||
Right entries ->
|
||||
return (journalPage l10n loc version mcookie mpage entries)
|
||||
Left err ->
|
||||
case err of
|
||||
FailureResponse _ resp ->
|
||||
if statusCode (responseStatusCode resp) == 401
|
||||
then
|
||||
redirectOverAuth Nothing (Just $ journalLink mpage) Nothing
|
||||
else
|
||||
throwError $
|
||||
addMessage (fromString $ show err) $
|
||||
redirect303 (userSelectLink Nothing)
|
||||
othererr ->
|
||||
throwError $
|
||||
addMessage (fromString $ show othererr) $
|
||||
redirect303 (userSelectLink Nothing)
|
||||
Nothing ->
|
||||
redirectOverAuth Nothing (Just $ journalLink mpage) Nothing
|
||||
|
||||
journalGetCheckControl
|
||||
:: Maybe T.Text
|
||||
-> UserHandler JournalCheckPage
|
||||
journalGetCheckControl mcookie = do
|
||||
(token, muser, loc, l10n, _, symbol, version) <- controlInit mcookie
|
||||
return $ journalCheckPage l10n loc version mcookie
|
||||
|
||||
journalPostCheckControl
|
||||
:: Maybe T.Text
|
||||
-> CashCheck
|
||||
-> UserHandler JournalPage
|
||||
journalPostCheckControl mcookie (CashCheck floatAmount) = do
|
||||
(token, muser, loc, l10n, backend, symbol, version) <- controlInit mcookie
|
||||
case muser of
|
||||
Just user -> do
|
||||
eresult <- liftIO $ runClientM
|
||||
(journalPostCashCheck
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
(MT.JournalCashCheck (fromJust muser) $ floor $ floatAmount * 100)
|
||||
)
|
||||
backend
|
||||
case eresult of
|
||||
Right _ -> throwError $
|
||||
addMessage (translate l10n loc "Cash check received and processed") $
|
||||
redirect303 (journalLink Nothing)
|
||||
Left err ->
|
||||
handleClientErr err muser (Just journalGetCheckLink)
|
||||
Nothing ->
|
||||
redirectOverAuth Nothing (Just $ journalLink Nothing) Nothing
|
||||
where
|
||||
translate l10n locale = localize l10n locale . gettext
|
|
@ -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
|
|
@ -1,29 +1,29 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Control.User where
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client.Core.Auth
|
||||
import Servant.Server
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Either.Combinators (leftToMaybe)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Reader (ask, asks)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import Network.HTTP.Types.Status
|
||||
|
||||
-- imports from "mateamt"
|
||||
|
||||
import qualified "mateamt" API as MA
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
-- internal imports
|
||||
|
@ -36,94 +36,72 @@ 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
|
||||
Left err ->
|
||||
error $ show err
|
||||
|
||||
userNewControl :: Maybe T.Text -> UserHandler UserNewPage
|
||||
userNewControl mcookie = do
|
||||
(ReadState l10n _ _ _ version) <- ask
|
||||
(ReadState l10n backend _) <- 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
|
||||
|
||||
userNewPostControl
|
||||
:: Maybe T.Text
|
||||
-> MT.UserSubmit
|
||||
-> UserHandler UserSelectPage
|
||||
userNewPostControl _ us = do
|
||||
backend <- asks rsBackend
|
||||
userNewPostControl _ us@(MT.UserSubmit ident email pass) = do
|
||||
backend <- rsBackend <$> ask
|
||||
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
|
||||
-> Int
|
||||
-> Maybe MT.ProductRefine
|
||||
-> UserHandler UserOverviewPage
|
||||
userOverviewControl mcookie uid mRefine = do
|
||||
(ReadState l10n backend _ symbol version) <- ask
|
||||
userOverviewControl mcookie uid = do
|
||||
(ReadState l10n backend _) <- ask
|
||||
let loc = Locale
|
||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
||||
mParsedCookie = fmap parseCookieText mcookie
|
||||
(token, mAuthUser) = parseTokenAndUser mcookie
|
||||
mMethod = T.unpack <$>
|
||||
(lookup "x-method" =<< mParsedCookie)
|
||||
getProducts = liftIO $ runClientM
|
||||
(productShortList mRefine)
|
||||
backend
|
||||
euser <- liftIO $
|
||||
runClientM
|
||||
(userGet (mkAuthenticatedRequest token authenticateReq))
|
||||
backend
|
||||
eproducts <- case fmap (toEnum . read) mMethod of
|
||||
Just MT.PrimaryPass -> return (Right [])
|
||||
Just MT.SecondaryPass -> getProducts
|
||||
Just MT.ChallengeResponse -> getProducts
|
||||
_ -> return (Right [])
|
||||
euser <- liftIO $ runClientM
|
||||
(userGet (mkAuthenticatedRequest "secret" authenticateReq) uid)
|
||||
backend
|
||||
eproducts <- liftIO $ runClientM
|
||||
(productShortList Nothing)
|
||||
backend
|
||||
case (euser, eproducts) of
|
||||
(Right ud, Right prods) ->
|
||||
case mMethod of
|
||||
Just method ->
|
||||
if mAuthUser == Just uid
|
||||
then
|
||||
return $
|
||||
userOverviewPage
|
||||
l10n
|
||||
loc
|
||||
(toEnum $ read method)
|
||||
ud
|
||||
prods
|
||||
version
|
||||
mcookie
|
||||
symbol
|
||||
else
|
||||
redirectOverAuth
|
||||
(Just uid)
|
||||
(Just $ userOverviewLink uid mRefine)
|
||||
mRefine
|
||||
Nothing ->
|
||||
redirectOverAuth mAuthUser Nothing mRefine
|
||||
return $ userOverviewPage l10n loc ud prods
|
||||
(Left uerr, Right _) -> case uerr of
|
||||
FailureResponse _ resp ->
|
||||
if statusCode (responseStatusCode resp) == 401
|
||||
then
|
||||
redirectOverAuth (Just uid) Nothing mRefine
|
||||
then do
|
||||
let redirectHeaders = errHeaders $ redirect303 authLink
|
||||
throwError
|
||||
(err303
|
||||
{ errHeaders = redirectHeaders ++
|
||||
[ ("Set-Cookie", "x-auth-user=" <> (fromString $ show uid)
|
||||
<> "; Path=/"
|
||||
)
|
||||
]
|
||||
}
|
||||
)
|
||||
else
|
||||
throwError $ err500
|
||||
{ errBody = fromString (show uerr)
|
||||
|
@ -138,132 +116,5 @@ userOverviewControl mcookie uid mRefine = do
|
|||
}
|
||||
(Left uerr, Left perr) ->
|
||||
throwError $ err500
|
||||
{ errBody = fromString (show uerr) <> " " <> fromString (show perr)
|
||||
{ errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr)
|
||||
}
|
||||
|
||||
userRechargeControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> UserHandler UserRechargePage
|
||||
userRechargeControl mcookie uid = do
|
||||
(ReadState l10n _ _ symbol version) <- ask
|
||||
let loc = localeFromCookie mcookie
|
||||
return $ userRechargePage l10n loc version mcookie uid symbol
|
||||
|
||||
userPostRechargeControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> UserRecharge
|
||||
-> UserHandler UserOverviewPage
|
||||
userPostRechargeControl mcookie uid (UserRecharge amount) = do
|
||||
(ReadState l10n backend _ _ _) <- ask
|
||||
let loc = localeFromCookie mcookie
|
||||
(token, mauthuser) = parseTokenAndUser mcookie
|
||||
eresult <- liftIO $ runClientM
|
||||
(userRecharge
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
(MT.UserRecharge $ floor $ amount * 100)
|
||||
)
|
||||
backend
|
||||
if isJust mauthuser
|
||||
then
|
||||
case eresult of
|
||||
Right _ -> throwError $
|
||||
addMessage (translate l10n loc "Recharge Successful") $
|
||||
redirect303 (userOverviewLink uid Nothing)
|
||||
Left err -> throwError $
|
||||
addMessage (translate l10n loc ("An error occured. " <>
|
||||
fromString (show err))) $
|
||||
redirect303 (userRechargeLink uid)
|
||||
else
|
||||
redirectOverAuth (Just uid) (Just (userRechargeLink uid)) Nothing
|
||||
where
|
||||
translate l10n locale = localize l10n locale . gettext
|
||||
|
||||
userManageControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> UserHandler UserManagePage
|
||||
userManageControl mcookie uid = do
|
||||
(ReadState l10n backend _ _ version) <- ask
|
||||
let loc = localeFromCookie mcookie
|
||||
(token, mAuthUser) = parseTokenAndUser mcookie
|
||||
eUserDetails <- liftIO $
|
||||
runClientM
|
||||
(userGet (mkAuthenticatedRequest token authenticateReq))
|
||||
backend
|
||||
eAuthOverviews <- liftIO $
|
||||
runClientM
|
||||
(authManageList (mkAuthenticatedRequest token authenticateReq))
|
||||
backend
|
||||
case (eUserDetails, eAuthOverviews) of
|
||||
(Right userDetails, Right authOverviews) ->
|
||||
if Just uid == mAuthUser
|
||||
then
|
||||
return $
|
||||
userManagePage l10n loc userDetails authOverviews version mcookie
|
||||
else
|
||||
redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing
|
||||
err -> handleErrors
|
||||
(Just uid)
|
||||
(Just $ userManageLink uid)
|
||||
[leftToMaybe (fst err), leftToMaybe (snd err)]
|
||||
|
||||
userManageDetailsSubmitControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> MT.UserDetailsSubmit
|
||||
-> UserHandler UserOverviewPage
|
||||
userManageDetailsSubmitControl mcookie uid uds = do
|
||||
(ReadState _ backend _ _ _) <- ask
|
||||
let (token, mAuthUser) = parseTokenAndUser mcookie
|
||||
eReturn <- liftIO $ runClientM
|
||||
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
|
||||
backend
|
||||
case eReturn of
|
||||
Right _ -> throwError $ redirect303 (userManageLink uid)
|
||||
Left err ->
|
||||
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
|
||||
|
||||
userManageAuthCreateControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> AuthSubmitReturn
|
||||
-> UserHandler UserOverviewPage
|
||||
userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
|
||||
(ReadState _ backend _ _ _) <- ask
|
||||
let (token, mAuthUser) = parseTokenAndUser mcookie
|
||||
hashedPass <- hashPassword pass
|
||||
eReturn <- liftIO $ runClientM
|
||||
(authManageNewAuth
|
||||
(mkAuthenticatedRequest token authenticateReq)
|
||||
(MT.AuthSubmit (toEnum method) comment hashedPass)
|
||||
)
|
||||
backend
|
||||
case eReturn of
|
||||
Right _ -> throwError $ redirect303 $ userManageLink uid
|
||||
Left err ->
|
||||
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
|
||||
|
||||
userManageAuthDeleteControl
|
||||
:: Maybe T.Text
|
||||
-> Int
|
||||
-> AuthDetailId
|
||||
-> UserHandler UserOverviewPage
|
||||
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
|
||||
backend <- asks rsBackend
|
||||
let (token, mAuthUser) = parseTokenAndUser mcookie
|
||||
eReturn <- liftIO $ runClientM
|
||||
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
|
||||
backend
|
||||
case eReturn of
|
||||
Right _ -> throwError $ redirect303 $ userManageLink uid
|
||||
Left err -> case err of
|
||||
FailureResponse _ resp ->
|
||||
if statusCode (responseStatusCode resp) == 406
|
||||
then
|
||||
throwError (redirect303 $ userManageLink uid)
|
||||
else
|
||||
handleErrors mAuthUser Nothing [Just err]
|
||||
_ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
|
||||
[Just err]
|
||||
|
|
|
@ -10,7 +10,7 @@ import Data.ByteString
|
|||
import Data.ByteString.Random (random)
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
|
||||
import Control.Monad.Reader (asks)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
-- internal imports
|
||||
|
@ -21,8 +21,8 @@ hashPassword
|
|||
:: T.Text
|
||||
-> UserHandler T.Text
|
||||
hashPassword passwd = do
|
||||
(HashParams iter _ outputl) <- asks rsHashParams
|
||||
let saltl = 0 :: Int
|
||||
(HashParams iter _ outputl) <- rsHashParams <$> ask
|
||||
let saltl = 0
|
||||
salt <- liftIO $ random (fromIntegral saltl)
|
||||
let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString
|
||||
return $ decodeUtf8 $ B64.encode hash
|
||||
|
|
95
src/Main.hs
95
src/Main.hs
|
@ -1,8 +1,9 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Servant
|
||||
import Servant.Server
|
||||
import Servant.Client
|
||||
|
||||
import Network.Wai.Handler.Warp
|
||||
|
@ -12,104 +13,42 @@ import Network.HTTP.Client hiding (Proxy)
|
|||
|
||||
import Control.Monad.Reader
|
||||
|
||||
import Data.String (fromString)
|
||||
import Data.Text.I18n
|
||||
import Data.Text.I18n.Po
|
||||
import qualified Data.Text as T
|
||||
import Data.ByteString.Lazy as BL hiding (putStrLn)
|
||||
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 View
|
||||
import Control
|
||||
import Client
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
(Options confLoc) <- execParser opts
|
||||
raw <- BL.readFile (T.unpack confLoc)
|
||||
case decode1 raw of
|
||||
Left (loc, msg) ->
|
||||
error (T.unpack $ confLoc <> ":" <>
|
||||
fromString (prettyPosWithSource loc raw " error") <>
|
||||
fromString msg)
|
||||
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)
|
||||
where
|
||||
opts = info (options <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "Run the \"matebeamter\" frontend to the \"mateamt\" API."
|
||||
<> header "matebeamter - a client for mateamt"
|
||||
)
|
||||
manager <- newManager defaultManagerSettings
|
||||
(l10n, _) <- getL10n "./locales"
|
||||
withStdoutLogger $ \ilog -> do
|
||||
let settings = setPort 3000 $ setLogger ilog defaultSettings
|
||||
initState = ReadState
|
||||
-- { rsManager = manager
|
||||
{ rsL10n = l10n
|
||||
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
|
||||
, rsHashParams = recommendedHashParams
|
||||
}
|
||||
|
||||
runSettings settings (userApp initState)
|
||||
|
||||
userApp :: ReadState -> Application
|
||||
userApp initState = serveWithContext userApi EmptyContext $
|
||||
userApp initState = serveWithContext userApi (EmptyContext) $
|
||||
hoistServerWithContext
|
||||
userApi
|
||||
Proxy
|
||||
(`runReaderT` initState)
|
||||
(\mcookie -> userSelectControl mcookie
|
||||
:<|> userOverviewControl mcookie
|
||||
:<|> buyControl mcookie
|
||||
:<|> purchaseControl mcookie
|
||||
:<|> userRechargeControl mcookie
|
||||
:<|> userPostRechargeControl mcookie
|
||||
:<|> userManageControl mcookie
|
||||
:<|> userManageDetailsSubmitControl mcookie
|
||||
:<|> userManageAuthCreateControl mcookie
|
||||
:<|> userManageAuthDeleteControl mcookie
|
||||
:<|> userNewControl mcookie
|
||||
:<|> userNewPostControl mcookie
|
||||
:<|> cashBuyOverviewControl mcookie
|
||||
:<|> cashBuyPurchaseControl mcookie
|
||||
:<|> 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
|
||||
|
|
3
src/Model/Auth.hs
Normal file
3
src/Model/Auth.hs
Normal file
|
@ -0,0 +1,3 @@
|
|||
module Model.Auth where
|
||||
|
||||
|
7
src/Model/User.hs
Normal file
7
src/Model/User.hs
Normal file
|
@ -0,0 +1,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
module Model.User where
|
||||
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
|
|
@ -6,7 +6,4 @@ import Types.Auth as T
|
|||
import Types.Page as T
|
||||
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.Configuration as T
|
||||
import Types.Orphans as T
|
||||
|
|
|
@ -20,21 +20,3 @@ data AuthReturn = AuthReturn
|
|||
|
||||
instance MimeRender HTML AuthReturn
|
||||
instance FromForm AuthReturn
|
||||
|
||||
data AuthSubmitReturn = AuthSubmitReturn
|
||||
{ authSubmitReturnComment :: T.Text
|
||||
, authSubmitReturnPass :: T.Text
|
||||
, authSubmitReturnMethod :: Int
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance MimeRender HTML AuthSubmitReturn
|
||||
instance FromForm AuthSubmitReturn
|
||||
|
||||
newtype AuthDetailId = AuthDetailId
|
||||
{ unId :: Int
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance MimeRender HTML AuthDetailId
|
||||
instance FromForm AuthDetailId
|
||||
|
|
|
@ -1,44 +0,0 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Types.Configuration where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Options.Applicative as O
|
||||
|
||||
import Data.YAML as Y
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
data Configuration = Configuration
|
||||
{ configApiHost :: T.Text
|
||||
, configApiPort :: Word
|
||||
, configApiUri :: T.Text
|
||||
, configApiSecure :: Bool
|
||||
, configListenPort :: Word
|
||||
, configLocalesLocation :: T.Text
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance FromYAML Configuration where
|
||||
parseYAML = withMap "Configuration" $ \m -> Configuration
|
||||
<$> m .: "api_host"
|
||||
<*> m .: "api_port"
|
||||
<*> m .:? "api_uri" .!= ""
|
||||
<*> m .:? "api_secure" .!= False
|
||||
<*> m .: "listen_port"
|
||||
<*> m .: "locales_location"
|
||||
|
||||
newtype Options = Options
|
||||
{ optConfigLocation :: T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
options :: O.Parser Options
|
||||
options = Options
|
||||
<$> strOption
|
||||
( long "configuration"
|
||||
<> short 'c'
|
||||
<> metavar "FILEPATH"
|
||||
<> help "The location of the configuration YAML-file"
|
||||
)
|
|
@ -1,18 +0,0 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Types.Journal where
|
||||
|
||||
import Servant.API
|
||||
import Servant.HTML.Blaze
|
||||
import Web.Internal.FormUrlEncoded
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
newtype CashCheck = CashCheck
|
||||
{ cashCheckAmount :: Float
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance MimeUnrender HTML CashCheck
|
||||
instance FromForm CashCheck
|
|
@ -1,67 +1,17 @@
|
|||
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Types.Orphans where
|
||||
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
import Text.Blaze
|
||||
|
||||
import Servant.API
|
||||
import Servant.HTML.Blaze
|
||||
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
|
||||
|
||||
instance MimeUnrender HTML MT.UserDetailsSubmit
|
||||
instance FromForm MT.UserDetailsSubmit
|
||||
|
||||
instance MimeUnrender HTML [MT.PurchaseDetail]
|
||||
instance FromForm [MT.PurchaseDetail] where
|
||||
fromForm form =
|
||||
let kvs = toListStable form
|
||||
ks = map fst kvs
|
||||
kpids = filter ("productSelect" `T.isPrefixOf`) ks
|
||||
prods = filter ((`notElem` kpids) . fst) kvs
|
||||
stripPid = snd . T.breakOnEnd "-"
|
||||
digestForm key =
|
||||
let pid = read (T.unpack $ stripPid key)
|
||||
amount = read
|
||||
(T.unpack . fromJust $
|
||||
lookup ("productAmount-" <> stripPid key) prods)
|
||||
in MT.PurchaseDetail pid amount
|
||||
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
|
||||
|
|
|
@ -4,7 +4,6 @@ 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 +35,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
|
||||
|
@ -54,9 +44,9 @@ template
|
|||
template (Page title favicon meta style) content =
|
||||
H.docTypeHtml $ do
|
||||
H.head $ do
|
||||
H.title $ H.toHtml title
|
||||
H.title $ H.toHtml $ title
|
||||
meta
|
||||
favicon
|
||||
style
|
||||
H.body
|
||||
H.body $
|
||||
content
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -1,18 +0,0 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Types.User where
|
||||
|
||||
import Servant.API
|
||||
import Servant.HTML.Blaze
|
||||
import Web.Internal.FormUrlEncoded
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
newtype UserRecharge = UserRecharge
|
||||
{ userRechargeAmount :: Float
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance MimeUnrender HTML UserRecharge
|
||||
instance FromForm UserRecharge
|
|
@ -8,26 +8,4 @@ type UserNewPage = H.Html
|
|||
|
||||
type UserOverviewPage = H.Html
|
||||
|
||||
type UserRechargePage = H.Html
|
||||
|
||||
type UserManagePage = H.Html
|
||||
|
||||
type ProductListPage = H.Html
|
||||
|
||||
type AuthPage = H.Html
|
||||
|
||||
type BuyConfirmPage = H.Html
|
||||
|
||||
type JournalPage = H.Html
|
||||
|
||||
type JournalCheckPage = H.Html
|
||||
|
||||
type CashBuyOverviewPage = H.Html
|
||||
|
||||
type CashBuyConfirmPage = H.Html
|
||||
|
||||
type ProductPriceListPage = H.Html
|
||||
|
||||
type ProductRefillPage = H.Html
|
||||
|
||||
type ProductNewPage = H.Html
|
||||
|
|
183
src/Util.hs
183
src/Util.hs
|
@ -2,42 +2,31 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Util where
|
||||
|
||||
import Servant hiding (addHeader)
|
||||
import Servant.Client
|
||||
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
import Text.Blaze.Internal
|
||||
import Servant.Client.Core.Request
|
||||
import Servant.Client.Core.Request (addHeader)
|
||||
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
import API
|
||||
setCookie
|
||||
:: SetCookie
|
||||
-> Request
|
||||
-> Request
|
||||
setCookie c = addHeader "Set-Cookie" (decodeUtf8 . toLazyByteString $ renderSetCookie c)
|
||||
|
||||
formatMoney :: Int -> T.Text
|
||||
formatMoney amount = pre <> t <> "," <> c
|
||||
|
@ -48,7 +37,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 amount))
|
||||
|
||||
redirect303
|
||||
:: Link
|
||||
|
@ -56,161 +45,13 @@ redirect303
|
|||
redirect303 link =
|
||||
err303
|
||||
{ errHeaders =
|
||||
[ ("Location", "/" <> fromString (show $ linkURI link))
|
||||
[ ("Location", "/" <> (fromString $ show $ linkURI $ link))
|
||||
]
|
||||
}
|
||||
|
||||
redirect307
|
||||
:: Link
|
||||
-> ServerError
|
||||
redirect307 link =
|
||||
err307
|
||||
{ errHeaders =
|
||||
[ ("Location", "/" <> fromString (show $ linkURI link))
|
||||
]
|
||||
}
|
||||
|
||||
addMessage
|
||||
:: T.Text
|
||||
-> ServerError
|
||||
-> ServerError
|
||||
addMessage message err =
|
||||
err
|
||||
{ errHeaders =
|
||||
( "Set-Cookie"
|
||||
, "message=" <>
|
||||
encodeUtf8 message <>
|
||||
"; Path=/; Max-Age=5"
|
||||
) : errHeaders err
|
||||
}
|
||||
|
||||
parseCookieText
|
||||
:: T.Text
|
||||
-> [(T.Text, T.Text)]
|
||||
parseCookieText = map
|
||||
(\x -> let (one, two) = T.breakOn "=" x in (one, T.tail two))
|
||||
. T.splitOn "; "
|
||||
|
||||
parseTokenAndUser
|
||||
:: Maybe T.Text
|
||||
-> (String, Maybe Int)
|
||||
parseTokenAndUser mcookie =
|
||||
(token, mAuthUser)
|
||||
where
|
||||
token = T.unpack $ fromMaybe "secret"
|
||||
(lookup "x-token" =<< mParsedCookie)
|
||||
mAuthUser = read . T.unpack <$>
|
||||
(lookup "x-auth-user" =<< mParsedCookie)
|
||||
mParsedCookie = fmap parseCookieText mcookie
|
||||
|
||||
localeFromCookie
|
||||
:: Maybe T.Text
|
||||
-> Locale
|
||||
localeFromCookie mcookie = Locale
|
||||
(fromMaybe "en" $ lookup "locale" . parseCookieText =<< mcookie)
|
||||
|
||||
handleErrors
|
||||
:: (Traversable t, Show (t (Maybe ClientError)))
|
||||
=> Maybe Int
|
||||
-> Maybe Link
|
||||
-> t (Maybe ClientError)
|
||||
-> UserHandler UserOverviewPage
|
||||
handleErrors mAuthUser mLink merrs = do
|
||||
codes <- mapM
|
||||
(\case
|
||||
Just (FailureResponse _ resp) ->
|
||||
return $ statusCode (responseStatusCode resp)
|
||||
Just err ->
|
||||
throwError $ err500
|
||||
{ errBody = fromString (show err)
|
||||
}
|
||||
Nothing ->
|
||||
return 200
|
||||
)
|
||||
merrs
|
||||
if 401 `elem` codes
|
||||
then
|
||||
redirectOverAuth mAuthUser mLink Nothing
|
||||
else
|
||||
throwError $ err500
|
||||
{ errBody = fromString (show merrs)
|
||||
}
|
||||
|
||||
redirectOverAuth
|
||||
:: Maybe Int
|
||||
-> Maybe Link
|
||||
-> Maybe MT.ProductRefine
|
||||
-> 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
|
||||
))))
|
||||
throwError
|
||||
(err303
|
||||
{ errHeaders = redirectHeaders ++ (case muid of
|
||||
Just uid ->
|
||||
[ ( "Set-Cookie"
|
||||
, "x-auth-user=" <> fromString (show uid) <> "; Path=/"
|
||||
)
|
||||
]
|
||||
Nothing ->
|
||||
[
|
||||
]
|
||||
)
|
||||
++
|
||||
[ ( "Set-Cookie"
|
||||
, "x-token=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
|
||||
)
|
||||
, ( "Set-Cookie"
|
||||
, "x-method=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT"
|
||||
)
|
||||
]
|
||||
}
|
||||
)
|
||||
|
||||
productBgStyle
|
||||
:: AttributeValue
|
||||
-> Attribute
|
||||
productBgStyle aid = HA.style $ mconcat
|
||||
[ "background-image: url(#" <> aid <> ");" -- FILLME
|
||||
, "backgronud-color: blue;"
|
||||
, "text-shadow:"
|
||||
, " -1px 0 1px black,"
|
||||
, " 0 1px 1px black,"
|
||||
, " 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)
|
||||
|
|
|
@ -4,6 +4,3 @@ module View
|
|||
|
||||
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
|
||||
|
|
|
@ -7,8 +7,6 @@ import Servant.Links (linkURI)
|
|||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.String
|
||||
|
@ -26,24 +24,19 @@ import View.Scaffold
|
|||
authPage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> Maybe T.Text
|
||||
-> T.Text
|
||||
-> Maybe T.Text
|
||||
-> AuthPage
|
||||
authPage l10n locale mDestination version mcookie = scaffold
|
||||
authPage l10n locale = scaffold
|
||||
l10n
|
||||
locale
|
||||
version
|
||||
mcookie
|
||||
(initPage $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Authentication"
|
||||
)
|
||||
$ H.p $ H.form
|
||||
$ do
|
||||
H.p $ H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <> fromString (show $ linkURI $
|
||||
authPostLink mDestination))
|
||||
H.! HA.action ("/" <> (fromString $ show $ linkURI $ authPostLink))
|
||||
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label H.! HA.for "method" $ H.toHtml $
|
||||
|
@ -70,9 +63,9 @@ authPage l10n locale mDestination version mcookie = scaffold
|
|||
H.! HA.type_ "password"
|
||||
H.! HA.required ""
|
||||
H.! HA.value ""
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.div H.! HA.class_ "form-group optional" $ do
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.class_ "btn btn-default"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ translate "Submit"
|
||||
where
|
||||
|
|
207
src/View/Buy.hs
207
src/View/Buy.hs
|
@ -1,207 +0,0 @@
|
|||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module View.Buy where
|
||||
|
||||
import Servant.Links
|
||||
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
|
||||
import Control.Monad (when)
|
||||
|
||||
-- imports from mateamt
|
||||
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Util
|
||||
import Types
|
||||
import View.Scaffold
|
||||
import API
|
||||
|
||||
buyConfirmPage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> Int
|
||||
-> [(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 $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Home"
|
||||
) $ do
|
||||
if not forceBuy
|
||||
then
|
||||
H.p $ H.toHtml $ translate "You are about to buy the following items:"
|
||||
else
|
||||
H.p $ H.toHtml $ translate "The following Items seem out of stock:"
|
||||
H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action
|
||||
("/" <> fromString
|
||||
(show $ linkURI $ purchaseCompleteLink uid forceBuy)
|
||||
)
|
||||
H.! HA.enctype "application/x-www-form-urlencoded"
|
||||
$ do
|
||||
mapM_
|
||||
(\( MT.PurchaseDetail _ _
|
||||
, MT.ProductShortOverview pid ident price amount _ mava) ->
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.input
|
||||
H.! HA.id ("product-select-" <> fromString (show pid))
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name ("productSelect-" <> fromString (show pid))
|
||||
H.! HA.type_ "hidden"
|
||||
H.! HA.value "true"
|
||||
H.label
|
||||
H.! HA.for ("product-amount-" <> fromString (show pid))
|
||||
$ do
|
||||
H.img
|
||||
H.!?
|
||||
( isJust mava
|
||||
, HA.src
|
||||
(fromString $ show $ fromJust mava) -- TODO: ask for avatar
|
||||
)
|
||||
H.toHtml ident
|
||||
H.input
|
||||
H.! HA.id ("product-amount-" <> fromString (show pid))
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name ("productAmount-" <> fromString (show pid))
|
||||
H.! HA.type_ "number"
|
||||
H.! HA.min "0"
|
||||
H.! HA.step "1"
|
||||
H.! HA.value (fromString $ show amount)
|
||||
-- H.! HA.disabled ""
|
||||
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
|
||||
)
|
||||
ziptups
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label
|
||||
H.! HA.for "total-price"
|
||||
$ H.toHtml ("Total price: " :: T.Text)
|
||||
H.input
|
||||
H.! HA.id "total-price"
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name "totalPrice"
|
||||
H.! HA.type_ "text"
|
||||
H.! HA.value (fromString $ T.unpack $ formatMoney total)
|
||||
H.! HA.disabled ""
|
||||
H.toHtml symbol
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ if forceBuy
|
||||
then translate "Buy anyway"
|
||||
else translate "Buy"
|
||||
when forceBuy $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.formnovalidate "formnovalidate"
|
||||
H.! HA.formmethod "get"
|
||||
H.! HA.formaction
|
||||
("/" <> fromString
|
||||
(show $ linkURI $ userOverviewLink uid Nothing)
|
||||
)
|
||||
$ H.toHtml $ translate "Cancel"
|
||||
where
|
||||
translate = localize l10n locale . gettext
|
||||
|
||||
buyProductsForm
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> [MT.ProductShortOverview]
|
||||
-> H.Html
|
||||
buyProductsForm l10n locale prods = do
|
||||
H.div H.! HA.class_ "tile-list" $
|
||||
mapM_ (\(MT.ProductShortOverview pid ident _ _ _ maid) ->
|
||||
H.div
|
||||
H.! HA.class_ "tile"
|
||||
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
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ translate "Proceed"
|
||||
where
|
||||
translate = localize l10n locale . gettext
|
||||
|
||||
cashBuyOverviewPage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> T.Text
|
||||
-> Maybe T.Text
|
||||
-> [MT.ProductShortOverview]
|
||||
-> CashBuyOverviewPage
|
||||
cashBuyOverviewPage l10n loc version mcookie psos =
|
||||
scaffold l10n loc version mcookie (initPage $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Buy with Cash"
|
||||
) $
|
||||
H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <> fromString (
|
||||
show $ linkURI cashBuyPostLink
|
||||
))
|
||||
H.! HA.enctype "application/x-www-form-urlencoded"
|
||||
$ buyProductsForm l10n loc psos
|
||||
where
|
||||
translate = localize l10n loc . gettext
|
|
@ -1,133 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module View.Journal where
|
||||
|
||||
import Servant.Links (linkURI)
|
||||
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Control.Monad (when)
|
||||
|
||||
-- imports from "mateamt"
|
||||
|
||||
import qualified "mateamt" Types as MT
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Util
|
||||
import Types
|
||||
import View.Scaffold
|
||||
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 $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Journal"
|
||||
) $ do
|
||||
H.table $ do
|
||||
H.thead $
|
||||
H.tr $ do
|
||||
H.th (H.toHtml $ translate "ID")
|
||||
H.th (H.toHtml $ translate "Time")
|
||||
H.th (H.toHtml $ translate "Description")
|
||||
H.th (H.toHtml $ translate "Amount")
|
||||
H.th (H.toHtml $ translate "Total amount")
|
||||
mapM_
|
||||
(\(MT.JournalEntry jid time user action amount total) ->
|
||||
H.tr
|
||||
H.!? (action == MT.CashCheck, 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 $ formatMoney amount)
|
||||
H.td (H.toHtml $ formatMoney total)
|
||||
)
|
||||
entries
|
||||
let page = fromMaybe 0 mpage
|
||||
H.form $ do
|
||||
when (page /= 0) $
|
||||
H.a
|
||||
H.! HA.href
|
||||
("/" <> fromString
|
||||
(show $ linkURI (journalLink (Just $ page - 1)))
|
||||
)
|
||||
$ H.toHtml $ translate "Previous Page"
|
||||
when (length entries == 50) $
|
||||
H.a
|
||||
H.! HA.href
|
||||
("/" <> fromString
|
||||
(show $ linkURI (journalLink (Just $ page + 1)))
|
||||
)
|
||||
$ 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))
|
||||
$ H.toHtml $ translate "Perform cash check"
|
||||
where
|
||||
translate = localize l10n loc . gettext
|
||||
|
||||
journalCheckPage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> T.Text
|
||||
-> Maybe T.Text
|
||||
-> JournalCheckPage
|
||||
journalCheckPage l10n loc version mcookie =
|
||||
scaffold l10n loc version mcookie (initPage $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Cash check"
|
||||
) $ do
|
||||
H.div $ do
|
||||
H.p $
|
||||
H.toHtml $ translate $ mconcat
|
||||
[ "Please count all the cash in stock thoroughly and diligently, "
|
||||
, "then submit the total amount in the field below."
|
||||
]
|
||||
H.p $
|
||||
H.toHtml $ translate "Thank you for your cooperation."
|
||||
H.div $ H.p $ H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <> fromString (show $ linkURI journalPostCheckLink))
|
||||
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label H.! HA.for "total" $ H.toHtml $ translate "Total amount"
|
||||
H.input
|
||||
H.! HA.id "total"
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name "cashCheckAmount"
|
||||
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" $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ translate "Submit"
|
||||
where
|
||||
translate = localize l10n loc . gettext
|
|
@ -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
|
|
@ -4,7 +4,7 @@ module View.Scaffold where
|
|||
import Servant.Links
|
||||
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
import qualified Text.Blaze.Html5.Attributes as H
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
@ -12,74 +12,21 @@ import Data.String (fromString)
|
|||
|
||||
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
|
||||
import API
|
||||
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
|
||||
scaffold l10n locale 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)
|
||||
H.li $ H.a H.! H.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" $
|
||||
H.toHtml (fromJust message)
|
||||
)
|
||||
H.div H.! HA.id "main" H.! HA.role "main" $
|
||||
H.div H.! H.id "main" H.! H.role "main" $ do
|
||||
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
|
||||
|
|
364
src/View/User.hs
364
src/View/User.hs
|
@ -7,8 +7,6 @@ import Servant.Links
|
|||
import qualified Text.Blaze.Html5 as H hiding (style)
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.Text.I18n
|
||||
|
||||
import Data.String (fromString)
|
||||
|
@ -24,175 +22,80 @@ import qualified "mateamt" Types as MT
|
|||
import Util
|
||||
import Types
|
||||
import View.Scaffold
|
||||
import View.Buy
|
||||
import API
|
||||
|
||||
userSelectPage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> [MT.UserSummary]
|
||||
-> T.Text
|
||||
-> Maybe T.Text
|
||||
-> UserSelectPage
|
||||
userSelectPage l10n locale uss version mcookie =
|
||||
scaffold l10n locale version 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"
|
||||
userSelectPage l10n locale uss = scaffold l10n locale (initPage $
|
||||
(translate "Matebeamter") <>
|
||||
" - " <>
|
||||
(translate "Home")
|
||||
) $ do
|
||||
mapM_ (\(MT.UserSummary uid ident _) -> do
|
||||
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userOverviewLink uid)) $
|
||||
H.toHtml ident
|
||||
) uss
|
||||
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $
|
||||
H.toHtml $ translate "New user"
|
||||
where
|
||||
translate = localize l10n locale . gettext
|
||||
|
||||
userOverviewPage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> 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 $
|
||||
localize l10n locale (gettext "Matebeamter") <>
|
||||
" - " <>
|
||||
localize l10n locale (gettext "User Menu for ") <>
|
||||
MT.userDetailsIdent ud
|
||||
) $ do
|
||||
H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud
|
||||
<> "!"
|
||||
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
|
||||
translate "Your current balance is" <>
|
||||
": " <>
|
||||
formatMoney (MT.userDetailsBalance ud) <> 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.type_ "submit"
|
||||
$ H.toHtml $ translate "Logout"
|
||||
case method of
|
||||
MT.PrimaryPass ->
|
||||
userSettingsPointer l10n locale (MT.userDetailsId ud)
|
||||
MT.SecondaryPass ->
|
||||
buyForm
|
||||
MT.ChallengeResponse -> do
|
||||
userSettingsPointer l10n locale (MT.userDetailsId ud)
|
||||
buyForm
|
||||
where
|
||||
translate = localize l10n locale . gettext
|
||||
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 ("/" <>
|
||||
fromString
|
||||
(show $ linkURI $ userRechargeLink $ MT.userDetailsId ud))
|
||||
$ H.toHtml $ translate "Recharge Credit"
|
||||
H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <> fromString (show $ linkURI $
|
||||
buyLink (MT.userDetailsId ud) False)
|
||||
)
|
||||
H.! HA.enctype "application/x-www-form-urlencoded" $
|
||||
buyProductsForm l10n locale pos
|
||||
|
||||
userSettingsPointer
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> Int
|
||||
-> H.Html
|
||||
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
|
||||
|
||||
productList
|
||||
:: [MT.ProductShortOverview]
|
||||
-> H.Html
|
||||
productList pos =
|
||||
H.p $
|
||||
H.ul H.! HA.class_ "tile-list" $
|
||||
userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
|
||||
(localize l10n locale $ gettext "Matebeamter") <>
|
||||
" - " <>
|
||||
(localize l10n locale $ gettext "User Menu for ") <>
|
||||
(MT.userDetailsIdent ud)
|
||||
) $ do
|
||||
H.p $ H.toHtml $ (translate "Welcome back, ") <> (MT.userDetailsIdent ud)
|
||||
<> "!"
|
||||
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
|
||||
(translate "Your current balance is") <>
|
||||
": " <>
|
||||
(formatMoney $ MT.userDetailsBalance ud)
|
||||
-- TODO: Add currency symbol
|
||||
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
|
||||
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
|
||||
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
|
||||
where
|
||||
translate = localize l10n locale . gettext
|
||||
productBgStyle aid = HA.style $ mconcat
|
||||
[ "background-image: url(#" <> aid <> ");" -- FILLME
|
||||
, "backgronud-color: blue;"
|
||||
, "text-shadow:"
|
||||
, " -1px 0 1px black,"
|
||||
, " 0 1px 1px black,"
|
||||
, " 1px 0 1px black,"
|
||||
, " 0 -1px 1px black;"
|
||||
]
|
||||
|
||||
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
|
||||
userNewPage l10n locale = scaffold l10n locale (initPage $
|
||||
(translate "Matebeamter") <>
|
||||
" - " <>
|
||||
(translate "Create new user")
|
||||
) $ do
|
||||
H.p $ H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <> fromString (show $ linkURI userNewPostLink))
|
||||
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"
|
||||
|
@ -221,175 +124,10 @@ userNewPage l10n locale version mcookie =
|
|||
H.! HA.type_ "password"
|
||||
H.! HA.required ""
|
||||
H.! HA.value ""
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.div H.! HA.class_ "form-group optional" $ do
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
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 $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Recharge account"
|
||||
) $ H.p $ H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <>
|
||||
fromString (show $ linkURI $ userPostRechargeLink uid))
|
||||
H.! HA.enctype "aplication/x-www-form-urlencoded" $ do
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label H.! HA.for "recharge-amount" $ H.toHtml $ translate "Amount"
|
||||
H.input
|
||||
H.! HA.id "recharde-amount"
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name "userRechargeAmount"
|
||||
H.! HA.type_ "number"
|
||||
H.! HA.min "0"
|
||||
H.! HA.step "0.01"
|
||||
H.! HA.value "0"
|
||||
H.toHtml symbol
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ translate "Recharge"
|
||||
where
|
||||
translate = localize l10n locale . gettext
|
||||
|
||||
userManagePage
|
||||
:: L10n
|
||||
-> Locale
|
||||
-> MT.UserDetails
|
||||
-> [MT.AuthOverview]
|
||||
-> T.Text
|
||||
-> Maybe T.Text
|
||||
-> UserManagePage
|
||||
userManagePage l10n locale userDetails authOverviews version mcookie =
|
||||
scaffold l10n locale version mcookie (initPage $
|
||||
translate "Matebeamter" <>
|
||||
" - " <>
|
||||
translate "Manage user data"
|
||||
) $ H.p $ do
|
||||
H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <>
|
||||
fromString (show $ linkURI $
|
||||
userManageDetailsSubmitLink (MT.userDetailsId userDetails)))
|
||||
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
||||
H.legend $ H.toHtml $ translate "User details"
|
||||
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 "userDetailsSubmitIdent"
|
||||
H.! HA.type_ "text"
|
||||
H.! HA.required ""
|
||||
H.! HA.value
|
||||
(fromString $ T.unpack $ MT.userDetailsIdent userDetails)
|
||||
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 "userDetailsSubmitEmail"
|
||||
H.! HA.type_ "email"
|
||||
H.! HA.required ""
|
||||
H.! HA.value
|
||||
(maybe "" (fromString . T.unpack)
|
||||
(MT.userDetailsEmail userDetails))
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ translate "Submit"
|
||||
H.p $ do
|
||||
H.toHtml $ translate "Authentication details"
|
||||
mapM_
|
||||
(\(MT.AuthOverview aoid _ comment method) -> H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <>
|
||||
fromString (show $ linkURI $
|
||||
userManageAuthDeleteLink (MT.userDetailsId userDetails)))
|
||||
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
||||
H.legend $ H.toHtml (comment <> " - " <> case method of
|
||||
MT.PrimaryPass ->
|
||||
translate "Primary password"
|
||||
MT.SecondaryPass ->
|
||||
translate "Secondary password"
|
||||
MT.ChallengeResponse ->
|
||||
translate "Challenge response authentication"
|
||||
)
|
||||
H.div H.! HA.class_ "form-group required" $
|
||||
H.input
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name "unId"
|
||||
H.! HA.type_ "hidden"
|
||||
H.! HA.required ""
|
||||
H.! HA.value (fromString $ show aoid)
|
||||
H.div H.! HA.class_ "form-group optional" $
|
||||
H.button
|
||||
H.! HA.class_ "btn btn-primary"
|
||||
H.! HA.type_ "submit"
|
||||
$ H.toHtml $ translate "Delete"
|
||||
)
|
||||
authOverviews
|
||||
H.form
|
||||
H.! HA.method "post"
|
||||
H.! HA.action ("/" <>
|
||||
fromString (show $ linkURI $
|
||||
userManageAuthCreateLink (MT.userDetailsId userDetails)))
|
||||
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
||||
H.legend $ H.toHtml $ translate "New authentication"
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label H.! HA.for "comment" $ H.toHtml $
|
||||
translate "Comment"
|
||||
H.input
|
||||
H.! HA.id "comment"
|
||||
H.! HA.class_ "form_control"
|
||||
H.! HA.name "authSubmitReturnComment"
|
||||
H.! HA.type_ "text"
|
||||
H.! HA.required ""
|
||||
H.! HA.value ""
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label H.! HA.for "password" $ H.toHtml $
|
||||
translate "Password"
|
||||
H.input
|
||||
H.! HA.id "password"
|
||||
H.! HA.class_ "form_control"
|
||||
H.! HA.name "authSubmitReturnPass"
|
||||
H.! HA.type_ "password"
|
||||
H.! HA.required ""
|
||||
H.! HA.value ""
|
||||
H.div H.! HA.class_ "form-group required" $ do
|
||||
H.label H.! HA.for "method" $ H.toHtml $
|
||||
translate "Authentication Method"
|
||||
H.select
|
||||
H.! HA.id "method"
|
||||
H.! HA.class_ "form-control"
|
||||
H.! HA.name "authSubmitReturnMethod"
|
||||
H.! HA.required ""
|
||||
H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do
|
||||
H.option H.!
|
||||
HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $
|
||||
H.toHtml $ translate "Secondary password"
|
||||
H.option H.!
|
||||
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
|
||||
H.toHtml $ translate "Primary password"
|
||||
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
|
||||
|
|
7
static/css/bootstrap.min.css
vendored
7
static/css/bootstrap.min.css
vendored
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
@ -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;
|
||||
}
|
Loading…
Reference in a new issue