aboutsummaryrefslogtreecommitdiff
path: root/src/server/Application.hs
diff options
context:
space:
mode:
authorJoris Guyonvarch2015-08-09 00:21:03 +0200
committerJoris Guyonvarch2015-08-09 00:21:03 +0200
commit169d52bfbe8b7f95dcece3cef245cdd62336e2f8 (patch)
tree491b5edb2646b41d36920f1c670cba26a674868c /src/server/Application.hs
parenta4f60df0f3b72553380bdd3ca960abf42048ed7e (diff)
downloadbudget-169d52bfbe8b7f95dcece3cef245cdd62336e2f8.tar.gz
budget-169d52bfbe8b7f95dcece3cef245cdd62336e2f8.tar.bz2
budget-169d52bfbe8b7f95dcece3cef245cdd62336e2f8.zip
Wording for sign in email
Diffstat (limited to 'src/server/Application.hs')
-rw-r--r--src/server/Application.hs147
1 files changed, 0 insertions, 147 deletions
diff --git a/src/server/Application.hs b/src/server/Application.hs
deleted file mode 100644
index 5306e17..0000000
--- a/src/server/Application.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Application
- ( signInAction
- , validateSignInAction
- , getUserName
- , getPaymentsAction
- , createPaymentAction
- , signOutAction
-
- , getIndexAction
- , getUsersAction
- , addUserAction
- , deleteUserAction
- ) 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.String (fromString)
-import Data.Time.Clock (getCurrentTime, diffUTCTime)
-import Data.Maybe (isJust)
-
-import Text.Email.Validate (isValid)
-
-import qualified LoginSession
-
-import qualified Secure
-
-import Model.Database
-import Model.User
-import Model.Payment
-import Model.SignIn
-import Model.Message
-
-import Config
-
-import View.Page (page)
-
-import Mail
-
-signInAction :: Config -> Text -> ActionM ()
-signInAction config login =
- if isValid (TE.encodeUtf8 login)
- then do
- maybeUser <- liftIO . runDb $ getUser login
- if isJust maybeUser
- then do
- token <- liftIO . runDb $ createSignInToken login
- let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token]
- let mail = Mail [login] "Sign in" url url
- maybeSentMail <- liftIO . sendMail $ mail
- case maybeSentMail of
- Right _ ->
- status ok200
- Left _ ->
- errorResponse "Sorry, we failed to send you the sign up email."
- else
- errorResponse "You are not authorized to sign in."
- else
- errorResponse "Please enter a valid email address."
-
-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]
-
-getUserName :: ActionM ()
-getUserName =
- Secure.loggedAction (\user -> do
- json . Message . userName . entityVal $ user
- )
-
-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 ()
- )
-
-signOutAction :: ActionM ()
-signOutAction = do
- LoginSession.delete
- status ok200
-
-errorResponse :: Text -> ActionM ()
-errorResponse msg = do
- status badRequest400
- json (Message msg)
-
-
-
-
-
-getIndexAction :: ActionM ()
-getIndexAction = html page
-
-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