aboutsummaryrefslogtreecommitdiff
path: root/server/src/Controller
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Controller')
-rw-r--r--server/src/Controller/Index.hs77
-rw-r--r--server/src/Controller/Payment.hs2
-rw-r--r--server/src/Controller/SignIn.hs44
3 files changed, 56 insertions, 67 deletions
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index f05ce6f..9a3e2b7 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -1,16 +1,23 @@
module Controller.Index
( get
+ , askSignIn
+ , trySignIn
, signOut
) where
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
import Data.Time.Clock (diffUTCTime, getCurrentTime)
-import Network.HTTP.Types.Status (ok200)
+import Network.HTTP.Types.Status (badRequest400, ok200)
import Prelude hiding (error)
-import Web.Scotty hiding (get)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
-import Common.Model (InitResult (..), User (..))
+import Common.Model (InitResult (..), SignIn (..),
+ User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
@@ -21,26 +28,52 @@ import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
import qualified Model.User as User
import Secure (getUserFromToken)
+import qualified SendMail
+import qualified Text.Email.Validate as Email
+import qualified View.Mail.SignIn as SignIn
import View.Page (page)
-get :: Conf -> Maybe Text -> ActionM ()
-get conf mbToken = do
- initResult <- case mbToken of
- Just token -> do
- userOrError <- validateSignIn conf token
- case userOrError of
- Left errorKey ->
- return . InitEmpty . Left . Msg.get $ errorKey
- Right user ->
- liftIO . Query.run . fmap InitSuccess $ getInit user conf
- Nothing -> do
- mbLoggedUser <- getLoggedUser
- case mbLoggedUser of
- Nothing ->
- return . InitEmpty . Right $ Nothing
- Just user ->
- liftIO . Query.run . fmap InitSuccess $ getInit user conf
- html $ page initResult
+get :: Conf -> ActionM ()
+get conf = do
+ initResult <- do
+ mbLoggedUser <- getLoggedUser
+ case mbLoggedUser of
+ Nothing ->
+ return . InitEmpty . Right $ Nothing
+ Just user ->
+ liftIO . Query.run . fmap InitSuccess $ getInit user conf
+ S.html $ page initResult
+
+askSignIn :: Conf -> SignIn -> ActionM ()
+askSignIn conf (SignIn email) =
+ if Email.isValid (TE.encodeUtf8 email)
+ then do
+ maybeUser <- liftIO . Query.run $ User.get email
+ case maybeUser of
+ Just user -> do
+ token <- liftIO . Query.run $ SignIn.createSignInToken email
+ let url = T.concat [
+ if Conf.https conf then "https://" else "http://",
+ Conf.hostname conf,
+ "/signIn/",
+ token
+ ]
+ maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
+ case maybeSentMail of
+ Right _ -> textKey ok200 Msg.SignIn_EmailSent
+ Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
+ Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
+ else textKey badRequest400 Msg.SignIn_EmailInvalid
+ where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+
+trySignIn :: Conf -> Text -> ActionM ()
+trySignIn conf token = do
+ userOrError <- validateSignIn conf token
+ case userOrError of
+ Left errorKey ->
+ S.html $ page (InitEmpty . Left . Msg.get $ errorKey)
+ Right _ ->
+ S.redirect "/"
validateSignIn :: Conf -> Text -> ActionM (Either Key User)
validateSignIn conf textToken = do
@@ -82,4 +115,4 @@ getLoggedUser = do
liftIO . Query.run . getUserFromToken $ token
signOut :: Conf -> ActionM ()
-signOut conf = LoginSession.delete conf >> status ok200
+signOut conf = LoginSession.delete conf >> S.status ok200
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index c6c874a..f2af6c9 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -22,7 +22,7 @@ import qualified Secure
list :: ActionM ()
list =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ Payment.list) >>= json
+ (liftIO . Query.run $ Payment.listActive) >>= json
)
create :: CreatePayment -> ActionM ()
diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs
deleted file mode 100644
index cf92c9f..0000000
--- a/server/src/Controller/SignIn.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Controller.SignIn
- ( signIn
- ) where
-
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty
-
-import Common.Model (SignIn (..))
-import qualified Common.Msg as Msg
-
-import Conf (Conf)
-import qualified Conf
-import qualified Model.Query as Query
-import qualified Model.SignIn as SignIn
-import qualified Model.User as User
-import qualified SendMail
-import qualified Text.Email.Validate as Email
-import qualified View.Mail.SignIn as SignIn
-
-signIn :: Conf -> SignIn -> ActionM ()
-signIn conf (SignIn email) =
- if Email.isValid (TE.encodeUtf8 email)
- then do
- maybeUser <- liftIO . Query.run $ User.get email
- case maybeUser of
- Just user -> do
- token <- liftIO . Query.run $ SignIn.createSignInToken email
- let url = T.concat [
- if Conf.https conf then "https://" else "http://",
- Conf.hostname conf,
- "?signInToken=",
- token
- ]
- maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email]
- case maybeSentMail of
- Right _ -> textKey ok200 Msg.SignIn_EmailSent
- Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
- Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
- else textKey badRequest400 Msg.SignIn_EmailInvalid
- where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key)