more blergh

This commit is contained in:
nek0 2019-09-08 17:27:38 +02:00
parent c86ab331cc
commit 7ebe66dc56
9 changed files with 95 additions and 17 deletions

View file

@ -20,7 +20,7 @@ executable matebeamter
main-is: Main.hs main-is: Main.hs
other-modules: API other-modules: API
, Client , Client
, AuthUtil , Util
, Types , Types
, Types.Page , Types.Page
, Types.Reader , Types.Reader
@ -28,6 +28,7 @@ executable matebeamter
, Control.Auth , Control.Auth
, Control.User , Control.User
, View , View
, View.Scaffold
, View.Auth , View.Auth
, View.User , View.User
-- other-extensions: -- other-extensions:
@ -47,5 +48,7 @@ executable matebeamter
, wai-logger , wai-logger
, http-client , http-client
, mtl , mtl
, i18n
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall

View file

@ -8,6 +8,8 @@ import Servant.Client.Core.Auth
import Data.Aeson (decode) import Data.Aeson (decode)
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)
@ -22,13 +24,18 @@ import qualified "mateamt" Types as MT
import Types import Types
import Client import Client
import View import View
import AuthUtil import Util
import API import API
userListControl :: Int -> UserHandler UserPage userListControl :: Int -> UserHandler UserPage
userListControl uid = do userListControl uid = do
manager <- liftIO $ newManager defaultManagerSettings (ReadState manager l10n) <- ask
muser <- liftIO $ runClientM let loc = Locale "en"
(userList (Just MT.All)) euser <- liftIO $ runClientM
(userList (Nothing))
(mkClientEnv manager (BaseUrl Http "localhost" 8000 "")) (mkClientEnv manager (BaseUrl Http "localhost" 8000 ""))
error (show muser) case euser of
Right uss ->
return $ userPage l10n loc uss
Left err ->
error $ show err

View file

@ -10,6 +10,9 @@ import Network.HTTP.Client hiding (Proxy)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Text.I18n
import Data.Text.I18n.Po
-- internal imports -- internal imports
import API import API
@ -20,10 +23,12 @@ import Control
main :: IO () main :: IO ()
main = do main = do
manager <- newManager defaultManagerSettings manager <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
let settings = setPort 3000 $ setLogger ilog defaultSettings let settings = setPort 3000 $ setLogger ilog defaultSettings
initState = ReadState initState = ReadState
{ rsManager = manager { rsManager = manager
, rsL10n = l10n
} }
runSettings settings (userApp initState) runSettings settings (userApp initState)

View file

@ -3,6 +3,8 @@ 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
@ -28,17 +30,19 @@ 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 T.Text initPage :: Page H.Html (I18n T.Text)
initPage = Page "Matebeamter" mempty mempty mempty initPage = Page (gettext "Matebeamter") mempty mempty mempty
template template
:: Page H.Html T.Text :: Page H.Html (I18n T.Text)
-> L10n
-> Locale
-> H.Html -> H.Html
-> H.Html -> H.Html
template (Page title favicon meta style) content = template (Page title favicon meta style) l10n locale content =
H.docTypeHtml $ do H.docTypeHtml $ do
H.head $ do H.head $ do
H.title $ H.toHtml $ title H.title $ H.toHtml $ localize l10n locale title
meta meta
favicon favicon
style style

View file

@ -6,8 +6,11 @@ import Servant (Handler)
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT)
import Data.Text.I18n
data ReadState = ReadState data ReadState = ReadState
{ rsManager :: Manager { rsManager :: Manager
, rsL10n :: L10n
} }
type UserHandler = ReaderT ReadState Handler type UserHandler = ReaderT ReadState Handler

View file

@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module AuthUtil where module Util where
import Servant hiding (addHeader) import Servant hiding (addHeader)
import Servant.Client import Servant.Client

View file

@ -3,10 +3,19 @@ module View.Auth where
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import Data.Text.I18n
-- internal imports
import Types import Types
import View.Scaffold
type AuthPage = H.Html type AuthPage = H.Html
authPage :: AuthPage authPage
authPage = template initPage $ do :: L10n
-> Locale
-> AuthPage
authPage l10n locale = scaffold l10n locale initPage $ do
H.p $ "Test" H.p $ "Test"

26
src/View/Scaffold.hs Normal file
View file

@ -0,0 +1,26 @@
{-# LANGUAGE OverloadedStrings #-}
module View.Scaffold where
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as H
import qualified Data.Text as T
import Data.Text.I18n
-- internal imports
import Types.Page
scaffold
:: L10n
-> Locale
-> Page H.Html (I18n T.Text)
-> H.Html
-> H.Html
scaffold l10n locale page content = template page l10n locale $ do
H.header $ H.nav $ H.ul $ do
H.li $ H.a H.! H.href "/" $ H.toHtml $ localize l10n locale $ gettext "Home"
H.hr
H.div H.! H.id "main" H.! H.role "main" $ do
content

View file

@ -1,12 +1,33 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module View.User where module View.User where
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as H
import Data.Text.I18n
import Data.String (fromString)
-- imports from mateamt
import qualified "mateamt" Types as MT
-- internal imports
import Types import Types
import View.Scaffold
type UserPage = H.Html type UserPage = H.Html
userPage :: UserPage userPage
userPage = template initPage $ do :: L10n
H.p $ "Test" -> Locale
-> [MT.UserSummary]
-> UserPage
userPage l10n locale uss = scaffold l10n locale (initPage
{ pageTitle = gettext "Matebeamter - User list"
}) $ mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! H.href ("#" <> fromString (show uid)) $ H.toHtml ident
) uss