From 2a53fe50c62d4b7aec0f422998c743f68aa523c1 Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Tue, 21 Jul 2015 23:25:58 +0200
Subject: Adding the payment without reloading the page

---
 src/server/Application.hs   | 86 ++++++++++++++++++++++++---------------------
 src/server/Design/Global.hs |  2 +-
 src/server/Main.hs          |  3 ++
 src/server/Secure.hs        | 23 +++++++++---
 4 files changed, 69 insertions(+), 45 deletions(-)

(limited to 'src/server')

diff --git a/src/server/Application.hs b/src/server/Application.hs
index 24342dc..59aa252 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -3,13 +3,15 @@
 module Application
   ( signInAction
   , validateSignInAction
+  , getUserName
+  , getPaymentsAction
+  , createPaymentAction
   , signOutAction
+
   , getIndexAction
   , getUsersAction
-  , getPaymentsAction
   , addUserAction
   , deleteUserAction
-  , createPaymentAction
   ) where
 
 import Web.Scotty
@@ -44,44 +46,6 @@ import View.Page (page)
 
 import Mail
 
-getIndexAction :: ActionM ()
-getIndexAction = html page
-
-getUsersAction :: ActionM ()
-getUsersAction = do
-  users <- liftIO $ runDb getUsers
-  html . fromString . show $ users
-
-getPaymentsAction :: ActionM ()
-getPaymentsAction =
-  Secure.loggedAction (\_ -> do
-    payments <- liftIO $ runDb getPayments
-    json payments
-  )
-
-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
-
-createPaymentAction :: Text -> Int -> ActionM ()
-createPaymentAction name cost =
-  Secure.loggedAction (\login -> do
-    maybeUser <- liftIO . runDb $ getUser login
-    case maybeUser of
-      Just user -> do
-        _ <- liftIO . runDb $ createPayment (entityKey user) name cost
-        return ()
-      Nothing -> do
-        status badRequest400
-        status ok200
-  )
-
 signInAction :: Text -> ActionM ()
 signInAction login =
   if isValid (TE.encodeUtf8 login)
@@ -129,6 +93,26 @@ 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
@@ -138,3 +122,25 @@ 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
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 9d096e4..1f35732 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -74,7 +74,7 @@ global = do
 
   ".signIn" ? do
 
-    ".form" ? do
+    form ? do
       let inputHeight = 50
       width (px 500)
       marginTop (px 50)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index d534c4e..2ae319b 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -29,6 +29,9 @@ main = do
       token <- param "token" :: ActionM Text
       validateSignInAction token
 
+    get "/userName" $
+      getUserName
+
     get "/payments" $
       getPaymentsAction
 
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 94ee8a9..1fef713 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -8,16 +8,31 @@ import Web.Scotty
 
 import Network.HTTP.Types.Status (forbidden403)
 
-import Data.Text (Text)
+import Database.Persist (Entity)
+
+import Model.Database (User, runDb)
+import Model.User (getUser)
+
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
 
 import qualified LoginSession
 
-loggedAction :: (Text -> ActionM ()) -> ActionM ()
+loggedAction :: (Entity User -> ActionM ()) -> ActionM ()
 loggedAction action = do
   maybeLogin <- LoginSession.get
   case maybeLogin of
-    Just login ->
-      action login
+    Just login -> do
+      maybeUser <- liftIO . runDb $ getUser login
+      case maybeUser of
+        Just user ->
+          action user
+        Nothing -> do
+          status forbidden403
+          liftIO . TIO.putStrLn . T.concat $ ["Could not find the user which login is ", login]
+          html "Could not find a user from your login"
     Nothing -> do
       status forbidden403
       html "You need to be logged in to perform this action"
-- 
cgit v1.2.3