Add init data in html page

11 files changed, 214 insertions, 62 deletions

diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index bbf741e..f84f945 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -3,20 +3,88 @@ module Controller.Index
   , signOut
   ) where
 
+import Control.Monad.IO.Class (liftIO)
+
 import Web.Scotty
 
 import Network.HTTP.Types.Status (ok200)
 
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+
+import Database.Persist hiding (Key)
+
 import Conf (Conf(..))
 import qualified LoginSession
+import Secure (getUserFromToken)
 
+import Model.Database
 import qualified Model.Json.Conf as M
-import Model.Message.Key (Key)
+import Model.User (getUser)
+import Model.Message.Key
+import Model.SignIn (getSignIn, signInTokenToUsed)
+import Model.Json.Init (InitResult(..))
+import Model.Init (getInit)
 
 import View.Page (page)
 
-getIndex :: Conf -> Maybe Key -> ActionM ()
-getIndex conf mbErrorKey = html $ page (M.Conf { M.currency = currency conf }) mbErrorKey
+getIndex :: Conf -> Maybe Text -> ActionM ()
+getIndex conf mbToken = do
+  initResult <- case mbToken of
+    Just token -> do
+      userOrError <- validateSignIn conf token
+      case userOrError of
+        Left errorKey ->
+          return . InitError $ errorKey
+        Right user ->
+          liftIO . runDb . fmap InitSuccess . getInit $ user
+    Nothing -> do
+      mbLoggedUser <- getLoggedUser
+      case mbLoggedUser of
+        Nothing ->
+          return InitEmpty
+        Just user ->
+          liftIO . runDb . fmap InitSuccess . getInit $ user
+  html $ page (M.Conf { M.currency = currency conf }) initResult
+
+validateSignIn :: Conf -> Text -> ActionM (Either Key (Entity User))
+validateSignIn conf textToken = do
+  mbLoggedUser <- getLoggedUser
+  case mbLoggedUser of
+    Just loggedUser ->
+      return . Right $ loggedUser
+    Nothing -> do
+      mbSignIn <- liftIO . runDb $ getSignIn textToken
+      now <- liftIO getCurrentTime
+      case mbSignIn of
+        Nothing ->
+          return . Left $ SignInInvalid
+        Just signInValue ->
+          if signInIsUsed . entityVal $ signInValue
+            then
+              return . Left $ SignInUsed
+            else
+              let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue)
+              in  if diffTime > signInExpiration conf
+                    then
+                      return . Left $ SignInExpired
+                    else do
+                      LoginSession.put (signInToken . entityVal $ signInValue)
+                      mbUser <- liftIO . runDb $ do
+                        signInTokenToUsed . entityKey $ signInValue
+                        getUser . signInEmail . entityVal $ signInValue
+                      return $ case mbUser of
+                        Nothing -> Left UnauthorizedSignIn
+                        Just user -> Right user
+
+getLoggedUser :: ActionM (Maybe (Entity User))
+getLoggedUser = do
+  mbToken <- LoginSession.get
+  case mbToken of
+    Nothing ->
+      return Nothing
+    Just token -> do
+      liftIO . runDb . getUserFromToken $ token
 
 signOut :: ActionM ()
 signOut = do
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 33c19b4..f6804e1 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -2,7 +2,6 @@
 
 module Controller.SignIn
   ( signIn
-  , validateSignIn
   ) where
 
 import Web.Scotty
@@ -17,10 +16,6 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Encoding as TE
-import Data.Time.Clock (getCurrentTime, diffUTCTime)
-import Data.Maybe (isJust)
-
-import qualified LoginSession
 
 import Conf
 
@@ -33,8 +28,6 @@ import Model.User
 import Model.SignIn
 import Model.Message.Key
 
-import Secure (getUserFromToken)
-
 import qualified View.Mail.SignIn as SignIn
 
 signIn :: Conf -> Text -> ActionM ()
@@ -59,38 +52,3 @@ signIn conf login =
     else do
       status badRequest400
       text . TL.pack . show $ EnterValidEmail
-
-validateSignIn :: Conf -> Text -> ActionM (Either Key ())
-validateSignIn conf textToken = do
-  alreadySigned <- isAlreadySigned
-  if alreadySigned
-    then
-      return . Right $ ()
-    else do
-      mbSignIn <- liftIO . runDb $ getSignIn textToken
-      now <- liftIO getCurrentTime
-      case mbSignIn of
-        Just signInValue ->
-          if signInIsUsed . entityVal $ signInValue
-            then
-              return . Left $ SignInUsed
-            else
-              let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue)
-              in  if diffTime > signInExpiration conf
-                    then
-                      return . Left $ SignInExpired
-                    else do
-                      LoginSession.put (signInToken . entityVal $ signInValue)
-                      liftIO . runDb . signInTokenToUsed . entityKey $ signInValue
-                      return . Right $ ()
-        Nothing ->
-          return . Left $ SignInInvalid
-
-isAlreadySigned :: ActionM Bool
-isAlreadySigned = do
-  mbToken <- LoginSession.get
-  case mbToken of
-    Nothing ->
-      return False
-    Just token -> do
-      liftIO . runDb . fmap isJust $ getUserFromToken token
diff --git a/src/server/Cookie.hs b/src/server/Cookie.hs
new file mode 100644
index 0000000..7ff5493
--- /dev/null
+++ b/src/server/Cookie.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Cookie
+  ( makeSimpleCookie
+  , setCookie
+  , setSimpleCookie
+  , getCookie
+  , getCookies
+  , deleteCookie
+  ) where
+
+import Control.Monad ( liftM )
+
+import qualified Data.Text as TS
+import qualified Data.Text.Encoding as TS
+import qualified Data.Text.Lazy.Encoding as TL
+
+import qualified Data.Map as Map
+
+import qualified Data.ByteString.Lazy as BSL
+
+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+
+import Blaze.ByteString.Builder ( toLazyByteString )
+
+import Web.Scotty.Trans
+import Web.Cookie
+
+makeSimpleCookie :: TS.Text -> TS.Text -> SetCookie
+makeSimpleCookie n v =
+  def
+    { setCookieName  = TS.encodeUtf8 n
+    , setCookieValue = TS.encodeUtf8 v
+    , setCookiePath = Just $ TS.encodeUtf8 "/"
+    , setCookieSecure = True
+    }
+
+setCookie :: (Monad m, ScottyError e) => SetCookie -> ActionT e m ()
+setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c)
+
+setSimpleCookie :: (Monad m, ScottyError e) => TS.Text -> TS.Text -> ActionT e m ()
+setSimpleCookie n v = setCookie $ makeSimpleCookie n v
+
+getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text)
+getCookie c = liftM (Map.lookup c) getCookies
+
+getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text)
+getCookies =
+  liftM (Map.fromList . maybe [] parse) $ header "Cookie"
+  where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8
+
+deleteCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m ()
+deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }
diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs
index c755607..3897b4c 100644
--- a/src/server/LoginSession.hs
+++ b/src/server/LoginSession.hs
@@ -7,7 +7,7 @@ module LoginSession
   ) where
 
 import Web.Scotty (ActionM)
-import Web.Scotty.Cookie (setSimpleCookie, getCookie, deleteCookie)
+import Cookie (setSimpleCookie, getCookie, deleteCookie)
 import qualified Web.ClientSession as CS
 
 import Control.Monad.IO.Class (liftIO)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 9734781..387f782 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -3,6 +3,7 @@
 import Web.Scotty
 
 import Network.Wai.Middleware.Static
+import Network.HTTP.Types.Status (ok200)
 
 import Control.Concurrent (forkIO)
 
@@ -41,14 +42,12 @@ main = do
         notFound $
           ( do
               signInToken <- param "signInToken" :: ActionM Text
-              successOrError <- validateSignIn conf signInToken
-              case successOrError of
-                Left errorKey ->
-                  (getIndex conf (Just errorKey))
-                Right _ ->
-                  (getIndex conf Nothing)
-          ) `rescue` (\_ -> getIndex conf Nothing)
-
+              status ok200
+              getIndex conf (Just signInToken)
+          ) `rescue` (\_ -> do
+            status ok200
+            getIndex conf Nothing
+          )
 
 api :: Conf -> ScottyM ()
 api conf = do
diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs
new file mode 100644
index 0000000..167eead
--- /dev/null
+++ b/src/server/Model/Init.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Init
+  ( getInit
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Database.Persist
+
+import Model.Database
+
+import Model.Json.Init (Init, Init(Init))
+import Model.Payment (getPayments)
+import Model.User (getUsers, getJsonUser)
+import Model.Income (getIncomes, getJsonIncome)
+
+import qualified Model.Json.Init as Init
+
+getInit :: Entity User -> Persist Init
+getInit user =
+  liftIO . runDb $ do
+    users <- getUsers
+    payments <- getPayments
+    incomes <- getIncomes
+    return $ Init
+      { Init.users = map getJsonUser users
+      , Init.me = entityKey user
+      , Init.payments = payments
+      , Init.incomes = map getJsonIncome incomes
+      }
diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs
new file mode 100644
index 0000000..5e6d2a2
--- /dev/null
+++ b/src/server/Model/Json/Init.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Init
+  ( Init(..)
+  , InitResult(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+
+import Model.Database (UserId)
+import Model.Json.User (User)
+import Model.Json.Payment (Payment)
+import Model.Json.Income (Income)
+import Model.Message.Key (Key)
+
+data Init = Init
+  { users :: [User]
+  , me :: UserId
+  , payments :: [Payment]
+  , incomes :: [Income]
+  } deriving (Show, Generic)
+
+instance ToJSON Init
+
+data InitResult =
+  InitEmpty
+  | InitSuccess Init
+  | InitError Key
+  deriving (Show, Generic)
+
+instance ToJSON InitResult
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 6f29f43..8f5cf2a 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -20,6 +20,7 @@ data Key =
   | SendEmailFail
   | InvalidEmail
   | UnauthorizedSignIn
+  | Forbidden
   | EnterValidEmail
   | SignInUsed
   | SignInExpired
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index b7d9b4f..f41a417 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -44,6 +44,11 @@ m l UnauthorizedSignIn =
     English -> "You are not authorized to sign in."
     French  -> "Tu n'es pas autorisé à te connecter."
 
+m l Forbidden =
+  case l of
+    English -> "You need to be logged in to perform this action"
+    French  -> "Tu dois te connecter pour effectuer cette action"
+
 m l SendEmailFail =
   case l of
     English -> "You are authorized to sign in, but we failed to send you the sign up email."
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index f563f23..93d5a60 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -11,14 +11,17 @@ import Network.HTTP.Types.Status (forbidden403)
 
 import Database.Persist (Entity, entityVal)
 
+import Data.Text (Text)
+import Data.Text.Lazy (fromStrict)
+
 import Model.User (getUser)
 import Model.SignIn (getSignIn)
 import Model.Database
+import Model.Message (getMessage)
+import qualified Model.Message.Key as Key
 
 import Control.Monad.IO.Class (liftIO)
 
-import Data.Text (Text)
-
 import qualified LoginSession
 
 loggedAction :: (Entity User -> ActionM ()) -> ActionM ()
@@ -32,10 +35,10 @@ loggedAction action = do
           action user
         Nothing -> do
           status forbidden403
-          html "You are not authorized to logged in"
+          html . fromStrict . getMessage $ Key.UnauthorizedSignIn
     Nothing -> do
       status forbidden403
-      html "You need to be logged in to perform this action"
+      html . fromStrict . getMessage $ Key.Forbidden
 
 getUserFromToken :: Text -> Persist (Maybe (Entity User))
 getUserFromToken token = do
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index 0f1ff86..4108b99 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -20,10 +20,11 @@ import Design.Global (globalDesign)
 
 import Model.Message
 import Model.Json.Conf
-import Model.Message.Key (Key, Key(SharedCost))
+import Model.Json.Init (InitResult)
+import Model.Message.Key (Key(SharedCost))
 
-page :: Conf -> Maybe Key -> Text
-page conf mbSignInError =
+page :: Conf -> InitResult -> Text
+page conf initResult =
   renderHtml . docTypeHtml $ do
     H.head $ do
       meta ! charset "UTF-8"
@@ -31,7 +32,7 @@ page conf mbSignInError =
       script ! src "javascripts/client.js" $ ""
       jsonScript "messages" getTranslations
       jsonScript "conf" conf
-      jsonScript "signInError" mbSignInError
+      jsonScript "initResult" initResult
       link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css"
       link ! rel "stylesheet" ! href "css/font-awesome-4.5.0/css/font-awesome.min.css"
       link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"