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 , aeson
, blaze-html , blaze-html
, text , text
, bytestring
, warp , warp
, wai , wai
, wai-logger , wai-logger
, http-client , http-client
, mtl , mtl
, i18n , i18n
, cookie
, split
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

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

View file

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

View file

@ -4,10 +4,46 @@
module Util where module Util where
import Servant hiding (addHeader) import Servant hiding (addHeader)
import Servant.Client import Servant.Client.Core.Request
import Servant.Client.Core.Auth import Servant.Client.Core.Auth
import Servant.Client.Core.Request (addHeader) 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 authenticateReq s req = addHeader "Authentication" s req
type instance AuthClientData (AuthProtect "header-auth") = String 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 :: L10n
-> Locale -> Locale
-> AuthPage -> AuthPage
authPage l10n locale = scaffold l10n locale initPage $ do authPage l10n locale = scaffold
H.p $ "Test" 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 scaffold
:: L10n :: L10n
-> Locale -> Locale
-> Page H.Html (I18n T.Text) -> Page H.Html T.Text
-> H.Html -> H.Html
-> 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.header $ H.nav $ H.ul $ do
H.li $ H.a H.! H.href "/" $ H.toHtml $ localize l10n locale $ gettext "Home" H.li $ H.a H.! H.href "/" $ H.toHtml $ localize l10n locale $ gettext "Home"
H.hr H.hr

View file

@ -2,32 +2,79 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
module View.User where 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 qualified Text.Blaze.Html5.Attributes as H
import Data.Text.I18n import Data.Text.I18n
import Data.String (fromString) import Data.String (fromString)
import Data.Maybe (isJust, fromJust)
-- imports from mateamt -- imports from mateamt
import qualified "mateamt" Types as MT import qualified "mateamt" Types as MT
-- internal imports -- internal imports
import Util
import Types import Types
import View.Scaffold import View.Scaffold
type UserPage = H.Html type UserSelectPage = H.Html
userPage userSelectPage
:: L10n :: L10n
-> Locale -> Locale
-> [MT.UserSummary] -> [MT.UserSummary]
-> UserPage -> UserSelectPage
userPage l10n locale uss = scaffold l10n locale (initPage userSelectPage l10n locale uss = scaffold l10n locale (initPage $
{ pageTitle = gettext "Matebeamter - User list" (localize l10n locale $ gettext "Matebeamter") <>
}) $ mapM_ (\(MT.UserSummary uid ident _) -> do " - " <>
(localize l10n locale $ gettext "Home")
) $ mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! H.href ("#" <> fromString (show uid)) $ H.toHtml ident H.a H.! H.href ("#" <> fromString (show uid)) $ H.toHtml ident
) uss ) 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;"
]