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

{-# LANGUAGE OverloadedStrings #-}

module Site (site) where

import           Paths_mysnapsession_example

import           Data.ByteString.Char8 (ByteString)
import           Data.Text (Text)
import qualified Data.Text.Encoding as T
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   Text
           | Question Text 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.decodeUtf8 t)]) $ render "rules"
    parse   = return ()

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

goAgainPage :: MonadHeist n m => Dlg m Bool
goAgainPage = showPage build parse
  where
    build t = heistLocal (bindStrings [("dlgid", T.decodeUtf8 t)]) $ render "goAgain"
    parse   = do p <- getParam "answer"
                 case p of Just "yes" -> return True
                           _          -> return False

guessPage :: MonadHeist n m => Text -> Dlg m Bool
guessPage animal = showPage build parse
  where
    build t = heistLocal (bindStrings
                 [("dlgid", T.decodeUtf8 t),
                  ("animal", animal)]) $ render "guess"
    parse   = do p <- getParam "answer"
                 case p of Just "yes" -> return True
                           _          -> return False

questionPage :: MonadHeist n m => Text -> Dlg m Bool
questionPage q = showPage build parse
  where
    build t = heistLocal (bindStrings
                 [("dlgid", T.decodeUtf8 t),
                  ("question", q)]) $ render "question"
    parse   = do p <- getParam "answer"
                 case p of Just "yes" -> return True
                           _          -> return False

detailsPage :: MonadHeist n m
            => Text
            -> Dlg m (Text, Text, Bool)
detailsPage oldAnimal = showPage build parse
  where
    build t = heistLocal (bindStrings
                 [("dlgid", T.decodeUtf8 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 (T.decodeUtf8 newAnimal, T.decodeUtf8 newQuestion, answer)

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