make some sites

matebeamter.cabal

@@ -43,12 +43,15 @@ executable matebeamter
                      , aeson
                      , blaze-html
                      , text
+                     , bytestring
                      , warp
                      , wai
                      , wai-logger
                      , http-client
                      , mtl
                      , i18n
+                     , cookie
+                     , split
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall

src/API.hs

@@ -20,6 +20,7 @@ import Types
 import View
 
 type UserAPI =
-  "auth" :> Get '[HTML] AuthPage
+  Get '[HTML] UserSelectPage
+  :<|> "user" :> Capture "id" Int :> Get '[HTML] UserOverviewPage
+  :<|> "auth" :> Get '[HTML] AuthPage
 
-  :<|> "user" :> Capture "id" Int :> Get '[HTML] UserPage

src/Control/User.hs

@@ -2,40 +2,34 @@
 {-# LANGUAGE PackageImports #-}
 module Control.User where
 
-import Servant.Server (Server)
 import Servant.Client
-import Servant.Client.Core.Auth
-
-import Data.Aeson (decode)
 
 import Data.Text.I18n
 
 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)
 
-import Network.HTTP.Client
-
 -- imports from mateamt
 
-import qualified "mateamt" Types as MT
-
 -- internal imports
 
 import Types
 import Client
 import View
-import Util
-import API
 
-userListControl :: Int -> UserHandler UserPage
+userSelectControl :: UserHandler UserSelectPage
-userListControl uid = do
+userSelectControl = do
-  (ReadState manager l10n) <- ask
+  (ReadState mngr l10n) <- ask
   let loc = Locale "en"
   euser <- liftIO $ runClientM
         (userList (Nothing))
-        (mkClientEnv manager (BaseUrl Http "localhost" 8000 ""))
+        (mkClientEnv mngr (BaseUrl Http "localhost" 8000 ""))
   case euser of
     Right uss ->
-      return $ userPage l10n loc uss
+      return $ userSelectPage l10n loc uss
     Left err ->
       error $ show err
+
+userOverviewControl :: Int -> UserHandler UserOverviewPage
+userOverviewControl uid = do
+  error "Not yet implemented"

src/Main.hs

@@ -37,8 +37,9 @@ userApp initState = serveWithContext userApi (EmptyContext) $
     userApi
     Proxy
     (`runReaderT` initState)
-    ( authControl
+    ( userSelectControl
-    :<|> userListControl
+    :<|> userOverviewControl
+    :<|> authControl
     )
 
 userApi :: Proxy UserAPI

src/Types/Page.hs

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

src/Util.hs

@@ -4,10 +4,46 @@
 module Util where
 
 import Servant hiding (addHeader)
-import Servant.Client
+import Servant.Client.Core.Request
 import Servant.Client.Core.Auth
 import Servant.Client.Core.Request (addHeader)
 
+import qualified Data.Text as T
+import Data.Text.Lazy.Encoding
+
+import Data.ByteString.Builder
+
+import Data.List (intercalate)
+import Data.List.Split (chunksOf)
+
+import Data.String (fromString)
+
+import Web.Cookie
+
+import Text.Printf (printf)
+
+authenticateReq
+  :: ToHttpApiData a
+  => a
+  -> Servant.Client.Core.Request.Request
+  -> Servant.Client.Core.Request.Request
 authenticateReq s req = addHeader "Authentication" s req
 
 type instance AuthClientData (AuthProtect "header-auth") = String
+
+setCookie
+  :: SetCookie
+  -> Request
+  -> Request
+setCookie c = addHeader "Set-Cookie" (decodeUtf8 . toLazyByteString $ renderSetCookie c)
+
+formatMoney :: Int -> T.Text
+formatMoney amount = pre <> t <> "," <> c
+  where
+    pre = if amount < 0
+      then "-"
+      else ""
+    t = fromString $ reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
+    c = fromString $ snd sp
+    sp = tail <$>
+      break (== '.') (printf "%.2f" (abs amount))

src/View/Auth.hs

@@ -17,5 +17,15 @@ authPage
   :: L10n
   -> Locale
   -> AuthPage
-authPage l10n locale = scaffold l10n locale initPage $ do
+authPage l10n locale = scaffold
-  H.p $ "Test"
+  l10n
+  locale
+  (initPage $
+    translate "Matebeamter" <>
+    " - " <>
+    translate "Authentication"
+    )
+  $ do
+    H.p $ "Test"
+  where
+    translate = localize l10n locale . gettext

src/View/Scaffold.hs

@@ -15,10 +15,10 @@ import Types.Page
 scaffold
   :: L10n
   -> Locale
-  -> Page H.Html (I18n T.Text)
+  -> Page H.Html T.Text
   -> H.Html
   -> H.Html
-scaffold l10n locale page content = template page l10n locale $ do
+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.hr

src/View/User.hs

@@ -2,32 +2,79 @@
 {-# LANGUAGE PackageImports #-}
 module View.User where
 
-import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5 as H hiding (style)
 import qualified Text.Blaze.Html5.Attributes as H
 
 import Data.Text.I18n
 
 import Data.String (fromString)
 
+import Data.Maybe (isJust, fromJust)
+
 -- imports from mateamt
 
 import qualified "mateamt" Types as MT
 
 -- internal imports
 
+import Util
 import Types
 import View.Scaffold
 
-type UserPage = H.Html
+type UserSelectPage = H.Html
 
-userPage
+userSelectPage
   :: L10n
   -> Locale
   -> [MT.UserSummary]
-  -> UserPage
+  -> UserSelectPage
-userPage l10n locale uss = scaffold l10n locale (initPage
+userSelectPage l10n locale uss = scaffold l10n locale (initPage $
-  { pageTitle = gettext "Matebeamter - User list"
+  (localize l10n locale $ gettext "Matebeamter") <>
-  }) $ mapM_ (\(MT.UserSummary uid ident _) -> do
+  " - " <>
+  (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
+
+userOverviewPage
+  :: L10n
+  -> Locale
+  -> MT.UserDetails
+  -> [MT.ProductShortOverview]
+  -> UserOverviewPage
+userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
+  (localize l10n locale $ gettext "Matebeamter") <>
+  " - " <>
+  (localize l10n locale $ gettext "User Menu for ") <>
+  (MT.userDetailsIdent ud)
+  ) $ do
+    H.p $ H.toHtml $ (translate "Welcome back, ") <> (MT.userDetailsIdent ud)
+      <> "!"
+    H.p H.!? (MT.userDetailsBalance ud < 0, H.class_ "debt") $ H.toHtml $
+      (translate "Your current balance is") <>
+      ": " <>
+      (formatMoney $ MT.userDetailsBalance ud)
+      -- TODO: Add currency symbol
+    H.ul H.! H.class_ "product_list" $
+      mapM_
+        (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
+          H.li H.! H.class_ "product" H.!?
+            (isJust avatarid
+            , productBgStyle (fromString $ show $ fromJust avatarid)
+            ) $
+              H.a H.! H.href ("#" <> fromString (show pid)) $ H.toHtml ident
+        )
+        pos
+  where
+    translate = localize l10n locale . gettext
+    productBgStyle aid = H.style $ mconcat
+      [ "background-image: url(#" <> aid <> ");" -- FILLME
+      , "backgronud-color: blue;"
+      , "text-shadow:"
+      , "  -1px 0 1px black,"
+      , "  0 1px 1px black,"
+      , "  1px 0 1px black,"
+      , "  0 -1px 1px black;"
+      ]