diff --git a/matebeamter.cabal b/matebeamter.cabal index 62cb42c..b8cbcb1 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -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 diff --git a/shell.nix b/shell.nix index cad3e28..b2b9849 100644 --- a/shell.nix +++ b/shell.nix @@ -1,6 +1,125 @@ -{ pkgs ? import {} }: +{ nixpkgs ? import {}, 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 diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 52944d6..bca8cf2 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -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 diff --git a/src/Control/Product.hs b/src/Control/Product.hs index a7df2d9..91847ca 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -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 diff --git a/src/Control/User.hs b/src/Control/User.hs index f425eab..79146a3 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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] diff --git a/src/Util.hs b/src/Util.hs index 641c51d..3f66c42 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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 diff --git a/src/View/Journal.hs b/src/View/Journal.hs index abc494e..07088aa 100644 --- a/src/View/Journal.hs +++ b/src/View/Journal.hs @@ -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) ) diff --git a/src/View/Scaffold.hs b/src/View/Scaffold.hs index 70845c9..e73b8f9 100644 --- a/src/View/Scaffold.hs +++ b/src/View/Scaffold.hs @@ -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 $