From 048fdaa4fa5cc2497aab7d68341deed48ac10cec Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 2 Nov 2019 22:53:23 +0100 Subject: [PATCH] add Journal --- matebeamter.cabal | 2 ++ src/API.hs | 3 ++ src/Control.hs | 1 + src/Control/Journal.hs | 68 +++++++++++++++++++++++++++++++++++ src/Main.hs | 1 + src/Types/Views.hs | 2 ++ src/View.hs | 1 + src/View/Journal.hs | 81 ++++++++++++++++++++++++++++++++++++++++++ src/View/User.hs | 15 ++++++-- 9 files changed, 172 insertions(+), 2 deletions(-) create mode 100644 src/Control/Journal.hs create mode 100644 src/View/Journal.hs diff --git a/matebeamter.cabal b/matebeamter.cabal index d317b9c..72ad6f4 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -35,11 +35,13 @@ executable matebeamter , Control.Auth , Control.User , Control.Buy + , Control.Journal , View , View.Scaffold , View.Auth , View.User , View.Buy + , View.Journal -- other-extensions: build-depends: base ^>=4.12.0.0 , mateamt diff --git a/src/API.hs b/src/API.hs index fbc4f27..3aa2484 100644 --- a/src/API.hs +++ b/src/API.hs @@ -56,6 +56,8 @@ type UserAPI = :<|> "user" :> "create" :> Get '[HTML] UserNewPage :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :> Post '[HTML] UserSelectPage + :<|> "journal" :> QueryParam "page" Word + :> Get '[HTML] JournalPage :<|> "auth" :> QueryParam "destination" T.Text :> Get '[HTML] @@ -83,6 +85,7 @@ type UserAPI = userManageAuthDeleteLink :<|> userNewLink :<|> userNewPostLink :<|> + journalLink :<|> authLink :<|> authPostLink :<|> authLogoutLink diff --git a/src/Control.hs b/src/Control.hs index 8a5ef45..3bd5729 100644 --- a/src/Control.hs +++ b/src/Control.hs @@ -5,3 +5,4 @@ module Control import Control.Auth as C import Control.User as C import Control.Buy as C +import Control.Journal as C diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs new file mode 100644 index 0000000..2e4da1c --- /dev/null +++ b/src/Control/Journal.hs @@ -0,0 +1,68 @@ +{-# 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.Maybe (fromMaybe) + +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 + let (token, muser) = parseTokenAndUser mcookie + loc = localeFromCookie mcookie + l10n <- asks rsL10n + backend <- asks rsBackend + case muser of + Just user -> do + eresult <- liftIO $ runClientM + (journalShow + (mkAuthenticatedRequest token authenticateReq) + (Just 50) + (Just $ 50 * fromMaybe 0 (fromIntegral <$> mpage)) + ) + backend + case eresult of + Right entries -> + return (journalPage l10n loc 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 + othererr -> + throwError $ + addMessage (fromString $ show othererr) $ + redirect303 userSelectLink diff --git a/src/Main.hs b/src/Main.hs index be993ed..29f40c4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -80,6 +80,7 @@ userApp initState = serveWithContext userApi EmptyContext $ :<|> userManageAuthDeleteControl mcookie :<|> userNewControl mcookie :<|> userNewPostControl mcookie + :<|> journalControl mcookie :<|> authControl mcookie :<|> authPostControl mcookie :<|> authLogoutControl mcookie diff --git a/src/Types/Views.hs b/src/Types/Views.hs index 51a7ef8..eaa614f 100644 --- a/src/Types/Views.hs +++ b/src/Types/Views.hs @@ -17,3 +17,5 @@ type ProductListPage = H.Html type AuthPage = H.Html type BuyConfirmPage = H.Html + +type JournalPage = H.Html diff --git a/src/View.hs b/src/View.hs index 7b55893..cf121e8 100644 --- a/src/View.hs +++ b/src/View.hs @@ -5,3 +5,4 @@ module View import View.Auth as V import View.User as V import View.Buy as V +import View.Journal as V diff --git a/src/View/Journal.hs b/src/View/Journal.hs new file mode 100644 index 0000000..b20ad90 --- /dev/null +++ b/src/View/Journal.hs @@ -0,0 +1,81 @@ +{-# 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 + -> Maybe T.Text + -> Maybe Word + -> [MT.JournalEntry] + -> H.Html +journalPage l10n loc mcookie mpage entries = + scaffold l10n loc 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 desc time amount total check) -> + H.tr + H.!? (check, 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 $ 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" + where + translate = localize l10n loc . gettext diff --git a/src/View/User.hs b/src/View/User.hs index 1e707a3..c5a1db2 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -113,8 +113,19 @@ userSettingsPointer -> Int -> H.Html userSettingsPointer l10n locale uid = - H.a H.! HA.href ("/" <> fromString (show $ linkURI $ userManageLink uid)) $ - H.toHtml $ translate "Manage user settings" + H.form $ do + H.button + 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.type_ "submit" + H.! HA.formmethod "get" + H.! HA.formaction + ("/" <> fromString (show $ linkURI $ journalLink Nothing)) + $ H.toHtml $ translate "View Journal" where translate = localize l10n locale . gettext