From c1f44a5890fbb26faf6f17c676662ea1bd495f2e Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 4 Sep 2015 09:52:20 +0200 Subject: Adding paging (need some fixes) --- src/client/Main.elm | 4 ++-- src/client/Model/Payment.elm | 6 +++++- src/client/Model/View/PaymentView.elm | 2 ++ src/client/ServerCommunication.elm | 32 +++++++++++++++++++++----------- src/client/Update/Payment.elm | 6 ++++++ src/client/View/Payments.elm | 2 ++ src/client/View/Payments/Paging.elm | 31 +++++++++++++++++++++++++++++++ src/server/Controller/Payment.hs | 6 +++--- src/server/Design/Color.hs | 4 ++-- src/server/Design/Global.hs | 24 ++++++++++++++++++++++-- src/server/Main.hs | 6 ++++-- src/server/Model/Payment.hs | 7 +++++-- 12 files changed, 105 insertions(+), 25 deletions(-) create mode 100644 src/client/View/Payments/Paging.elm (limited to 'src') 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) -- cgit v1.2.3