This commit is contained in:
nek0 2019-09-16 09:44:46 +02:00
parent 11d0f8b7bc
commit 017484ff9d
11 changed files with 64 additions and 20 deletions

View File

@ -24,6 +24,7 @@ executable matebeamter
, Types
, Types.Page
, Types.Reader
, Types.Views
, Control
, Control.Auth
, Control.User

View File

@ -11,16 +11,23 @@
module API where
import Servant.API
import Servant.Links
import Servant.RawM
import Servant.HTML.Blaze
import Data.Proxy
-- internal imports
import Types
import View
type UserAPI =
Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> Get '[HTML] UserOverviewPage
:<|> "auth" :> Get '[HTML] AuthPage
( userSelectLink :<|>
userOverviewLink :<|>
authLink
) = allLinks (Proxy :: Proxy UserAPI)

View File

@ -19,11 +19,11 @@ import View
userSelectControl :: UserHandler UserSelectPage
userSelectControl = do
(ReadState mngr l10n) <- ask
(ReadState l10n backend) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userList (Nothing))
(mkClientEnv mngr (BaseUrl Http "localhost" 8000 ""))
(userList (Nothing))
backend
case euser of
Right uss ->
return $ userSelectPage l10n loc uss

14
src/Links.hs Normal file
View File

@ -0,0 +1,14 @@
module Links where
import Servant.Lnks
import Data.Proxy
-- internal imports
import API
( userSelectLink :<|>
userOverviewLink :<|>
authLink
) = allLinks (Proxy :: Proxy UserAPI)

View File

@ -2,6 +2,7 @@ module Main where
import Servant
import Servant.Server
import Servant.Client
import Network.Wai.Handler.Warp
import Network.Wai.Logger
@ -27,8 +28,9 @@ main = do
withStdoutLogger $ \ilog -> do
let settings = setPort 3000 $ setLogger ilog defaultSettings
initState = ReadState
{ rsManager = manager
, rsL10n = l10n
-- { rsManager = manager
{ rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
}
runSettings settings (userApp initState)

View File

@ -4,3 +4,4 @@ module Types
import Types.Page as T
import Types.Reader as T
import Types.Views as T

View File

@ -3,14 +3,16 @@ module Types.Reader where
import Network.HTTP.Client (Manager)
import Servant (Handler)
import Servant.Client (ClientEnv)
import Control.Monad.Reader (ReaderT)
import Data.Text.I18n
data ReadState = ReadState
{ rsManager :: Manager
, rsL10n :: L10n
-- { rsManager :: Manager
{ rsL10n :: L10n
, rsBackend :: ClientEnv
}
type UserHandler = ReaderT ReadState Handler

9
src/Types/Views.hs Normal file
View File

@ -0,0 +1,9 @@
module Types.Views where
import qualified Text.Blaze.Html5 as H
type UserSelectPage = H.Html
type UserOverviewPage = H.Html
type AuthPage = H.Html

View File

@ -11,8 +11,6 @@ import Types
import View.Scaffold
type AuthPage = H.Html
authPage
:: L10n
-> Locale

View File

@ -1,16 +1,21 @@
{-# LANGUAGE OverloadedStrings #-}
module View.Scaffold where
import Servant.Links
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as H
import qualified Data.Text as T
import Data.String (fromString)
import Data.Text.I18n
-- internal imports
import Types.Page
import API
scaffold
:: L10n
@ -20,7 +25,8 @@ scaffold
-> H.Html
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.li $ H.a H.! H.href (fromString $ show $ linkURI $ userSelectLink) $
H.toHtml $ localize l10n locale $ gettext "Home"
H.hr
H.div H.! H.id "main" H.! H.role "main" $ do
content

View File

@ -2,6 +2,8 @@
{-# LANGUAGE PackageImports #-}
module View.User where
import Servant.Links
import qualified Text.Blaze.Html5 as H hiding (style)
import qualified Text.Blaze.Html5.Attributes as H
@ -20,8 +22,7 @@ import qualified "mateamt" Types as MT
import Util
import Types
import View.Scaffold
type UserSelectPage = H.Html
import API
userSelectPage
:: L10n
@ -29,14 +30,17 @@ userSelectPage
-> [MT.UserSummary]
-> UserSelectPage
userSelectPage l10n locale uss = scaffold l10n locale (initPage $
(localize l10n locale $ gettext "Matebeamter") <>
(translate "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
(translate "Home")
) $ do
mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! H.href (fromString $ show $ linkURI $ userOverviewLink uid) $
H.toHtml ident
) uss
H.a H.! H.href ("#") $ H.toHtml $ translate "New user"
where
translate = localize l10n locale . gettext
userOverviewPage
:: L10n