From 0d589e12a0c32936303de46b1e462dd19648170d Mon Sep 17 00:00:00 2001 From: Joris Guyonvarch Date: Sun, 19 Jul 2015 16:07:15 +0200 Subject: Login with a token validation --- elm-package.json | 6 +++--- gen | 2 +- payments.cabal | 30 ---------------------------- sharedCost.cabal | 31 +++++++++++++++++++++++++++++ src/client/Model/View.elm | 3 ++- src/client/Model/View/SignIn.elm | 15 ++++++++++++++ src/client/Update.elm | 15 ++++++++++---- src/client/Update/SignIn.elm | 15 ++++++++++++++ src/client/View/Page.elm | 22 ++++++++++++++------ src/server/Application.hs | 43 +++++++++++++++++++++++++++------------- src/server/Design/Color.hs | 3 +++ src/server/Design/Global.hs | 22 ++++++++++++-------- src/server/Main.hs | 10 +++++++--- src/server/Model/Database.hs | 7 +++++++ src/server/Model/Message.hs | 15 ++++++++++++++ src/server/Model/Payment.hs | 6 +++--- src/server/Model/SignIn.hs | 34 +++++++++++++++++++++++++++++++ src/server/Model/UUID.hs | 10 ++++++++++ src/server/Model/User.hs | 6 +++--- 19 files changed, 219 insertions(+), 76 deletions(-) delete mode 100644 payments.cabal create mode 100644 sharedCost.cabal create mode 100644 src/client/Model/View/SignIn.elm create mode 100644 src/client/Update/SignIn.elm create mode 100644 src/server/Model/Message.hs create mode 100644 src/server/Model/SignIn.hs create mode 100644 src/server/Model/UUID.hs diff --git a/elm-package.json b/elm-package.json index e975976..a520a22 100644 --- a/elm-package.json +++ b/elm-package.json @@ -1,11 +1,11 @@ { "version": "0.0.1", - "summary": "Payments", - "repository": "https://github.com/guyonvarch/payments.git", + "summary": "SharedCost", + "repository": "https://github.com/guyonvarch/sharedCost.git", "license": "BSD3", "source-directories": ["src/client"], "exposed-modules": ["Main"], - "elm-version": "0.15.0 <= v < 0.16.0", + "elm-version": "0.15.1 <= v < 0.16.0", "dependencies": { "elm-lang/core": "2.0.1 <= v < 3.0.0", "evancz/elm-html": "3.0.0 <= v < 4.0.0", diff --git a/gen b/gen index 28a2d2b..5e5358d 100755 --- a/gen +++ b/gen @@ -2,4 +2,4 @@ trap 'fuser -k 3000/tcp' EXIT elm-make src/client/Main.elm --output public/javascripts/client.js \ && cabal build \ - && ./dist/build/payments/payments + && ./dist/build/sharedCost/sharedCost diff --git a/payments.cabal b/payments.cabal deleted file mode 100644 index 0e39dbc..0000000 --- a/payments.cabal +++ /dev/null @@ -1,30 +0,0 @@ -name: Payments -version: 0.0.1 -homepage: https://github.com/guyonvarch/payments -author: Joris Guyonvarch -category: Web -build-type: Simple -cabal-version: >= 1.8 - -executable payments - main-is: Main.hs - hs-source-dirs: src/server - ghc-options: -Wall -fwarn-incomplete-uni-patterns - build-depends: base - , scotty == 0.10.1 - , wai-middleware-static == 0.7.0.1 - , http-types == 0.8.6 - , time == 1.5.0.1 - , text == 1.2.1.1 - , persistent == 2.2 - , persistent-sqlite == 2.2 - , persistent-template == 2.1.3.4 - , esqueleto == 2.2.7 - , monad-logger == 0.3.13.1 - , resourcet == 1.1.5 - , transformers == 0.4.2.0 - , blaze-html == 0.8.0.2 - , clay == 0.10.1 - , aeson == 0.9.0.1 - , scotty-cookie == 0.1.0.3 - , clientsession == 0.9.1.1 diff --git a/sharedCost.cabal b/sharedCost.cabal new file mode 100644 index 0000000..1ccddc5 --- /dev/null +++ b/sharedCost.cabal @@ -0,0 +1,31 @@ +name: SharedCost +version: 0.0.1 +homepage: https://github.com/guyonvarch/sharedCost +author: Joris Guyonvarch +category: Web +build-type: Simple +cabal-version: >= 1.8 + +executable sharedCost + main-is: Main.hs + hs-source-dirs: src/server + ghc-options: -Wall -fwarn-incomplete-uni-patterns + build-depends: base + , scotty == 0.10.1 + , wai-middleware-static == 0.7.0.1 + , http-types == 0.8.6 + , time == 1.5.0.1 + , text == 1.2.1.1 + , persistent == 2.2 + , persistent-sqlite == 2.2 + , persistent-template == 2.1.3.4 + , esqueleto == 2.2.7 + , monad-logger == 0.3.13.1 + , resourcet == 1.1.5 + , transformers == 0.4.2.0 + , blaze-html == 0.8.0.2 + , clay == 0.10.1 + , aeson == 0.9.0.1 + , scotty-cookie == 0.1.0.3 + , clientsession == 0.9.1.1 + , uuid == 1.3.10 diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm index ca819e3..3e3cbca 100644 --- a/src/client/Model/View.elm +++ b/src/client/Model/View.elm @@ -3,8 +3,9 @@ module Model.View ) where import Model.Payment exposing (Payments) +import Model.View.SignIn exposing (..) type View = LoadingView | PaymentView Payments - | SignInView String + | SignInView SignIn diff --git a/src/client/Model/View/SignIn.elm b/src/client/Model/View/SignIn.elm new file mode 100644 index 0000000..1c8eae7 --- /dev/null +++ b/src/client/Model/View/SignIn.elm @@ -0,0 +1,15 @@ +module Model.View.SignIn + ( SignIn + , initSignIn + ) where + +type alias SignIn = + { login : String + , authentication : Maybe (Result String String) + } + +initSignIn : SignIn +initSignIn = + { login = "" + , authentication = Nothing + } diff --git a/src/client/Update.elm b/src/client/Update.elm index 3937888..1d0fe95 100644 --- a/src/client/Update.elm +++ b/src/client/Update.elm @@ -7,11 +7,14 @@ module Update import Model exposing (Model) import Model.Payment exposing (Payments) import Model.View exposing (..) +import Model.View.SignIn exposing (..) + +import Update.SignIn exposing (..) type Action = NoOp | SignIn - | UpdateLogin String + | UpdateSignIn SignInAction | UpdatePayments Payments actions : Signal.Mailbox Action @@ -23,8 +26,12 @@ updateModel action model = NoOp -> model SignIn -> - { model | view <- SignInView "" } - UpdateLogin login -> - { model | view <- SignInView login } + { model | view <- SignInView initSignIn } + UpdateSignIn signInAction -> + case model.view of + SignInView signIn -> + { model | view <- SignInView (updateSignIn signInAction signIn) } + _ -> + model UpdatePayments payments -> { model | view <- PaymentView payments } diff --git a/src/client/Update/SignIn.elm b/src/client/Update/SignIn.elm new file mode 100644 index 0000000..a962f90 --- /dev/null +++ b/src/client/Update/SignIn.elm @@ -0,0 +1,15 @@ +module Update.SignIn + ( SignInAction(..) + , updateSignIn + ) where + +import Model.View.SignIn exposing (..) + +type SignInAction = + UpdateLogin String + +updateSignIn : SignInAction -> SignIn -> SignIn +updateSignIn action signIn = + case action of + UpdateLogin login -> + { signIn | login <- login } diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm index 1683cf3..eb86132 100644 --- a/src/client/View/Page.elm +++ b/src/client/View/Page.elm @@ -13,11 +13,14 @@ import Date exposing (Date) import String exposing (append) +import Json.Decode as Json + import Model exposing (Model) import Model.Payment exposing (Payments, Payment) import Model.View exposing (..) import Update exposing (..) +import Update.SignIn exposing (..) import ServerCommunication as SC import ServerCommunication exposing (serverCommunications) @@ -38,7 +41,7 @@ renderHeader model = [] [ h1 [] - [ text "Payments" ] + [ text "Shared Cost" ] , case model.view of LoadingView -> text "" @@ -57,7 +60,7 @@ renderMain model = case model.view of LoadingView -> loadingView - SignInView login -> + SignInView { login } -> signInView login PaymentView payments -> paymentsView payments @@ -67,18 +70,25 @@ loadingView = text "" signInView : String -> Html signInView login = - H.form + div [ class "signIn" ] [ input [ value login - , on "input" targetValue (Signal.message actions.address << UpdateLogin) + , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin) + , onEnter serverCommunications.address (SC.SignIn login) ] [] , button [ onClick serverCommunications.address (SC.SignIn login) ] - [ renderIcon "sign-in" ] + [ text "Sign in" ] ] +onEnter : Signal.Address a -> a -> Attribute +onEnter address value = + on "keydown" + (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err "")) + (\_ -> Signal.message address value) + paymentsView : Payments -> Html paymentsView payments = table @@ -112,5 +122,5 @@ paymentLine payment = renderDate : Date -> String renderDate date = toString (Date.day date) - |> flip append (" " ++ (toString (Date.month date))) + |> flip append (" " ++ (toString (Date.month date)) ++ ".") |> flip append (" " ++ (toString (Date.year date))) diff --git a/src/server/Application.hs b/src/server/Application.hs index 28ad3cd..75d0323 100644 --- a/src/server/Application.hs +++ b/src/server/Application.hs @@ -1,14 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} module Application - ( signIn - , signOut + ( signInAction + , validateSignInAction + , signOutAction , getIndexAction , getUsersAction , getPaymentsAction , addUserAction , deleteUserAction - , insertPaymentAction + , createPaymentAction ) where import Web.Scotty @@ -21,16 +22,17 @@ import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Data.String (fromString) -import qualified Data.Text.Lazy as TL import qualified LoginSession import qualified Secure -import Model.Database (runDb) +import Model.Database import Model.User import Model.Payment +import Model.SignIn import View.Page (page) @@ -51,7 +53,7 @@ getPaymentsAction = addUserAction :: Text -> Text -> ActionM () addUserAction email name = do - _ <- liftIO . runDb $ insertUser email name + _ <- liftIO . runDb $ createUser email name status ok200 deleteUserAction :: Text -> ActionM () @@ -59,28 +61,41 @@ deleteUserAction email = do _ <- liftIO . runDb $ deleteUser email status ok200 -insertPaymentAction :: Text -> Text -> Int -> ActionM () -insertPaymentAction email name cost = do +createPaymentAction :: Text -> Text -> Int -> ActionM () +createPaymentAction email name cost = do maybeUser <- liftIO . runDb $ getUser email case maybeUser of Just user -> do - _ <- liftIO . runDb $ insertPayment (entityKey user) name cost + _ <- liftIO . runDb $ createPayment (entityKey user) name cost return () Nothing -> do status badRequest400 status ok200 -signIn :: Text -> ActionM () -signIn login = do +signInAction :: Text -> ActionM () +signInAction login = do maybeUser <- liftIO . runDb $ getUser login case maybeUser of Just _ -> do - LoginSession.put login + token <- liftIO . runDb $ createSignInToken login + let url = T.concat ["http://localhost:3000/validateSignIn?token=", token] + liftIO . TIO.putStrLn $ url status ok200 Nothing -> status badRequest400 -signOut :: ActionM () -signOut = do +validateSignInAction :: Text -> ActionM () +validateSignInAction token = do + maybeSignIn <- liftIO . runDb $ getSignInToken token + case maybeSignIn of + Just signIn -> do + LoginSession.put (signInEmail . entityVal $ signIn) + liftIO . runDb . signInTokenIsUsed . entityKey $ signIn + redirect "/" + Nothing -> + status badRequest400 + +signOutAction :: ActionM () +signOutAction = do LoginSession.delete status ok200 diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index 6344fe6..b744cf2 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -11,5 +11,8 @@ brown = C.brown green :: C.Color green = C.green +grey :: C.Color +grey = C.rgb 200 200 200 + lightGrey :: C.Color lightGrey = C.rgb 245 245 245 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index 7074f65..6e3cbe6 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -9,7 +9,6 @@ import Prelude import Clay -import Data.Monoid ((<>)) import Data.Text.Lazy (Text) import Design.Color as C @@ -23,8 +22,12 @@ iconFontSize = 32 global :: Css global = do + input ? do + borderRadius (px 0) (px 0) (px 0) (px 0) + border solid (px 1) C.grey + header ? do - let headerHeight = 120 + let headerHeight = 150 h1 ? do fontSize (px 40) @@ -64,20 +67,23 @@ global = do lineHeight (px 60) nthChild "odd" & backgroundColor C.lightGrey - form # ".signIn" ? do + ".signIn" ? do let inputHeight = 50 - marginTop (px 80) - marginBottom (px 80) - width (pct 60) + width (px 500) + marginTop (px 50) marginLeft auto marginRight auto input ? do - width (pct 80) + display block + width (pct 100) padding (px 10) (px 10) (px 10) (px 10) height (px inputHeight) + marginBottom (px 10) button ? do - width (pct 20) + display block + width (pct 100) height (px inputHeight) backgroundColor C.brown color C.white borderWidth (px 0) + borderRadius (px 3) (px 3) (px 3) (px 3) diff --git a/src/server/Main.hs b/src/server/Main.hs index 4461945..7fd42a7 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -23,10 +23,14 @@ main = do post "/signIn" $ do login <- param "login" :: ActionM Text - signIn login + signInAction login + + get "/validateSignIn" $ do + token <- param "token" :: ActionM Text + validateSignInAction token post "/signOut" $ - signOut + signOutAction get "/payments" $ getPaymentsAction @@ -43,4 +47,4 @@ main = do email <- param "email" :: ActionM Text name <- param "name" :: ActionM Text cost <- param "cost" :: ActionM Int - insertPaymentAction email name cost + createPaymentAction email name cost diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index abf235d..e5fd075 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -33,6 +33,13 @@ Payment name Text cost Int deriving Show +SignIn + token Text + creation UTCTime + email Text + isUsed Bool + UniqToken token + deriving Show |] type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs new file mode 100644 index 0000000..acc785e --- /dev/null +++ b/src/server/Model/Message.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Message.Json + ( Message(..) + ) where + +import Data.Aeson +import GHC.Generics + +data Message = Message + { message :: String + } deriving (Show, Generic) + +instance FromJSON Message +instance ToJSON Message diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index b35e13c..ad1c261 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,6 +1,6 @@ module Model.Payment ( getPayments - , insertPayment + , createPayment ) where import Data.Text (Text) @@ -30,7 +30,7 @@ getJsonPayment (paymentEntity, userEntity) = in P.Payment (paymentCreation payment) (paymentName payment) (paymentCost payment) (userName user) -insertPayment :: UserId -> Text -> Int -> Persist PaymentId -insertPayment userId name cost = do +createPayment :: UserId -> Text -> Int -> Persist PaymentId +createPayment userId name cost = do now <- liftIO getCurrentTime insert $ Payment userId now name cost diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs new file mode 100644 index 0000000..c447416 --- /dev/null +++ b/src/server/Model/SignIn.hs @@ -0,0 +1,34 @@ +module Model.SignIn + ( createSignInToken + , getSignInToken + , signInTokenIsUsed + ) where + +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) + +import Control.Monad.IO.Class (liftIO) + +import Database.Persist + +import Model.Database +import Model.UUID (generateUUID) + +createSignInToken :: Text -> Persist Text +createSignInToken email = do + now <- liftIO getCurrentTime + token <- liftIO generateUUID + _ <- insert $ SignIn token now email False + return token + +getSignInToken :: Text -> Persist (Maybe (Entity SignIn)) +getSignInToken token = + selectFirst + [ SignInToken ==. token + , SignInIsUsed ==. False + ] + [] + +signInTokenIsUsed :: SignInId -> Persist () +signInTokenIsUsed tokenId = + update tokenId [SignInIsUsed =. True] diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs new file mode 100644 index 0000000..6cb7ce0 --- /dev/null +++ b/src/server/Model/UUID.hs @@ -0,0 +1,10 @@ +module Model.UUID + ( generateUUID + ) where + +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) +import Data.Text (Text, pack) + +generateUUID :: IO Text +generateUUID = pack . toString <$> nextRandom diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index ddca0fb..339aff6 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,7 +1,7 @@ module Model.User ( getUsers , getUser - , insertUser + , createUser , deleteUser ) where @@ -20,8 +20,8 @@ getUsers = map entityVal <$> selectList [] [Desc UserCreation] getUser :: Text -> Persist (Maybe (Entity User)) getUser email = selectFirst [UserEmail ==. email] [] -insertUser :: Text -> Text -> Persist UserId -insertUser email name = do +createUser :: Text -> Text -> Persist UserId +createUser email name = do now <- liftIO getCurrentTime insert $ User now email name -- cgit v1.2.3