SES

.gitignore

@@ -5,3 +5,4 @@ client_session_key.aes
 devel-server
 dist
 static/tmp
+SESCreds.hs

Handler/Email.hs

@@ -9,11 +9,14 @@ module Handler.Email
 import Haskellers
 import Control.Monad (when)
 import Network.Mail.Mime
+import Network.Mail.Mime.SES
 import System.Random (newStdGen)
 import Data.Maybe (isJust)
 import qualified Data.ByteString.Lazy.UTF8 as LU
 import StaticFiles (logo_png)
 import Data.Text (Text, pack, unpack)
+import SESCreds (access, secret)
+import Data.Text.Encoding (encodeUtf8)
 
 postResetEmailR :: Handler ()
 postResetEmailR = do
@@ -55,9 +58,15 @@ postSendVerifyR = do
                                ]
             render <- getUrlRender
             let url = render $ VerifyEmailR verkey
-            liftIO $ renderSendMail Mail
+            let ses = SES
+                    { sesFrom = "webmaster@haskellers.com"
+                    , sesTo = [encodeUtf8 email]
+                    , sesAccessKey = access
+                    , sesSecretKey = secret
+                    }
+            liftIO $ renderSendMailSES ses Mail
                 { mailHeaders =
-                    [ ("From", "noreply@haskellers.com")
+                    [ ("From", "webmaster@haskellers.com")
                     , ("To", email)
                     , ("Subject", "Verify your email address")
                     ]

Handler/User.hs

@@ -25,6 +25,8 @@ import Data.Time (getCurrentTime)
 import Data.Monoid (mappend)
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Read
+import Data.Maybe (fromJust)
 
 getByIdentR :: Handler RepJson
 getByIdentR = do
@@ -41,15 +43,17 @@ getByIdentR = do
 getUserR :: Text -> Handler RepHtmlJson
 getUserR input = do
     (uid, u) <-
-        case fromSinglePiece input of
-            Just uid -> runDB $ do
+        case Data.Text.Read.decimal input :: Either String (Int, Text) of
+            Right (x, "") -> runDB $ do
+                let uid = fromJust $ fromSinglePiece input
+                liftIO $ print $ "Looking for: " ++ show x ++ ", uid == " ++ show uid
                 u <- get404 uid
                 mun <- getBy $ UniqueUsernameUser uid
                 case mun of
                     Nothing -> return (uid, u)
                     Just (_, Username _ un) ->
                         lift $ redirect RedirectPermanent $ UserR un
-            Nothing -> runDB $ do
+            _ -> runDB $ do
                 mun <- getBy $ UniqueUsername input
                 case mun of
                     Nothing -> lift notFound

Haskellers.hs

@@ -67,6 +67,8 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import Data.Monoid (mappend)
 import Network.HTTP.Types (encodePath, queryTextToQuery)
 import Text.Hamlet.NonPoly (IHamlet, ihamletFile)
+import qualified Data.Text.Read
+import Data.Maybe (fromJust)
 
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -142,7 +144,7 @@ instance Yesod Haskellers where
       where
         qs = map (\(x, y) -> (x, if T.null y then Nothing else Just y)) qs'
         pieces'
-            | pieces == ["page", "openid", "complete"] = ["page", "openid", "complete", ""]
+            | pieces == ["auth", "page", "openid", "complete"] = ["auth", "page", "openid", "complete", ""] -- For Google, it remembers the old OpenIDs
             | otherwise = pieces
     cleanPath _ ["page", "openid", "complete", ""] = Right ["page", "openid", "complete"]
     cleanPath _ s =
@@ -289,9 +291,9 @@ instance YesodBreadcrumbs Haskellers where
     breadcrumb (FlagR uid) = return ("Report a User", Just $ UserR $ toSinglePiece uid)
     breadcrumb (UserR str) = do
         u <- runDB $
-            case fromSinglePiece str of
-                Just uid -> get404 uid
-                Nothing -> do
+            case Data.Text.Read.decimal str :: Either String (Int, Text) of
+                Right (_, "") -> get404 $ fromJust $ fromSinglePiece str
+                _ -> do
                     x <- getBy $ UniqueUsername str
                     case x of
                         Nothing -> lift notFound

haskellers.cabal

@@ -59,8 +59,8 @@ executable         haskellers
                    wai-extra,
                    directory,
                    bytestring,
-                   persistent,
-                   persistent-template,
+                   persistent < 0.5.1,
+                   persistent-template < 0.5.2,
                    persistent-postgresql,
                    template-haskell,
                    hamlet >= 0.8.2,
@@ -78,6 +78,7 @@ executable         haskellers
                    web-routes-quasi,
                    data-default,
                    mime-mail,
+                   mime-mail-ses,
                    text,
                    text-icu,
                    hjsmin,

upload.sh

@@ -1 +1 @@
-cabal clean && cabal configure -fproduction && cabal build && rm -rf static/tmp && strip dist/build/haskellers/haskellers && bzip2 dist/build/haskellers/haskellers && scp favicon.ico -i ~/.ec2/ec2-keypair.pem -r static dist/build/haskellers/haskellers.bz2 ubuntu@50.16.170.145:/home/ubuntu/haskellers
+cabal clean && cabal configure -fproduction && cabal build && rm -rf static/tmp && strip dist/build/haskellers/haskellers && bzip2 dist/build/haskellers/haskellers && scp -i ~/.ec2/ec2-keypair.pem -r favicon.ico static dist/build/haskellers/haskellers.bz2 ubuntu@50.16.170.145:/home/ubuntu/haskellers