aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Index.hs74
-rw-r--r--src/server/Controller/SignIn.hs42
-rw-r--r--src/server/Cookie.hs53
-rw-r--r--src/server/LoginSession.hs2
-rw-r--r--src/server/Main.hs15
-rw-r--r--src/server/Model/Init.hs31
-rw-r--r--src/server/Model/Json/Init.hs33
-rw-r--r--src/server/Model/Message/Key.hs1
-rw-r--r--src/server/Model/Message/Translations.hs5
-rw-r--r--src/server/Secure.hs11
-rw-r--r--src/server/View/Page.hs9
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:24:42 +0000