snaplet-customauth 0.1.2 → 0.2
raw patch · 8 files changed
+55/−46 lines, 8 filesdep +binary-instancesdep +bytestring-showdep −binary-orphansdep ~aesondep ~hoauth2dep ~lenssetup-changed
Dependencies added: binary-instances, bytestring-show
Dependencies removed: binary-orphans
Dependency ranges changed: aeson, hoauth2, lens, time
Files
- Setup.hs +0/−2
- Snap/Snaplet/CustomAuth.hs +1/−1
- Snap/Snaplet/CustomAuth/AuthManager.hs +2/−1
- Snap/Snaplet/CustomAuth/Handlers.hs +1/−1
- Snap/Snaplet/CustomAuth/OAuth2/Internal.hs +18/−21
- Snap/Snaplet/CustomAuth/Types.hs +7/−8
- Snap/Snaplet/CustomAuth/User.hs +16/−4
- snaplet-customauth.cabal +10/−8
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
Snap/Snaplet/CustomAuth.hs view
@@ -10,7 +10,7 @@ , UserData(..) , defAuthSettings , authName- , authSetCookie+ , authCookieLifetime , createAccount , loginUser , logoutUser
Snap/Snaplet/CustomAuth/AuthManager.hs view
@@ -17,6 +17,7 @@ import Data.ByteString (ByteString) import Data.HashMap.Lazy (HashMap) import Data.Text (Text)+import Data.Time.Clock (NominalDiffTime) import Network.HTTP.Client (Manager) import Snap.Core@@ -43,7 +44,7 @@ data AuthManager u e b = forall i. IAuthBackend u i e b => AuthManager { activeUser :: UserData u => Maybe u- , setCookie :: ByteString -> Cookie+ , cookieLifetime :: Maybe NominalDiffTime , sessionCookieName :: ByteString , userField :: ByteString , passwordField :: ByteString
Snap/Snaplet/CustomAuth/Handlers.hs view
@@ -131,7 +131,7 @@ ps <- maybe (return M.empty) oauth2Init oa return $ AuthManager { activeUser = Nothing- , setCookie = s ^. authSetCookie+ , cookieLifetime = s ^. authCookieLifetime , sessionCookieName = scn , userField = un , passwordField = pn
Snap/Snaplet/CustomAuth/OAuth2/Internal.hs view
@@ -19,9 +19,9 @@ import Data.Aeson import qualified Data.Binary import Data.Binary (Binary)-import Data.Binary.Orphans ()+import Data.Binary.Instances () import qualified Data.ByteString.Base64-import Data.ByteString.Lazy (toStrict, fromStrict)+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict) import Data.Char (chr) import qualified Data.Configurator as C import Data.HashMap.Lazy (HashMap)@@ -53,7 +53,7 @@ cfg <- getSnapletUserConfig root <- getSnapletRootURL hostname <- liftIO $ C.require cfg "hostname"- scheme <- liftIO $ C.lookupDefault "http" cfg "protocol"+ scheme <- liftIO $ C.lookupDefault "https" cfg "protocol" names <- liftIO $ C.lookupDefault [] cfg "oauth2.providers" -- TODO: use discovery let makeProvider name = let@@ -73,7 +73,7 @@ <*> lk ".identityField" <*> (OAuth2 <$> lk ".clientId"- <*> lk ".clientSecret"+ <*> (lift $ runMaybeT $ lk ".clientSecret") <*> lku ".endpoint.auth" <*> lku ".endpoint.access" <*> (pure $ Just callback))@@ -132,24 +132,20 @@ redirect' redirUrl 303 getUserInfo- :: OAuth2Settings u i e b+ :: MonadIO m+ => Manager -> Provider -> AccessToken- -> Handler b (AuthManager u e b) (Maybe Text)-getUserInfo s provider token = do+ -> ExceptT (Maybe ByteString) m Text+getUserInfo mgr provider token = do let endpoint = identityEndpoint provider- let mgr = httpManager s- liftIO $ runMaybeT $ do- dat <- MaybeT $ hush <$> authGetJSON' mgr token endpoint- MaybeT . return $ lookupProviderInfo dat+ (withExceptT Just $ ExceptT $ liftIO $ authGetJSON mgr token endpoint) >>=+ (maybe (throwE Nothing) pure . lookupProviderInfo) where- authGetJSON' :: Manager -> AccessToken -> URI- -> IO (OAuth2Result (HashMap Text Value) (HashMap Text Value))- authGetJSON' = authGetJSON lookup' a b = maybeText =<< M.lookup a b maybeText (String x) = Just x maybeText _ = Nothing- lookupProviderInfo dat = lookup' (identityField provider) dat+ lookupProviderInfo = lookup' (identityField provider) oauth2Callback :: IAuthBackend u i e b@@ -184,14 +180,15 @@ err <- MaybeT $ lift $ getParam "error" lift $ throwE $ ProviderError $ hush $ decodeUtf8' err -- Get the user id from provider- (maybe (throwE IdExtractionFailed) return =<<) $ runMaybeT $ do- code <- MaybeT $ (fmap ExchangeToken) <$> (lift $ getParamText "code")- -- TODO: catch?- token <- either (const $ lift $ throwE AccessTokenFetchError) return =<< liftIO- (fetchAccessToken mgr param code)+ (maybe (throwE (IdExtractionFailed Nothing)) pure =<<+ (fmap ExchangeToken) <$> (lift $ getParamText "code")) >>=+ -- TODO: catch?+ (liftIO . fetchAccessToken mgr param >=>+ either (const $ throwE AccessTokenFetchError) pure >=> -- TODO: get user id (sub) from idToken in token, if -- available. Requires JWT handling.- MaybeT $ lift $ getUserInfo s provider (accessToken token)+ withExceptT (IdExtractionFailed . ((hush . decodeUtf8' . toStrict) =<<)) .+ getUserInfo (httpManager s) provider . accessToken) either (setFailure ((oauth2Failure s) SCallback) (Just $ providerName provider) . Right . Create . OAuth2Failure) (oauth2Success s provider) res
Snap/Snaplet/CustomAuth/Types.hs view
@@ -6,10 +6,10 @@ import Control.Lens.TH import Data.Binary-import Data.Binary.Orphans ()+import Data.Binary.Instances () import Data.ByteString import Data.Text (Text)-import Data.Time.Clock (UTCTime)+import Data.Time.Clock (UTCTime, NominalDiffTime) import GHC.Generics (Generic) import Network.OAuth.OAuth2 (OAuth2) import URI.ByteString (URI)@@ -36,7 +36,7 @@ data OAuth2Failure = StateNotStored | StateNotReceived | ExpiredState | BadState- | ConfigurationError | IdExtractionFailed | NoStoredToken+ | ConfigurationError | IdExtractionFailed (Maybe Text) | NoStoredToken | AlreadyUser | AlreadyLoggedIn | IdentityInUse | ProviderError (Maybe Text)@@ -68,8 +68,8 @@ { actionProvider :: Text , actionStamp :: UTCTime , actionUser :: Maybe ByteString- -- Is the action expected to match with an ID attached to the user.- -- Use False if using the action to attach a new ID.+ -- | Is the action expected to match with an ID attached to the+ -- user. Use False if using the action to attach a new ID. , requireUser :: Bool , savedAction :: ByteString } deriving (Generic)@@ -84,11 +84,10 @@ data AuthSettings = AuthSettings { _authName :: Text- , _authSetCookie :: ByteString -> Cookie+ , _authCookieLifetime :: Maybe NominalDiffTime } makeLenses ''AuthSettings defAuthSettings :: AuthSettings-defAuthSettings = AuthSettings "auth" $ \x ->- Cookie "_session" x Nothing Nothing (Just "/") False True+defAuthSettings = AuthSettings "auth" Nothing
Snap/Snaplet/CustomAuth/User.hs view
@@ -1,13 +1,19 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} module Snap.Snaplet.CustomAuth.User where import Control.Error.Util import Control.Monad.State import Control.Monad.Trans.Maybe+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import qualified Data.Configurator as C import Data.Maybe import Data.Text.Encoding+import Data.Time.Clock (addUTCTime, getCurrentTime) import Snap+import qualified Text.Show.ByteString import Snap.Snaplet.CustomAuth.Types (AuthUser(..)) import Snap.Snaplet.CustomAuth.AuthManager@@ -17,11 +23,17 @@ => u -> Handler b (AuthManager u e b) () setUser usr = do- setter <- gets setCookie+ cfg <- getSnapletUserConfig+ secure <- fmap (== "https") $ liftIO $ C.lookupDefault ("https" :: ByteString) cfg "protocol" let udata = extractUser usr- -- TODO- let wafer = setter $ session udata- modifyResponse $ addResponseCookie wafer+ (name, lifetime) <- gets ((,) <$> sessionCookieName <*> cookieLifetime)+ modifyResponse $ addHeader "Set-Cookie" $+ name <> "=" <> session udata <>+ (maybe "" (("; Max-Age=" <>) . toStrict . Text.Show.ByteString.show @Int . floor) lifetime) <>+ "; Path=/" <>+ (if secure then "; Secure" else "") <>+ "; HttpOnly" <>+ "; SameSite=Lax" modify $ \mgr -> mgr { activeUser = Just usr } currentUser :: UserData u => Handler b (AuthManager u e b) (Maybe u)
snaplet-customauth.cabal view
@@ -1,5 +1,5 @@ Name: snaplet-customauth-Version: 0.1.2+Version: 0.2 Synopsis: Alternate authentication snaplet Description: More customizable authentication snaplet with OAuth2 support License: BSD3@@ -9,13 +9,14 @@ Stability: Experimental Category: Web Build-type: Simple-Cabal-version: >=1.6+Cabal-version: >=1.10 source-repository head type: git location: https://github.com/kaol/snaplet-customauth library+ default-language: Haskell2010 exposed-modules: Snap.Snaplet.CustomAuth, Snap.Snaplet.CustomAuth.OAuth2@@ -32,9 +33,10 @@ Build-depends: base >= 4.4 && < 5,- lens >= 3.7.6 && < 4.17,+ lens >= 3.7.6 && < 4.20, bytestring >= 0.9.1 && < 0.11, base64-bytestring >= 1.0.0.1 && < 1.1,+ bytestring-show >= 0.3.5.6 && < 0.4, heist >= 1.0.1 && < 1.2, mtl >= 2 && < 3, transformers >= 0.4 && < 0.6,@@ -43,16 +45,16 @@ snap-core >= 1.0 && < 1.1, configurator >= 0.3 && < 0.4, text >= 0.11 && < 1.3,- time >= 1.1 && < 1.7,+ time >= 1.1 && < 1.12, xmlhtml >= 0.1 && < 0.3, binary >= 0.8.5 && < 0.9,- binary-orphans >= 0.1.7 && < 0.2,- hoauth2 >= 1.7.0 && < 1.8.0,- http-client >= 0.5.7 && < 0.6,+ binary-instances >= 1 && < 2,+ hoauth2 >= 1.11.0 && < 1.17.0,+ http-client >= 0.5.7 && < 0.7, http-client-tls >= 0.3.5 && < 0.4, containers >= 0.5.6 && < 0.6, unordered-containers >= 0.2.7.1 && < 0.3,- aeson >= 1.2 && < 1.4,+ aeson >= 1.2 && < 1.6, uri-bytestring >= 0.2.3 && < 0.4, map-syntax >= 0.2 && < 0.4, random >= 1.1 && < 1.2