add Journal

This commit is contained in:
nek0 2019-11-02 22:53:23 +01:00
parent 4d56de5469
commit 048fdaa4fa
9 changed files with 172 additions and 2 deletions

View file

@ -35,11 +35,13 @@ executable matebeamter
, Control.Auth , Control.Auth
, Control.User , Control.User
, Control.Buy , Control.Buy
, Control.Journal
, View , View
, View.Scaffold , View.Scaffold
, View.Auth , View.Auth
, View.User , View.User
, View.Buy , View.Buy
, View.Journal
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base ^>=4.12.0.0
, mateamt , mateamt

View file

@ -56,6 +56,8 @@ type UserAPI =
:<|> "user" :> "create" :> Get '[HTML] UserNewPage :<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "journal" :> QueryParam "page" Word
:> Get '[HTML] JournalPage
:<|> "auth" :<|> "auth"
:> QueryParam "destination" T.Text :> QueryParam "destination" T.Text
:> Get '[HTML] :> Get '[HTML]
@ -83,6 +85,7 @@ type UserAPI =
userManageAuthDeleteLink :<|> userManageAuthDeleteLink :<|>
userNewLink :<|> userNewLink :<|>
userNewPostLink :<|> userNewPostLink :<|>
journalLink :<|>
authLink :<|> authLink :<|>
authPostLink :<|> authPostLink :<|>
authLogoutLink authLogoutLink

View file

@ -5,3 +5,4 @@ module Control
import Control.Auth as C import Control.Auth as C
import Control.User as C import Control.User as C
import Control.Buy as C import Control.Buy as C
import Control.Journal as C

68
src/Control/Journal.hs Normal file
View file

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

View file

@ -80,6 +80,7 @@ userApp initState = serveWithContext userApi EmptyContext $
:<|> userManageAuthDeleteControl mcookie :<|> userManageAuthDeleteControl mcookie
:<|> userNewControl mcookie :<|> userNewControl mcookie
:<|> userNewPostControl mcookie :<|> userNewPostControl mcookie
:<|> journalControl mcookie
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
:<|> authLogoutControl mcookie :<|> authLogoutControl mcookie

View file

@ -17,3 +17,5 @@ type ProductListPage = H.Html
type AuthPage = H.Html type AuthPage = H.Html
type BuyConfirmPage = H.Html type BuyConfirmPage = H.Html
type JournalPage = H.Html

View file

@ -5,3 +5,4 @@ module View
import View.Auth as V import View.Auth as V
import View.User as V import View.User as V
import View.Buy as V import View.Buy as V
import View.Journal as V

81
src/View/Journal.hs Normal file
View file

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

View file

@ -113,8 +113,19 @@ userSettingsPointer
-> Int -> Int
-> H.Html -> H.Html
userSettingsPointer l10n locale uid = userSettingsPointer l10n locale uid =
H.a H.! HA.href ("/" <> fromString (show $ linkURI $ userManageLink uid)) $ H.form $ do
H.toHtml $ translate "Manage user settings" 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 where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext