Adding login/logout functions thanks to a client session

1 files changed, 51 insertions, 0 deletions

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