Logged in page

src/Aggreact/Auth.hs

@@ -4,17 +4,17 @@
 {-# 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
@@ -36,14 +36,17 @@ import           Protolude
 
 --------------------------------------------------------------------------------
 import           Aggreact.Html
-import Aggreact.User (UserHandler(..), checkUserLogin)
+import           Aggreact.User       (NewUser (..), User, UserHandler (..),
+                                      checkUserLogin, loginWidget)
 
 --------------------------------------------------------------------------------
 import           Data.Aeson
+import           Database.Store
 import           Servant
+import           Servant.Auth.Server
 import           Servant.Errors
 import           Servant.HTML.Blaze  (HTML)
-import           Servant.Auth.Server
+import qualified Text.Blaze.Html5    as H
 import qualified Web.FormUrlEncoded  as Form
 
 data Login = Login
@@ -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)