Adding UI to sign in and sign out

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