mysnapsession-example-0.1: src/Site.hs

{-# 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"