Logged in page
This commit is contained in:
parent
bafa7799f0
commit
d2832f56b4
1 changed files with 42 additions and 22 deletions
|
@ -1,20 +1,20 @@
|
||||||
-- Local Pragmas
|
-- Local Pragmas
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE Strict #-}
|
{-# LANGUAGE Strict #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
|
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
|
||||||
{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ...
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _
|
{-# LANGUAGE NamedWildCards #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000
|
{-# LANGUAGE NumericUnderscores #-}
|
||||||
{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PartialTypeSignatures #-} -- write foo :: (_) => a -> Bool
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ...
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{- |
|
{- |
|
||||||
Module : Aggreact.Comments.StoreService
|
Module : Aggreact.Comments.StoreService
|
||||||
Description : CommentStore service
|
Description : CommentStore service
|
||||||
|
@ -35,16 +35,19 @@ where
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Aggreact.Html
|
import Aggreact.Html
|
||||||
import Aggreact.User (UserHandler(..), checkUserLogin)
|
import Aggreact.User (NewUser (..), User, UserHandler (..),
|
||||||
|
checkUserLogin, loginWidget)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
import Database.Store
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.Errors
|
|
||||||
import Servant.HTML.Blaze (HTML)
|
|
||||||
import Servant.Auth.Server
|
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
|
data Login = Login
|
||||||
{ username :: Text
|
{ username :: Text
|
||||||
|
@ -59,10 +62,11 @@ instance Form.FromForm Login where
|
||||||
type LoginAPI =
|
type LoginAPI =
|
||||||
"login"
|
"login"
|
||||||
:> (ReqBody '[JSON, FormUrlEncoded] Login
|
:> (ReqBody '[JSON, FormUrlEncoded] Login
|
||||||
:> PostNoContent '[JSON, FormUrlEncoded]
|
:> QueryParam "origin" Text
|
||||||
|
:> Post '[JSON, HTML]
|
||||||
(Headers '[ Header "Set-Cookie" SetCookie
|
(Headers '[ Header "Set-Cookie" SetCookie
|
||||||
, Header "Set-Cookie" SetCookie]
|
, Header "Set-Cookie" SetCookie]
|
||||||
NoContent)
|
LoggedIn)
|
||||||
:<|> Get '[HTML] LoginPage)
|
:<|> Get '[HTML] LoginPage)
|
||||||
|
|
||||||
serverLoginAPI :: LoginSettings -> Server LoginAPI
|
serverLoginAPI :: LoginSettings -> Server LoginAPI
|
||||||
|
@ -80,10 +84,11 @@ data LoginSettings =
|
||||||
-- Here is the login handler
|
-- Here is the login handler
|
||||||
checkCreds :: LoginSettings
|
checkCreds :: LoginSettings
|
||||||
-> Login
|
-> Login
|
||||||
|
-> Maybe Text
|
||||||
-> Handler (Headers '[ Header "Set-Cookie" SetCookie
|
-> Handler (Headers '[ Header "Set-Cookie" SetCookie
|
||||||
, Header "Set-Cookie" SetCookie]
|
, Header "Set-Cookie" SetCookie]
|
||||||
NoContent)
|
LoggedIn)
|
||||||
checkCreds LoginSettings{..} (Login loginNick loginPass) = do
|
checkCreds LoginSettings{..} (Login loginNick loginPass) origin = do
|
||||||
muser <- liftIO $ checkUserLogin userHandler loginNick loginPass
|
muser <- liftIO $ checkUserLogin userHandler loginNick loginPass
|
||||||
case muser of
|
case muser of
|
||||||
Just user -> do
|
Just user -> do
|
||||||
|
@ -92,7 +97,22 @@ checkCreds LoginSettings{..} (Login loginNick loginPass) = do
|
||||||
mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings user
|
mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings user
|
||||||
case mApplyCookies of
|
case mApplyCookies of
|
||||||
Nothing -> unauthorized "Could not create a cookie"
|
Nothing -> unauthorized "Could not create a cookie"
|
||||||
Just applyCookies -> return $ applyCookies NoContent
|
Just applyCookies -> return $ applyCookies (LoggedIn user (maybe NoAction URL origin))
|
||||||
_ -> do
|
_ -> do
|
||||||
putErrText "User not found"
|
putErrText "User not found"
|
||||||
unauthorized "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)
|
||||||
|
|
Loading…
Reference in a new issue