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

I did way too much here. Polishing, fixing redirection etc.

Browse source
This commit is contained in:
nek0 2019-12-26 09:41:31 +01:00
parent f2f9f46c4e
commit 74a666f092
18 changed files with 180 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
matebeamter.cabal
View file

@ -46,6 +46,7 @@ executable matebeamter
, View.Buy
, View.Journal
, View.Product
, Paths_matebeamter
-- other-extensions:
build-depends: base ^>=4.12.0.0
, mateamt

3
src/API.hs
View file

@ -27,7 +27,8 @@ import qualified "mateamt" Types as MT
import Types
type UserAPI =
Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
Header "Cookie" T.Text :> (
QueryParam "refine" MT.UserRefine :> Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] UserOverviewPage
:<|> "user" :> Capture "id" Int :> "buy"

16
src/Control/Auth.hs
View file

@ -117,9 +117,10 @@ authPostControl
-> Maybe T.Text
-> AuthReturn
-> UserHandler UserSelectPage
authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
authPostControl mcookies@(Just cookies) mDestination (AuthReturn pass method) = do
let mticket = lookup ("x-ticket-" <> fromString (show method)) $
parseCookieText cookies
(_, _, loc, l10n, _, _, _) <- controlInit mcookies
case mticket of
Just ticket -> do
(ReadState _ backend _ _ _) <- ask
@ -145,7 +146,7 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
(read $ T.unpack user)
Nothing
)
_ -> errHeaders $ redirect303 userSelectLink
_ -> errHeaders $ redirect303 (userSelectLink Nothing)
throwError $ err303
{ errHeaders = headers ++
[ ( "Set-Cookie"
@ -158,15 +159,18 @@ authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
, "x-method=" <> fromString (show $ fromEnum method) <>";Path=/")
]
}
Right MT.Denied -> throwError $ err401
{ errBody = "Authentication failed!"
}
Right MT.Denied -> throwError (
addMessage (translate l10n loc "Authentication failed!") $
redirect303 (userSelectLink Nothing)
)
Left err -> throwError $ err500
{ errBody = fromString $ show err
}
Nothing -> throwError $ err400
{ errBody = "No ticket cookie present."
}
where
translate l10n locale = localize l10n locale . gettext
authPostControl Nothing _ _ = throwError $ err400
{ errBody = "No ticket cookie present."
}
@ -184,7 +188,7 @@ authLogoutControl mcookie = do
backend
case eReturn of
Right _ -> do
let redirectHeaders = errHeaders (redirect303 userSelectLink)
let redirectHeaders = errHeaders (redirect303 $ userSelectLink Nothing)
unsetCookiesHeaders = map
(\c ->
( "Set-Cookie"

29
src/Control/Buy.hs
View file

@ -42,14 +42,14 @@ buyControl
-> [MT.PurchaseDetail]
-> Bool
-> UserHandler BuyConfirmPage
buyControl mcookie uid pds forceBuy =
buyControl mcookie uid pds forceBuy = do
(ReadState l10n backend _ symbol version) <- ask
let (token, _) = parseTokenAndUser mcookie
loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
if not (null pds)
then do
(ReadState l10n backend _ symbol version) <- ask
let (token, _) = parseTokenAndUser mcookie
loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
pids = map MT.purchaseDetailProduct pds
let pids = map MT.purchaseDetailProduct pds
epsovs <- liftIO $ runClientM
(productShortList (Just MT.AllProducts))
backend
@ -85,9 +85,14 @@ buyControl mcookie uid pds forceBuy =
Left err ->
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
else
throwError (redirect303 $ userOverviewLink uid Nothing)
throwError (
addMessage (translate l10n loc "Please select items for purchase") $
redirect303 (userOverviewLink uid Nothing)
)
where
translate l10n locale = localize l10n locale . gettext
purchaseControl
:: Maybe T.Text
@ -179,7 +184,7 @@ purchaseControl mcookie uid pds forceBuy = do
backend
throwError
$ addMessage message
$ redirect303 userSelectLink
$ redirect303 (userSelectLink Nothing)
translate l10n locale = localize l10n locale . gettext
cashBuyOverviewControl
@ -240,7 +245,7 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
addMessage
(translate l10n loc "Please Pay" <>
": " <> formatMoney price <> symbol) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
(MT.PurchaseResult (MT.PayAmount price) miss) -> do
eproducts <- liftIO $ runClientM
(productShortList
@ -268,13 +273,13 @@ cashBuyPurchaseControl mcookie {-forceBuy-} pds = do
[]
prods
))
$ redirect303 userSelectLink
$ redirect303 (userSelectLink Nothing)
Left err ->
throwError $ err500
{ errBody = fromString (show err)
}
Left err ->
handleClientErr err Nothing (Just userSelectLink)
handleClientErr err Nothing (Just (userSelectLink Nothing))
else
throwError
$ addMessage (translate l10n loc "Please choose your product(s)")

4
src/Control/Journal.hs
View file

@ -59,11 +59,11 @@ journalControl mcookie mpage = do
else
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
othererr ->
throwError $
addMessage (fromString $ show othererr) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
Nothing ->
redirectOverAuth Nothing (Just $ journalLink mpage) Nothing

4
src/Control/Product.hs
View file

@ -45,7 +45,7 @@ productGetPriceList mcookie mrefine = do
Left err ->
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
productGetRefill
:: Maybe T.Text
@ -63,7 +63,7 @@ productGetRefill mcookie = do
Left err ->
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
Nothing ->
redirectOverAuth Nothing (Just productGetRefillLink) Nothing

14
src/Control/User.hs
View file

@ -36,13 +36,16 @@ import Hash
import API
import Util
userSelectControl :: Maybe T.Text -> UserHandler UserSelectPage
userSelectControl mcookie = do
userSelectControl
:: Maybe T.Text
-> Maybe MT.UserRefine
-> UserHandler UserSelectPage
userSelectControl mcookie mrefine = do
(ReadState l10n backend _ symbol version) <- ask
let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
euser <- liftIO $ runClientM
(userList Nothing)
(userList mrefine)
backend
case euser of
Right uss ->
@ -69,7 +72,7 @@ userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do
{ MT.userSubmitPassHash = hashedPass
})
backend
throwError $ redirect303 userSelectLink
throwError $ redirect303 (userSelectLink Nothing)
userOverviewControl
:: Maybe T.Text
@ -266,4 +269,5 @@ userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
throwError (redirect303 $ userManageLink uid)
else
handleErrors (fmap read mAuthUser) Nothing [Just err]
_ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]
_ -> handleErrors (fmap read mAuthUser) (Just $ userSelectLink Nothing)
[Just err]

7
src/Types/Page.hs
View file

@ -39,7 +39,12 @@ initPage title = Page
(H.link
H.! HA.rel "stylesheet"
H.! HA.type_ "text/css"
H.! HA.href "/static/css/style.css"
H.! HA.href "/static/css/bootstrap.min.css"
<>
H.link
H.! HA.rel "stylesheet"
H.! HA.type_ "text/css"
H.! HA.href "/static/css/style.css"
)
template

6
src/Util.hs
View file

@ -152,7 +152,7 @@ redirectOverAuth muid mLink mRefine = do
fromString (show $ linkURI (case (mLink, muid) of
(Just link, _) -> link
(Nothing, Just uid) -> userOverviewLink uid mRefine
_ -> userSelectLink
_ -> userSelectLink Nothing
))))
throwError
(err303
@ -205,8 +205,8 @@ handleClientErr err muid authTargetLink =
else
throwError $
addMessage (fromString $ show err) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)
othererr ->
throwError $
addMessage (fromString $ show othererr) $
redirect303 userSelectLink
redirect303 (userSelectLink Nothing)

2
src/View/Auth.hs
View file

@ -72,7 +72,7 @@ authPage l10n locale mDestination version mcookie = scaffold
H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where

35
src/View/Buy.hs
View file

@ -116,13 +116,14 @@ buyConfirmPage l10n locale uid ziptups total forceBuy version mcookie symbol =
H.toHtml symbol
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ if forceBuy
then translate "Buy anyway"
else translate "Buy"
when forceBuy $
H.button
H.! HA.class_ "btn btn-primary"
H.! HA.formnovalidate "formnovalidate"
H.! HA.formmethod "get"
H.! HA.formaction
@ -143,25 +144,23 @@ buyProductsForm l10n locale prods = do
mapM_ (\(MT.ProductShortOverview pid ident price amount ml maid) ->
H.div
H.! HA.class_ "tile"
H.!?
( isJust maid
, productBgStyle (fromString $ show $ fromJust maid)
)
$ do
H.div
H.label
H.! HA.for ("product-select-" <> fromString (show pid)) $
H.toHtml ident
H.! HA.class_ "tile-content form-group optional"
H.!?
( isJust maid
, productBgStyle (fromString $ show $ fromJust maid)
)
$ do
H.label
H.! HA.for ("product-select-" <> fromString (show pid)) $
H.toHtml ident
H.input
H.! HA.id ("product-select-" <> fromString (show pid))
H.! HA.class_ "form-control product-select"
H.! HA.name ("productSelect-" <> fromString (show pid))
H.! HA.type_ "checkbox"
H.! HA.value "true"
H.div
H.input
H.! HA.id ("product-select-" <> fromString (show pid))
H.! HA.class_ "form-control product-select"
H.! HA.class_ "tile-content form-group optional"
H.! HA.name ("productSelect-" <> fromString (show pid))
H.! HA.type_ "checkbox"
-- H.! HA.value "true"
H.div
$ do
H.label
H.! HA.for ("product-amount-" <> fromString (show pid)) $
@ -178,7 +177,7 @@ buyProductsForm l10n locale prods = do
prods
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Proceed"
where

3
src/View/Journal.hs
View file

@ -80,6 +80,7 @@ journalPage l10n loc version mcookie mpage entries =
$ H.toHtml $ translate "Next Page"
H.form $
H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
H.! HA.formmethod "get"
H.! HA.formaction
@ -124,7 +125,7 @@ journalCheckPage l10n loc version mcookie =
H.! HA.value "0"
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where

4
src/View/Product.hs
View file

@ -154,7 +154,7 @@ productRefillPage l10n loc version mcookie prodList =
prodList
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where
@ -288,7 +288,7 @@ productNewPage l10n loc version mcookie symbol =
-}
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where

14
src/View/Scaffold.hs
View file

@ -14,8 +14,12 @@ import Data.Text.I18n
import Data.Maybe (fromJust, isJust)
import Data.Version (showVersion)
import Control.Monad (when)
import qualified Paths_matebeamter as MyPath (version)
-- internal imports
import Types.Page
@ -32,7 +36,7 @@ scaffold
-> H.Html
scaffold l10n locale version mcookie page content = template page $ do
H.header $ H.nav $ H.ul $ do
H.li $ H.a H.! HA.href ("/" <> fromString (show $ linkURI userSelectLink)) $
H.li $ H.a H.! HA.href ("/" <> fromString (show $ linkURI (userSelectLink Nothing))) $
H.toHtml $ translate "Home"
maybe
(return ())
@ -52,6 +56,7 @@ scaffold l10n locale version mcookie page content = template page $ do
H.hr
H.footer $ H.form $ do
H.button
H.! HA.class_ "btn btn-primary"
H.! HA.formmethod "get"
H.! HA.formaction ("/" <>
(fromString $ show $ linkURI $ productGetPriceListLink Nothing))
@ -60,6 +65,7 @@ scaffold l10n locale version mcookie page content = template page $ do
(return ())
(\_ ->
H.button
H.! HA.class_ "btn btn-primary"
H.! HA.formmethod "get"
H.! HA.formaction ("/" <>
(fromString $ show $ linkURI $ productGetRefillLink))
@ -68,7 +74,11 @@ scaffold l10n locale version mcookie page content = template page $ do
(getLogin mcookie)
H.div
H.! HA.class_ "backend-version"
$ H.toHtml $ (translate "Powered by mateamt version") <> " " <> version
$ H.toHtml $
(translate "Powered by ") <> "matebeamter " <>
(fromString $ showVersion MyPath.version) <> " " <>
(translate "connected to ") <> "mateamt " <>
version
where
message = lookup "message" =<< fmap parseCookieText mcookie
translate = localize l10n locale . gettext

29
src/View/User.hs
View file

@ -42,8 +42,8 @@ userSelectPage l10n locale uss version mcookie =
) $ H.ul
H.! HA.class_ "tile-list"
$ do
H.li H.! HA.class_ "tile" $ H.a
H.! HA.class_ "tile-content function"
H.li H.! HA.class_ "tile function" $ H.a
H.! HA.class_ "tile-content"
H.! HA.href ("/" <> fromString
(show $ linkURI $ cashBuyLink Nothing)
) $
@ -55,8 +55,13 @@ userSelectPage l10n locale uss version mcookie =
userOverviewLink uid Nothing)) $
H.toHtml ident
) uss
H.li H.! HA.class_ "tile" $ H.a
H.! HA.class_ "tile-content function"
H.li H.! HA.class_ "tile function" $ H.a
H.! HA.class_ "tile-content"
H.! HA.href ("/" <> fromString
(show $ linkURI $ userSelectLink (Just MT.OldUsers))) $
H.toHtml $ translate "Show inactive users"
H.li H.! HA.class_ "tile function" $ H.a
H.! HA.class_ "tile-content"
H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
H.toHtml $ translate "New user"
where
@ -91,7 +96,7 @@ userOverviewPage l10n locale method ud pos version mcookie symbol =
H.! HA.enctype "application/x-www-form-urlencoded" $
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Logout"
case method of
@ -107,6 +112,7 @@ userOverviewPage l10n locale method ud pos version mcookie symbol =
buyForm = do
H.div $ H.form $
H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
H.! HA.formmethod "get"
H.! HA.formaction ("/" <>
@ -129,18 +135,21 @@ userSettingsPointer
userSettingsPointer l10n locale uid =
H.form $ do
H.button
H.! HA.class_ "btn btn-primary"
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.class_ "btn btn-primary"
H.! HA.type_ "submit"
H.! HA.formmethod "get"
H.! HA.formaction
("/" <> fromString (show $ linkURI $ journalLink Nothing))
$ H.toHtml $ translate "View Journal"
H.button
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
H.! HA.formmethod "get"
H.! HA.formaction
@ -214,7 +223,7 @@ userNewPage l10n locale version mcookie =
H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where
@ -251,7 +260,7 @@ userRechargePage l10n locale version mcookie uid symbol =
H.toHtml symbol
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Recharge"
where
@ -301,7 +310,7 @@ userManagePage l10n locale userDetails authOverviews version mcookie =
(MT.userDetailsEmail userDetails))
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
H.p $ do
@ -330,7 +339,7 @@ userManagePage l10n locale userDetails authOverviews version mcookie =
H.! HA.value (fromString $ show aoid)
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Delete"
)
@ -379,7 +388,7 @@ userManagePage l10n locale userDetails authOverviews version mcookie =
H.toHtml $ translate "Primary password"
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-primary"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where

7
static/css/bootstrap.min.css vendored Normal file
View file

File diff suppressed because one or more lines are too long

1
static/css/bootstrap.min.css.map Normal file
View file

File diff suppressed because one or more lines are too long

82
static/css/style.css
View file

@ -1,16 +1,26 @@
.tile-content {
flex: 1 1 auto;
background-color: #36c30023;
display: flex;
justify-content: center;
flex-direction: column;
:root {
--tile-color: #36c30023;
--function-tile-color: #c300d223;
}
.tile-content * {
body {
margin: 30px;
}
.tile-content label, .tile-content div {
width: 100%;
form button, nav ul > li {
margin: 5px;
}
.tile-list, nav ul {
list-style: none;
padding: 0;
}
nav ul > li {
display: inline-block;
border-radius: 6px;
background-color: var(--function-tile-color);
padding : 10px;
}
.tile {
@ -18,21 +28,63 @@
flex-direction: column;
align-content: stretch;
align-items: stretch;
justify-content: stretch;
justify-content: center;
border-radius: 6px;
background-color: var(--tile-color);
box-shadow: 0 0 3px #c3c3c3;
margin: 30px 15px 0;
margin: 30px 30px 0 5px;
width: 200px;
height: 200px;
text-align: center;
}
.function {
background-color: #c300d223
.tile > label, .tile > * {
flex: 1 1 auto;
}
.tile-list {
list-style: none;
.tile-content {
flex: 1 1 auto;
display: flex;
justify-content: center;
flex-direction: column;
align-content: stretch;
align-items: stretch;
}
.tile-content * {
flex: 1 1 auto;
display: inline-block;
width: 100%;
justify-content: center;
flex-direction: column;
align-content: stretch;
align-items: stretch;
margin: 0;
padding: 0;
}
.tile input[type="checkbox"] {
display: none;
}
.tile input[type="checkbox"] + * {
display: none;
opacity: 0;
transition: opacity 0.5s;
}
.tile input[type="checkbox"]:checked + * {
display: inline-block;
opacity: 1;
transition: opacity 0.5s;
}
.function {
background-color: var(--function-tile-color);
}
.tile-list + * {
margin-top: 30px;
}
hr {