meow

matebeamter.cabal

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

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)

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

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)

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)
 

src/Types.hs

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

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

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

src/View/Auth.hs

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

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

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