aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Index.hs5
-rw-r--r--src/server/Controller/SignIn.hs21
-rw-r--r--src/server/Main.hs16
-rw-r--r--src/server/Model/Message/Key.hs14
-rw-r--r--src/server/View/Page.hs21
5 files changed, 49 insertions, 28 deletions
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index db1038a..bbf741e 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -11,11 +11,12 @@ import Conf (Conf(..))
import qualified LoginSession
import qualified Model.Json.Conf as M
+import Model.Message.Key (Key)
import View.Page (page)
-getIndex :: Conf -> ActionM ()
-getIndex conf = html . page $ M.Conf { M.currency = currency conf }
+getIndex :: Conf -> Maybe Key -> ActionM ()
+getIndex conf mbErrorKey = html $ page (M.Conf { M.currency = currency conf }) mbErrorKey
signOut :: ActionM ()
signOut = do
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 0153784..b87f7a1 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -9,7 +9,7 @@ import Web.Scotty
import Network.HTTP.Types.Status (ok200, badRequest400)
-import Database.Persist
+import Database.Persist hiding (Key)
import Control.Monad.IO.Class (liftIO)
@@ -32,7 +32,6 @@ import Model.Database
import Model.User
import Model.SignIn
import Model.Message.Key
-import Model.Message (getMessage)
import Secure (getUserFromToken)
@@ -46,7 +45,7 @@ signIn conf login =
case maybeUser of
Just user -> do
token <- liftIO . runDb $ createSignInToken login
- let url = T.concat ["http://", hostname conf, "/validateSignIn?token=", token]
+ let url = T.concat ["http://", hostname conf, "?signInToken=", token]
maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login]
case maybeSentMail of
Right _ ->
@@ -61,12 +60,12 @@ signIn conf login =
status badRequest400
text . TL.pack . show $ EnterValidEmail
-validateSignIn :: Conf -> Text -> ActionM ()
+validateSignIn :: Conf -> Text -> ActionM (Either Key ())
validateSignIn conf textToken = do
alreadySigned <- isAlreadySigned
if alreadySigned
then
- redirect "/"
+ return . Right $ ()
else do
mbSignIn <- liftIO . runDb $ getSignIn textToken
now <- liftIO getCurrentTime
@@ -74,18 +73,18 @@ validateSignIn conf textToken = do
Just signInValue ->
if signInIsUsed . entityVal $ signInValue
then
- redirectError (getMessage SignInUsed)
+ return . Left $ SignInUsed
else
let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue)
in if diffTime > (fromIntegral $ (signInExpirationMn conf) * 60)
then
- redirectError (getMessage SignInExpired)
+ return . Left $ SignInExpired
else do
LoginSession.put (signInToken . entityVal $ signInValue)
liftIO . runDb . signInTokenToUsed . entityKey $ signInValue
- redirect "/"
+ return . Right $ ()
Nothing ->
- redirectError (getMessage SignInInvalid)
+ return . Left $ SignInInvalid
isAlreadySigned :: ActionM Bool
isAlreadySigned = do
@@ -95,7 +94,3 @@ isAlreadySigned = do
return False
Just token -> do
liftIO . runDb . fmap isJust $ getUserFromToken token
-
-redirectError :: Text -> ActionM ()
-redirectError msg =
- redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 998b394..5688324 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -35,7 +35,17 @@ main = do
middleware $
staticPolicy (noDots >-> addBase "public")
- get "/" (getIndex conf)
+ get "/" $
+ ( 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)
+
post "/signOut" signOut
-- SignIn
@@ -44,10 +54,6 @@ main = do
email <- param "email" :: ActionM Text
signIn conf email
- get "/validateSignIn" $ do
- token <- param "token" :: ActionM Text
- validateSignIn conf token
-
-- Users
get "/users" getUsers
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 4c0287b..b883132 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -1,7 +1,13 @@
+{-# LANGUAGE DeriveGeneric #-}
+
module Model.Message.Key
( Key(..)
) where
+import GHC.Generics
+
+import Data.Aeson
+
data Key =
-- Title
@@ -77,4 +83,10 @@ data Key =
| NetworkError
| UnexpectedPayload
- deriving (Enum, Bounded, Show)
+ deriving (Enum, Bounded, Show, Generic)
+
+instance ToJSON Key
+
+-- instance ToJSON Coord where
+-- toJSON (Coord x y) = object ["x" .= x, "y" .= y]
+-- toEncoding (Coord x y) = pairs ("x" .= x <> "y" .= y)
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index 4fc57f9..0f1ff86 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -7,6 +7,7 @@ module View.Page
import Data.Text.Internal.Lazy (Text)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Aeson (encode)
+import qualified Data.Aeson.Types as Json
import Text.Blaze.Html
import Text.Blaze.Html5
@@ -19,22 +20,28 @@ import Design.Global (globalDesign)
import Model.Message
import Model.Json.Conf
-import Model.Message.Key (Key(SharedCost))
+import Model.Message.Key (Key, Key(SharedCost))
-page :: Conf -> Text
-page conf =
+page :: Conf -> Maybe Key -> Text
+page conf mbSignInError =
renderHtml . docTypeHtml $ do
H.head $ do
meta ! charset "UTF-8"
- meta ! httpEquiv "X-UA-Compatible" ! content "IE=Edge" -- IE8+ only is valid to use with persona
H.title (toHtml $ getMessage SharedCost)
- script ! src "https://login.persona.org/include.js" $ ""
script ! src "javascripts/client.js" $ ""
- script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations
- script ! A.id "conf" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ conf
+ jsonScript "messages" getTranslations
+ jsonScript "conf" conf
+ jsonScript "signInError" mbSignInError
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"
H.style $ toHtml globalDesign
body $ do
script ! src "javascripts/main.js" $ ""
+
+jsonScript :: Json.ToJSON a => Text -> a -> Html
+jsonScript scriptId json =
+ script
+ ! A.id (toValue scriptId)
+ ! type_ "application/json"
+ $ toHtml . decodeUtf8 . encode $ json
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 01:08:43 +0000