Merge branch 'master' of github.com:c3d2/ta-haskell-yesod

c3d2 · Aug 29, 2012 · 6149e8f · 6149e8f
2 parents 9fd7471 + 459f030
commit 6149e8f
Show file tree

Hide file tree

Showing 4 changed files with 118 additions and 1 deletion.
diff --git a/index.html b/index.html
@@ -49,6 +49,8 @@ <h1>Themenabend Haskell &amp; Yesod</h1>
   <p>Chaos Computer Club Dresden</p>
   <p>2012-08-29</p>
   <p class="note">Genesis: 1990</p>
+  <p class="note">Most Advanced Flow Control</p>
+  <p class="note">Academic Reputation</p>
 </div> 
 
 <div class="slide">
@@ -267,7 +269,9 @@ <h1>Record-Syntax</h1>
 Prelude> :t meinInteger
 meinInteger :: MeinTyp -> Integer
 Prelude> meinInteger fnord
-23</div>
+23</pre>
+  <p class="note">Parameterisierte Typen!</p>
+</div>
 <!-- Classes, instances -->
 <div class="slide">
   <h1>Classes &amp; Instances</h1>
@@ -1415,6 +1419,10 @@ <h1>WAI: Motivation</h1>
     <a href="http://www.yesodweb.com/blog/2011/03/preliminary-warp-cross-language-benchmarks">www.yesodweb.com/blog/2011/03/preliminary-warp-cross-language-benchmarks</a>
   </p>
 </div>
+<div class="slide">
+  <h1>Yesod</h1>
+  <p>Live-Coding!</p>
+</div>
 <!--
 mtl
 lists: monomorph

diff --git a/yesod-example/Application.hs b/yesod-example/Application.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiParamTypeClasses, TypeFamilies, OverloadedStrings #-}
+module Application where
+
+import Control.Applicative
+import Yesod
+import Yesod.Form.Jquery
+import Text.Hamlet
+import qualified Data.Text as T
+import Control.Concurrent.STM
+
+
+
+app :: IO Application
+app = do
+  dents <- liftIO $ atomically $ newTVar []
+  toWaiAppPlain $ ChatApp dents
+
+
+data Dent = Dent
+               { dentSender :: T.Text 
+               , dentBody :: T.Text
+               }
+
+data ChatApp = ChatApp { chatDents :: TVar [Dent] }
+
+getDents = chatDents <$> getYesod
+
+mkYesod "ChatApp" [parseRoutes|
+                   / HomeR GET
+                   /send SendR POST
+                   |]
+
+instance Yesod ChatApp where
+    defaultLayout widget =
+        do pc <- widgetToPageContent widget
+           hamletToRepHtml $(hamletFile "default-layout.hamlet")
+
+instance YesodJquery ChatApp
+
+instance RenderMessage ChatApp FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+
+getHomeR :: Handler RepHtml
+getHomeR = do
+  (form, enctype) <- generateFormPost dentForm
+  dents <- getDents >>=
+           liftIO . atomically . readTVar
+  defaultLayout $ do 
+    setTitle "Welcome to Yitter"
+    [whamlet|
+     <h1>Chat
+     <form method=POST action=@{SendR} enctype=#{enctype}>
+       ^{form}
+       <input type=submit value=Ok>
+     $forall dent <- dents
+       <article>
+         <h2>#{dentSender dent}
+         <p>#{dentBody dent}
+     |]
+
+dentForm = renderDivs $ Dent
+           <$> areq textField "Name: " Nothing
+           <*> areq textField "Body: " Nothing
+
+postSendR :: Handler RepHtml
+postSendR = do
+  ((result, widget), enctype) <- runFormPost dentForm
+  case result of
+    FormSuccess dent -> do
+                dents <- getDents
+                liftIO $ atomically $
+                       modifyTVar dents $ (dent :)
+                redirect HomeR
+    _ ->
+      defaultLayout [whamlet|
+                     <h1>Oops
+                     |]
+
+
+-- TODO: i18n, form validation
diff --git a/yesod-example/default-layout.hamlet b/yesod-example/default-layout.hamlet
@@ -0,0 +1,9 @@
+$newline always
+<html>
+  <head>
+    <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+    <title>#{pageTitle pc}
+    ^{pageHead pc}
+  <body>
+    <div #page>
+      ^{pageBody pc}
diff --git a/yesod-example/main.hs b/yesod-example/main.hs
@@ -0,0 +1,19 @@
+module Main where
+
+import System.IO
+import Network.Wai.Handler.Warp (runSettings, defaultSettings, 
+                                 settingsHost, settingsPort, settingsOnException)
+import Data.Conduit.Network (HostPreference (HostIPv6))
+import Application
+
+
+main :: IO ()
+main = app >>=
+       runSettings (defaultSettings
+                    { settingsHost = HostIPv6
+                    , settingsPort = 8000
+                    , settingsOnException = \e ->
+                                            hPrint stdout e
+                                            >>
+                                            hFlush stdout
+                    })