From 892a7dd19a92fc18767984e624b8a5026dce61e4 Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Tue, 11 Aug 2015 21:32:10 +0200
Subject: Showing server sides generated messages from the client

---
 src/client/Main.elm                      |  8 +++-
 src/client/Model.elm                     | 11 ++++-
 src/client/Model/Translations.elm        | 70 ++++++++++++++++++++++++++++++++
 src/client/View/Header.elm               |  3 +-
 src/client/View/Page.elm                 |  2 +-
 src/client/View/SignIn.elm               |  8 ++--
 src/server/Controller/SignIn.hs          |  8 ++--
 src/server/Model/Json/MessagePart.hs     | 18 ++++++++
 src/server/Model/Json/Translation.hs     |  4 +-
 src/server/Model/Message.hs              |  5 +--
 src/server/Model/Message/Key.hs          | 12 +++++-
 src/server/Model/Message/Parts.hs        | 23 +++++------
 src/server/Model/Message/Translations.hs | 25 ++++++++++++
 13 files changed, 169 insertions(+), 28 deletions(-)
 create mode 100644 src/client/Model/Translations.elm
 create mode 100644 src/server/Model/Json/MessagePart.hs

(limited to 'src')

diff --git a/src/client/Main.elm b/src/client/Main.elm
index fd0cec7..226ae13 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -11,10 +11,12 @@ import Html exposing (Html)
 import Http
 import Task exposing (..)
 import Time exposing (..)
+import Json.Decode as Json
 
 import Model exposing (Model, initialModel)
 import Model.Payment exposing (Payments, paymentsDecoder)
 import Model.Message exposing (messageDecoder)
+import Model.Translations exposing (..)
 
 import Update exposing (Action(..), actions, updateModel)
 import Update.SignIn exposing (..)
@@ -29,7 +31,7 @@ main : Signal Html
 main = Signal.map renderPage model
 
 model : Signal Model
-model = Signal.foldp updateModel (initialModel initialTime) update
+model = Signal.foldp updateModel (initialModel initialTime translations) update
 
 update : Signal Action
 update = Signal.mergeMany
@@ -47,6 +49,10 @@ port initialTime : Time
 
 ---------------------------------------
 
+port translations : String
+
+---------------------------------------
+
 port initView : Task Http.Error ()
 port initView =
   case signInError of
diff --git a/src/client/Model.elm b/src/client/Model.elm
index 45fdf87..72db56a 100644
--- a/src/client/Model.elm
+++ b/src/client/Model.elm
@@ -4,16 +4,23 @@ module Model
   ) where
 
 import Time exposing (Time)
+import Json.Decode as Json
 
 import Model.View exposing (..)
+import Model.Translations exposing (..)
 
 type alias Model =
   { view : View
   , currentTime : Time
+  , translations : Translations
   }
 
-initialModel : Time -> Model
-initialModel initialTime =
+initialModel : Time -> String -> Model
+initialModel initialTime translationsValue =
   { view = LoadingView
   , currentTime = initialTime
+  , translations =
+      case Json.decodeString translationsDecoder translationsValue of
+        Ok translations -> translations
+        Err err -> []
   }
diff --git a/src/client/Model/Translations.elm b/src/client/Model/Translations.elm
new file mode 100644
index 0000000..2a8a3a7
--- /dev/null
+++ b/src/client/Model/Translations.elm
@@ -0,0 +1,70 @@
+module Model.Translations
+  ( translationsDecoder
+  , Translations
+  , Translation
+  , getMessage
+  , getVarMessage
+  ) where
+
+import Maybe exposing (withDefault)
+import Json.Decode as Json exposing ((:=))
+import String
+
+type alias Translations = List Translation
+
+translationsDecoder : Json.Decoder Translations
+translationsDecoder =
+  ("translations" := Json.list translationDecoder)
+
+type alias Translation =
+  { key : String
+  , message : List MessagePart
+  }
+
+getTranslation : String -> Translations -> Maybe (List MessagePart)
+getTranslation key translations =
+  translations
+    |> List.filter (\translation -> translation.key == key)
+    |> List.head
+    |> Maybe.map .message
+
+translationDecoder : Json.Decoder Translation
+translationDecoder =
+  Json.object2 Translation
+    ("key" := Json.string)
+    ("message" := Json.list partDecoder)
+
+type MessagePart =
+  Order Int
+  | Str String
+
+partDecoder : Json.Decoder MessagePart
+partDecoder =
+  ("tag" := Json.string) `Json.andThen` partDecoderWithTag
+
+partDecoderWithTag : String -> Json.Decoder MessagePart
+partDecoderWithTag tag =
+  case tag of
+    "Order" -> Json.object1 Order ("contents" := Json.int)
+    "Str" -> Json.object1 Str ("contents" := Json.string)
+
+-----
+
+getMessage : String -> Translations -> String
+getMessage = getVarMessage []
+
+getVarMessage : List String -> String -> Translations -> String
+getVarMessage values key translations =
+  getTranslation key translations
+    |> Maybe.map (\parts -> String.concat (List.map (replacePart values) parts))
+    |> withDefault key
+
+replacePart : List String -> MessagePart -> String
+replacePart values part =
+  case part of
+    Str str -> str
+    Order n ->
+      values
+        |> List.drop (n - 1)
+        |> List.head
+        |> withDefault ("{" ++ (toString n) ++ "}")
diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm
index 788a473..1738d71 100644
--- a/src/client/View/Header.elm
+++ b/src/client/View/Header.elm
@@ -11,6 +11,7 @@ import ServerCommunication exposing (serverCommunications)
 
 import Model exposing (Model)
 import Model.View exposing (..)
+import Model.Translations exposing (getMessage)
 
 import View.Icon exposing (renderIcon)
 
@@ -20,7 +21,7 @@ renderHeader model =
     []
     [ h1
         []
-        [ text "Shared Cost" ]
+        [ text (getMessage "SharedCost" model.translations) ]
     , case model.view of
         LoadingView ->
           text ""
diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm
index 59c21a2..f7292ed 100644
--- a/src/client/View/Page.elm
+++ b/src/client/View/Page.elm
@@ -26,6 +26,6 @@ renderMain model =
     LoadingView ->
       renderLoading
     SignInView signInView ->
-      renderSignIn signInView
+      renderSignIn model signInView
     PaymentView paymentsView ->
       renderPayments paymentsView
diff --git a/src/client/View/SignIn.elm b/src/client/View/SignIn.elm
index a790f0a..6fb809d 100644
--- a/src/client/View/SignIn.elm
+++ b/src/client/View/SignIn.elm
@@ -14,12 +14,14 @@ import Update.SignIn exposing (..)
 import ServerCommunication as SC
 import ServerCommunication exposing (serverCommunications)
 
+import Model exposing (Model)
 import Model.View.SignInView exposing (..)
+import Model.Translations exposing (getMessage)
 
 import View.Events exposing (onSubmitPrevDefault)
 
-renderSignIn : SignInView -> Html
-renderSignIn signInView =
+renderSignIn : Model -> SignInView -> Html
+renderSignIn model signInView =
   div
     [ class "signIn" ]
     [ H.form
@@ -31,7 +33,7 @@ renderSignIn signInView =
             []
         , button
             []
-            [ text "Sign in" ]
+            [ text (getMessage "SignIn" model.translations)]
         ]
     , div
         [ class "result" ]
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 1110c72..263e470 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -31,6 +31,8 @@ import Model.Database
 import Model.User
 import Model.SignIn
 import Model.Json.Message
+import Model.Message.Key
+import Model.Message (getMessage)
 
 import qualified View.Mail.SignIn as SignIn
 
@@ -48,11 +50,11 @@ signInAction config login =
             Right _ ->
               status ok200
             Left _ ->
-              errorResponse "Sorry, we failed to send you the sign up email."
+              errorResponse (getMessage SendEmailFail)
         Nothing ->
-            errorResponse "You are not authorized to sign in."
+            errorResponse (getMessage Unauthorized)
     else
-      errorResponse "Please enter a valid email address."
+      errorResponse (getMessage EnterValidEmail)
 
 errorResponse :: Text -> ActionM ()
 errorResponse msg = do
diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs
new file mode 100644
index 0000000..0753d7c
--- /dev/null
+++ b/src/server/Model/Json/MessagePart.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.MessagePart
+  ( MessagePart(..)
+  ) where
+
+import Data.Text (Text)
+
+import Data.Aeson
+import GHC.Generics
+
+data MessagePart =
+  Order Int
+  | Str Text
+  deriving (Eq, Show, Generic)
+
+instance FromJSON MessagePart
+instance ToJSON MessagePart
diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs
index 7291157..9dcfe80 100644
--- a/src/server/Model/Json/Translation.hs
+++ b/src/server/Model/Json/Translation.hs
@@ -9,9 +9,11 @@ import GHC.Generics
 import Data.Aeson
 import Data.Text
 
+import Model.Json.MessagePart
+
 data Translation = Translation
   { key :: Text
-  , message :: Text
+  , message :: [MessagePart]
   } deriving (Show, Generic)
 
 instance FromJSON Translation
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
index 8475740..12893b8 100644
--- a/src/server/Model/Message.hs
+++ b/src/server/Model/Message.hs
@@ -19,11 +19,10 @@ getMessage :: Key -> Text
 getMessage = getVarMessage []
 
 getVarMessage :: [Text] -> Key -> Text
-getVarMessage values key =
-  replaceParts values (getParts (getNonFormattedMessage lang key))
+getVarMessage values key = replaceParts values (getNonFormattedMessage lang key)
 
 getTranslations :: Translations
 getTranslations = Translations (map getTranslation [minBound..])
 
 getTranslation :: Key -> Translation
-getTranslation key = Translation (T.pack . show $ key) (getNonFormattedMessage lang key)
+getTranslation key = Translation (T.pack . show $ key) (getParts $ getNonFormattedMessage lang key)
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 59a5dbc..e1a382c 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -4,7 +4,17 @@ module Model.Message.Key
 
 data Key =
 
-  January
+  -- Sign in
+
+  SharedCost
+  | SignIn
+  | SendEmailFail
+  | Unauthorized
+  | EnterValidEmail
+
+  -- Dates
+
+  | January
   | February
   | March
   | April
diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs
index b7855f8..d065cf2 100644
--- a/src/server/Model/Message/Parts.hs
+++ b/src/server/Model/Message/Parts.hs
@@ -11,28 +11,27 @@ import qualified Data.Text as T
 
 import Text.ParserCombinators.Parsec
 
-replaceParts :: [Text] -> [Part] -> Text
-replaceParts values = T.concat . map (replacePart values)
+import Model.Json.MessagePart
 
-replacePart :: [Text] -> Part -> Text
+replaceParts :: [Text] -> Text -> Text
+replaceParts values message =
+  T.concat . map (replacePart values) $ getParts message
+
+replacePart :: [Text] -> MessagePart -> Text
 replacePart _ (Str str) = str
-replacePart values (Num n) =
+replacePart values (Order n) =
   fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values
 
-data Part =
-  Num Int
-  | Str Text
-
-getParts :: Text -> [Part]
+getParts :: Text -> [MessagePart]
 getParts str =
   case parse partsParser "" (T.unpack str) of
     Right parts -> parts
     Left _ -> []
 
-partsParser :: Parser [Part]
+partsParser :: Parser [MessagePart]
 partsParser = many partParser
 
-partParser :: Parser Part
+partParser :: Parser MessagePart
 partParser =
-  (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Num n))
+  (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n))
   <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str))
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index 289b714..2cc1761 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -14,6 +14,31 @@ getNonFormattedMessage = m
 
 m :: Lang -> Key -> Text
 
+m l SharedCost =
+  case l of
+    English -> "Shared Cost"
+    French  -> "Partage des frais"
+
+m l SignIn =
+  case l of
+    English -> "Sign in"
+    French  -> "Connexion"
+
+m l SendEmailFail =
+  case l of
+    English -> "Sorry, we failed to send you the sign up email."
+    French  -> "Désolé, nous n'avons pas pu vous envoyer le courriel de connexion."
+
+m l Unauthorized =
+  case l of
+    English -> "You are not authorized to sign in."
+    French  -> "Vous n'êtes pas authorisé à vous connecter."
+
+m l EnterValidEmail =
+  case l of
+    English -> "Please enter a valid email address."
+    French  -> "Entrez s'il vous plait un email valide."
+
 m l January =
   case l of
     English -> "January"
-- 
cgit v1.2.3