1 {-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}

        2 import Ella.Framework

        3 import Ella.Response

        4 import Ella.Processors.General (addSlashRedirectView)

        5 

        6 import Control.Exception (catchDyn)

        7 import Database.HDBC (quickQuery, toSql, SqlError, commit)

        8 import Database.HDBC.Sqlite3 (connectSqlite3)

        9 

       10 -- Settings

       11 

       12 sqlite_path = "/home/luke/httpd/lukeplant.me.uk/web/cgi-bin/data/addresses.db"

       13 

       14 -- Database

       15 

       16 connect = connectSqlite3 sqlite_path

       17 

       18 updateStatement = "UPDATE addresses SET send_email = ? WHERE id = ?;"

       19 queryStatement  = "SELECT email FROM addresses WHERE id = ?;"

       20 

       21 update :: Bool -> String -> IO Bool

       22 update addthem personid = do

       23   conn <- connect

       24   retval <- idpresent conn personid

       25   if retval

       26     then do

       27       quickQuery conn updateStatement [toSql addthem, toSql personid]

       28       commit conn

       29       return retval

       30     else do

       31       return retval

       32 

       33 confirm = update True

       34 remove = update False

       35 

       36 idpresent conn personid = do

       37   vals <- quickQuery conn queryStatement [toSql personid]

       38   return (length vals == 1)

       39 

       40 -- Error handling

       41 

       42 sqlErrorHandler = \e -> do

       43                     let errMessage = show (e :: SqlError)

       44                     let resp = default500 errMessage

       45                     sendResponseCGI resp

       46 

       47 -- Routing

       48 

       49 views = [ addSlashRedirectView

       50         , "yes/" <+/> stringParam            //->  addEmailView    $ []

       51         , "no/" <+/> stringParam             //->  removeEmailView $ []

       52         ]

       53 

       54 -- Views

       55 

       56 message content = buildResponse [addContent content] utf8HtmlResponse

       57 

       58 idNotFoundResponse = message "Sorry, the URL entered does not correspond to any known email address.  Please check you entered the full URL."

       59 addedResponse      = message "Thanks, I'll add you to my list."

       60 removedResponse    = message "Thanks, you won't be added you to my list."

       61 

       62 addEmailView personid req = do

       63   updated <- confirm personid

       64   return $ Just $ if (not updated)

       65                     then idNotFoundResponse

       66                     else addedResponse

       67 

       68 removeEmailView personid req = do

       69   updated <- remove personid

       70   return $ Just $ if (not updated)

       71                     then idNotFoundResponse

       72                     else removedResponse

       73 

       74 -- Main

       75 

       76 main :: IO ()

       77 main = catchDyn (do

       78                   dispatchCGI views defaultDispatchOptions

       79                 ) sqlErrorHandler