aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/Main.elm4
-rw-r--r--src/client/Model/View.elm7
-rw-r--r--src/client/Model/View/PaymentView.elm19
-rw-r--r--src/client/Model/View/SignIn.elm15
-rw-r--r--src/client/Model/View/SignInView.elm15
-rw-r--r--src/client/ServerCommunication.elm12
-rw-r--r--src/client/Update.elm33
-rw-r--r--src/client/Update/Payment.elm22
-rw-r--r--src/client/Update/SignIn.elm12
-rw-r--r--src/client/View/Header.elm35
-rw-r--r--src/client/View/Loading.elm8
-rw-r--r--src/client/View/Page.elm136
-rw-r--r--src/client/View/Payments.elm20
-rw-r--r--src/client/View/Payments/Add.elm34
-rw-r--r--src/client/View/Payments/Table.elm51
-rw-r--r--src/client/View/SignIn.elm60
-rw-r--r--src/server/Application.hs22
-rw-r--r--src/server/Design/Global.hs33
-rw-r--r--src/server/Main.hs16
19 files changed, 356 insertions, 198 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-08 18:23:55 +0000