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