From a3bab4f2a0cc8a6a95753dc91d8e862f40c80dcc Mon Sep 17 00:00:00 2001
From: Joris Guyonvarch
Date: Mon, 10 Aug 2015 23:30:31 +0200
Subject: Embedding messages into the page

---
 src/server/Config.hs                     |  5 +-
 src/server/Controller/Index.hs           |  2 +-
 src/server/Controller/SignIn.hs          |  2 +-
 src/server/Main.hs                       |  3 +-
 src/server/Message.hs                    | 45 ------------------
 src/server/Message/Key.hs                | 20 --------
 src/server/Message/Lang.hs               |  5 --
 src/server/Message/Translations.hs       | 76 ------------------------------
 src/server/Model/Json/Message.hs         | 16 +++++++
 src/server/Model/Json/Translation.hs     | 18 +++++++
 src/server/Model/Json/Translations.hs    | 17 +++++++
 src/server/Model/Message.hs              | 33 +++++++++----
 src/server/Model/Message/Key.hs          | 22 +++++++++
 src/server/Model/Message/Lang.hs         | 11 +++++
 src/server/Model/Message/Parts.hs        | 38 +++++++++++++++
 src/server/Model/Message/Translations.hs | 80 ++++++++++++++++++++++++++++++++
 src/server/View/Page.hs                  | 10 +++-
 17 files changed, 240 insertions(+), 163 deletions(-)
 delete mode 100644 src/server/Message.hs
 delete mode 100644 src/server/Message/Key.hs
 delete mode 100644 src/server/Message/Lang.hs
 delete mode 100644 src/server/Message/Translations.hs
 create mode 100644 src/server/Model/Json/Message.hs
 create mode 100644 src/server/Model/Json/Translation.hs
 create mode 100644 src/server/Model/Json/Translations.hs
 create mode 100644 src/server/Model/Message/Key.hs
 create mode 100644 src/server/Model/Message/Lang.hs
 create mode 100644 src/server/Model/Message/Parts.hs
 create mode 100644 src/server/Model/Message/Translations.hs

(limited to 'src/server')

diff --git a/src/server/Config.hs b/src/server/Config.hs
index f4144f7..9bc780f 100644
--- a/src/server/Config.hs
+++ b/src/server/Config.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 module Config
@@ -20,9 +21,9 @@ data Config = Config
   , port :: Int
   } deriving (Read, Eq, Show)
 
-getConfig :: FilePath -> IO (Either String Config)
+getConfig :: FilePath -> IO (Either Text Config)
 getConfig filePath =
-  left show <$> (runErrorT $ do
+  left (T.pack . show) <$> (runErrorT $ do
     cp <- join $ liftIO $ readfile emptyCP filePath
     liftA2
       Config
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index 610c57c..2d8c40c 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -24,7 +24,7 @@ import qualified Secure
 
 import Model.Database
 import Model.User
-import Model.Message
+import Model.Json.Message
 
 import View.Page (page)
 
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index a46894a..1110c72 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -30,7 +30,7 @@ import Text.Email.Validate (isValid)
 import Model.Database
 import Model.User
 import Model.SignIn
-import Model.Message
+import Model.Json.Message
 
 import qualified View.Mail.SignIn as SignIn
 
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 14e69fa..0828e0d 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -5,6 +5,7 @@ import Web.Scotty
 import Network.Wai.Middleware.Static
 
 import Data.Text (Text)
+import qualified Data.Text.IO as TIO
 
 import Controller.Index
 import Controller.SignIn
@@ -19,7 +20,7 @@ main = do
   eitherConfig <- getConfig "config.txt"
   case eitherConfig of
     Left errorMessage ->
-      putStrLn errorMessage
+      TIO.putStrLn errorMessage
     Right config -> do
       runMigrations
       scotty (port config) $ do
diff --git a/src/server/Message.hs b/src/server/Message.hs
deleted file mode 100644
index 1673b22..0000000
--- a/src/server/Message.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Message
-  ( getMessage
-  , getVarMessage
-  ) where
-
-import Data.Maybe (listToMaybe, fromMaybe)
-
-import Text.ParserCombinators.Parsec
-
-import Message.Key (Key)
-import Message.Lang
-import Message.Translations (getNonFormattedMessage)
-
-getMessage :: Key -> String
-getMessage = getVarMessage []
-
-getVarMessage :: [String] -> Key -> String
-getVarMessage values key =
-  replaceParts values (getParts (getNonFormattedMessage French key))
-
-replaceParts :: [String] -> [Part] -> String
-replaceParts values = concatMap (replacePart values)
-
-replacePart :: [String] -> Part -> String
-replacePart _ (Str str) = str
-replacePart values (Num n) =
-  fromMaybe ("{" ++ show n ++ "}") . listToMaybe . drop (n - 1) $ values
-
-data Part =
-  Num Int
-  | Str String
-
-getParts :: String -> [Part]
-getParts str =
-  case parse partsParser "" str of
-    Right parts -> parts
-    Left _ -> []
-
-partsParser :: Parser [Part]
-partsParser = many partParser
-
-partParser :: Parser Part
-partParser =
-  (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Num n))
-  <|> (do str <- many1 (noneOf "{"); return (Str str))
diff --git a/src/server/Message/Key.hs b/src/server/Message/Key.hs
deleted file mode 100644
index 407ba34..0000000
--- a/src/server/Message/Key.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Message.Key
-  ( Key(..)
-  ) where
-
-data Key =
-
-  January
-  | February
-  | March
-  | April
-  | May
-  | June
-  | July
-  | August
-  | September
-  | October
-  | November
-  | December
-
-  | Date
diff --git a/src/server/Message/Lang.hs b/src/server/Message/Lang.hs
deleted file mode 100644
index e9519f1..0000000
--- a/src/server/Message/Lang.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Message.Lang
-  ( Lang(..)
-  ) where
-
-data Lang = English | French
diff --git a/src/server/Message/Translations.hs b/src/server/Message/Translations.hs
deleted file mode 100644
index f16ffe1..0000000
--- a/src/server/Message/Translations.hs
+++ /dev/null
@@ -1,76 +0,0 @@
-module Message.Translations
-  ( getNonFormattedMessage
-  ) where
-
-import Message.Key
-import Message.Lang
-
-getNonFormattedMessage :: Lang -> Key -> String
-getNonFormattedMessage = m
-
-m :: Lang -> Key -> String
-
-m l January =
-  case l of
-    English -> "January"
-    French  -> "Janvier"
-
-m l February =
-  case l of
-    English -> "February"
-    French -> "Février"
-
-m l March =
-  case l of
-    English -> "March"
-    French -> "Mars"
-
-m l April =
-  case l of
-    English -> "April"
-    French -> "Avril"
-
-m l May =
-  case l of
-    English -> "May"
-    French -> "Mai"
-
-m l June =
-  case l of
-    English -> "June"
-    French -> "Juin"
-
-m l July =
-  case l of
-    English -> "July"
-    French -> "Juillet"
-
-m l August =
-  case l of
-    English -> "August"
-    French -> "Août"
-
-m l September =
-  case l of
-    English -> "September"
-    French -> "Septembre"
-
-m l October =
-  case l of
-    English -> "October"
-    French -> "Octoble"
-
-m l November =
-  case l of
-    English -> "November"
-    French -> "Novembre"
-
-m l December =
-  case l of
-    English -> "December"
-    French -> "Décembre"
-
-m l Date =
-  case l of
-    English -> "{2} {1}, {3}"
-    French -> "{1} {2} {3}"
diff --git a/src/server/Model/Json/Message.hs b/src/server/Model/Json/Message.hs
new file mode 100644
index 0000000..354dd8f
--- /dev/null
+++ b/src/server/Model/Json/Message.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Message
+  ( Message(..)
+  ) where
+
+import Data.Aeson
+import Data.Text (Text)
+import GHC.Generics
+
+data Message = Message
+  { message :: Text
+  } deriving (Show, Generic)
+
+instance FromJSON Message
+instance ToJSON Message
diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs
new file mode 100644
index 0000000..7291157
--- /dev/null
+++ b/src/server/Model/Json/Translation.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Translation
+  ( Translation(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Text
+
+data Translation = Translation
+  { key :: Text
+  , message :: Text
+  } deriving (Show, Generic)
+
+instance FromJSON Translation
+instance ToJSON Translation
diff --git a/src/server/Model/Json/Translations.hs b/src/server/Model/Json/Translations.hs
new file mode 100644
index 0000000..21b188a
--- /dev/null
+++ b/src/server/Model/Json/Translations.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Translations
+  ( Translations(..)
+  ) where
+
+import Data.Aeson
+import GHC.Generics
+
+import Model.Json.Translation
+
+data Translations = Translations
+  { translations :: [Translation]
+  } deriving (Show, Generic)
+
+instance FromJSON Translations
+instance ToJSON Translations
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
index d84aaa9..8475740 100644
--- a/src/server/Model/Message.hs
+++ b/src/server/Model/Message.hs
@@ -1,16 +1,29 @@
-{-# LANGUAGE DeriveGeneric #-}
-
 module Model.Message
-  ( Message(..)
+  ( getMessage
+  , getVarMessage
+  , getTranslations
   ) where
 
-import Data.Aeson
 import Data.Text (Text)
-import GHC.Generics
+import qualified Data.Text as T
+
+import Model.Message.Key (Key)
+import Model.Message.Lang
+import Model.Message.Translations (getNonFormattedMessage)
+import Model.Message.Parts
+
+import Model.Json.Translations
+import Model.Json.Translation
+
+getMessage :: Key -> Text
+getMessage = getVarMessage []
+
+getVarMessage :: [Text] -> Key -> Text
+getVarMessage values key =
+  replaceParts values (getParts (getNonFormattedMessage lang key))
 
-data Message = Message
-  { message :: Text
-  } deriving (Show, Generic)
+getTranslations :: Translations
+getTranslations = Translations (map getTranslation [minBound..])
 
-instance FromJSON Message
-instance ToJSON Message
+getTranslation :: Key -> Translation
+getTranslation key = Translation (T.pack . show $ key) (getNonFormattedMessage lang key)
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
new file mode 100644
index 0000000..59a5dbc
--- /dev/null
+++ b/src/server/Model/Message/Key.hs
@@ -0,0 +1,22 @@
+module Model.Message.Key
+  ( Key(..)
+  ) where
+
+data Key =
+
+  January
+  | February
+  | March
+  | April
+  | May
+  | June
+  | July
+  | August
+  | September
+  | October
+  | November
+  | December
+
+  | Date
+
+  deriving (Enum, Bounded, Show)
diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs
new file mode 100644
index 0000000..f515c96
--- /dev/null
+++ b/src/server/Model/Message/Lang.hs
@@ -0,0 +1,11 @@
+module Model.Message.Lang
+  ( Lang(..)
+  , lang
+  ) where
+
+data Lang =
+  English
+  | French
+
+lang :: Lang
+lang = French
diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs
new file mode 100644
index 0000000..b7855f8
--- /dev/null
+++ b/src/server/Model/Message/Parts.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Message.Parts
+  ( replaceParts
+  , getParts
+  ) where
+
+import Data.Maybe (listToMaybe, fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.ParserCombinators.Parsec
+
+replaceParts :: [Text] -> [Part] -> Text
+replaceParts values = T.concat . map (replacePart values)
+
+replacePart :: [Text] -> Part -> Text
+replacePart _ (Str str) = str
+replacePart values (Num n) =
+  fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values
+
+data Part =
+  Num Int
+  | Str Text
+
+getParts :: Text -> [Part]
+getParts str =
+  case parse partsParser "" (T.unpack str) of
+    Right parts -> parts
+    Left _ -> []
+
+partsParser :: Parser [Part]
+partsParser = many partParser
+
+partParser :: Parser Part
+partParser =
+  (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Num 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
new file mode 100644
index 0000000..289b714
--- /dev/null
+++ b/src/server/Model/Message/Translations.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Message.Translations
+  ( getNonFormattedMessage
+  ) where
+
+import Data.Text (Text)
+
+import Model.Message.Key
+import Model.Message.Lang
+
+getNonFormattedMessage :: Lang -> Key -> Text
+getNonFormattedMessage = m
+
+m :: Lang -> Key -> Text
+
+m l January =
+  case l of
+    English -> "January"
+    French  -> "Janvier"
+
+m l February =
+  case l of
+    English -> "February"
+    French -> "Février"
+
+m l March =
+  case l of
+    English -> "March"
+    French -> "Mars"
+
+m l April =
+  case l of
+    English -> "April"
+    French -> "Avril"
+
+m l May =
+  case l of
+    English -> "May"
+    French -> "Mai"
+
+m l June =
+  case l of
+    English -> "June"
+    French -> "Juin"
+
+m l July =
+  case l of
+    English -> "July"
+    French -> "Juillet"
+
+m l August =
+  case l of
+    English -> "August"
+    French -> "Août"
+
+m l September =
+  case l of
+    English -> "September"
+    French -> "Septembre"
+
+m l October =
+  case l of
+    English -> "October"
+    French -> "Octoble"
+
+m l November =
+  case l of
+    English -> "November"
+    French -> "Novembre"
+
+m l December =
+  case l of
+    English -> "December"
+    French -> "Décembre"
+
+m l Date =
+  case l of
+    English -> "{2} {1}, {3}"
+    French -> "{1} {2} {3}"
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index a397a96..e0b924b 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -5,15 +5,20 @@ module View.Page
   ) where
 
 import Data.Text.Internal.Lazy (Text)
+import Data.Text.Lazy.Encoding (decodeUtf8)
+import Data.Aeson (encode)
 
 import Text.Blaze.Html
 import Text.Blaze.Html5
-import Text.Blaze.Html5.Attributes
 import qualified Text.Blaze.Html5 as H
+import Text.Blaze.Html5.Attributes
+import qualified Text.Blaze.Html5.Attributes as A
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 import Design.Global (globalDesign)
 
+import Model.Message (getTranslations)
+
 page :: Text
 page =
   renderHtml . docTypeHtml $ do
@@ -21,9 +26,10 @@ page =
       meta ! charset "UTF-8"
       H.title "Shared Cost"
       script ! src "javascripts/client.js" $ ""
+      script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations
       link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css"
       link ! rel "stylesheet" ! href "css/font-awesome/css/font-awesome.min.css"
       link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"
       H.style $ toHtml globalDesign
-    body $
+    body $ do
       script ! src "javascripts/elmLauncher.js" $ ""
-- 
cgit v1.2.3