Compare commits

..

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

40 changed files with 225 additions and 2770 deletions

3
.gitignore vendored
View file

@ -7,6 +7,3 @@ dist/
*.prof
.ghc*
cabal.project.*
*.bak*
.direnv/
.envrc

View file

@ -1,6 +0,0 @@
api_host: "localhost"
api_port: 8000
#api_uri: ""
#api_secure: false
listen_port: 3000
locales_location: "./locales"

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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
View file

@ -0,0 +1,3 @@
module Model.Auth where

7
src/Model/User.hs Normal file
View file

@ -0,0 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Model.User where
import qualified "mateamt" Types as MT

View file

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

View file

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

View file

@ -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"
)

View 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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

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