diff --git a/animalgame/resources/static/screen.css b/animalgame/resources/static/screen.css new file mode 100644 --- /dev/null +++ b/animalgame/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/animalgame/resources/templates/conclusion.tpl b/animalgame/resources/templates/conclusion.tpl new file mode 100644 --- /dev/null +++ b/animalgame/resources/templates/conclusion.tpl @@ -0,0 +1,15 @@ + + + + mysnapsessions Sample Application + + + +
+

Conclusion

+

+ Thank you for playing! +

+
+ + diff --git a/animalgame/resources/templates/details.tpl b/animalgame/resources/templates/details.tpl new file mode 100644 --- /dev/null +++ b/animalgame/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/animalgame/resources/templates/goAgain.tpl b/animalgame/resources/templates/goAgain.tpl new file mode 100644 --- /dev/null +++ b/animalgame/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/animalgame/resources/templates/guess.tpl b/animalgame/resources/templates/guess.tpl new file mode 100644 --- /dev/null +++ b/animalgame/resources/templates/guess.tpl @@ -0,0 +1,21 @@ + + + + mysnapsessions Sample Application + + + +
+

I've got it!

+

+ I guess: Am I right? +

+
+

+ + +

+
+
+ + diff --git a/animalgame/resources/templates/index.tpl b/animalgame/resources/templates/index.tpl new file mode 100644 --- /dev/null +++ b/animalgame/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/animalgame/resources/templates/question.tpl b/animalgame/resources/templates/question.tpl new file mode 100644 --- /dev/null +++ b/animalgame/resources/templates/question.tpl @@ -0,0 +1,21 @@ + + + + mysnapsessions Sample Application + + + +
+

Hmm...

+

+ Next question: +

+
+

+ + +

+
+
+ + diff --git a/animalgame/resources/templates/rules.tpl b/animalgame/resources/templates/rules.tpl new file mode 100644 --- /dev/null +++ b/animalgame/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/animalgame/src/Application.hs b/animalgame/src/Application.hs new file mode 100644 --- /dev/null +++ b/animalgame/src/Application.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- + +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.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 "animalgame/resources/templates" + sessions <- memorySessionInitializer 1800 newSession + return $ AppState heist sessions + where + newSession = fmap AppSession makeDlgManager + diff --git a/animalgame/src/Main.hs b/animalgame/src/Main.hs new file mode 100644 --- /dev/null +++ b/animalgame/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/animalgame/src/Site.hs b/animalgame/src/Site.hs new file mode 100644 --- /dev/null +++ b/animalgame/src/Site.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Site (site) where + +import Data.ByteString.Char8 (ByteString) +import Control.Applicative +import Control.Monad +import Snap.Extension.Heist +import Snap.Dialogues +import Snap.SessionUtil +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 = inSession $ + ifTop (render "index") + <|> dialogue "animal" (animalGame startingKey) + <|> fileServe "animalgame/resources/static" diff --git a/clientcount/resources/static/screen.css b/clientcount/resources/static/screen.css new file mode 100644 --- /dev/null +++ b/clientcount/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/clientcount/resources/templates/index.tpl b/clientcount/resources/templates/index.tpl new file mode 100644 --- /dev/null +++ b/clientcount/resources/templates/index.tpl @@ -0,0 +1,18 @@ + + + + mysnapsessions Sample Application + + + +
+

Welcome!

+

+ Your current session count is . +

+

+ Bump me up one more! +

+
+ + diff --git a/clientcount/src/Application.hs b/clientcount/src/Application.hs new file mode 100644 --- /dev/null +++ b/clientcount/src/Application.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- + +This module defines our application's monad and any application-specific +information it requires. + +-} + +module Application ( + App, + appInitializer + ) where + +import Data.ByteString.Char8 (ByteString) +import Snap.Extension +import Snap.Extension.Heist.Impl +import Snap.Extension.Session.Client +import Web.ClientSession + +type App = SnapExtend AppState + +data AppState = AppState { + templateState :: HeistState App, + sessionMgr :: ClientSessionManager Int + } + +instance HasHeistState App AppState where + getHeistState = templateState + setHeistState s a = a { templateState = s } + +instance HasClientSessionManager AppState where + type ClientSessionValue AppState = Int + clientSessionMgr = sessionMgr + +sessionKey :: ByteString +sessionKey = $(embedDefaultKey) + +appInitializer :: Initializer AppState +appInitializer = do + heist <- heistInitializer "clientcount/resources/templates" + sessions <- clientSessionInitializer sessionKey 0 (Just 10) + return $ AppState heist sessions diff --git a/clientcount/src/Main.hs b/clientcount/src/Main.hs new file mode 100644 --- /dev/null +++ b/clientcount/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/clientcount/src/Site.hs b/clientcount/src/Site.hs new file mode 100644 --- /dev/null +++ b/clientcount/src/Site.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Site (site) where + +import Control.Applicative +import Snap.Extension.Heist +import Snap.Extension.Session +import Snap.SessionUtil +import Snap.Util.FileServe +import Snap.Types +import Text.Templating.Heist + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B + +import Application + +index :: App () +index = do + i <- getSession + putSession (i+1) + heistLocal (bindString "num" (B.pack $ show i)) $ render "index" + +site :: App () +site = inSession $ + ifTop index + <|> fileServe "clientcount/resources/static" diff --git a/mysnapsession-example.cabal b/mysnapsession-example.cabal --- a/mysnapsession-example.cabal +++ b/mysnapsession-example.cabal @@ -1,9 +1,8 @@ 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. +Version: 0.2 +Synopsis: Example projects using mysnapsession +Description: This is a collection of simple web applications that use + the mysnapsession package for stateful HTTP. License: BSD3 License-file: LICENSE Author: Chris Smith @@ -13,33 +12,46 @@ Build-type: Simple Cabal-version: >=1.6 -Extra-source-files: resources/static/*.css, resources/templates/*.tpl +Extra-source-files: animalgame/resources/static/*.css, + animalgame/resources/templates/*.tpl -Executable testsnap - Hs-source-dirs: src - Main-is: Main.hs - Other-modules: Main, Application, Site +Extra-source-files: clientcount/resources/static/*.css, + clientcount/resources/templates/*.tpl +Executable animalgame + Hs-source-dirs: animalgame/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.* + mysnapsession == 0.2.*, + clientsession == 0.4.* - extensions: TypeSynonymInstances MultiParamTypeClasses + Ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-orphans - 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 +Executable clientcount + Hs-source-dirs: clientcount/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, + mtl >= 2 && < 3, + snap >= 0.3 && < 0.4, + snap-core >= 0.3 && < 0.4, + snap-server >= 0.3 && <0.4, + time == 1.1.*, + mysnapsession == 0.2.* + + Ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-orphans diff --git a/resources/static/screen.css b/resources/static/screen.css deleted file mode 100644 --- a/resources/static/screen.css +++ /dev/null @@ -1,26 +0,0 @@ -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 deleted file mode 100644 --- a/resources/templates/conclusion.tpl +++ /dev/null @@ -1,15 +0,0 @@ - - - - mysnapsessions Sample Application - - - -
-

Conclusion

-

- Thank you for playing! -

-
- - diff --git a/resources/templates/details.tpl b/resources/templates/details.tpl deleted file mode 100644 --- a/resources/templates/details.tpl +++ /dev/null @@ -1,30 +0,0 @@ - - - - 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 deleted file mode 100644 --- a/resources/templates/goAgain.tpl +++ /dev/null @@ -1,21 +0,0 @@ - - - - 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 deleted file mode 100644 --- a/resources/templates/guess.tpl +++ /dev/null @@ -1,21 +0,0 @@ - - - - mysnapsessions Sample Application - - - -
-

I've got it!

-

- I guess: Am I right? -

-
-

- - -

-
-
- - diff --git a/resources/templates/index.tpl b/resources/templates/index.tpl deleted file mode 100644 --- a/resources/templates/index.tpl +++ /dev/null @@ -1,22 +0,0 @@ - - - - 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 deleted file mode 100644 --- a/resources/templates/question.tpl +++ /dev/null @@ -1,21 +0,0 @@ - - - - mysnapsessions Sample Application - - - -
-

Hmm...

-

- Next question: -

-
-

- - -

-
-
- - diff --git a/resources/templates/rules.tpl b/resources/templates/rules.tpl deleted file mode 100644 --- a/resources/templates/rules.tpl +++ /dev/null @@ -1,20 +0,0 @@ - - - - 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 deleted file mode 100644 --- a/src/Application.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/src/Site.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# 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" -