nek0/matebeamter
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

adapt to journal entries with no description string

Browse source
This commit is contained in:
nek0 2020-05-10 11:31:23 +02:00
parent 74a666f092
commit 37dab5540b
8 changed files with 158 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
matebeamter.cabal
View file

@ -48,7 +48,7 @@ executable matebeamter
, View.Product
, Paths_matebeamter
-- other-extensions:
build-depends: base ^>=4.12.0.0
build-depends: base >=4.12.0.0 && < 5
, mateamt
, servant
, servant-server
@ -79,10 +79,9 @@ executable matebeamter
, base64-bytestring
, cryptonite
, stm
, stm-containers
, either
, optparse-applicative
, HsYAML
, HsYAML ^>=0.2.1.0
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

125
shell.nix
View file

@ -1,6 +1,125 @@
{ pkgs ? import <nixpkgs> {} }:
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
let
hsPkgs = import ./default.nix;
inherit (nixpkgs) pkgs;
mateamt =
haskellPackages.callPackage(
{ mkDerivation, aeson, base, base16-bytestring, base64-bytestring
, bytestring, case-insensitive, clock, containers, HsYAML
, http-api-data, http-types, iproute, mtl, network, opaleye
, optparse-applicative, postgresql-simple
, postgresql-simple-migration, product-profunctors, profunctors
, pureMD5, random-bytestring, servant, servant-rawm, servant-server
, stdenv, stm, text, time, wai, wai-logger, wai-middleware-throttle
, warp
}:
mkDerivation {
pname = "mateamt";
version = "0.0.0.0";
src = ../mateamt;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson base base16-bytestring base64-bytestring bytestring
containers http-api-data http-types mtl opaleye postgresql-simple
product-profunctors profunctors pureMD5 random-bytestring servant
servant-rawm servant-server stm text time wai wai-logger warp
];
executableHaskellDepends = [
base base16-bytestring bytestring case-insensitive clock containers
HsYAML iproute mtl network opaleye optparse-applicative
postgresql-simple postgresql-simple-migration servant
servant-server stm text time wai wai-logger wai-middleware-throttle
warp
];
description = "A whole new matemat";
license = stdenv.lib.licenses.agpl3;
}
) {};
HsYAML =
haskellPackages.callPackage(
{ mkDerivation, base, bytestring, containers, deepseq, mtl, parsec
, QuickCheck, stdenv, tasty, tasty-quickcheck, text
}:
mkDerivation {
pname = "HsYAML";
version = "0.2.1.0";
sha256 = "60f727d5c90e693ef71df7dcbed8f40b66d2db11375528043e0326749e861f83";
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
base bytestring containers deepseq mtl parsec text
];
testHaskellDepends = [
base bytestring containers mtl QuickCheck tasty tasty-quickcheck
text
];
homepage = "https://github.com/hvr/HsYAML";
description = "Pure Haskell YAML 1.2 processor";
license = stdenv.lib.licenses.gpl2;
}) {};
i18n =
haskellPackages.callPackage(
{ mkDerivation, base, containers, directory, filepath, hspec, mtl
, parsec, stdenv, tasty, tasty-hspec, text, transformers
}:
mkDerivation {
pname = "i18n";
version = "0.4.0.0";
sha256 = "7e0df375883fb3428b0cd20aac1163ea38de80fd3499ec3007979b36fe2f93fa";
revision = "1";
editedCabalFile = "1sxiifn4m17294inyb4q7isbdd3s77zpqxafghpbfkz5hkrv0xxg";
libraryHaskellDepends = [
base containers directory filepath mtl parsec text transformers
];
testHaskellDepends = [
base containers hspec tasty tasty-hspec text
];
doCheck = false;
homepage = "https://github.com/filib/i18n";
description = "Internationalization for Haskell";
license = stdenv.lib.licenses.bsd3;
}
) {};
f = { mkDerivation, aeson, base, base64-bytestring, blaze-html
, blaze-markup, bytestring, cookie, cryptonite, either, hashable
, http-api-data, http-client, http-types
, mtl, optparse-applicative, random-bytestring, servant
, servant-blaze, servant-client, servant-client-core, servant-rawm
, servant-server, split, stdenv, stm, text, wai, wai-app-static
, wai-logger, wai-session, warp
}:
mkDerivation {
pname = "matebeamter";
version = "0.0.0.0";
src = ./.;
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
aeson base base64-bytestring blaze-html blaze-markup bytestring
cookie cryptonite either hashable HsYAML http-api-data http-client
http-types i18n mateamt mtl optparse-applicative random-bytestring
servant servant-blaze servant-client servant-client-core
servant-rawm servant-server split stm text wai wai-app-static
wai-logger wai-session warp
];
description = "A reference frontent to mateamt";
license = stdenv.lib.licenses.agpl3;
};
haskellPackages = if compiler == "default"
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler};
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
drv = variant (haskellPackages.callPackage f {});
in
hsPkgs.matebeamter.components.all
if pkgs.lib.inNixShell then drv.env else drv

6
src/Control/Journal.hs
View file

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

10
src/Control/Product.hs
View file

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

14
src/Control/User.hs
View file

@ -103,7 +103,7 @@ userOverviewControl mcookie uid mRefine = do
(Right ud, Right prods) ->
case mMethod of
Just method ->
if fmap read mAuthUser == Just uid
if mAuthUser == Just uid
then
return $
userOverviewPage
@ -121,7 +121,7 @@ userOverviewControl mcookie uid mRefine = do
(Just $ userOverviewLink uid mRefine)
mRefine
Nothing ->
redirectOverAuth (read <$> mAuthUser) Nothing mRefine
redirectOverAuth mAuthUser Nothing mRefine
(Left uerr, Right _) -> case uerr of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
@ -202,7 +202,7 @@ userManageControl mcookie uid = do
backend
case (eUserDetails, eAuthOverviews) of
(Right userDetails, Right authOverviews) ->
if Just uid == fmap read mAuthUser
if Just uid == mAuthUser
then
return $
userManagePage l10n loc userDetails authOverviews version mcookie
@ -227,7 +227,7 @@ userManageDetailsSubmitControl mcookie uid uds = do
case eReturn of
Right _ -> throwError $ redirect303 (userManageLink uid)
Left err ->
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
userManageAuthCreateControl
:: Maybe T.Text
@ -247,7 +247,7 @@ userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) =
case eReturn of
Right _ -> throwError $ redirect303 $ userManageLink uid
Left err ->
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
handleErrors mAuthUser (Just $ userManageLink uid) [Just err]
userManageAuthDeleteControl
:: Maybe T.Text
@ -268,6 +268,6 @@ userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
then
throwError (redirect303 $ userManageLink uid)
else
handleErrors (fmap read mAuthUser) Nothing [Just err]
_ -> handleErrors (fmap read mAuthUser) (Just $ userSelectLink Nothing)
handleErrors mAuthUser Nothing [Just err]
_ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
[Just err]

6
src/Util.hs
View file

@ -97,13 +97,13 @@ parseCookieText = map
parseTokenAndUser
:: Maybe T.Text
-> (String, Maybe String)
-> (String, Maybe Int)
parseTokenAndUser mcookie =
(token, mAuthUser)
where
token = T.unpack $ fromMaybe "secret"
(lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$>
mAuthUser = read <$> T.unpack <$>
(lookup "x-auth-user" =<< mParsedCookie)
mParsedCookie = fmap parseCookieText mcookie
@ -189,7 +189,7 @@ productBgStyle aid = HA.style $ mconcat
controlInit
:: Maybe T.Text
-> UserHandler (String, Maybe String, Locale, L10n, ClientEnv, T.Text, T.Text)
-> UserHandler (String, Maybe Int, Locale, L10n, ClientEnv, T.Text, T.Text)
controlInit mcookie = do
let (token, muser) = parseTokenAndUser mcookie
loc = localeFromCookie mcookie

7
src/View/Journal.hs
View file

@ -51,13 +51,14 @@ journalPage l10n loc version mcookie mpage entries =
H.th (H.toHtml $ translate "Amount")
H.th (H.toHtml $ translate "Total amount")
mapM_
(\(MT.JournalEntry jid desc time amount total check) ->
(\(MT.JournalEntry jid time user action amount total) ->
H.tr
H.!? (check, HA.class_ "checked")
H.!? (action == MT.CashCheck, HA.class_ "checked")
$ do
H.td (H.toHtml $ show jid)
H.td (H.toHtml $ show time)
H.td (H.toHtml desc)
H.td (H.toHtml $ fromMaybe "" (show <$> user))
H.td (H.toHtml $ show action)
H.td (H.toHtml $ formatMoney amount)
H.td (H.toHtml $ formatMoney total)
)

24
src/View/Scaffold.hs
View file

@ -45,7 +45,7 @@ scaffold l10n locale version mcookie page content = template page $ do
(fromString $ show $ linkURI $ userOverviewLink (read uid) Nothing)) $
H.toHtml $ translate "User Page"
)
(getLogin mcookie)
(show <$> getLogin mcookie)
H.hr
when (isJust message)
(H.div H.! HA.id "message" H.! HA.class_ "message" $
@ -61,17 +61,17 @@ scaffold l10n locale version mcookie page content = template page $ do
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)
-- 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 $