Sign in token link to /

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