From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 3 Jan 2018 17:31:20 +0100
Subject: Modify weelky report and payment search interface

- Add payment balance in weekly report
- Show a message and hide pages when the search results in no results
- Go to page 1 when the search is updated / erased
---
 server/src/Controller/Index.hs | 77 ++++++++++++++++++++++++++++++------------
 1 file changed, 55 insertions(+), 22 deletions(-)

(limited to 'server/src/Controller/Index.hs')

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
-- 
cgit v1.2.3