From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 8 Nov 2017 23:47:26 +0100
Subject: Use a better project structure

---
 server/src/Controller/Index.hs | 86 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 86 insertions(+)
 create mode 100644 server/src/Controller/Index.hs

(limited to 'server/src/Controller/Index.hs')

diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
new file mode 100644
index 0000000..8473c5c
--- /dev/null
+++ b/server/src/Controller/Index.hs
@@ -0,0 +1,86 @@
+module Controller.Index
+  ( get
+  , signOut
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+import Network.HTTP.Types.Status (ok200)
+import Prelude hiding (error)
+import Web.Scotty hiding (get)
+
+import qualified Common.Message as Message
+import Common.Message.Key (Key)
+import qualified Common.Message.Key as Key
+import Common.Model (InitResult(..), User(..))
+
+import Conf (Conf(..))
+import Model.Init (getInit)
+import qualified LoginSession
+import qualified Model.Query as Query
+import qualified Model.SignIn as SignIn
+import qualified Model.User as User
+import Secure (getUserFromToken)
+import View.Page (page)
+
+get :: Conf -> Maybe Text -> ActionM ()
+get conf mbToken = do
+  initResult <- case mbToken of
+    Just token -> do
+      userOrError <- validateSignIn conf token
+      case userOrError of
+        Left errorKey ->
+          return . InitEmpty . Left . Message.get $ errorKey
+        Right user ->
+          liftIO . Query.run . fmap InitSuccess $ getInit user conf
+    Nothing -> do
+      mbLoggedUser <- getLoggedUser
+      case mbLoggedUser of
+        Nothing ->
+          return . InitEmpty . Right $ Nothing
+        Just user ->
+          liftIO . Query.run . fmap InitSuccess $ getInit user conf
+  html $ page initResult
+
+validateSignIn :: Conf -> Text -> ActionM (Either Key User)
+validateSignIn conf textToken = do
+  mbLoggedUser <- getLoggedUser
+  case mbLoggedUser of
+    Just loggedUser ->
+      return . Right $ loggedUser
+    Nothing -> do
+      mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken
+      now <- liftIO getCurrentTime
+      case mbSignIn of
+        Nothing ->
+          return . Left $ Key.SignIn_LinkInvalid
+        Just signIn ->
+          if SignIn.isUsed signIn
+            then
+              return . Left $ Key.SignIn_LinkUsed
+            else
+              let diffTime = now `diffUTCTime` (SignIn.creation signIn)
+              in  if diffTime > signInExpiration conf
+                    then
+                      return . Left $ Key.SignIn_LinkExpired
+                    else do
+                      LoginSession.put conf (SignIn.token signIn)
+                      mbUser <- liftIO . Query.run $ do
+                        SignIn.signInTokenToUsed . SignIn.id $ signIn
+                        User.get . SignIn.email $ signIn
+                      return $ case mbUser of
+                        Nothing -> Left Key.Secure_Unauthorized
+                        Just user -> Right user
+
+getLoggedUser :: ActionM (Maybe User)
+getLoggedUser = do
+  mbToken <- LoginSession.get
+  case mbToken of
+    Nothing ->
+      return Nothing
+    Just token -> do
+      liftIO . Query.run . getUserFromToken $ token
+
+signOut :: Conf -> ActionM ()
+signOut conf = LoginSession.delete conf >> status ok200
-- 
cgit v1.2.3