From d2832f56b48740665d59a22f447bb237d1ee94f2 Mon Sep 17 00:00:00 2001
From: "Yann Esposito (Yogsototh)" <yann.esposito@gmail.com>
Date: Thu, 31 Jan 2019 23:43:21 +0100
Subject: [PATCH] Logged in page

---
 src/Aggreact/Auth.hs | 64 +++++++++++++++++++++++++++++---------------
 1 file changed, 42 insertions(+), 22 deletions(-)

diff --git a/src/Aggreact/Auth.hs b/src/Aggreact/Auth.hs
index 6fdee74..f78b11c 100644
--- a/src/Aggreact/Auth.hs
+++ b/src/Aggreact/Auth.hs
@@ -1,20 +1,20 @@
 -- Local Pragmas
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE Strict                #-}
 {-# LANGUAGE TypeOperators         #-}
 
 -- Common Pragmas (already stated in cabal file but repeated here for some tools)
-{-# LANGUAGE BlockArguments             #-} -- blabla do ... instead of blabla $ do ...
-{-# LANGUAGE DerivingStrategies         #-} -- remove warn about deriving strategies
-{-# LANGUAGE ExplicitForAll             #-} -- f :: forall a b. a -> b -> b
-{-# LANGUAGE NamedWildCards             #-} -- can use _type instead of just _
-{-# LANGUAGE NoImplicitPrelude          #-} -- to use protolude for example
-{-# LANGUAGE NumericUnderscores         #-} -- write 1_000 instead of 1000
-{-# LANGUAGE OverloadedLists            #-} -- write [1,2,3] :: Set
-{-# LANGUAGE OverloadedStrings          #-} -- write "foo" and it will be the correct text type
-{-# LANGUAGE PartialTypeSignatures      #-} -- write foo :: (_) => a -> Bool
-{-# LANGUAGE RecordWildCards            #-} -- f Conf{..} = field1 ...
-{-# LANGUAGE ScopedTypeVariables        #-} -- write expr :: Type  inside an expression
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE ExplicitForAll        #-}
+{-# LANGUAGE NamedWildCards        #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE NumericUnderscores    #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {- |
 Module      : Aggreact.Comments.StoreService
 Description : CommentStore service
@@ -35,16 +35,19 @@ where
 import           Protolude
 
 --------------------------------------------------------------------------------
-import Aggreact.Html
-import Aggreact.User (UserHandler(..), checkUserLogin)
+import           Aggreact.Html
+import           Aggreact.User       (NewUser (..), User, UserHandler (..),
+                                      checkUserLogin, loginWidget)
 
 --------------------------------------------------------------------------------
 import           Data.Aeson
+import           Database.Store
 import           Servant
-import           Servant.Errors
-import           Servant.HTML.Blaze (HTML)
 import           Servant.Auth.Server
-import qualified Web.FormUrlEncoded               as Form
+import           Servant.Errors
+import           Servant.HTML.Blaze  (HTML)
+import qualified Text.Blaze.Html5    as H
+import qualified Web.FormUrlEncoded  as Form
 
 data Login = Login
   { username :: Text
@@ -59,10 +62,11 @@ instance Form.FromForm Login where
 type LoginAPI =
   "login"
     :> (ReqBody '[JSON, FormUrlEncoded] Login
-        :> PostNoContent '[JSON, FormUrlEncoded]
+         :> QueryParam "origin" Text
+         :> Post '[JSON, HTML]
          (Headers '[ Header "Set-Cookie" SetCookie
                    , Header "Set-Cookie" SetCookie]
-          NoContent)
+          LoggedIn)
         :<|> Get '[HTML] LoginPage)
 
 serverLoginAPI :: LoginSettings -> Server LoginAPI
@@ -80,10 +84,11 @@ data LoginSettings =
 -- Here is the login handler
 checkCreds :: LoginSettings
            -> Login
+           -> Maybe Text
            -> Handler (Headers '[ Header "Set-Cookie" SetCookie
                                 , Header "Set-Cookie" SetCookie]
-                               NoContent)
-checkCreds LoginSettings{..} (Login loginNick loginPass) = do
+                                LoggedIn)
+checkCreds LoginSettings{..} (Login loginNick loginPass) origin = do
    muser <- liftIO $ checkUserLogin userHandler loginNick loginPass
    case muser of
      Just user -> do
@@ -92,7 +97,22 @@ checkCreds LoginSettings{..} (Login loginNick loginPass) = do
        mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings user
        case mApplyCookies of
          Nothing           -> unauthorized "Could not create a cookie"
-         Just applyCookies -> return $ applyCookies NoContent
+         Just applyCookies -> return $ applyCookies (LoggedIn user (maybe NoAction URL origin))
      _ -> do
        putErrText "User not found"
        unauthorized "User not found"
+
+data PendingAction = NoAction | URL Text
+
+data LoggedIn =
+  LoggedIn { user :: User
+           , pendingAction :: PendingAction
+           }
+
+instance ToJSON LoggedIn where
+  toJSON = toJSON . user
+
+instance H.ToMarkup LoggedIn where
+  toMarkup LoggedIn{..} = boilerplate (loginWidget (Just user)) $ do
+    let n = toS (nick (val user))
+    H.h2 $ H.text ("Welcome " <> n)