Wording for sign in email

3 files changed, 174 insertions, 0 deletions

diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
new file mode 100644
index 0000000..610c57c
--- /dev/null
+++ b/src/server/Controller/Index.hs
@@ -0,0 +1,58 @@
+module Controller.Index
+  ( getIndexAction
+  , getUserName
+  , signOutAction
+  , getUsersAction
+  , addUserAction
+  , deleteUserAction
+  ) where
+
+import Web.Scotty
+
+import Network.HTTP.Types.Status (ok200)
+
+import Database.Persist
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Text (Text)
+import Data.String (fromString)
+
+import qualified LoginSession
+
+import qualified Secure
+
+import Model.Database
+import Model.User
+import Model.Message
+
+import View.Page (page)
+
+getIndexAction :: ActionM ()
+getIndexAction = html page
+
+getUserName :: ActionM ()
+getUserName =
+  Secure.loggedAction (\user -> do
+    json . Message . userName . entityVal $ user
+  )
+
+signOutAction :: ActionM ()
+signOutAction = do
+  LoginSession.delete
+  status ok200
+
+getUsersAction :: ActionM ()
+getUsersAction = do
+  users <- liftIO $ runDb getUsers
+  html . fromString . show $ users
+
+addUserAction :: Text -> Text -> ActionM ()
+addUserAction email name = do
+  _ <- liftIO . runDb $ createUser email name
+  status ok200
+
+deleteUserAction :: Text -> ActionM ()
+deleteUserAction email = do
+  _ <- liftIO . runDb $ deleteUser email
+  status ok200
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
new file mode 100644
index 0000000..1287825
--- /dev/null
+++ b/src/server/Controller/Payment.hs
@@ -0,0 +1,31 @@
+module Controller.Payment
+  ( getPaymentsAction
+  , createPaymentAction
+  ) where
+
+import Web.Scotty
+
+import Database.Persist
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Text (Text)
+
+import qualified Secure
+
+import Model.Database
+import Model.Payment
+
+getPaymentsAction :: ActionM ()
+getPaymentsAction =
+  Secure.loggedAction (\_ -> do
+    payments <- liftIO $ runDb getPayments
+    json payments
+  )
+
+createPaymentAction :: Text -> Int -> ActionM ()
+createPaymentAction name cost =
+  Secure.loggedAction (\user -> do
+    _ <- liftIO . runDb $ createPayment (entityKey user) name cost
+    return ()
+  )
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
new file mode 100644
index 0000000..a46894a
--- /dev/null
+++ b/src/server/Controller/SignIn.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Controller.SignIn
+  ( signInAction
+  , validateSignInAction
+  ) where
+
+import Web.Scotty
+
+import Network.HTTP.Types.Status (ok200, badRequest400)
+
+import Database.Persist
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Encoding as TE
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+
+import qualified LoginSession
+
+import Config
+
+import SendMail
+
+import Text.Email.Validate (isValid)
+
+import Model.Database
+import Model.User
+import Model.SignIn
+import Model.Message
+
+import qualified View.Mail.SignIn as SignIn
+
+signInAction :: Config -> Text -> ActionM ()
+signInAction config login =
+  if isValid (TE.encodeUtf8 login)
+    then do
+      maybeUser <- liftIO . runDb $ getUser login
+      case maybeUser of
+        Just user -> do
+          token <- liftIO . runDb $ createSignInToken login
+          let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token]
+          maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login]
+          case maybeSentMail of
+            Right _ ->
+              status ok200
+            Left _ ->
+              errorResponse "Sorry, we failed to send you the sign up email."
+        Nothing ->
+            errorResponse "You are not authorized to sign in."
+    else
+      errorResponse "Please enter a valid email address."
+
+errorResponse :: Text -> ActionM ()
+errorResponse msg = do
+  status badRequest400
+  json (Message msg)
+
+validateSignInAction :: Text -> ActionM ()
+validateSignInAction token = do
+  maybeSignIn <- liftIO . runDb $ getSignInToken token
+  now <- liftIO getCurrentTime
+  case maybeSignIn of
+    Just signIn ->
+      if signInIsUsed . entityVal $ signIn
+        then
+          redirectError "The token has already been used."
+        else
+          let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
+          in  if diffTime > 2 * 60 -- 2 minutes
+                then
+                  redirectError "The token has expired."
+                else do
+                  LoginSession.put (signInEmail . entityVal $ signIn)
+                  liftIO . runDb . signInTokenToUsed . entityKey $ signIn
+                  redirect "/"
+    Nothing ->
+      redirectError "The token is invalid."
+
+redirectError :: Text -> ActionM ()
+redirectError msg =
+  redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]