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/Payment.elm6
-rw-r--r--src/client/Model/View/PaymentView.elm2
-rw-r--r--src/client/ServerCommunication.elm32
-rw-r--r--src/client/Update/Payment.elm6
-rw-r--r--src/client/View/Payments.elm2
-rw-r--r--src/client/View/Payments/Paging.elm31
-rw-r--r--src/server/Controller/Payment.hs6
-rw-r--r--src/server/Design/Color.hs4
-rw-r--r--src/server/Design/Global.hs24
-rw-r--r--src/server/Main.hs6
-rw-r--r--src/server/Model/Payment.hs7
12 files changed, 105 insertions, 25 deletions
diff --git a/src/client/Main.elm b/src/client/Main.elm
index 6ca2743..685d3b2 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -12,7 +12,7 @@ import Time exposing (..)
import Json.Decode as Json exposing ((:=))
import Model exposing (Model, initialModel)
-import Model.Payment exposing (Payments, paymentsDecoder)
+import Model.Payment exposing (Payments, paymentsDecoder, perPage)
import Model.Payers exposing (Payers, payersDecoder)
import Model.Message exposing (messageDecoder)
import Model.Translations exposing (..)
@@ -64,7 +64,7 @@ getUserName : Task Http.Error String
getUserName = Http.get messageDecoder "/userName"
getPayments : Task Http.Error Payments
-getPayments = Http.get paymentsDecoder "/payments"
+getPayments = Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage)
getPaymentsCount : Task Http.Error Int
getPaymentsCount = Http.get ("number" := Json.int) "/payments/count"
diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm
index e773be3..02dcf7e 100644
--- a/src/client/Model/Payment.elm
+++ b/src/client/Model/Payment.elm
@@ -1,5 +1,6 @@
module Model.Payment
- ( Payments
+ ( perPage
+ , Payments
, Payment
, PaymentId
, PaymentWithId
@@ -12,6 +13,9 @@ import Date exposing (..)
import Json.Decode as Json exposing ((:=))
import Dict exposing (..)
+perPage : Int
+perPage = 10
+
type alias Payments = Dict PaymentId Payment
type alias PaymentWithId = (PaymentId, Payment)
diff --git a/src/client/Model/View/PaymentView.elm b/src/client/Model/View/PaymentView.elm
index 117be59..bf5804f 100644
--- a/src/client/Model/View/PaymentView.elm
+++ b/src/client/Model/View/PaymentView.elm
@@ -15,6 +15,7 @@ type alias PaymentView =
, paymentsCount : Int
, payers : Payers
, edition : Maybe Edition
+ , currentPage : Int
}
initPaymentView : String -> Payments -> Int -> Payers -> PaymentView
@@ -25,4 +26,5 @@ initPaymentView userName payments paymentsCount payers =
, paymentsCount = paymentsCount
, payers = payers
, edition = Nothing
+ , currentPage = 1
}
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
index 9bf2008..9359160 100644
--- a/src/client/ServerCommunication.elm
+++ b/src/client/ServerCommunication.elm
@@ -11,7 +11,7 @@ import Json.Decode exposing (..)
import Date
import Model.Message exposing (messageDecoder)
-import Model.Payment exposing (PaymentId)
+import Model.Payment exposing (PaymentId, perPage, paymentsDecoder)
import Update as U
import Update.SignIn exposing (..)
@@ -22,6 +22,7 @@ type Communication =
| SignIn String
| AddPayment String Int
| DeletePayment PaymentId
+ | UpdatePage Int
| SignOut
serverCommunications : Signal.Mailbox Communication
@@ -42,17 +43,19 @@ getRequest communication =
NoCommunication ->
Nothing
SignIn login ->
- Just (simplePost ("/signIn?login=" ++ login))
+ Just (simple "post" ("/signIn?login=" ++ login))
AddPayment name cost ->
- Just (simplePost ("/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost)))
+ Just (simple "post" ("/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost)))
DeletePayment paymentId ->
- Just (simplePost ("payment/delete?id=" ++ paymentId))
+ Just (simple "post" ("payment/delete?id=" ++ paymentId))
+ UpdatePage page ->
+ Just (simple "get" ("payments?page=" ++ toString page ++ "&perPage=" ++ toString perPage))
SignOut ->
- Just (simplePost "/signOut")
+ Just (simple "post" "/signOut")
-simplePost : String -> Http.Request
-simplePost url =
- { verb = "post"
+simple : String -> String -> Http.Request
+simple method url =
+ { verb = method
, headers = []
, url = url
, body = Http.empty
@@ -70,14 +73,21 @@ communicationToAction communication response =
AddPayment name cost ->
decodeResponse
response
+ messageDecoder
(\id -> U.UpdatePayment (UP.AddPayment id name cost))
DeletePayment id ->
U.UpdatePayment (UP.Remove id)
+ UpdatePage page ->
+ decodeResponse
+ response
+ paymentsDecoder
+ (\payments -> U.UpdatePayment (UP.UpdatePage page payments))
SignOut ->
U.GoSignInView
else
decodeResponse
response
+ messageDecoder
(\error ->
case communication of
SignIn _ ->
@@ -86,11 +96,11 @@ communicationToAction communication response =
U.NoOp
)
-decodeResponse : Http.Response -> (String -> U.Action) -> U.Action
-decodeResponse response responseToAction =
+decodeResponse : Http.Response -> Decoder a -> (a -> U.Action) -> U.Action
+decodeResponse response decoder responseToAction =
case response.value of
Http.Text text ->
- case decodeString messageDecoder text of
+ case decodeString decoder text of
Ok x ->
responseToAction x
Err _ ->
diff --git a/src/client/Update/Payment.elm b/src/client/Update/Payment.elm
index 53dc08a..798cdb4 100644
--- a/src/client/Update/Payment.elm
+++ b/src/client/Update/Payment.elm
@@ -20,6 +20,7 @@ type PaymentAction =
| AddPayment PaymentId String Int
| ToggleEdit PaymentId
| Remove PaymentId
+ | UpdatePage Int Payments
updatePayment : Model -> PaymentAction -> PaymentView -> PaymentView
updatePayment model action paymentView =
@@ -51,3 +52,8 @@ updatePayment model action paymentView =
}
Nothing ->
paymentView
+ UpdatePage page payments ->
+ { paymentView
+ | currentPage <- page
+ , payments <- payments
+ }
diff --git a/src/client/View/Payments.elm b/src/client/View/Payments.elm
index c38cc18..3c9c09d 100644
--- a/src/client/View/Payments.elm
+++ b/src/client/View/Payments.elm
@@ -12,6 +12,7 @@ import Model.View.PaymentView exposing (PaymentView)
import View.Payments.ExceedingPayer exposing (exceedingPayers)
import View.Payments.Add exposing (addPayment)
import View.Payments.Table exposing (paymentsTable)
+import View.Payments.Paging exposing (paymentsPaging)
renderPayments : Model -> PaymentView -> Html
renderPayments model paymentView =
@@ -20,4 +21,5 @@ renderPayments model paymentView =
[ exceedingPayers model paymentView
, addPayment model paymentView.add
, paymentsTable model paymentView
+ , paymentsPaging paymentView
]
diff --git a/src/client/View/Payments/Paging.elm b/src/client/View/Payments/Paging.elm
new file mode 100644
index 0000000..7be4c7b
--- /dev/null
+++ b/src/client/View/Payments/Paging.elm
@@ -0,0 +1,31 @@
+module View.Payments.Paging
+ ( paymentsPaging
+ ) where
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.Events exposing (..)
+
+import Model.View.PaymentView exposing (..)
+import Model.Payment exposing (perPage)
+
+import ServerCommunication as SC exposing (serverCommunications)
+
+import Update exposing (..)
+import Update.Payment exposing (..)
+
+paymentsPaging : PaymentView -> Html
+paymentsPaging paymentView =
+ let maxPage = ceiling (toFloat paymentView.paymentsCount / toFloat perPage)
+ pages = [1..maxPage]
+ in ul
+ [ class "pages" ]
+ ( pages
+ |> List.map (\page ->
+ li
+ [ class ("page" ++ (if page == paymentView.currentPage then " current" else ""))
+ , onClick serverCommunications.address (SC.UpdatePage page)
+ ]
+ [ text (toString page) ]
+ )
+ )
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index dc1083e..271d970 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -25,10 +25,10 @@ import Model.Json.Number
import Model.Message
import Model.Message.Key (Key(PaymentNotDeleted))
-getPaymentsAction :: ActionM ()
-getPaymentsAction =
+getPaymentsAction :: Int -> Int -> ActionM ()
+getPaymentsAction page perPage =
Secure.loggedAction (\_ -> do
- payments <- liftIO $ runDb getPayments
+ payments <- liftIO $ runDb (getPayments page perPage)
json payments
)
diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs
index c1c4057..adbe50f 100644
--- a/src/server/Design/Color.hs
+++ b/src/server/Design/Color.hs
@@ -23,8 +23,8 @@ blue = C.rgb 108 162 164
paymentFocus :: C.Color
paymentFocus = C.rgb 255 223 196
-darkgrey :: C.Color
-darkgrey = C.rgb 150 150 150
+darkGrey :: C.Color
+darkGrey = C.rgb 150 150 150
grey :: C.Color
grey = C.rgb 200 200 200
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 4933300..5efb2bf 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -78,7 +78,7 @@ global = do
display inlineBlock
width (px 60)
textAlign (alignSide sideCenter)
- backgroundColor C.darkgrey
+ backgroundColor C.darkGrey
color C.white
height (px inputHeight)
lineHeight (px inputHeight)
@@ -167,6 +167,26 @@ global = do
color C.white
visibility hidden
+ ".pages" ? do
+ padding (px 30) (px 30) (px 30) (px 30)
+ clearFix
+ ".page" ? do
+ border solid (px 2) C.darkGrey
+ borderRadius (px 2) (px 2) (px 2) (px 2)
+ marginRight (px 10)
+ cursor pointer
+ let side = 50
+ width (px side)
+ height (px side)
+ lineHeight (px side)
+ textAlign (alignSide (sideCenter))
+ float floatLeft
+ fontWeight bold
+
+ ".current" & do
+ borderColor C.red
+ color C.red
+
".signIn" ? do
form ? do
@@ -214,6 +234,6 @@ defaultInput inputHeight = do
height (px inputHeight)
padding (px 10) (px 10) (px 10) (px 10)
borderRadius (px 3) (px 3) (px 3) (px 3)
- border solid (px 1) C.darkgrey
+ border solid (px 1) C.darkGrey
focus & borderColor C.grey
verticalAlign middle
diff --git a/src/server/Main.hs b/src/server/Main.hs
index ce652d0..8a77598 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -42,8 +42,10 @@ main = do
get "/userName" $
getUserName
- get "/payments" $
- getPaymentsAction
+ get "/payments" $ do
+ page <- param "page" :: ActionM Int
+ perPage <- param "perPage" :: ActionM Int
+ getPaymentsAction page perPage
post "/payment/add" $ do
name <- param "name" :: ActionM Text
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index db1f36f..ce8c5a1 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -23,12 +23,15 @@ import Model.Database
import qualified Model.Json.Payment as P
import qualified Model.Json.TotalPayment as TP
-getPayments :: Persist [P.Payment]
-getPayments = do
+getPayments :: Int -> Int -> Persist [P.Payment]
+getPayments page perPage = do
xs <- select $
from $ \(payment `InnerJoin` user) -> do
on (payment ^. PaymentUserId E.==. user ^. UserId)
where_ (isNothing (payment ^. PaymentDeletedAt))
+ orderBy [desc (payment ^. PaymentCreation)]
+ limit . fromIntegral $ perPage
+ offset . fromIntegral $ (page - 1) * perPage
return (payment, user)
return (map getJsonPayment xs)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 16:45:14 +0000