From 89dd4de13896f8e37d1bf133080eb881ab42b292 Mon Sep 17 00:00:00 2001 From: Joris Guyonvarch Date: Sat, 18 Jul 2015 15:19:48 +0200 Subject: Adding login/logout functions thanks to a client session --- src/client/Main.elm | 4 ++++ src/client/View/Page.elm | 8 +++---- src/server/Application.hs | 34 +++++++++++++++++++++++++++++- src/server/Design/Color.hs | 6 ++++++ src/server/Design/Global.hs | 14 +++++++++++-- src/server/LoginSession.hs | 51 +++++++++++++++++++++++++++++++++++++++++++++ src/server/Main.hs | 10 +++++++++ 7 files changed, 120 insertions(+), 7 deletions(-) create mode 100644 src/server/LoginSession.hs (limited to 'src') diff --git a/src/client/Main.elm b/src/client/Main.elm index 18a4aba..e112144 100644 --- a/src/client/Main.elm +++ b/src/client/Main.elm @@ -2,6 +2,8 @@ module Main ( main ) where +{-| @docs main -} + import Graphics.Element exposing (..) import Html exposing (Html) @@ -16,6 +18,8 @@ import Update exposing (Action(..), actions, updateModel) import View.Page exposing (renderPage) +{-| main -} + main : Signal Html main = Signal.map renderPage model diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm index ca8efc9..73afed9 100644 --- a/src/client/View/Page.elm +++ b/src/client/View/Page.elm @@ -27,10 +27,10 @@ renderPage model = [] ([ tr [] - [ td [] [ text "Utilisateur" ] - , td [] [ text "Nom" ] - , td [] [ text "Prix" ] - , td [] [ text "Date" ] + [ th [] [ text "Utilisateur" ] + , th [] [ text "Nom" ] + , th [] [ text "Prix" ] + , th [] [ text "Date" ] ] ] ++ (List.map renderPayment model.payments)) ] diff --git a/src/server/Application.hs b/src/server/Application.hs index 344b38c..377d1ff 100644 --- a/src/server/Application.hs +++ b/src/server/Application.hs @@ -7,6 +7,10 @@ module Application , addUserAction , deleteUserAction , insertPaymentAction + + , signIn + , checkConnection + , signOut ) where import Web.Scotty @@ -18,14 +22,17 @@ import Database.Persist import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import qualified Data.Text as T import Data.String (fromString) +import qualified Data.Text.Lazy as TL + +import qualified LoginSession import Model.Database (runDb) import Model.User import Model.Payment import View.Page (page) - getIndexAction :: ActionM () getIndexAction = do html $ page @@ -60,3 +67,28 @@ insertPaymentAction email name cost = do Nothing -> do status badRequest400 html "Not found" + +signIn :: Text -> ActionM () +signIn value = do + LoginSession.put value + html "Ok" + +checkConnection :: ActionM () +checkConnection = do + maybeLogin <- LoginSession.get + case maybeLogin of + Just login -> + html . TL.fromStrict $ + T.intercalate + " " + [ "You are connected with the following login:" + , login + ] + Nothing -> do + status badRequest400 + html "You are not connected" + +signOut :: ActionM () +signOut = do + LoginSession.delete + html "Ok" diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index bc7fca0..dada3df 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -4,3 +4,9 @@ import qualified Clay.Color as C brown :: C.Color brown = C.brown + +green :: C.Color +green = C.green + +lightGrey :: C.Color +lightGrey = C.rgb 230 230 230 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index 3408b22..6460220 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -6,6 +6,7 @@ module Design.Global import Clay +import Data.Monoid ((<>)) import Data.Text.Lazy (Text) import Design.Color as C @@ -20,10 +21,19 @@ global = do h1 ? do fontSize (px 40) textAlign (alignSide sideCenter) - margin (px 30) (px 0) (px 30) (px 0) + margin (px 30) (px 0) (px 40) (px 0) color C.brown table ? do - width (pct 50) + width (pct 100) textAlign (alignSide (sideCenter)) "border-spacing" -: "10 px" + + th ? do + color C.green + fontWeight bold + borderBottom solid (px 1) C.brown + + tr <> th ? do + fontSize (px 18) + lineHeight (px 30) diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs new file mode 100644 index 0000000..c755607 --- /dev/null +++ b/src/server/LoginSession.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LoginSession + ( put + , get + , delete + ) where + +import Web.Scotty (ActionM) +import Web.Scotty.Cookie (setSimpleCookie, getCookie, deleteCookie) +import qualified Web.ClientSession as CS + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +sessionName :: Text +sessionName = "SESSION" + +sessionKeyFile :: FilePath +sessionKeyFile = "sessionKey" + +put :: Text -> ActionM () +put value = do + encrypted <- liftIO $ encrypt value + setSimpleCookie sessionName encrypted + +encrypt :: Text -> IO Text +encrypt value = do + iv <- CS.randomIV + key <- CS.getKey sessionKeyFile + return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) + +get :: ActionM (Maybe Text) +get = do + maybeEncrypted <- getCookie sessionName + case maybeEncrypted of + Just encrypted -> + liftIO $ decrypt encrypted + Nothing -> + return Nothing + +decrypt :: Text -> IO (Maybe Text) +decrypt encrypted = do + key <- CS.getKey sessionKeyFile + let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) + return decrypted + +delete :: ActionM () +delete = deleteCookie sessionName diff --git a/src/server/Main.hs b/src/server/Main.hs index 981c865..69de885 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -30,3 +30,13 @@ main = do name <- param "name" :: ActionM Text cost <- param "cost" :: ActionM Int insertPaymentAction email name cost + + get "/signIn" $ do + email <- param "email" :: ActionM Text + signIn email + + get "/checkConnection" $ + checkConnection + + get "/signOut" $ + signOut -- cgit v1.2.3