aboutsummaryrefslogtreecommitdiff
path: root/src/server/Controller
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/Controller')
-rw-r--r--src/server/Controller/Index.hs58
-rw-r--r--src/server/Controller/Payment.hs31
-rw-r--r--src/server/Controller/SignIn.hs85
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]