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

        2 ---

        3 --- A simple CGI app designed to handle a personal mailing list

        4 ---

        5 --- The public interface is simply 'yes' and 'no' links in emails.

        6 --- Anyone invited to the list needs to be sent an email with

        7 --- appropriate URLs for them to click.  These URLs are of the form

        8 ---

        9 --- http://something.com/yes/<id>/

       10 ---

       11 --- and

       12 ---

       13 --- http://something.com/no/<id>/

       14 ---

       15 --- where <id> is a random alphanumeric id stored in the DB.

       16 ---

       17 --- The 'admin' interface consists of URLs that can be posted to (with

       18 --- an appropriate password) to add/remove entries from the database,

       19 --- or just confirm/remove those entries from being on the list.  It

       20 --- is intended that this interface is accessed using curl or a

       21 --- similar utility -- there is no HTML interface (yet).

       22 ---

       23 --- For retrieving the list of 'yes' people, the only method currently

       24 --- is to download the SQLite database.

       25 

       26 import Ella.Framework

       27 import Ella.Request (getPOST)

       28 import Ella.Response

       29 import Ella.Processors.General (addSlashRedirectView)

       30 

       31 import Control.Exception (catchDyn, throwDyn)

       32 import Database.HDBC (quickQuery, toSql, SqlError(SqlError), withTransaction)

       33 import Database.HDBC.Sqlite3 (connectSqlite3)

       34 import Maybe (isNothing, fromJust)

       35 import Random (randomRs, newStdGen)

       36 

       37 -- Settings

       38 

       39 -- Change these!

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

       41 access_password = "mypassword"

       42 

       43 -- Database

       44 

       45 connect = connectSqlite3 sqlite_path

       46 

       47 updateStatusByIdStmnt = "UPDATE addresses SET send_email = ? WHERE id = ?;"

       48 updateStatusByEmailStmnt = "UPDATE addresses SET send_email = ? WHERE email = ?;"

       49 queryByIdStmnt  = "SELECT email FROM addresses WHERE id = ?;"

       50 queryByEmailStmnt  = "SELECT email FROM addresses WHERE email = ?;"

       51 insertEntryStmnt = "INSERT INTO addresses (name, email, id) VALUES (?, ?, ?);"

       52 deleteEntryStmnt = "DELETE FROM addresses WHERE email = ?;"

       53 

       54 updateById :: Bool -> String -> IO Bool

       55 updateById addthem personid = do

       56   conn <- connect

       57   retval <- idpresent conn personid

       58   if retval

       59     then do

       60       withTransaction conn (\c -> quickQuery c updateStatusByIdStmnt [toSql addthem, toSql personid])

       61       return retval

       62     else do

       63       return retval

       64 

       65 confirmById = updateById True

       66 removeById = updateById False

       67 

       68 idpresent conn personid = do

       69   vals <- quickQuery conn queryByIdStmnt [toSql personid]

       70   return (length vals == 1)

       71 

       72 emailpresent conn email = do

       73   vals <- quickQuery conn queryByEmailStmnt [toSql email]

       74   return (length vals == 1)

       75 

       76 addEntry :: String -> String -> IO ()

       77 addEntry name email = do

       78   conn <- connect

       79   newid <- randomStr 10

       80   withTransaction conn (\c ->

       81                             quickQuery c insertEntryStmnt [toSql name, toSql email, toSql newid]

       82                        )

       83   return ()

       84 

       85 deleteEntry :: String -> IO ()

       86 deleteEntry email = do

       87   conn <- connect

       88   withTransaction conn (\c -> quickQuery c deleteEntryStmnt [toSql email])

       89   return ()

       90 

       91 updateByEmail :: Bool -> String -> IO Bool

       92 updateByEmail addthem email = do

       93   conn <- connect

       94   retval <- emailpresent conn email

       95   if retval

       96     then do

       97       withTransaction conn (\c -> quickQuery c updateStatusByEmailStmnt [toSql addthem, toSql email])

       98       return retval

       99     else do

      100       return retval

      101 

      102 confirmByEmail = updateByEmail True

      103 removeByEmail = updateByEmail False

      104 

      105 -- Error handling

      106 

      107 sqlErrorHandler = \e -> do

      108                     let errMessage = show (e :: SqlError)

      109                     let resp = default500 errMessage

      110                     sendResponseCGI resp

      111 

      112 -- Routing

      113 

      114 views = [ addSlashRedirectView

      115         -- Public

      116         , "yes/" <+/> stringParam            //->  confirmIdView     $ []

      117         , "no/" <+/> stringParam             //->  removeIdView      $ []

      118         -- Admin

      119         , "add/" <+/> empty                  //->  addEntryView      $ [passwordRequired]

      120         , "delete/" <+/> empty               //->  deleteEntryView   $ [passwordRequired]

      121         , "set/yes/" <+/> stringParam        //->  confirmEmailView  $ [passwordRequired]

      122         , "set/no/" <+/> stringParam         //->  removeEmailView   $ [passwordRequired]

      123         ]

      124 

      125 -- Views

      126 

      127 -- -- Utilities

      128 

      129 message content = buildResponse [addContent content] utf8HtmlResponse

      130 

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

      132 addedResponse      = message "Thanks, I'll add you to my list.\n"

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

      134 

      135 forbidden content = buildResponse [setStatus 403,

      136                                    addContent content] utf8HtmlResponse

      137 accessDenied = forbidden "Access denied\n"

      138 

      139 invalidInput content = buildResponse [ setStatus 400

      140                                      , addContent content] utf8HtmlResponse

      141 

      142 emailNotFoundResponse = invalidInput "Email address not found.\n"

      143 

      144 -- -- Decorators

      145 

      146 -- | Decorator that enforces a POST parameter 'password' to be present

      147 -- and correct

      148 passwordRequired :: View -> View

      149 passwordRequired view req = do

      150   let password = getPOST req "password"

      151   case password of

      152     Nothing -> return ad

      153     Just pw | pw == access_password -> view req

      154             | otherwise -> return ad

      155  where ad = Just accessDenied

      156 

      157 -- -- Clickable URLs

      158 

      159 confirmIdView personid req = do

      160   updated <- confirmById personid

      161   return $ Just $ if (not updated)

      162                     then idNotFoundResponse

      163                     else addedResponse

      164 

      165 removeIdView personid req = do

      166   updated <- removeById personid

      167   return $ Just $ if (not updated)

      168                     then idNotFoundResponse

      169                     else removedResponse

      170 

      171 -- -- Admin URLs

      172 

      173 addEntryView req = do

      174   let name  = getPOST req "name"

      175       email = getPOST req "email"

      176   if any isNothing [name, email]

      177      then return $ Just $ invalidInput "Please provide 'name' and 'email' parameters\n"

      178      else do

      179        addEntry (fromJust name) (fromJust email)

      180        return $ Just $ message "Added!\n"

      181 

      182 deleteEntryView req = do

      183   let email = getPOST req "email"

      184   if isNothing email

      185      then return $ Just $ invalidInput "Please provide 'email' parameter"

      186      else do

      187        deleteEntry (fromJust email)

      188        return $ Just $ message "Entry removed!\n"

      189 

      190 confirmEmailView email req = do

      191   updated <- confirmByEmail email

      192   return $ Just $ if (not updated)

      193                     then emailNotFoundResponse

      194                     else message "Email added to mailing list.\n"

      195 

      196 removeEmailView email req = do

      197   updated <- removeByEmail email

      198   return $ Just $ if (not updated)

      199                     then emailNotFoundResponse

      200                     else message "Email removed from mailing list.\n"

      201 

      202 -- Utilities

      203 

      204 randomStr :: Int -> IO String

      205 randomStr n = do

      206     g <- newStdGen

      207     return $ take n (randomRs chars g)

      208   where chars = ('a','z')

      209 

      210 -- Main

      211 

      212 main :: IO ()

      213 main = catchDyn (do

      214                   dispatchCGI views defaultDispatchOptions

      215                 ) sqlErrorHandler