From c95e19407d492a0d4e9e14e320520fe29ce379e5 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 31 Mar 2016 00:06:50 +0200 Subject: Add init data in html page --- src/server/Controller/Index.hs | 74 ++++++++++++++++++++++++++++++-- src/server/Controller/SignIn.hs | 42 ------------------ src/server/Cookie.hs | 53 +++++++++++++++++++++++ src/server/LoginSession.hs | 2 +- src/server/Main.hs | 15 +++---- src/server/Model/Init.hs | 31 +++++++++++++ src/server/Model/Json/Init.hs | 33 ++++++++++++++ src/server/Model/Message/Key.hs | 1 + src/server/Model/Message/Translations.hs | 5 +++ src/server/Secure.hs | 11 +++-- src/server/View/Page.hs | 9 ++-- 11 files changed, 214 insertions(+), 62 deletions(-) create mode 100644 src/server/Cookie.hs create mode 100644 src/server/Model/Init.hs create mode 100644 src/server/Model/Json/Init.hs (limited to 'src/server') 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" -- cgit v1.2.3