aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/client/elm/Main.elm26
-rw-r--r--src/client/elm/Model.elm20
-rw-r--r--src/client/elm/Model/View/SignInView.elm6
-rw-r--r--src/client/elm/Update.elm5
-rw-r--r--src/client/elm/View/SignIn.elm2
-rw-r--r--src/client/js/main.js14
-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
11 files changed, 89 insertions, 61 deletions
diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm
index 06b5ec3..c3d5192 100644
--- a/src/client/elm/Main.elm
+++ b/src/client/elm/Main.elm
@@ -7,6 +7,7 @@ import Graphics.Element exposing (..)
import Html exposing (Html)
import StartApp exposing (App)
import Effects exposing (Effects, Never)
+import Json.Decode as Json
import Task exposing (..)
import Time exposing (..)
@@ -20,18 +21,26 @@ import View exposing (view)
import Server
+import Utils.Maybe exposing (isJust)
+
main : Signal Html
main = app.html
app : App Model
app = StartApp.start
{ init =
- ( initialModel initialTime translations conf
- , Server.init
- |> Task.map GoLoggedInView
- |> flip Task.onError (always <| Task.succeed GoSignInView)
- |> Effects.task
- )
+ case Json.decodeString Json.string signInError of
+ Ok signInError ->
+ ( initialModel initialTime translations conf (Just signInError)
+ , Effects.none
+ )
+ Err _ ->
+ ( initialModel initialTime translations conf Nothing
+ , Server.init
+ |> Task.map GoLoggedInView
+ |> flip Task.onError (always <| Task.succeed GoSignInView)
+ |> Effects.task
+ )
, view = view
, update = update
, inputs = [ Signal.map UpdateTime (Time.every 1000) ]
@@ -45,7 +54,4 @@ port tasks = app.tasks
port initialTime : Time
port translations : String
port conf : String
-
--- Output ports
-
-port signInError : Maybe String
+port signInError : String
diff --git a/src/client/elm/Model.elm b/src/client/elm/Model.elm
index 5dc6692..7852c9a 100644
--- a/src/client/elm/Model.elm
+++ b/src/client/elm/Model.elm
@@ -7,9 +7,12 @@ import Time exposing (Time)
import Json.Decode as Json
import Model.View exposing (..)
+import Model.View.SignInView exposing (initSignInView)
import Model.Translations exposing (..)
import Model.Conf exposing (..)
+import Utils.Maybe exposing (isJust)
+
type alias Model =
{ view : View
, currentTime : Time
@@ -17,16 +20,19 @@ type alias Model =
, conf : Conf
}
-initialModel : Time -> String -> String -> Model
-initialModel initialTime translationsValue confValue =
- { view = LoadingView
+initialModel : Time -> String -> String -> Maybe String -> Model
+initialModel initialTime translations conf mbSignInError =
+ { view =
+ if isJust mbSignInError
+ then SignInView (initSignInView mbSignInError)
+ else LoadingView
, currentTime = initialTime
, translations =
- case Json.decodeString translationsDecoder translationsValue of
+ case Json.decodeString translationsDecoder translations of
Ok translations -> translations
- Err err -> []
+ Err _ -> []
, conf =
- case Json.decodeString confDecoder confValue of
+ case Json.decodeString confDecoder conf of
Ok conf -> conf
- Err err -> { currency = "" }
+ Err _ -> { currency = "" }
}
diff --git a/src/client/elm/Model/View/SignInView.elm b/src/client/elm/Model/View/SignInView.elm
index 0d69445..f72d05a 100644
--- a/src/client/elm/Model/View/SignInView.elm
+++ b/src/client/elm/Model/View/SignInView.elm
@@ -9,9 +9,9 @@ type alias SignInView =
, result : Maybe (Result String String)
}
-initSignInView : SignInView
-initSignInView =
+initSignInView : Maybe String -> SignInView
+initSignInView mbSignInError =
{ login = ""
, waitingServer = False
- , result = Nothing
+ , result = Maybe.map Err mbSignInError
}
diff --git a/src/client/elm/Update.elm b/src/client/elm/Update.elm
index adb90ab..1625167 100644
--- a/src/client/elm/Update.elm
+++ b/src/client/elm/Update.elm
@@ -34,8 +34,7 @@ update action model =
, Server.signIn email
|> Task.map (always (UpdateSignIn SignInAction.ValidLogin))
|> flip Task.onError (\error ->
- let errorMessage = getMessage (errorKey error) model.translations
- in Task.succeed (UpdateSignIn (SignInAction.ErrorLogin errorMessage))
+ Task.succeed (UpdateSignIn (SignInAction.ErrorLogin (errorKey error)))
)
|> Effects.task
)
@@ -49,7 +48,7 @@ update action model =
({ model | currentTime = time }, Effects.none)
GoSignInView ->
- ({ model | view = V.SignInView initSignInView }, Effects.none)
+ ({ model | view = V.SignInView (initSignInView Nothing) }, Effects.none)
UpdateSignIn signInAction ->
(applySignIn model signInAction, Effects.none)
diff --git a/src/client/elm/View/SignIn.elm b/src/client/elm/View/SignIn.elm
index 6fba764..acff960 100644
--- a/src/client/elm/View/SignIn.elm
+++ b/src/client/elm/View/SignIn.elm
@@ -57,6 +57,6 @@ signInResult model signInView =
Err error ->
div
[ class "error" ]
- [ text error ]
+ [ text (getMessage error model.translations) ]
Nothing ->
text ""
diff --git a/src/client/js/main.js b/src/client/js/main.js
index 4c7e2df..0928ab5 100644
--- a/src/client/js/main.js
+++ b/src/client/js/main.js
@@ -1,13 +1,9 @@
+// Remove query params
+window.history.pushState({html: document.documentElement.innerHTML, pageTitle: document.title}, '', '/');
+
Elm.fullscreen(Elm.Main, {
- signInError: getParameterByName('signInError'),
initialTime: new Date().getTime(),
translations: document.getElementById('messages').innerHTML,
- conf: document.getElementById('conf').innerHTML
+ conf: document.getElementById('conf').innerHTML,
+ signInError: document.getElementById('signInError').innerHTML
});
-
-function getParameterByName(name) {
- name = name.replace(/[\[]/, "\\[").replace(/[\]]/, "\\]");
- var regex = new RegExp("[\\?&]" + name + "=([^&#]*)"),
- results = regex.exec(location.search);
- return results && decodeURIComponent(results[1].replace(/\+/g, " "));
-}
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-22 16:28:48 +0000