Add a payment from the UI, it needs polishing however

3 files changed, 39 insertions, 32 deletions

diff --git a/src/server/Application.hs b/src/server/Application.hs
index 7e93fe1..24342dc 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -69,16 +69,18 @@ deleteUserAction email = do
   _ <- liftIO . runDb $ deleteUser email
   status ok200
 
-createPaymentAction :: Text -> Text -> Int -> ActionM ()
-createPaymentAction email name cost = do
-  maybeUser <- liftIO . runDb $ getUser email
-  case maybeUser of
-    Just user -> do
-      _ <- liftIO . runDb $ createPayment (entityKey user) name cost
-      return ()
-    Nothing -> do
-      status badRequest400
-      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 =
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 6985174..9d096e4 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -51,21 +51,26 @@ global = do
       fontSize (px iconFontSize)
       hover & transform (scale 1.2 1.2)
 
-  table ? do
-    width (pct 100)
-    textAlign (alignSide (sideCenter))
-    "border-spacing" -: "10 px"
-
-    th ? do
-      backgroundColor C.brown
-      color C.white
-      fontSize (px iconFontSize)
-      lineHeight (px 70)
+  ".payments" ? do
+    ".add" ? do
+      marginBottom (px 20)
+      marginLeft (px 20)
+
+    table ? do
+      width (pct 100)
+      textAlign (alignSide (sideCenter))
+      "border-spacing" -: "10 px"
+
+      th ? do
+        backgroundColor C.brown
+        color C.white
+        fontSize (px iconFontSize)
+        lineHeight (px 70)
 
-    tr ? do
-      fontSize (px 20)
-      lineHeight (px 60)
-      nthChild "odd" & backgroundColor C.lightGrey
+      tr ? do
+        fontSize (px 20)
+        lineHeight (px 60)
+        nthChild "odd" & backgroundColor C.lightGrey
 
   ".signIn" ? do
 
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 7fd42a7..d534c4e 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -29,12 +29,17 @@ main = do
       token <- param "token" :: ActionM Text
       validateSignInAction token
 
-    post "/signOut" $
-      signOutAction
-
     get "/payments" $
       getPaymentsAction
 
+    post "/payment/add" $ do
+      name <- param "name" :: ActionM Text
+      cost <- param "cost" :: ActionM Int
+      createPaymentAction name cost
+
+    post "/signOut" $
+      signOutAction
+
     get "/users" getUsersAction
     post "/user/add" $ do
       email <- param "email" :: ActionM Text
@@ -43,8 +48,3 @@ main = do
     post "/user/delete" $ do
       email <- param "email" :: ActionM Text
       deleteUserAction email
-    post "/payment/add" $ do
-      email <- param "email" :: ActionM Text
-      name <- param "name" :: ActionM Text
-      cost <- param "cost" :: ActionM Int
-      createPaymentAction email name cost