diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/mysnapsession-example.cabal b/mysnapsession-example.cabal new file mode 100644 --- /dev/null +++ b/mysnapsession-example.cabal @@ -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 +Maintainer: Chris Smith +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 + diff --git a/resources/static/screen.css b/resources/static/screen.css new file mode 100644 --- /dev/null +++ b/resources/static/screen.css @@ -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%; +} diff --git a/resources/templates/conclusion.tpl b/resources/templates/conclusion.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/conclusion.tpl @@ -0,0 +1,15 @@ + + + + mysnapsessions Sample Application + + + +
+

Conclusion

+

+ Thank you for playing! +

+
+ + diff --git a/resources/templates/details.tpl b/resources/templates/details.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/details.tpl @@ -0,0 +1,30 @@ + + + + mysnapsessions Sample Application + + + +
+

Drat!

+

+ Well, perhaps you can help me learn for next time. +

+
+

+ What was the right answer? +
+

+

+ What is a question that distinguishes your animal from a(n) ? +
+

+

+ Finally, what is the correct answer for your animal?
+ + +

+
+
+ + diff --git a/resources/templates/goAgain.tpl b/resources/templates/goAgain.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/goAgain.tpl @@ -0,0 +1,21 @@ + + + + mysnapsessions Sample Application + + + +
+

All done.

+

+ That was fun! Would you like to play again? +

+
+

+ + +

+
+
+ + diff --git a/resources/templates/guess.tpl b/resources/templates/guess.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/guess.tpl @@ -0,0 +1,21 @@ + + + + mysnapsessions Sample Application + + + +
+

I've got it!

+

+ I guess: Am I right? +

+
+

+ + +

+
+
+ + diff --git a/resources/templates/index.tpl b/resources/templates/index.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/index.tpl @@ -0,0 +1,22 @@ + + + + mysnapsessions Sample Application + + + +
+

Welcome!

+

+ This simple application demonstrates the continuation-based programming + model in the mysnapsessions 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. +

+

+ get started! +

+
+ + diff --git a/resources/templates/question.tpl b/resources/templates/question.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/question.tpl @@ -0,0 +1,21 @@ + + + + mysnapsessions Sample Application + + + +
+

Hmm...

+

+ Next question: +

+
+

+ + +

+
+
+ + diff --git a/resources/templates/rules.tpl b/resources/templates/rules.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/rules.tpl @@ -0,0 +1,20 @@ + + + + mysnapsessions Sample Application + + + +
+

Rules

+

+ Think of an animal, and click OK to get started when you are ready. +

+
+

+ +

+
+
+ + diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 --- /dev/null +++ b/src/Application.hs @@ -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 + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Snap.Extension.Server +import Application +import Site + +main :: IO () +main = quickHttpServe appInitializer site diff --git a/src/Site.hs b/src/Site.hs new file mode 100644 --- /dev/null +++ b/src/Site.hs @@ -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" +