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

View file

@ -8,6 +8,8 @@ import Servant.Client.Core.Auth
import Data.Aeson (decode)
import Data.Text.I18n
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
@ -22,13 +24,18 @@ import qualified "mateamt" Types as MT
import Types
import Client
import View
import AuthUtil
import Util
import API
userListControl :: Int -> UserHandler UserPage
userListControl uid = do
manager <- liftIO $ newManager defaultManagerSettings
muser <- liftIO $ runClientM
(userList (Just MT.All))
(ReadState manager l10n) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userList (Nothing))
(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 Data.Text.I18n
import Data.Text.I18n.Po
-- internal imports
import API
@ -20,10 +23,12 @@ import Control
main :: IO ()
main = do
manager <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do
let settings = setPort 3000 $ setLogger ilog defaultSettings
initState = ReadState
{ rsManager = manager
, rsL10n = l10n
}
runSettings settings (userApp initState)

View file

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

View file

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

View file

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

View file

@ -3,10 +3,19 @@ module View.Auth where
import qualified Text.Blaze.Html5 as H
import Data.Text.I18n
-- internal imports
import Types
import View.Scaffold
type AuthPage = H.Html
authPage :: AuthPage
authPage = template initPage $ do
authPage
:: L10n
-> Locale
-> AuthPage
authPage l10n locale = scaffold l10n locale initPage $ do
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 PackageImports #-}
module View.User where
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 View.Scaffold
type UserPage = H.Html
userPage :: UserPage
userPage = template initPage $ do
H.p $ "Test"
userPage
:: L10n
-> 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