1 files changed, 76 insertions, 0 deletions
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
new file mode 100644
index 0000000..4f4ae77
--- /dev/null
+++ b/server/src/Controller/Index.hs
@@ -0,0 +1,76 @@
+module Controller.Index
+  ( get
+  , signIn
+  , signOut
+  ) where
+
+import           Control.Monad.IO.Class    (liftIO)
+import           Data.Text                 (Text)
+import qualified Data.Text.Lazy            as TL
+import           Data.Validation           (Validation (..))
+import qualified Network.HTTP.Types.Status as Status
+import           Prelude                   hiding (error, init)
+import           Web.Scotty                (ActionM)
+import qualified Web.Scotty                as S
+
+import           Common.Model              (Init (..), SignInForm (..),
+                                            User (..))
+import qualified Common.Msg                as Msg
+
+import           Conf                      (Conf (..))
+import qualified LoginSession
+import           Model.Query               (Query)
+import qualified Model.Query               as Query
+import           Model.SignIn              (SignIn (..))
+import qualified Persistence.User          as UserPersistence
+import qualified Validation.SignIn         as SignInValidation
+import           View.Page                 (page)
+
+get :: Conf -> ActionM ()
+get conf = do
+  init <- do
+    mbToken <- LoginSession.get
+    case mbToken of
+      Nothing ->
+        return Nothing
+      Just token -> do
+        liftIO . Query.run $ getInit conf token
+  S.html $ page init
+
+signIn :: Conf -> SignInForm -> ActionM ()
+signIn conf form =
+  case SignInValidation.signIn form of
+    Failure _ ->
+      textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+    Success (SignIn email password) -> do
+      result <- liftIO . Query.run $ do
+        isPasswordValid <- UserPersistence.checkPassword email password
+        if isPasswordValid then
+          do
+            signInToken <- UserPersistence.createSignInToken email
+            init <- getInit conf signInToken
+            return $ Just (signInToken, init)
+        else
+          return Nothing
+      case result of
+        Just (signInToken, init) -> do
+          LoginSession.put conf signInToken
+          S.json init
+
+        Nothing ->
+          textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+  where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+
+getInit :: Conf -> Text -> Query (Maybe Init)
+getInit conf signInToken = do
+  user <- UserPersistence.get signInToken
+  case user of
+    Just u ->
+      do
+        users <- UserPersistence.list
+        return . Just $ Init users (_user_id u) (Conf.currency conf)
+    Nothing ->
+      return Nothing
+
+signOut :: Conf -> ActionM ()
+signOut conf = LoginSession.delete conf >> S.status Status.ok200