snap_bad_word.hs

import qualified Data.ByteString as B

main :: IO ()
main = do
    td <- newTemplateDirectory' "templates" emptyTemplateState
    quickServer $ templateHandler td defaultReloadHandler $ \ts ->
        route [ ("echo/:s", echoHandler)
              ] <|>
        templateServe ts <|>
        dir "static" (fileServe ".")

echoHandler :: Snap ()
echoHandler = do
    s <- getParam "s"
    case s of
        Just s' -> if (B.length s' == 4) then badWord else (writeBS s')
        _       -> writeBS ""
  where
    badWord = do
        putResponse $
          setResponseStatus 403 "Forbidden" emptyResponse
        writeBS "Forbidden: four-letter word"
        r <- getResponse
        finishWith r