{-|
Copyright:
This file is part of the package openid-connect. It is subject to
the license terms in the LICENSE file found in the top-level
directory of this distribution and at:
https://code.devalot.com/open/openid-connect
No part of this package, including this file, may be copied,
modified, propagated, or distributed except according to the terms
contained in the LICENSE file.
License: BSD-2-Clause
-}
module Auth (app) where
--------------------------------------------------------------------------------
-- Imports:
import Control.Monad.Except
import Data.ByteString (ByteString)
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy.Char8 as LChar8
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding as Text
import Data.Time.Clock (getCurrentTime)
import Network.HTTP.Client (Manager)
import Network.URI (uriToString)
import OpenID.Connect.Client.Flow.AuthorizationCode
import Servant.API
import Servant.HTML.Blaze
import Servant.Server
import Text.Blaze.Html
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Util
import Web.Cookie
--------------------------------------------------------------------------------
type Index = "index"
:> Get '[HTML] Html
--------------------------------------------------------------------------------
type Login = "login" :> Get '[HTML] Html
--------------------------------------------------------------------------------
type Success = "return"
:> QueryParam "code" Text
:> QueryParam "state" Text
:> Header "cookie" SessionCookie
:> Get '[HTML] Html
--------------------------------------------------------------------------------
type Failed = "return"
:> QueryParam "error" Text
:> QueryParam "state" Text
:> Header "cookie" SessionCookie
:> Get '[HTML] Html
--------------------------------------------------------------------------------
-- | Complete API.
type API = Index :<|> Login :<|> Success :<|> Failed
--------------------------------------------------------------------------------
-- | A type for getting the session cookie out of the request.
newtype SessionCookie = SessionCookie
{ getSessionCookie :: ByteString
}
instance FromHttpApiData SessionCookie where
parseUrlPiece = parseHeader . Text.encodeUtf8
parseHeader bs =
case lookup "session" (parseCookies bs) of
Nothing -> Left "session cookie missing"
Just val -> Right (SessionCookie val)
--------------------------------------------------------------------------------
api :: Proxy API
api = Proxy
--------------------------------------------------------------------------------
app :: Manager -> Provider -> Credentials -> Application
app mgr provider creds = serve api (handlers mgr provider creds)
--------------------------------------------------------------------------------
handlers :: Manager -> Provider -> Credentials -> Server API
handlers mgr provider creds =
index :<|> login :<|> success :<|> failed
where
----------------------------------------------------------------------------
-- Return the login HTML.
index :: Server Index
index = pure . H.docTypeHtml $ do
H.title "OpenID Connect Login"
H.p (H.a H.! A.href "/login" $ "Login")
----------------------------------------------------------------------------
-- Redirect the user to the provider.
login :: Server Login
login = do
let req = defaultAuthenticationRequest openid creds
r <- liftIO (authenticationRedirect (providerDiscovery provider) req)
case r of
Left e -> throwError (err403 { errBody = LChar8.pack (show e) })
Right (RedirectTo uri cookie) ->
throwError (err302
{ errHeaders =
[ ("Location", Char8.pack (uriToString id uri []))
, ("Set-Cookie", LChar8.toStrict
(toLazyByteString (renderSetCookie (cookie "session"))))
]
})
----------------------------------------------------------------------------
-- User returned from provider with a successful authentication.
success :: Server Success
success (Just code) (Just state) (Just cookie) = do
let browser = UserReturnFromRedirect
{ afterRedirectCodeParam = Text.encodeUtf8 code
, afterRedirectStateParam = Text.encodeUtf8 state
, afterRedirectSessionCookie = getSessionCookie cookie
}
now <- liftIO getCurrentTime
r <- liftIO (authenticationSuccess (https mgr) now provider creds browser)
case r of
Left e -> throwError (err403 { errBody = LChar8.pack (show e) })
Right _token -> pure . H.docTypeHtml $ do
H.title "Success!"
H.h1 "Successful Authentication"
----------------------------------------------------------------------------
-- Should have been a success, but one or more params are missing.
success _ _ _ = failed (Just "missing params") Nothing Nothing
----------------------------------------------------------------------------
-- User returned from provider with an authentication failure.
failed :: Server Failed
failed err _ _ = throwError $
err400 { errBody = maybe "WTF?" (LChar8.fromStrict . Text.encodeUtf8) err
}