From 0d589e12a0c32936303de46b1e462dd19648170d Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Sun, 19 Jul 2015 16:07:15 +0200
Subject: Login with a token validation

---
 src/server/Application.hs | 43 +++++++++++++++++++++++++++++--------------
 1 file changed, 29 insertions(+), 14 deletions(-)

(limited to 'src/server/Application.hs')

diff --git a/src/server/Application.hs b/src/server/Application.hs
index 28ad3cd..75d0323 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -1,14 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Application
-  ( signIn
-  , signOut
+  ( signInAction
+  , validateSignInAction
+  , signOutAction
   , getIndexAction
   , getUsersAction
   , getPaymentsAction
   , addUserAction
   , deleteUserAction
-  , insertPaymentAction
+  , createPaymentAction
   ) where
 
 import Web.Scotty
@@ -21,16 +22,17 @@ import Control.Monad.IO.Class (liftIO)
 
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
 import Data.String (fromString)
-import qualified Data.Text.Lazy as TL
 
 import qualified LoginSession
 
 import qualified Secure
 
-import Model.Database (runDb)
+import Model.Database
 import Model.User
 import Model.Payment
+import Model.SignIn
 
 import View.Page (page)
 
@@ -51,7 +53,7 @@ getPaymentsAction =
 
 addUserAction :: Text -> Text -> ActionM ()
 addUserAction email name = do
-  _ <- liftIO . runDb $ insertUser email name
+  _ <- liftIO . runDb $ createUser email name
   status ok200
 
 deleteUserAction :: Text -> ActionM ()
@@ -59,28 +61,41 @@ deleteUserAction email = do
   _ <- liftIO . runDb $ deleteUser email
   status ok200
 
-insertPaymentAction :: Text -> Text -> Int -> ActionM ()
-insertPaymentAction email name cost = do
+createPaymentAction :: Text -> Text -> Int -> ActionM ()
+createPaymentAction email name cost = do
   maybeUser <- liftIO . runDb $ getUser email
   case maybeUser of
     Just user -> do
-      _ <- liftIO . runDb $ insertPayment (entityKey user) name cost
+      _ <- liftIO . runDb $ createPayment (entityKey user) name cost
       return ()
     Nothing -> do
       status badRequest400
       status ok200
 
-signIn :: Text -> ActionM ()
-signIn login = do
+signInAction :: Text -> ActionM ()
+signInAction login = do
   maybeUser <- liftIO . runDb $ getUser login
   case maybeUser of
     Just _ -> do
-      LoginSession.put login
+      token <- liftIO . runDb $ createSignInToken login
+      let url = T.concat ["http://localhost:3000/validateSignIn?token=", token]
+      liftIO . TIO.putStrLn $ url
       status ok200
     Nothing ->
       status badRequest400
 
-signOut :: ActionM ()
-signOut = do
+validateSignInAction :: Text -> ActionM ()
+validateSignInAction token = do
+  maybeSignIn <- liftIO . runDb $ getSignInToken token
+  case maybeSignIn of
+    Just signIn -> do
+      LoginSession.put (signInEmail . entityVal $ signIn)
+      liftIO . runDb . signInTokenIsUsed . entityKey $ signIn
+      redirect "/"
+    Nothing ->
+      status badRequest400
+
+signOutAction :: ActionM ()
+signOutAction = do
   LoginSession.delete
   status ok200
-- 
cgit v1.2.3