render posts and users

web/src/Main.hs

@@ -1,11 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import           Data.Text.Lazy                       (toStrict)
 import qualified Database.SQLite.Simple               as Db
 import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
 import qualified Network.Wai.Middleware.Static        as Static
+import           Text.Blaze.Html.Renderer.Text
+import           Web.Spock.Safe                       ((<//>))
 import qualified Web.Spock.Safe                       as S hiding (head)
 import qualified Within.DBMemorial.Post               as Post
+import qualified Within.DBMemorial.User               as User
+import qualified Within.DBMemorial.Views.Materialize  as Materialize
 
 main :: IO ()
 main = do
@@ -20,4 +25,8 @@ main = do
          S.middleware $ Static.staticPolicy $ Static.addBase "public"
          S.middleware $ RequestLogger.logStdout
          S.get S.root $
-           S.text $ Post.body h
+           S.html $ toStrict (renderHtml (Materialize.base "The OP" (Post.render h)))
+         {-S.get ("users" <//> S.var) $ \id ->
+           S.text renderHtml $ User.render $ do
+             res <- Db.query_ conn "SELECT * FROM Users WHERE id=?" id :: IO [User.User]
+             head res-}

web/src/Within/DBMemorial/Post.hs

@@ -5,6 +5,9 @@ import           Control.Applicative
 import           Data.Monoid                    ()
 import           Data.Text
 import           Database.SQLite.Simple.FromRow
+import           Text.Blaze.Html5               ((!))
+import qualified Text.Blaze.Html5               as H
+import qualified Text.Blaze.Html5.Attributes    as A
 
 data Post = Post
           { id       :: Int
@@ -17,3 +20,10 @@ data Post = Post
 
 instance FromRow Post where
     fromRow = Post <$> field <*> field <*> field <*> field <*> field <*> field
+
+render :: Post -> H.Html
+render post = do
+    H.div ! A.class_ "card blue-grey darken-1" $ do
+      H.div ! A.class_ "card-content white-text" $ do
+        H.span ! A.class_ "card-title" $ H.toHtml $ unpack (author post)
+        H.p $ H.toHtml $ unpack (markdown post)

web/src/Within/DBMemorial/User.hs

@@ -5,6 +5,9 @@ import           Control.Applicative
 import           Data.Monoid                    ()
 import           Data.Text
 import           Database.SQLite.Simple.FromRow
+import           Text.Blaze.Html5               ((!))
+import qualified Text.Blaze.Html5               as H
+import qualified Text.Blaze.Html5.Attributes    as A
 
 data User = User
           { id     :: Int
@@ -15,3 +18,10 @@ data User = User
 
 instance FromRow User where
     fromRow = User <$> field <*> field <*> field <*> field
+
+render :: User -> H.Html
+render user = do
+    H.div ! A.class_ "card blue-grey darken-1" $ do
+      H.div ! A.class_ "card-content white-text" $ do
+        H.span ! A.class_ "card-title" $ H.toHtml $ unpack (name user)
+        H.img ! A.src (H.toValue $ unpack $ avatar user)

web/src/Within/DBMemorial/Utils.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Within.DBMemorial.Utils where
+
+fixString :: String -> [Char]
+fixString s = s

web/src/Within/DBMemorial/Views/Materialize.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Within.DBMemorial.Views.Materialize where
+
+import           Control.Monad               (forM_)
+import           Data.Monoid
+import           Data.Text
+import           Text.Blaze.Html
+import           Text.Blaze.Html5            as H
+import           Text.Blaze.Html5.Attributes as A
+
+base :: Text -> Html -> Html
+base pageTitle inner =
+    docTypeHtml ! lang "en" $ do
+      H.head $ do
+        H.title $ toHtml pageTitle
+
+        meta ! charset "utf-8"
+        meta ! name "viewport" ! content "width=device-width, initial-scale=1.0"
+        link ! rel "stylesheet" ! href "/materialize/css/materialize.min.css"
+        script ! type_ "text/javascript" ! src "https://code.jquery.com/jquery-2.1.1.min.js" $ mempty
+        script ! src "/materialize/js/materialize.min.js" $ mempty
+      H.body $ do
+        H.div ! class_ "container" $ do
+          inner