diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/client/Main.elm | 14 | ||||
-rw-r--r-- | src/client/Model.elm | 10 | ||||
-rw-r--r-- | src/client/Model/View.elm | 10 | ||||
-rw-r--r-- | src/client/ServerCommunication.elm | 63 | ||||
-rw-r--r-- | src/client/Update.elm | 12 | ||||
-rw-r--r-- | src/client/View/Icon.elm | 12 | ||||
-rw-r--r-- | src/client/View/Page.elm | 82 | ||||
-rw-r--r-- | src/server/Design/Color.hs | 5 | ||||
-rw-r--r-- | src/server/Design/Global.hs | 60 | ||||
-rw-r--r-- | src/server/Main.hs | 6 |
10 files changed, 224 insertions, 50 deletions
diff --git a/src/client/Main.elm b/src/client/Main.elm index bff5f23..e79fe2b 100644 --- a/src/client/Main.elm +++ b/src/client/Main.elm @@ -18,6 +18,8 @@ import Update exposing (Action(..), actions, updateModel) import View.Page exposing (renderPage) +import ServerCommunication exposing (serverCommunications, sendRequest) + {-| main -} main : Signal Html @@ -26,6 +28,8 @@ main = Signal.map renderPage model model : Signal Model model = Signal.foldp updateModel initialModel actions.signal +--------------------------------------- + port fetchPayments : Task Http.Error () port fetchPayments = getPayments @@ -36,7 +40,15 @@ reportSuccess : Payments -> Task x () reportSuccess payments = Signal.send actions.address (UpdatePayments payments) reportError : Http.Error -> Task x () -reportError error = Signal.send actions.address Forbidden +reportError error = Signal.send actions.address SignIn getPayments : Task Http.Error Payments getPayments = Http.get paymentsDecoder "/payments" + +--------------------------------------------------- + +port serverCommunicationsPort : Signal (Task Http.RawError ()) +port serverCommunicationsPort = + Signal.map + (\comm -> sendRequest comm `Task.andThen` (Signal.send actions.address)) + serverCommunications.signal diff --git a/src/client/Model.elm b/src/client/Model.elm index 6888676..8005429 100644 --- a/src/client/Model.elm +++ b/src/client/Model.elm @@ -3,17 +3,13 @@ module Model , initialModel ) where -import List - -import Model.Payment exposing (Payments) +import Model.View exposing (..) type alias Model = - { payments : Maybe Payments - , forbiddenAccess : Bool + { view : View } initialModel : Model initialModel = - { payments = Nothing - , forbiddenAccess = False + { view = LoadingView } diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm new file mode 100644 index 0000000..ca819e3 --- /dev/null +++ b/src/client/Model/View.elm @@ -0,0 +1,10 @@ +module Model.View + ( View(..) + ) where + +import Model.Payment exposing (Payments) + +type View = + LoadingView + | PaymentView Payments + | SignInView String diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm new file mode 100644 index 0000000..e29b084 --- /dev/null +++ b/src/client/ServerCommunication.elm @@ -0,0 +1,63 @@ +module ServerCommunication + ( Communication(..) + , sendRequest + , serverCommunications + ) where + +import Signal +import Task +import Task exposing (Task) +import Http + +import Update as U + +type Communication = + NoCommunication + | SignIn String + | SignOut + +serverCommunications : Signal.Mailbox Communication +serverCommunications = Signal.mailbox NoCommunication + +sendRequest : Communication -> Task Http.RawError U.Action +sendRequest communication = + case getRequest communication of + Nothing -> + Task.succeed U.NoOp + Just request -> + Http.send Http.defaultSettings request + |> Task.map (communicationToAction communication) + +getRequest : Communication -> Maybe Http.Request +getRequest communication = + case communication of + NoCommunication -> + Nothing + SignIn login -> + Just + { verb = "post" + , headers = [] + , url = "/signIn?login=" ++ login + , body = Http.empty + } + SignOut -> + Just + { verb = "post" + , headers = [] + , url = "/signOut" + , body = Http.empty + } + +communicationToAction : Communication -> Http.Response -> U.Action +communicationToAction communication response = + if response.status == 200 + then + case communication of + NoCommunication -> + U.NoOp + SignIn _ -> + U.NoOp + SignOut -> + U.SignIn + else + U.NoOp diff --git a/src/client/Update.elm b/src/client/Update.elm index b96d899..3937888 100644 --- a/src/client/Update.elm +++ b/src/client/Update.elm @@ -6,10 +6,12 @@ module Update import Model exposing (Model) import Model.Payment exposing (Payments) +import Model.View exposing (..) type Action = NoOp - | Forbidden + | SignIn + | UpdateLogin String | UpdatePayments Payments actions : Signal.Mailbox Action @@ -20,7 +22,9 @@ updateModel action model = case action of NoOp -> model - Forbidden -> - { model | forbiddenAccess <- True } + SignIn -> + { model | view <- SignInView "" } + UpdateLogin login -> + { model | view <- SignInView login } UpdatePayments payments -> - { model | payments <- Just payments } + { model | view <- PaymentView payments } diff --git a/src/client/View/Icon.elm b/src/client/View/Icon.elm new file mode 100644 index 0000000..f22c1a2 --- /dev/null +++ b/src/client/View/Icon.elm @@ -0,0 +1,12 @@ +module View.Icon + ( renderIcon + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) + +renderIcon : String -> Html +renderIcon iconClass = + i + [ class <| "fa fa-fw fa-" ++ iconClass ] + [] diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm index 777655c..1683cf3 100644 --- a/src/client/View/Page.elm +++ b/src/client/View/Page.elm @@ -15,50 +15,80 @@ import String exposing (append) import Model exposing (Model) import Model.Payment exposing (Payments, Payment) +import Model.View exposing (..) + +import Update exposing (..) + +import ServerCommunication as SC +import ServerCommunication exposing (serverCommunications) + +import View.Icon exposing (renderIcon) renderPage : Model -> Html renderPage model = div [] - [ renderHeader + [ renderHeader model , renderMain model ] -renderHeader : Html -renderHeader = +renderHeader : Model -> Html +renderHeader model = header [] [ h1 [] [ text "Payments" ] + , 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 = - if model.forbiddenAccess - then - forbiddenAccess - else - model.payments - |> Maybe.map paymentTable - |> Maybe.withDefault loadingTable - -forbiddenAccess : Html -forbiddenAccess = text "Forbidden access" - -loadingTable : Html -loadingTable = text "" - -paymentTable : Payments -> Html -paymentTable payments = + case model.view of + LoadingView -> + loadingView + SignInView login -> + signInView login + PaymentView payments -> + paymentsView payments + +loadingView : Html +loadingView = text "" + +signInView : String -> Html +signInView login = + H.form + [ class "signIn" ] + [ input + [ value login + , on "input" targetValue (Signal.message actions.address << UpdateLogin) + ] + [] + , button + [ onClick serverCommunications.address (SC.SignIn login) ] + [ renderIcon "sign-in" ] + ] + +paymentsView : Payments -> Html +paymentsView payments = table [] ([ tr [] - [ th [] [ text "Utilisateur" ] - , th [] [ text "Nom" ] - , th [] [ text "Prix" ] - , th [] [ text "Date" ] + [ th [] [ renderIcon "user" ] + , th [] [ renderIcon "shopping-cart" ] + , th [] [ renderIcon "euro" ] + , th [] [ renderIcon "calendar" ] ] ] ++ (paymentLines payments)) @@ -73,9 +103,9 @@ paymentLine : Payment -> Html paymentLine payment = tr [] - [ td [] [ text payment.name ] - , td [] [ text payment.userName ] - , td [] [ text (toString payment.cost) ] + [ td [] [ text payment.userName ] + , td [] [ text payment.name ] + , td [] [ text ((toString payment.cost) ++ " €") ] , td [] [ text (renderDate payment.creation) ] ] diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index dada3df..6344fe6 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -2,6 +2,9 @@ module Design.Color where import qualified Clay.Color as C +white :: C.Color +white = C.white + brown :: C.Color brown = C.brown @@ -9,4 +12,4 @@ green :: C.Color green = C.green lightGrey :: C.Color -lightGrey = C.rgb 230 230 230 +lightGrey = C.rgb 245 245 245 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index 6460220..7074f65 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -4,6 +4,9 @@ module Design.Global ( globalDesign ) where +import qualified Prelude +import Prelude + import Clay import Data.Monoid ((<>)) @@ -14,15 +17,36 @@ import Design.Color as C globalDesign :: Text globalDesign = renderWith compact [] global +iconFontSize :: Integer +iconFontSize = 32 + global :: Css global = do - header ? + header ? do + let headerHeight = 120 + h1 ? do fontSize (px 40) textAlign (alignSide sideCenter) - margin (px 30) (px 0) (px 40) (px 0) color C.brown + lineHeight (px headerHeight) + + button # ".signOut" ? do + let iconHeight = 50 + let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) + position absolute + top (px 0) + right (px 10) + marginTop (px sideMargin) + marginRight (px sideMargin) + height (px iconHeight) + lineHeight (px iconHeight) + backgroundColor C.white + color C.brown + borderWidth (px 0) + fontSize (px iconFontSize) + hover & transform (scale 1.2 1.2) table ? do width (pct 100) @@ -30,10 +54,30 @@ global = do "border-spacing" -: "10 px" th ? do - color C.green - fontWeight bold - borderBottom solid (px 1) C.brown + 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 <> th ? do - fontSize (px 18) - lineHeight (px 30) + form # ".signIn" ? do + let inputHeight = 50 + marginTop (px 80) + marginBottom (px 80) + width (pct 60) + marginLeft auto + marginRight auto + input ? do + width (pct 80) + padding (px 10) (px 10) (px 10) (px 10) + height (px inputHeight) + button ? do + width (pct 20) + height (px inputHeight) + backgroundColor C.brown + color C.white + borderWidth (px 0) diff --git a/src/server/Main.hs b/src/server/Main.hs index f73f2e0..8d5a625 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -31,12 +31,12 @@ main = do cost <- param "cost" :: ActionM Int insertPaymentAction email name cost - get "/signIn" $ do + post "/signIn" $ do login <- param "login" :: ActionM Text signIn login - get "/checkConnection" $ + post "/checkConnection" $ checkConnection - get "/signOut" $ + post "/signOut" $ signOut |