mysnapsession-example-0.3: animalgame/src/Site.hs

{-# LANGUAGE OverloadedStrings #-}

module Site (site) where

import Paths_mysnapsession_example

import Data.ByteString.Char8 (ByteString)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Snap.Extension.Heist
import Snap.Extension.Session
import Snap.Dialogues
import Snap.Util.FileServe
import Snap.Types
import Text.Templating.Heist

import Application

data DiKey = Answer   ByteString
           | Question ByteString DiKey DiKey

startingKey :: DiKey
startingKey = Answer "elephant"

animalGame :: (MonadHeist n m) => DiKey -> Dlg m ()
animalGame key = do
    rulePage
    key'  <- question key
    again <- goAgainPage
    if again then animalGame key' else conclusionPage

question :: (MonadHeist n m) => DiKey -> Dlg m DiKey
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 :: MonadHeist n m => Dlg m ()
rulePage = showPage build parse
  where
    build t = heistLocal (bindStrings [("dlgid", t)]) $ render "rules"
    parse   = return ()

conclusionPage :: MonadHeist n m => Dlg m ()
conclusionPage = showPage build parse
  where
    build t = heistLocal (bindStrings [("dlgid", t)]) $ render "conclusion"
    parse   = return ()

goAgainPage :: MonadHeist n m => Dlg m Bool
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 :: MonadHeist n m => ByteString -> Dlg m Bool
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 :: MonadHeist n m => ByteString -> Dlg m Bool
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 :: MonadHeist n m
            => ByteString
            -> Dlg m (ByteString, ByteString, Bool)
detailsPage oldAnimal = showPage build parse
  where
    build t = heistLocal (bindStrings
                 [("dlgid", t), ("oldAnimal", oldAnimal)]) $ render "details"
    parse   = do
        newAnimal   <- getParam "newAnimal" >>= maybe mzero return
        newQuestion <- getParam "question"  >>= maybe mzero return
        answerStr   <- getParam "answer"    >>= maybe mzero return
        let answer = case answerStr of "yes" -> True
                                       _     -> False
        return (newAnimal, newQuestion, answer)

site :: App ()
site = do
    sPath <- liftIO $ getDataFileName "animalgame/resources/static"
    inSession $
        ifTop (render "index")
        <|> dialogue "animal" (animalGame startingKey)
        <|> fileServe sPath