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
, Types.Page , Types.Page
, Types.Reader , Types.Reader
, Types.Views
, Control , Control
, Control.Auth , Control.Auth
, Control.User , Control.User

View file

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

View file

@ -19,11 +19,11 @@ import View
userSelectControl :: UserHandler UserSelectPage userSelectControl :: UserHandler UserSelectPage
userSelectControl = do userSelectControl = do
(ReadState mngr l10n) <- ask (ReadState l10n backend) <- ask
let loc = Locale "en" let loc = Locale "en"
euser <- liftIO $ runClientM euser <- liftIO $ runClientM
(userList (Nothing)) (userList (Nothing))
(mkClientEnv mngr (BaseUrl Http "localhost" 8000 "")) backend
case euser of case euser of
Right uss -> Right uss ->
return $ userSelectPage l10n loc 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
import Servant.Server import Servant.Server
import Servant.Client
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Network.Wai.Logger import Network.Wai.Logger
@ -27,8 +28,9 @@ main = do
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 { rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
} }
runSettings settings (userApp initState) runSettings settings (userApp initState)

View file

@ -4,3 +4,4 @@ module Types
import Types.Page as T import Types.Page as T
import Types.Reader 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 Network.HTTP.Client (Manager)
import Servant (Handler) import Servant (Handler)
import Servant.Client (ClientEnv)
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT)
import Data.Text.I18n import Data.Text.I18n
data ReadState = ReadState data ReadState = ReadState
{ rsManager :: Manager -- { rsManager :: Manager
, rsL10n :: L10n { rsL10n :: L10n
, rsBackend :: ClientEnv
} }
type UserHandler = ReaderT ReadState Handler 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 import View.Scaffold
type AuthPage = H.Html
authPage authPage
:: L10n :: L10n
-> Locale -> Locale

View file

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

View file

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