Luke Plant avatar Luke Plant committed b71943c

Added admin interface for adding/deleting/confirming/removing people

Comments (0)

Files changed (1)

src/ConfirmCgi.hs

 import Ella.Response
 import Ella.Processors.General (addSlashRedirectView)
 
-import Control.Exception (catchDyn)
-import Database.HDBC (quickQuery, toSql, SqlError, commit)
+import Control.Exception (catchDyn, throwDyn)
+import Database.HDBC (quickQuery, toSql, SqlError(SqlError), withTransaction)
 import Database.HDBC.Sqlite3 (connectSqlite3)
-import Maybe (isNothing)
+import Maybe (isNothing, fromJust)
 import Random (randomRs, newStdGen)
 
 -- Settings
 connect = connectSqlite3 sqlite_path
 
 updateStatusByIdStmnt = "UPDATE addresses SET send_email = ? WHERE id = ?;"
+updateStatusByEmailStmnt = "UPDATE addresses SET send_email = ? WHERE email = ?;"
 queryByIdStmnt  = "SELECT email FROM addresses WHERE id = ?;"
+queryByEmailStmnt  = "SELECT email FROM addresses WHERE email = ?;"
 insertEntryStmnt = "INSERT INTO addresses (name, email, id) VALUES (?, ?, ?);"
+deleteEntryStmnt = "DELETE FROM addresses WHERE email = ?;"
 
 updateById :: Bool -> String -> IO Bool
 updateById addthem personid = do
   retval <- idpresent conn personid
   if retval
     then do
-      quickQuery conn updateStatusByIdStmnt [toSql addthem, toSql personid]
-      commit conn
+      withTransaction conn (\c -> quickQuery c updateStatusByIdStmnt [toSql addthem, toSql personid])
       return retval
     else do
       return retval
   vals <- quickQuery conn queryByIdStmnt [toSql personid]
   return (length vals == 1)
 
+emailpresent conn email = do
+  vals <- quickQuery conn queryByEmailStmnt [toSql email]
+  return (length vals == 1)
+
+addEntry :: String -> String -> IO ()
 addEntry name email = do
   conn <- connect
   newid <- randomStr 10
-  quickQuery conn insertEntryStmnt [toSql name, toSql email, toSql newid]
-  commit conn
+  withTransaction conn (\c ->
+                            quickQuery c insertEntryStmnt [toSql name, toSql email, toSql newid]
+                       )
+  return ()
+
+deleteEntry :: String -> IO ()
+deleteEntry email = do
+  conn <- connect
+  withTransaction conn (\c -> quickQuery c deleteEntryStmnt [toSql email])
+  return ()
+
+updateByEmail :: Bool -> String -> IO Bool
+updateByEmail addthem email = do
+  conn <- connect
+  retval <- emailpresent conn email
+  if retval
+    then do
+      withTransaction conn (\c -> quickQuery c updateStatusByEmailStmnt [toSql addthem, toSql email])
+      return retval
+    else do
+      return retval
+
+confirmByEmail = updateByEmail True
+removeByEmail = updateByEmail False
 
 -- Error handling
 
 -- Routing
 
 views = [ addSlashRedirectView
+        -- Public
         , "yes/" <+/> stringParam            //->  confirmIdView     $ []
         , "no/" <+/> stringParam             //->  removeIdView      $ []
+        -- Admin
         , "add/" <+/> empty                  //->  addEntryView      $ [passwordRequired]
+        , "delete/" <+/> empty               //->  deleteEntryView   $ [passwordRequired]
+        , "set/yes/" <+/> stringParam        //->  confirmEmailView  $ [passwordRequired]
+        , "set/no/" <+/> stringParam         //->  removeEmailView   $ [passwordRequired]
         ]
 
 -- Views
 invalidInput content = buildResponse [ setStatus 400
                                      , addContent content] utf8HtmlResponse
 
+emailNotFoundResponse = invalidInput "Email address not found.\n"
+
 -- -- Decorators
 
 -- | Decorator that enforces a POST parameter 'password' to be present
   if any isNothing [name, email]
      then return $ Just $ invalidInput "Please provide 'name' and 'email' parameters\n"
      else do
-       addEntry name email
+       addEntry (fromJust name) (fromJust email)
        return $ Just $ message "Added!\n"
 
+deleteEntryView req = do
+  let email = getPOST "email" req
+  if isNothing email
+     then return $ Just $ invalidInput "Please provide 'email' parameter"
+     else do
+       deleteEntry (fromJust email)
+       return $ Just $ message "Entry removed!\n"
+
+confirmEmailView email req = do
+  updated <- confirmByEmail email
+  return $ Just $ if (not updated)
+                    then emailNotFoundResponse
+                    else message "Email added to mailing list.\n"
+
+removeEmailView email req = do
+  updated <- removeByEmail email
+  return $ Just $ if (not updated)
+                    then emailNotFoundResponse
+                    else message "Email removed from mailing list.\n"
+
 -- Utilities
 
 randomStr :: Int -> IO String
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 ProjectModifiedEvent.java.
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.