aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--public/css/reset.css4
-rw-r--r--src/client/Main.elm14
-rw-r--r--src/client/Model.elm10
-rw-r--r--src/client/Model/View.elm10
-rw-r--r--src/client/ServerCommunication.elm63
-rw-r--r--src/client/Update.elm12
-rw-r--r--src/client/View/Icon.elm12
-rw-r--r--src/client/View/Page.elm82
-rw-r--r--src/server/Design/Color.hs5
-rw-r--r--src/server/Design/Global.hs60
-rw-r--r--src/server/Main.hs6
11 files changed, 228 insertions, 50 deletions
diff --git a/public/css/reset.css b/public/css/reset.css
index 72bc5c9..c7044d5 100644
--- a/public/css/reset.css
+++ b/public/css/reset.css
@@ -42,6 +42,10 @@ table {
border-spacing: 0;
}
+button:hover {
+ cursor: pointer;
+}
+
html {
box-sizing: border-box;
}
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 22:07:52 +0000