From 4bca5379204edaba29ceb02c16be4e207699f767 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 11 Sep 2019 06:27:54 +0200 Subject: [PATCH] make some sites --- matebeamter.cabal | 3 +++ src/API.hs | 5 ++-- src/Control/User.hs | 24 +++++++---------- src/Main.hs | 5 ++-- src/Types/Page.hs | 20 ++++++++------- src/Util.hs | 38 ++++++++++++++++++++++++++- src/View/Auth.hs | 14 ++++++++-- src/View/Scaffold.hs | 4 +-- src/View/User.hs | 61 +++++++++++++++++++++++++++++++++++++++----- 9 files changed, 134 insertions(+), 40 deletions(-) diff --git a/matebeamter.cabal b/matebeamter.cabal index 5fdf84e..cc3e023 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -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 diff --git a/src/API.hs b/src/API.hs index c99d467..5494a53 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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 diff --git a/src/Control/User.hs b/src/Control/User.hs index 48451d5..ac261cb 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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" diff --git a/src/Main.hs b/src/Main.hs index 83534ea..2e07cd2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -37,8 +37,9 @@ userApp initState = serveWithContext userApi (EmptyContext) $ userApi Proxy (`runReaderT` initState) - ( authControl - :<|> userListControl + ( userSelectControl + :<|> userOverviewControl + :<|> authControl ) userApi :: Proxy UserAPI diff --git a/src/Types/Page.hs b/src/Types/Page.hs index 01ec38a..4e3401b 100644 --- a/src/Types/Page.hs +++ b/src/Types/Page.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index 45b7dbc..9f9fead 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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)) diff --git a/src/View/Auth.hs b/src/View/Auth.hs index 8ab15d7..5917aec 100644 --- a/src/View/Auth.hs +++ b/src/View/Auth.hs @@ -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 diff --git a/src/View/Scaffold.hs b/src/View/Scaffold.hs index 28ff489..d4dfcc5 100644 --- a/src/View/Scaffold.hs +++ b/src/View/Scaffold.hs @@ -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 diff --git a/src/View/User.hs b/src/View/User.hs index 39adef7..148c7e6 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -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;" + ]