mailinglistconfirm / src / ConfirmCgi.hs

{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
import Ella.Framework
import Ella.Response
import Ella.Processors.General (addSlashRedirectView)

import Control.Exception (catchDyn)
import Database.HDBC (quickQuery, toSql, SqlError, commit)
import Database.HDBC.Sqlite3 (connectSqlite3)

-- Settings

sqlite_path = "/home/luke/httpd/"

-- Database

connect = connectSqlite3 sqlite_path

updateStatement = "UPDATE addresses SET send_email = ? WHERE id = ?;"
queryStatement  = "SELECT email FROM addresses WHERE id = ?;"

update :: Bool -> String -> IO Bool
update addthem personid = do
  conn <- connect
  retval <- idpresent conn personid
  if retval
    then do
      quickQuery conn updateStatement [toSql addthem, toSql personid]
      commit conn
      return retval
    else do
      return retval

confirm = update True
remove = update False

idpresent conn personid = do
  vals <- quickQuery conn queryStatement [toSql personid]
  return (length vals == 1)

-- Error handling

sqlErrorHandler = \e -> do
                    let errMessage = show (e :: SqlError)
                    let resp = default500 errMessage
                    sendResponseCGI resp

-- Routing

views = [ addSlashRedirectView
        , "yes/" <+/> stringParam            //->  addEmailView    $ []
        , "no/" <+/> stringParam             //->  removeEmailView $ []

-- Views

idNotFoundResponse = buildResponse [addContent "Sorry, the URL entered does not correspond to any known email address.  Please check you entered the full URL."] utf8HtmlResponse
addedResponse = buildResponse [addContent "Thanks, I'll add you to my list."] utf8HtmlResponse
removedResponse = buildResponse [addContent "Thanks, you won't be added you to my list."] utf8HtmlResponse

addEmailView personid req = do
  updated <- confirm personid
  return $ Just $ if (not updated)
                    then idNotFoundResponse
                    else addedResponse

removeEmailView personid req = do
  updated <- remove personid
  return $ Just $ if (not updated)
                    then idNotFoundResponse
                    else removedResponse

dispatchOptions = defaultDispatchOptions

main :: IO ()
main = catchDyn (do
                  dispatchCGI views dispatchOptions
                ) sqlErrorHandler
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.