diff --git a/matebeamter.cabal b/matebeamter.cabal index cc3e023..5c34a5e 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -24,6 +24,7 @@ executable matebeamter , Types , Types.Page , Types.Reader + , Types.Views , Control , Control.Auth , Control.User diff --git a/src/API.hs b/src/API.hs index 5494a53..1a256b4 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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) diff --git a/src/Control/User.hs b/src/Control/User.hs index ac261cb..0bfd0ae 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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 diff --git a/src/Links.hs b/src/Links.hs new file mode 100644 index 0000000..5c08360 --- /dev/null +++ b/src/Links.hs @@ -0,0 +1,14 @@ +module Links where + +import Servant.Lnks + +import Data.Proxy + +-- internal imports + +import API + +( userSelectLink :<|> + userOverviewLink :<|> + authLink + ) = allLinks (Proxy :: Proxy UserAPI) diff --git a/src/Main.hs b/src/Main.hs index 2e07cd2..4a6b2af 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs index 57fa76a..9f99c3f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -4,3 +4,4 @@ module Types import Types.Page as T import Types.Reader as T +import Types.Views as T diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs index 7c5b63f..bd4f82c 100644 --- a/src/Types/Reader.hs +++ b/src/Types/Reader.hs @@ -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 diff --git a/src/Types/Views.hs b/src/Types/Views.hs new file mode 100644 index 0000000..ed5a043 --- /dev/null +++ b/src/Types/Views.hs @@ -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 diff --git a/src/View/Auth.hs b/src/View/Auth.hs index 5917aec..75cea1c 100644 --- a/src/View/Auth.hs +++ b/src/View/Auth.hs @@ -11,8 +11,6 @@ import Types import View.Scaffold -type AuthPage = H.Html - authPage :: L10n -> Locale diff --git a/src/View/Scaffold.hs b/src/View/Scaffold.hs index d4dfcc5..a3c30cc 100644 --- a/src/View/Scaffold.hs +++ b/src/View/Scaffold.hs @@ -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 diff --git a/src/View/User.hs b/src/View/User.hs index 148c7e6..7c527a0 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -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