adapt to journal entries with no description string

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

shell.nix

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

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

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

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 mAuthUser Nothing [Just err]
-      _ -> handleErrors (fmap read mAuthUser) (Just $ userSelectLink Nothing)
+      _ -> handleErrors mAuthUser (Just $ userSelectLink Nothing)
         [Just err]

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

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

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
+    -- maybe
-      (return ())
+    --   (return ())
-      (\_ ->
+    --   (\_ ->
-        H.button
+    --     H.button
-          H.! HA.class_ "btn btn-primary"
+    --       H.! HA.class_ "btn btn-primary"
-          H.! HA.formmethod "get"
+    --       H.! HA.formmethod "get"
-          H.! HA.formaction ("/" <>
+    --       H.! HA.formaction ("/" <>
-            (fromString $ show $ linkURI $ productGetRefillLink))
+    --         (fromString $ show $ linkURI $ productGetRefillLink))
-          $ H.toHtml $ translate "Refill stock"
+    --       $ H.toHtml $ translate "Refill stock"
-        )
+    --     )
-      (getLogin mcookie)
+    --   (getLogin mcookie)
     H.div
       H.! HA.class_ "backend-version"
       $ H.toHtml $