From a271d6034bc4cc631a64476d25d21c83a701fa39 Mon Sep 17 00:00:00 2001 From: Joris Guyonvarch Date: Mon, 20 Jul 2015 21:55:52 +0200 Subject: Add a payment from the UI, it needs polishing however --- src/client/Main.elm | 4 +- src/client/Model/View.elm | 7 +- src/client/Model/View/PaymentView.elm | 19 +++++ src/client/Model/View/SignIn.elm | 15 ---- src/client/Model/View/SignInView.elm | 15 ++++ src/client/ServerCommunication.elm | 12 ++- src/client/Update.elm | 33 ++++++--- src/client/Update/Payment.elm | 22 ++++++ src/client/Update/SignIn.elm | 12 +-- src/client/View/Header.elm | 35 +++++++++ src/client/View/Loading.elm | 8 ++ src/client/View/Page.elm | 136 +++------------------------------- src/client/View/Payments.elm | 20 +++++ src/client/View/Payments/Add.elm | 34 +++++++++ src/client/View/Payments/Table.elm | 51 +++++++++++++ src/client/View/SignIn.elm | 60 +++++++++++++++ src/server/Application.hs | 22 +++--- src/server/Design/Global.hs | 33 +++++---- src/server/Main.hs | 16 ++-- 19 files changed, 356 insertions(+), 198 deletions(-) create mode 100644 src/client/Model/View/PaymentView.elm delete mode 100644 src/client/Model/View/SignIn.elm create mode 100644 src/client/Model/View/SignInView.elm create mode 100644 src/client/Update/Payment.elm create mode 100644 src/client/View/Header.elm create mode 100644 src/client/View/Loading.elm create mode 100644 src/client/View/Payments.elm create mode 100644 src/client/View/Payments/Add.elm create mode 100644 src/client/View/Payments/Table.elm create mode 100644 src/client/View/SignIn.elm diff --git a/src/client/Main.elm b/src/client/Main.elm index 519360a..678d20e 100644 --- a/src/client/Main.elm +++ b/src/client/Main.elm @@ -46,10 +46,10 @@ port fetchPayments = |> flip Task.onError reportError reportSuccess : Payments -> Task x () -reportSuccess payments = Signal.send actions.address (UpdatePayments payments) +reportSuccess payments = Signal.send actions.address (GoPaymentView payments) reportError : Http.Error -> Task x () -reportError error = Signal.send actions.address SignIn +reportError error = Signal.send actions.address GoSignInView getPayments : Task Http.Error Payments getPayments = Http.get paymentsDecoder "/payments" diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm index 3e3cbca..7befca4 100644 --- a/src/client/Model/View.elm +++ b/src/client/Model/View.elm @@ -3,9 +3,10 @@ module Model.View ) where import Model.Payment exposing (Payments) -import Model.View.SignIn exposing (..) +import Model.View.SignInView exposing (..) +import Model.View.PaymentView exposing (..) type View = LoadingView - | PaymentView Payments - | SignInView SignIn + | SignInView SignInView + | PaymentView PaymentView diff --git a/src/client/Model/View/PaymentView.elm b/src/client/Model/View/PaymentView.elm new file mode 100644 index 0000000..cea7d2e --- /dev/null +++ b/src/client/Model/View/PaymentView.elm @@ -0,0 +1,19 @@ +module Model.View.PaymentView + ( PaymentView + , initPaymentView + ) where + +import Model.Payment exposing (Payments) + +type alias PaymentView = + { name : String + , cost : String + , payments : Payments + } + +initPaymentView : Payments -> PaymentView +initPaymentView payments = + { name = "" + , cost = "" + , payments = payments + } diff --git a/src/client/Model/View/SignIn.elm b/src/client/Model/View/SignIn.elm deleted file mode 100644 index 0a973e2..0000000 --- a/src/client/Model/View/SignIn.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Model.View.SignIn - ( SignIn - , initSignIn - ) where - -type alias SignIn = - { login : String - , result : Maybe (Result String String) - } - -initSignIn : SignIn -initSignIn = - { login = "" - , result = Nothing - } diff --git a/src/client/Model/View/SignInView.elm b/src/client/Model/View/SignInView.elm new file mode 100644 index 0000000..0fbce39 --- /dev/null +++ b/src/client/Model/View/SignInView.elm @@ -0,0 +1,15 @@ +module Model.View.SignInView + ( SignInView + , initSignInView + ) where + +type alias SignInView = + { login : String + , result : Maybe (Result String String) + } + +initSignInView : SignInView +initSignInView = + { login = "" + , result = Nothing + } diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm index d581f82..d763e29 100644 --- a/src/client/ServerCommunication.elm +++ b/src/client/ServerCommunication.elm @@ -16,6 +16,7 @@ import Update.SignIn exposing (..) type Communication = NoCommunication | SignIn String + | AddPayment String String | SignOut serverCommunications : Signal.Mailbox Communication @@ -42,6 +43,13 @@ getRequest communication = , url = "/signIn?login=" ++ login , body = Http.empty } + AddPayment name cost -> + Just + { verb = "post" + , headers = [] + , url = "/payment/add?name=" ++ name ++ "&cost=" ++ cost + , body = Http.empty + } SignOut -> Just { verb = "post" @@ -59,8 +67,10 @@ communicationToAction communication response = U.NoOp SignIn login -> U.UpdateSignIn (ValidLogin login) + AddPayment _ _ -> + U.NoOp SignOut -> - U.SignIn + U.GoSignInView else decodeResponse response diff --git a/src/client/Update.elm b/src/client/Update.elm index 508ee2f..f88a3a2 100644 --- a/src/client/Update.elm +++ b/src/client/Update.elm @@ -6,17 +6,20 @@ module Update import Model exposing (Model) import Model.Payment exposing (Payments) -import Model.View exposing (..) -import Model.View.SignIn exposing (..) +import Model.View as V +import Model.View.SignInView exposing (..) +import Model.View.PaymentView exposing (..) import Update.SignIn exposing (..) +import Update.Payment exposing (..) type Action = NoOp - | SignIn + | GoSignInView | SignInError String | UpdateSignIn SignInAction - | UpdatePayments Payments + | GoPaymentView Payments + | UpdatePayment PaymentAction actions : Signal.Mailbox Action actions = Signal.mailbox NoOp @@ -26,16 +29,22 @@ updateModel action model = case action of NoOp -> model - SignIn -> - { model | view <- SignInView initSignIn } + GoSignInView -> + { model | view <- V.SignInView initSignInView } + GoPaymentView payments -> + { model | view <- V.PaymentView (initPaymentView payments) } SignInError msg -> - let signIn = { initSignIn | result <- Just (Err msg) } - in { model | view <- SignInView signIn } + let signInView = { initSignInView | result <- Just (Err msg) } + in { model | view <- V.SignInView signInView } UpdateSignIn signInAction -> case model.view of - SignInView signIn -> - { model | view <- SignInView (updateSignIn signInAction signIn) } + V.SignInView signInView -> + { model | view <- V.SignInView (updateSignIn signInAction signInView) } + _ -> + model + UpdatePayment paymentAction -> + case model.view of + V.PaymentView paymentView -> + { model | view <- V.PaymentView (updatePayment paymentAction paymentView) } _ -> model - UpdatePayments payments -> - { model | view <- PaymentView payments } diff --git a/src/client/Update/Payment.elm b/src/client/Update/Payment.elm new file mode 100644 index 0000000..129ccde --- /dev/null +++ b/src/client/Update/Payment.elm @@ -0,0 +1,22 @@ +module Update.Payment + ( PaymentAction(..) + , updatePayment + ) where + +import Model.View.PaymentView exposing (..) +import Model.Payment exposing (..) + +type PaymentAction = + UpdateName String + | UpdateCost String + | UpdatePayments Payments + +updatePayment : PaymentAction -> PaymentView -> PaymentView +updatePayment action paymentView = + case action of + UpdateName name -> + { paymentView | name <- name } + UpdateCost cost -> + { paymentView | cost <- cost } + UpdatePayments payments -> + { paymentView | payments <- payments } diff --git a/src/client/Update/SignIn.elm b/src/client/Update/SignIn.elm index 0e118dc..0aa7c84 100644 --- a/src/client/Update/SignIn.elm +++ b/src/client/Update/SignIn.elm @@ -3,22 +3,22 @@ module Update.SignIn , updateSignIn ) where -import Model.View.SignIn exposing (..) +import Model.View.SignInView exposing (..) type SignInAction = UpdateLogin String | ValidLogin String | ErrorLogin String -updateSignIn : SignInAction -> SignIn -> SignIn -updateSignIn action signIn = +updateSignIn : SignInAction -> SignInView -> SignInView +updateSignIn action signInView = case action of UpdateLogin login -> - { signIn | login <- login } + { signInView | login <- login } ValidLogin message -> - { signIn + { signInView | login <- "" , result <- Just (Ok message) } ErrorLogin message -> - { signIn | result <- Just (Err message) } + { signInView | result <- Just (Err message) } diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm new file mode 100644 index 0000000..788a473 --- /dev/null +++ b/src/client/View/Header.elm @@ -0,0 +1,35 @@ +module View.Header + ( renderHeader + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import ServerCommunication as SC +import ServerCommunication exposing (serverCommunications) + +import Model exposing (Model) +import Model.View exposing (..) + +import View.Icon exposing (renderIcon) + +renderHeader : Model -> Html +renderHeader model = + header + [] + [ h1 + [] + [ text "Shared Cost" ] + , case model.view of + LoadingView -> + text "" + SignInView _ -> + text "" + PaymentView _ -> + button + [ class "signOut" + , onClick serverCommunications.address SC.SignOut + ] + [ renderIcon "power-off" ] + ] diff --git a/src/client/View/Loading.elm b/src/client/View/Loading.elm new file mode 100644 index 0000000..f8c6cd6 --- /dev/null +++ b/src/client/View/Loading.elm @@ -0,0 +1,8 @@ +module View.Loading + ( renderLoading + ) where + +import Html exposing (..) + +renderLoading : Html +renderLoading = text "" diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm index bf61dc1..59c21a2 100644 --- a/src/client/View/Page.elm +++ b/src/client/View/Page.elm @@ -3,30 +3,14 @@ module View.Page ) where import Html exposing (..) -import Html as H -import Html.Attributes exposing (..) -import Html.Attributes as A -import Html.Events exposing (..) - -import Date -import Date exposing (Date) - -import String exposing (append) - -import Json.Decode as Json import Model exposing (Model) -import Model.Payment exposing (Payments, Payment) import Model.View exposing (..) -import Model.View.SignIn exposing (..) -import Update exposing (..) -import Update.SignIn exposing (..) - -import ServerCommunication as SC -import ServerCommunication exposing (serverCommunications) - -import View.Icon exposing (renderIcon) +import View.Header exposing (renderHeader) +import View.Loading exposing (renderLoading) +import View.SignIn exposing (renderSignIn) +import View.Payments exposing (renderPayments) renderPage : Model -> Html renderPage model = @@ -36,114 +20,12 @@ renderPage model = , renderMain model ] -renderHeader : Model -> Html -renderHeader model = - header - [] - [ h1 - [] - [ text "Shared Cost" ] - , case model.view of - LoadingView -> - text "" - SignInView _ -> - text "" - PaymentView _ -> - button - [ class "signOut" - , onClick serverCommunications.address SC.SignOut - ] - [ renderIcon "power-off" ] - ] - renderMain : Model -> Html renderMain model = case model.view of LoadingView -> - loadingView - SignInView signIn -> - signInView signIn - PaymentView payments -> - paymentsView payments - -loadingView : Html -loadingView = text "" - -signInView : SignIn -> Html -signInView signIn = - div - [ class "signIn" ] - [ div - [ class "form" ] - [ input - [ value signIn.login - , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin) - , onEnter serverCommunications.address (SC.SignIn signIn.login) - ] - [] - , button - [ onClick serverCommunications.address (SC.SignIn signIn.login) ] - [ text "Sign in" ] - ] - , div - [ class "result" ] - [ signInResult signIn ] - ] - -onEnter : Signal.Address a -> a -> Attribute -onEnter address value = - on "keydown" - (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err "")) - (\_ -> Signal.message address value) - -signInResult : SignIn -> Html -signInResult signIn = - case signIn.result of - Just result -> - case result of - Ok login -> - div - [ class "success" ] - [ text ("We send you an email, please click to the provided link in order to sign in.") ] - Err error -> - div - [ class "error" ] - [ text error ] - Nothing -> - text "" - -paymentsView : Payments -> Html -paymentsView payments = - table - [] - ([ tr - [] - [ th [] [ renderIcon "user" ] - , th [] [ renderIcon "shopping-cart" ] - , th [] [ renderIcon "euro" ] - , th [] [ renderIcon "calendar" ] - ] - ] ++ (paymentLines payments)) - -paymentLines : Payments -> List Html -paymentLines payments = - payments - |> List.sortBy (Date.toTime << .creation) - |> List.reverse - |> List.map paymentLine - -paymentLine : Payment -> Html -paymentLine payment = - tr - [] - [ td [] [ text payment.userName ] - , td [] [ text payment.name ] - , td [] [ text ((toString payment.cost) ++ " €") ] - , td [] [ text (renderDate payment.creation) ] - ] - -renderDate : Date -> String -renderDate date = - toString (Date.day date) - |> flip append (" " ++ (toString (Date.month date)) ++ ".") - |> flip append (" " ++ (toString (Date.year date))) + renderLoading + SignInView signInView -> + renderSignIn signInView + PaymentView paymentsView -> + renderPayments paymentsView diff --git a/src/client/View/Payments.elm b/src/client/View/Payments.elm new file mode 100644 index 0000000..dfc0905 --- /dev/null +++ b/src/client/View/Payments.elm @@ -0,0 +1,20 @@ +module View.Payments + ( renderPayments + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) + +import Model.Payment exposing (Payments) +import Model.View.PaymentView exposing (PaymentView) + +import View.Payments.Add exposing (addPayment) +import View.Payments.Table exposing (paymentsTable) + +renderPayments : PaymentView -> Html +renderPayments paymentView = + div + [ class "payments" ] + [ addPayment paymentView.name paymentView.cost + , paymentsTable paymentView.payments + ] diff --git a/src/client/View/Payments/Add.elm b/src/client/View/Payments/Add.elm new file mode 100644 index 0000000..f2230be --- /dev/null +++ b/src/client/View/Payments/Add.elm @@ -0,0 +1,34 @@ +module View.Payments.Add + ( addPayment + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import ServerCommunication as SC +import ServerCommunication exposing (serverCommunications) + +import Update exposing (..) +import Update.Payment exposing (..) + +addPayment : String -> String -> Html +addPayment name cost = + div + [ class "add" ] + [ text "Name" + , input + [ value name + , on "input" targetValue (Signal.message actions.address << UpdatePayment << UpdateName) + ] + [] + , text "Cost" + , input + [ value cost + , on "input" targetValue (Signal.message actions.address << UpdatePayment << UpdateCost) + ] + [] + , button + [ onClick serverCommunications.address (SC.AddPayment name cost) ] + [ text "Add" ] + ] diff --git a/src/client/View/Payments/Table.elm b/src/client/View/Payments/Table.elm new file mode 100644 index 0000000..34dc058 --- /dev/null +++ b/src/client/View/Payments/Table.elm @@ -0,0 +1,51 @@ +module View.Payments.Table + ( paymentsTable + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) + +import Date +import Date exposing (Date) + +import String exposing (append) + +import Model.Payment exposing (Payments, Payment) + +import View.Icon exposing (renderIcon) + +paymentsTable : Payments -> Html +paymentsTable payments = + table + [] + ([ tr + [] + [ th [] [ renderIcon "user" ] + , th [] [ renderIcon "shopping-cart" ] + , th [] [ renderIcon "euro" ] + , th [] [ renderIcon "calendar" ] + ] + ] ++ (paymentLines payments)) + +paymentLines : Payments -> List Html +paymentLines payments = + payments + |> List.sortBy (Date.toTime << .creation) + |> List.reverse + |> List.map paymentLine + +paymentLine : Payment -> Html +paymentLine payment = + tr + [] + [ td [] [ text payment.userName ] + , td [] [ text payment.name ] + , td [] [ text ((toString payment.cost) ++ " €") ] + , td [] [ text (renderDate payment.creation) ] + ] + +renderDate : Date -> String +renderDate date = + toString (Date.day date) + |> flip append (" " ++ (toString (Date.month date)) ++ ".") + |> flip append (" " ++ (toString (Date.year date))) diff --git a/src/client/View/SignIn.elm b/src/client/View/SignIn.elm new file mode 100644 index 0000000..02ee1bd --- /dev/null +++ b/src/client/View/SignIn.elm @@ -0,0 +1,60 @@ +module View.SignIn + ( renderSignIn + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import Json.Decode as Json + +import Update exposing (..) +import Update.SignIn exposing (..) + +import ServerCommunication as SC +import ServerCommunication exposing (serverCommunications) + +import Model.View.SignInView exposing (..) + +renderSignIn : SignInView -> Html +renderSignIn signInView = + div + [ class "signIn" ] + [ div + [ class "form" ] + [ input + [ value signInView.login + , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin) + , onEnter serverCommunications.address (SC.SignIn signInView.login) + ] + [] + , button + [ onClick serverCommunications.address (SC.SignIn signInView.login) ] + [ text "Sign in" ] + ] + , div + [ class "result" ] + [ signInResult signInView ] + ] + +onEnter : Signal.Address a -> a -> Attribute +onEnter address value = + on "keydown" + (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err "")) + (\_ -> Signal.message address value) + +signInResult : SignInView -> Html +signInResult signInView = + case signInView.result of + Just result -> + case result of + Ok login -> + div + [ class "success" ] + [ text ("We send you an email, please click to the provided link in order to sign in.") ] + Err error -> + div + [ class "error" ] + [ text error ] + Nothing -> + text "" 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 -- cgit v1.2.3