make some sites

This commit is contained in:
nek0 2019-09-11 06:27:54 +02:00
parent 7ebe66dc56
commit 4bca537920
9 changed files with 134 additions and 40 deletions

View file

@ -43,12 +43,15 @@ executable matebeamter
, aeson
, blaze-html
, text
, bytestring
, warp
, wai
, wai-logger
, http-client
, mtl
, i18n
, cookie
, split
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

View file

@ -20,6 +20,7 @@ import Types
import View
type UserAPI =
"auth" :> Get '[HTML] AuthPage
Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> Get '[HTML] UserOverviewPage
:<|> "auth" :> Get '[HTML] AuthPage
:<|> "user" :> Capture "id" Int :> Get '[HTML] UserPage

View file

@ -2,40 +2,34 @@
{-# LANGUAGE PackageImports #-}
module Control.User where
import Servant.Server (Server)
import Servant.Client
import Servant.Client.Core.Auth
import Data.Aeson (decode)
import Data.Text.I18n
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Client
-- imports from mateamt
import qualified "mateamt" Types as MT
-- internal imports
import Types
import Client
import View
import Util
import API
userListControl :: Int -> UserHandler UserPage
userListControl uid = do
(ReadState manager l10n) <- ask
userSelectControl :: UserHandler UserSelectPage
userSelectControl = do
(ReadState mngr l10n) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userList (Nothing))
(mkClientEnv manager (BaseUrl Http "localhost" 8000 ""))
(mkClientEnv mngr (BaseUrl Http "localhost" 8000 ""))
case euser of
Right uss ->
return $ userPage l10n loc uss
return $ userSelectPage l10n loc uss
Left err ->
error $ show err
userOverviewControl :: Int -> UserHandler UserOverviewPage
userOverviewControl uid = do
error "Not yet implemented"

View file

@ -37,8 +37,9 @@ userApp initState = serveWithContext userApi (EmptyContext) $
userApi
Proxy
(`runReaderT` initState)
( authControl
:<|> userListControl
( userSelectControl
:<|> userOverviewControl
:<|> authControl
)
userApi :: Proxy UserAPI

View file

@ -3,8 +3,6 @@ module Types.Page where
import qualified Data.Text as T
import Data.Text.I18n
import qualified Text.Blaze.Html5 as H
data Page markup attr = Page
@ -30,19 +28,23 @@ instance (Semigroup m, Semigroup a) => Semigroup (Page m a)
instance (Monoid m, Monoid a) => Monoid (Page m a) where
mempty = Page mempty mempty mempty mempty
initPage :: Page H.Html (I18n T.Text)
initPage = Page (gettext "Matebeamter") mempty mempty mempty
initPage
:: T.Text
-> Page H.Html T.Text
initPage title = Page
title
mempty
mempty
mempty
template
:: Page H.Html (I18n T.Text)
-> L10n
-> Locale
:: Page H.Html T.Text
-> H.Html
-> H.Html
template (Page title favicon meta style) l10n locale content =
template (Page title favicon meta style) content =
H.docTypeHtml $ do
H.head $ do
H.title $ H.toHtml $ localize l10n locale title
H.title $ H.toHtml $ title
meta
favicon
style

View file

@ -4,10 +4,46 @@
module Util where
import Servant hiding (addHeader)
import Servant.Client
import Servant.Client.Core.Request
import Servant.Client.Core.Auth
import Servant.Client.Core.Request (addHeader)
import qualified Data.Text as T
import Data.Text.Lazy.Encoding
import Data.ByteString.Builder
import Data.List (intercalate)
import Data.List.Split (chunksOf)
import Data.String (fromString)
import Web.Cookie
import Text.Printf (printf)
authenticateReq
:: ToHttpApiData a
=> a
-> Servant.Client.Core.Request.Request
-> Servant.Client.Core.Request.Request
authenticateReq s req = addHeader "Authentication" s req
type instance AuthClientData (AuthProtect "header-auth") = String
setCookie
:: SetCookie
-> Request
-> Request
setCookie c = addHeader "Set-Cookie" (decodeUtf8 . toLazyByteString $ renderSetCookie c)
formatMoney :: Int -> T.Text
formatMoney amount = pre <> t <> "," <> c
where
pre = if amount < 0
then "-"
else ""
t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = fromString $ snd sp
sp = tail <$>
break (== '.') (printf "%.2f" (abs amount))

View file

@ -17,5 +17,15 @@ authPage
:: L10n
-> Locale
-> AuthPage
authPage l10n locale = scaffold l10n locale initPage $ do
H.p $ "Test"
authPage l10n locale = scaffold
l10n
locale
(initPage $
translate "Matebeamter" <>
" - " <>
translate "Authentication"
)
$ do
H.p $ "Test"
where
translate = localize l10n locale . gettext

View file

@ -15,10 +15,10 @@ import Types.Page
scaffold
:: L10n
-> Locale
-> Page H.Html (I18n T.Text)
-> Page H.Html T.Text
-> H.Html
-> H.Html
scaffold l10n locale page content = template page l10n locale $ do
scaffold l10n locale page content = template page $ do
H.header $ H.nav $ H.ul $ do
H.li $ H.a H.! H.href "/" $ H.toHtml $ localize l10n locale $ gettext "Home"
H.hr

View file

@ -2,32 +2,79 @@
{-# LANGUAGE PackageImports #-}
module View.User where
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5 as H hiding (style)
import qualified Text.Blaze.Html5.Attributes as H
import Data.Text.I18n
import Data.String (fromString)
import Data.Maybe (isJust, fromJust)
-- imports from mateamt
import qualified "mateamt" Types as MT
-- internal imports
import Util
import Types
import View.Scaffold
type UserPage = H.Html
type UserSelectPage = H.Html
userPage
userSelectPage
:: L10n
-> Locale
-> [MT.UserSummary]
-> UserPage
userPage l10n locale uss = scaffold l10n locale (initPage
{ pageTitle = gettext "Matebeamter - User list"
}) $ mapM_ (\(MT.UserSummary uid ident _) -> do
-> UserSelectPage
userSelectPage l10n locale uss = scaffold l10n locale (initPage $
(localize l10n locale $ gettext "Matebeamter") <>
" - " <>
(localize l10n locale $ gettext "Home")
) $ mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! H.href ("#" <> fromString (show uid)) $ H.toHtml ident
) uss
type UserOverviewPage = H.Html
userOverviewPage
:: L10n
-> Locale
-> MT.UserDetails
-> [MT.ProductShortOverview]
-> UserOverviewPage
userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
(localize l10n locale $ gettext "Matebeamter") <>
" - " <>
(localize l10n locale $ gettext "User Menu for ") <>
(MT.userDetailsIdent ud)
) $ do
H.p $ H.toHtml $ (translate "Welcome back, ") <> (MT.userDetailsIdent ud)
<> "!"
H.p H.!? (MT.userDetailsBalance ud < 0, H.class_ "debt") $ H.toHtml $
(translate "Your current balance is") <>
": " <>
(formatMoney $ MT.userDetailsBalance ud)
-- TODO: Add currency symbol
H.ul H.! H.class_ "product_list" $
mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
H.li H.! H.class_ "product" H.!?
(isJust avatarid
, productBgStyle (fromString $ show $ fromJust avatarid)
) $
H.a H.! H.href ("#" <> fromString (show pid)) $ H.toHtml ident
)
pos
where
translate = localize l10n locale . gettext
productBgStyle aid = H.style $ mconcat
[ "background-image: url(#" <> aid <> ");" -- FILLME
, "backgronud-color: blue;"
, "text-shadow:"
, " -1px 0 1px black,"
, " 0 1px 1px black,"
, " 1px 0 1px black,"
, " 0 -1px 1px black;"
]