Adding login/logout functions thanks to a client session

5 files changed, 112 insertions, 3 deletions

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