Add init data in html page

21 files changed, 280 insertions, 112 deletions

diff --git a/sharedCost.cabal b/sharedCost.cabal
index 779a81b..d61ea7c 100644
--- a/sharedCost.cabal
+++ b/sharedCost.cabal
@@ -21,6 +21,8 @@ executable sharedCost
                        , http-conduit
                        , time
                        , text
+                       , blaze-builder
+                       , cookie
                        , bytestring
                        , persistent
                        , persistent-sqlite
@@ -32,7 +34,6 @@ executable sharedCost
                        , blaze-html
                        , clay
                        , aeson
-                       , scotty-cookie
                        , clientsession
                        , uuid
                        , mime-mail
diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm
index 561ea91..0813573 100644
--- a/src/client/elm/Main.elm
+++ b/src/client/elm/Main.elm
@@ -17,6 +17,7 @@ import Server
 import Mailbox
 import Action exposing (..)
 import Model exposing (Model, initialModel)
+import Model.InitResult as InitResult exposing (initResultDecoder)
 import Update exposing (update, routerConfig)
 import View exposing (view)
 
@@ -28,7 +29,7 @@ main = app.html
 
 app : App Model
 app = StartApp.start
-  { init = initData `Effects.andThen` initRouter
+  { init = (initData, Effects.none) `Effects.andThen` initRouter
   , view = view
   , update = update
   , inputs =
@@ -40,20 +41,13 @@ app = StartApp.start
 
 -- Init
 
-initData : (Model, Effects Action)
+initData : Model
 initData =
-  case Json.decodeString Json.string signInError of
-    Ok signInError ->
-      ( initialModel initialTime translations conf (Just signInError)
-      , Effects.none
-      )
+  case Json.decodeString initResultDecoder initResult of
+    Ok init ->
+      initialModel initialTime translations conf init
     Err _ ->
-      ( initialModel initialTime translations conf Nothing
-      , Server.init
-          |> Task.map GoLoggedInView
-          |> flip Task.onError (always <| Task.succeed GoSignInView)
-          |> Effects.task
-      )
+      initialModel initialTime translations conf InitResult.InitEmpty
 
 initRouter : Model -> (Model, Effects Action)
 initRouter model = TransitRouter.init routerConfig location model
@@ -68,5 +62,5 @@ port tasks = app.tasks
 port initialTime : Time
 port translations : String
 port conf : String
-port signInError : String
+port initResult : String
 port location : String
diff --git a/src/client/elm/Model.elm b/src/client/elm/Model.elm
index 9e3f4a0..b4213d5 100644
--- a/src/client/elm/Model.elm
+++ b/src/client/elm/Model.elm
@@ -12,6 +12,8 @@ import Route exposing (Route)
 import Model.View exposing (..)
 import Model.Translations exposing (..)
 import Model.Conf exposing (..)
+import Model.InitResult exposing (..)
+import LoggedIn.Model as LoggedInModel
 
 import SignIn.Model as SignInModel
 
@@ -25,12 +27,16 @@ type alias Model =
   , transitRouter : TransitRouter.TransitRouter Route
   }
 
-initialModel : Time -> String -> String -> Maybe String -> Model
-initialModel initialTime translations conf mbSignInError =
+initialModel : Time -> String -> String -> InitResult -> Model
+initialModel initialTime translations conf initResult =
   { view =
-      if isJust mbSignInError
-        then SignInView (SignInModel.init mbSignInError)
-        else LoadingView
+      case initResult of
+        InitEmpty ->
+          SignInView (SignInModel.init Nothing)
+        InitSuccess init ->
+          LoggedInView (LoggedInModel.init init)
+        InitError error ->
+          SignInView (SignInModel.init (Just error))
   , currentTime = initialTime
   , translations =
       case Json.decodeString translationsDecoder translations of
diff --git a/src/client/elm/Model/Init.elm b/src/client/elm/Model/Init.elm
index 7fccf00..5db038d 100644
--- a/src/client/elm/Model/Init.elm
+++ b/src/client/elm/Model/Init.elm
@@ -1,10 +1,13 @@
 module Model.Init
   ( Init
+  , initDecoder
   ) where
 
-import Model.Payment exposing (Payments)
-import Model.Income exposing (Incomes)
-import Model.User exposing (Users, UserId)
+import Json.Decode as Json exposing ((:=))
+
+import Model.Payment exposing (Payments, paymentsDecoder)
+import Model.Income exposing (Incomes, incomesDecoder)
+import Model.User exposing (Users, UserId, usersDecoder, userIdDecoder)
 
 type alias Init =
   { users : Users
@@ -12,3 +15,11 @@ type alias Init =
   , payments : Payments
   , incomes : Incomes
   }
+
+initDecoder : Json.Decoder Init
+initDecoder =
+  Json.object4 Init
+    ("users" := usersDecoder)
+    ("me" := userIdDecoder)
+    ("payments" := paymentsDecoder)
+    ("incomes" := incomesDecoder)
diff --git a/src/client/elm/Model/InitResult.elm b/src/client/elm/Model/InitResult.elm
new file mode 100644
index 0000000..d1f1348
--- /dev/null
+++ b/src/client/elm/Model/InitResult.elm
@@ -0,0 +1,28 @@
+module Model.InitResult
+  ( InitResult(..)
+  , initResultDecoder
+  ) where
+
+import Json.Decode as Json exposing ((:=))
+
+import Model.Init exposing (Init, initDecoder)
+
+type InitResult =
+  InitEmpty
+  | InitSuccess Init
+  | InitError String
+
+initResultDecoder : Json.Decoder InitResult
+initResultDecoder = ("tag" := Json.string) `Json.andThen` initResultDecoderWithTag
+
+initResultDecoderWithTag : String -> Json.Decoder InitResult
+initResultDecoderWithTag tag =
+  case tag of
+    "InitEmpty" ->
+      Json.succeed InitEmpty
+    "InitSuccess" ->
+      Json.map InitSuccess ("contents" := initDecoder)
+    "InitError" ->
+      Json.map InitError ("contents" := Json.string)
+    _ ->
+      Json.fail <| "got " ++ tag ++ " for InitResult"
diff --git a/src/client/elm/Model/View.elm b/src/client/elm/Model/View.elm
index 9d64c73..475e826 100644
--- a/src/client/elm/Model/View.elm
+++ b/src/client/elm/Model/View.elm
@@ -8,6 +8,5 @@ import SignIn.Model as SignInModel
 import LoggedIn.Model as LoggedInModel
 
 type View =
-  LoadingView
-  | SignInView SignInModel.Model
+  SignInView SignInModel.Model
   | LoggedInView LoggedInModel.Model
diff --git a/src/client/elm/Server.elm b/src/client/elm/Server.elm
index ad6d212..be052bb 100644
--- a/src/client/elm/Server.elm
+++ b/src/client/elm/Server.elm
@@ -1,6 +1,5 @@
 module Server
-  ( init
-  , signIn
+  ( signIn
   , addPayment
   , deletePayment
   , setIncome
@@ -20,13 +19,6 @@ import Model.Income exposing (incomesDecoder, incomeIdDecoder, IncomeId)
 import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
 import Model.Init exposing (Init)
 
-init : Task Http.Error Init
-init =
-  Task.map Init (Http.get usersDecoder "/api/users")
-    `Task.andMap` (Http.get ("id" := userIdDecoder) "/api/whoAmI")
-    `Task.andMap` (Http.get paymentsDecoder "/api/payments")
-    `Task.andMap` (Http.get incomesDecoder "/api/incomes")
-
 signIn : String -> Task Http.Error ()
 signIn email =
   post ("/api/signIn?email=" ++ email)
diff --git a/src/client/elm/View.elm b/src/client/elm/View.elm
index 6165766..90808aa 100644
--- a/src/client/elm/View.elm
+++ b/src/client/elm/View.elm
@@ -11,7 +11,6 @@ import Model.View exposing (..)
 import LoggedData
 
 import View.Header exposing (renderHeader)
-import View.Loading exposing (renderLoading)
 
 import SignIn.View as SignInView
 import LoggedIn.View as LoggedInView
@@ -27,8 +26,6 @@ view address model =
 renderMain : Address Action -> Model -> Html
 renderMain address model =
   case model.view of
-    LoadingView ->
-      renderLoading address
     SignInView signIn ->
       SignInView.view address model signIn
     LoggedInView loggedIn ->
diff --git a/src/client/elm/View/Loading.elm b/src/client/elm/View/Loading.elm
deleted file mode 100644
index 5270099..0000000
--- a/src/client/elm/View/Loading.elm
+++ /dev/null
@@ -1,12 +0,0 @@
-module View.Loading
-  ( renderLoading
-  ) where
-
-import Signal exposing (Address)
-
-import Html exposing (..)
-
-import Action exposing (Action)
-
-renderLoading : Address Action -> Html
-renderLoading address = text ""
diff --git a/src/client/js/main.js b/src/client/js/main.js
index 1ab1287..296600e 100644
--- a/src/client/js/main.js
+++ b/src/client/js/main.js
@@ -5,6 +5,6 @@ Elm.fullscreen(Elm.Main, {
   initialTime: new Date().getTime(),
   translations: document.getElementById('messages').innerHTML,
   conf: document.getElementById('conf').innerHTML,
-  signInError: document.getElementById('signInError').innerHTML,
+  initResult: document.getElementById('initResult').innerHTML,
   location: location.pathname
 });
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"