packages feed

mysnapsession-example (empty) → 0.1

raw patch · 14 files changed

+403/−0 lines, 14 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed

Dependencies added: MonadCatchIO-transformers, base, bytestring, heist, hexpat, mtl, mysnapsession, snap, snap-core, snap-server, text, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Chris Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Chris Smith nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+> import Distribution.Simple+> main = defaultMain
+ mysnapsession-example.cabal view
@@ -0,0 +1,45 @@+Name:                mysnapsession-example+Version:             0.1+Synopsis:            Example project using mysnapsession+Description:         This is a simple web application that uses the+                     mysnapsession package's continuation programming model+                     to build an animal guessing game.+License:             BSD3+License-file:        LICENSE+Author:              Chris Smith <cdsmith@gmail.com>+Maintainer:          Chris Smith <cdsmith@gmail.com>+Stability:           Experimental+Category:            Web+Build-type:          Simple+Cabal-version:       >=1.6++Extra-source-files:  resources/static/*.css, resources/templates/*.tpl++Executable testsnap+  Hs-source-dirs: src+  Main-is: Main.hs+  Other-modules: Main, Application, Site++  Build-depends:+    base >= 4 && < 5,+    bytestring >= 0.9.1 && < 0.10,+    heist >= 0.4 && < 0.5,+    hexpat >= 0.19 && < 0.20,+    MonadCatchIO-transformers >= 0.2.1 && < 0.3,+    mtl >= 2 && < 3,+    snap >= 0.3 && < 0.4,+    snap-core >= 0.3 && < 0.4,+    snap-server >= 0.3 && <0.4,+    text >= 0.11 && < 0.12,+    time >= 1.1 && < 1.3,+    mysnapsession == 0.1.*++  extensions: TypeSynonymInstances MultiParamTypeClasses++  if impl(ghc >= 6.12.0)+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields+                 -fno-warn-orphans -fno-warn-unused-do-bind+  else+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields+                 -fno-warn-orphans+
+ resources/static/screen.css view
@@ -0,0 +1,26 @@+html {+   padding: 0;+   margin: 0;+   background-color: #ffffff;+   font-family: Verdana, Helvetica, sans-serif;+}+body {+   padding: 0;+   margin: 0;+}+a {+   text-decoration: underline;+}+a :hover {+   cursor: pointer;+   text-decoration: underline;+}+img {+   border: none;+}+#content {+   padding-left: 1em;+}+#info {+   font-size: 60%;+}
+ resources/templates/conclusion.tpl view
@@ -0,0 +1,15 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>Conclusion</h1>+      <p>+        Thank you for playing!+      </p>+    </div>+  </body>+</html>
+ resources/templates/details.tpl view
@@ -0,0 +1,30 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>Drat!</h1>+      <p>+        Well, perhaps you can help me learn for next time.+      </p>+      <form method="POST" action="/$(dlgid)">+      <p>+        What was the right answer?+        <br/><input type="text" name="newAnimal" value="" />+      </p>+      <p>+        What is a question that distinguishes your animal from a(n) <oldAnimal/>?+        <br/><input type="text" name="question" value="" />+      </p>+      <p>+        Finally, what is the correct answer for your animal?<br/>+        <input type="submit" name="answer" value="yes" />+        <input type="submit" name="answer" value="no" />+      </p>+      </form>+    </div>+  </body>+</html>
+ resources/templates/goAgain.tpl view
@@ -0,0 +1,21 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>All done.</h1>+      <p>+        That was fun!  Would you like to play again?+      </p>+      <form method="POST" action="/$(dlgid)">+      <p>+        <input type="submit" name="answer" value="yes" />+        <input type="submit" name="answer" value="no" />+      </p>+      </form>+    </div>+  </body>+</html>
+ resources/templates/guess.tpl view
@@ -0,0 +1,21 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>I've got it!</h1>+      <p>+        I guess: <b><animal/></b>  Am I right?+      </p>+      <form method="POST" action="/$(dlgid)">+      <p>+        <input type="submit" name="answer" value="yes" />+        <input type="submit" name="answer" value="no" />+      </p>+      </form>+    </div>+  </body>+</html>
+ resources/templates/index.tpl view
@@ -0,0 +1,22 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>Welcome!</h1>+      <p>+        This simple application demonstrates the continuation-based programming+        model in the <code>mysnapsessions</code> package.  You'll be asked to+        think of an animal, and the application will try to guess it.  The+        state of the game is stored in your session, so it's not shared between+        users.+      </p>+      <p>+        <a href="/animal">get started!</a>+      </p>+    </div>+  </body>+</html>
+ resources/templates/question.tpl view
@@ -0,0 +1,21 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>Hmm...</h1>+      <p>+        Next question: <b><question/></b>+      </p>+      <form method="POST" action="/$(dlgid)">+      <p>+        <input type="submit" name="answer" value="yes" />+        <input type="submit" name="answer" value="no" />+      </p>+      </form>+    </div>+  </body>+</html>
+ resources/templates/rules.tpl view
@@ -0,0 +1,20 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>mysnapsessions Sample Application</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>Rules</h1>+      <p>+        Think of an animal, and click OK to get started when you are ready.+      </p>+      <form method="POST" action="/$(dlgid)">+      <p>+        <input type="submit" value="Continue" />+      </p>+      </form>+    </div>+  </body>+</html>
+ src/Application.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}++{-++This module defines our application's monad and any application-specific+information it requires.++-}++module Application (+    App,+    appInitializer,+    AppSession(..)+    ) where++import Snap.Extension+import Snap.Extension.Heist.Impl+import Snap.Extension.Session.Memory+import Snap.Extension.Dialogues++type App = SnapExtend AppState++data AppState = AppState {+    templateState :: HeistState App,+    sessionMgr    :: MemorySessionManager AppSession+    }++instance HasHeistState App AppState where+    getHeistState     = templateState+    setHeistState s a = a { templateState = s }++instance HasMemorySessionManager AppState where+    type MemorySessionValue AppState = AppSession+    memorySessionMgr = sessionMgr++data AppSession = AppSession {+    dlgManager :: DlgManager App+    }++instance HasDlgManager App AppSession where+    getDlgManager = dlgManager++appInitializer :: Initializer AppState+appInitializer = do+    heist    <- heistInitializer "resources/templates"+    sessions <- memorySessionInitializer 1800 newSession+    return $ AppState heist sessions+  where+    newSession = fmap AppSession makeDlgManager+
+ src/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import           Snap.Extension.Server+import           Application+import           Site++main :: IO ()+main = quickHttpServe appInitializer site
+ src/Site.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}++module Site (site) where++import Data.ByteString.Char8 (ByteString)+import Control.Applicative+import Control.Monad+import Snap.Extension.Heist+import Snap.Extension.Dialogues+import Snap.Util.FileServe+import Snap.Types+import Text.Templating.Heist++import Application++data DiKey = Answer   ByteString+           | Question ByteString DiKey DiKey++startingKey = Answer "elephant"++animalGame key = do+    rulePage+    key'  <- question key+    again <- goAgainPage+    if again then animalGame key' else conclusionPage++question (Answer s) = do+    correct <- guessPage s+    if correct then return (Answer s)+               else do+        (anim, newq, newa) <- detailsPage s+        if newa then return (Question newq (Answer anim) (Answer s))+                else return (Question newq (Answer s) (Answer anim))++question (Question q y n) = do+    ans <- questionPage q+    if ans then do y' <- question y+                   return (Question q y' n)+           else do n' <- question n+                   return (Question q y n')++rulePage = showPage build parse+  where+    build t = heistLocal (bindStrings [("dlgid", t)]) $ render "rules"+    parse   = return ()++conclusionPage = showPage build parse+  where+    build t = heistLocal (bindStrings [("dlgid", t)]) $ render "conclusion"+    parse   = return ()++goAgainPage = showPage build parse+  where+    build t = heistLocal (bindStrings [("dlgid", t)]) $ render "goAgain"+    parse   = do p <- getParam "answer"+                 case p of Just "yes" -> return True+                           _          -> return False++guessPage animal = showPage build parse+  where+    build t = heistLocal (bindStrings+                 [("dlgid", t), ("animal", animal)]) $ render "guess"+    parse   = do p <- getParam "answer"+                 case p of Just "yes" -> return True+                           _          -> return False++questionPage q = showPage build parse+  where+    build t = heistLocal (bindStrings+                 [("dlgid", t), ("question", q)]) $ render "question"+    parse   = do p <- getParam "answer"+                 case p of Just "yes" -> return True+                           _          -> return False++detailsPage oldAnimal = showPage build parse+  where+    build t = heistLocal (bindStrings+                 [("dlgid", t), ("oldAnimal", oldAnimal)]) $ render "details"+    parse   = do+        newAnimal <- getParam "newAnimal" >>= maybe mzero return+        question  <- getParam "question"  >>= maybe mzero return+        answerStr <- getParam "answer"    >>= maybe mzero return+        let answer = case answerStr of "yes" -> True+                                       _     -> False+        return (newAnimal, question, answer)++site :: App ()+site = ifTop (render "index")+       <|> dialogue "animal" (animalGame startingKey)+       <|> fileServe "resources/static"+