packages feed

snaplet-customauth (empty) → 0.1.0

raw patch · 13 files changed

+1069/−0 lines, 13 filesdep +aesondep +basedep +base64-bytestringsetup-changed

Dependencies added: aeson, base, base64-bytestring, binary, binary-orphans, bytestring, configurator, containers, errors, heist, hoauth2, http-client, http-client-tls, lens, map-syntax, mtl, random, snap, snap-core, text, time, transformers, unordered-containers, uri-bytestring, xmlhtml

Files

+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2015-2018, Kari Pahula+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the snaplet-customauth authors nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Snap/Snaplet/CustomAuth.hs view
@@ -0,0 +1,38 @@+module Snap.Snaplet.CustomAuth+  (+    AuthManager(..)+  , AuthUser(..)+  , AuthFailure(UserError, Create, Login)+  , LoginFailure(..)+  , CreateFailure(..)+  , PasswordFailure(..)+  , IAuthBackend(..)+  , UserData(..)+  , defAuthSettings+  , authName+  , authSetCookie+  , createAccount+  , loginUser+  , logoutUser+  , recoverSession+  , combinedLoginRecover+  , setUser+  , currentUser+  , getAuthFailData+  , resetAuthFailData+  , authInit+  , isSessionDefined+    -- Heist+  , isLoggedIn+  , compiledAuthSplices+  , ifLoggedIn+  , ifLoggedOut+  , loggedInUser+  )+  where++import Snap.Snaplet.CustomAuth.Handlers+import Snap.Snaplet.CustomAuth.Heist+import Snap.Snaplet.CustomAuth.Types+import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.User
+ Snap/Snaplet/CustomAuth/AuthManager.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FunctionalDependencies #-}++module Snap.Snaplet.CustomAuth.AuthManager+  (+    AuthManager(..)+  , IAuthBackend(..)+  , UserData(..)+  , HasAuth(..)+  , AuthFailure(..)+  , OAuth2Settings(..)+  ) where++import Data.Binary (Binary)+import Data.ByteString (ByteString)+import Data.HashMap.Lazy (HashMap)+import Data.Text (Text)+import Network.HTTP.Client (Manager)++import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.CustomAuth.Types+import Snap.Snaplet.Session++class UserData a where+  extractUser :: a -> AuthUser++class UserData u => HasAuth u a where+  extractAuth :: a -> AuthManager u e b++class (UserData u, Binary i, Show e, Eq e) => IAuthBackend u i e b | u -> b, b -> e, e -> i where+  preparePasswordCreate :: Maybe u -> Text -> Handler b (AuthManager u e b) (Either e i)+  cancelPrepare :: i -> Handler b (AuthManager u e b) ()+  create :: Text -> i -> Handler b (AuthManager u e b) (Either (Either e CreateFailure) u)+  attachLoginMethod :: u -> i -> Handler b (AuthManager u e b) (Either e ())+  login :: Text -> Text -> Handler b (AuthManager u e b) (Either e (Maybe u))+  logout :: Text -> Handler b (AuthManager u e b) ()+  recover :: Text -> Handler b (AuthManager u e b) (Either (AuthFailure e) u)+  getUserId :: u -> Handler b (AuthManager u e b) ByteString+  isDuplicateError :: e -> Handler b (AuthManager u e b) Bool++data AuthManager u e b = forall i. IAuthBackend u i e b => AuthManager+  { activeUser :: UserData u => Maybe u+  , setCookie :: ByteString -> Cookie+  , sessionCookieName :: ByteString+  , userField :: ByteString+  , passwordField :: ByteString+  , stateStore' :: SnapletLens (Snaplet b) SessionManager+  , oauth2Provider :: Maybe Text+  , authFailData :: Maybe (AuthFailure e)+  , providers :: HashMap Text Provider+  }++data OAuth2Settings u i e b = IAuthBackend u i e b => OAuth2Settings {+    oauth2Check :: Text -> Text -> Handler b (AuthManager u e b) (Either e (Maybe ByteString))+  , oauth2Login :: Text -> Text -> Handler b (AuthManager u e b) (Either e (Maybe u))+  , oauth2Failure :: OAuth2Stage -> Handler b (AuthManager u e b) ()+  , prepareOAuth2Create :: Text -> Text -> Handler b (AuthManager u e b) (Either e i)+  , oauth2AccountCreated :: u -> Handler b (AuthManager u e b) ()+  , oauth2LoginDone :: Handler b (AuthManager u e b) ()+  , resumeAction :: Text -> Text -> ByteString -> Handler b (AuthManager u e b) ()+  , stateStore :: SnapletLens (Snaplet b) SessionManager+  , httpManager :: Manager+  , bracket :: Handler b (AuthManager u e b) () -> Handler b (AuthManager u e b) ()+  }
+ Snap/Snaplet/CustomAuth/Handlers.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Snap.Snaplet.CustomAuth.Handlers where++import Control.Error.Util hiding (err)+import Control.Lens hiding (un)+import Control.Monad.Trans+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.State+import qualified Data.Configurator as C+import qualified Data.HashMap.Lazy as M+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Data.Text.Encoding+import Snap+import Data.Map++import Snap.Snaplet.CustomAuth.Types hiding (name)+import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.OAuth2.Internal+import Snap.Snaplet.CustomAuth.User (setUser, recoverSession, currentUser, isSessionDefined)+import Snap.Snaplet.CustomAuth.Util (getParamText)++setFailure'+  :: Handler b (AuthManager u e b) ()+  -> AuthFailure e+  -> Handler b (AuthManager u e b) ()+setFailure' action err =+  (modify $ \s -> s { authFailData = Just err }) >> action++loginUser+  :: IAuthBackend u i e b+  => Handler b (AuthManager u e b) ()+  -> Handler b (AuthManager u e b) ()+  -> Handler b (AuthManager u e b) ()+loginUser loginFail loginSucc = do+  usrName <- gets userField+  pwdName <- gets passwordField+  res <- runExceptT $ do+    userName <- noteT (Login UsernameMissing) $ MaybeT $+      (fmap . fmap) decodeUtf8 $ getParam usrName+    passwd <- noteT (Login PasswordMissing) $ MaybeT $+      (fmap . fmap) decodeUtf8 $ getParam pwdName+    usr <- withExceptT UserError $ ExceptT $ login userName passwd+    lift $ maybe (return ()) setUser usr+    hoistEither $ note (Login WrongPasswordOrUsername) usr+  either (setFailure' loginFail) (const loginSucc) res++logoutUser+  :: IAuthBackend u i e b+  => Handler b (AuthManager u e b) ()+logoutUser = do+  sesName <- gets sessionCookieName+  runMaybeT $ do+    ses <- MaybeT $ getCookie sesName+    lift $ expireCookie ses >> logout (decodeUtf8 $ cookieValue ses)+  modify $ \mgr -> mgr { activeUser = Nothing }++-- Recover if session token is present.  Login if login+password are+-- present.+combinedLoginRecover+  :: IAuthBackend u i e b+  => Handler b (AuthManager u e b) ()+  -> Handler b (AuthManager u e b) (Maybe u)+combinedLoginRecover loginFail = do+  sesActive <- isSessionDefined+  usr <- runMaybeT $ do+    guard sesActive+    lift recoverSession+    MaybeT currentUser+  err <- gets authFailData+  maybe (maybe combinedLogin (return . Just) usr)+    (const $ loginFail >> return Nothing) err+    where+      combinedLogin = runMaybeT $ do+        usrName <- gets userField+        pwdName <- gets passwordField+        params <- lift $ fmap rqParams getRequest+        when (all (flip member params) [usrName, pwdName]) $ do+          lift $ loginUser loginFail $ return ()+        MaybeT currentUser++-- Account with password login+createAccount+  :: IAuthBackend u i e b+  => Handler b (AuthManager u e b) (Either (Either e CreateFailure) u)+createAccount = do+  usrName <- ("_new" <>) <$> gets userField+  pwdName <- ("_new" <>) <$> gets passwordField+  let pwdAgainName = pwdName <> "_again"+  usr <- runExceptT $ do+    name <- noteT (Right MissingName) $ MaybeT $+            getParamText usrName+    passwd <- noteT (Right $ PasswordFailure Missing) $ MaybeT $+              getParamText pwdName+    when (T.null passwd) $ throwE (Right $ PasswordFailure Missing)+    noteT (Right $ PasswordFailure Mismatch) $ guard =<<+      (MaybeT $ (fmap . fmap) (== passwd) (getParamText pwdAgainName))+    userId <- either (throwE . Left) return =<<+      (lift $ preparePasswordCreate Nothing passwd)+    return (name, userId)+  res <- runExceptT $ do+    (name, userId) <- hoistEither usr+    u <- ExceptT $ create name userId+    lift $ setUser u+    return u+  case (usr, res) of+    (Right i, Left _) -> cancelPrepare $ snd i+    _ -> return ()+  either (setFailure' (return ()) . either UserError Create) (const $ return ()) res+  return res++authInit+  :: IAuthBackend u i e b+  => Maybe (OAuth2Settings u i e b)+  -> AuthSettings+  -> SnapletInit b (AuthManager u e b)+authInit oa s = makeSnaplet (view authName s) "Custom auth" Nothing $ do+  cfg <- getSnapletUserConfig+  un <- liftIO $ C.lookupDefault "_login" cfg "userField"+  pn <- liftIO $ C.lookupDefault "_password" cfg "passwordField"+  scn <- liftIO $ C.lookupDefault "_session" cfg "sessionCookieName"+  ps <- maybe (return M.empty) oauth2Init oa+  return $ AuthManager+    { activeUser = Nothing+    , setCookie = s ^. authSetCookie+    , sessionCookieName = scn+    , userField = un+    , passwordField = pn+    , stateStore' = maybe (error "oauth2 hooks not defined") stateStore oa+    , oauth2Provider = Nothing+    , authFailData = Nothing+    , providers = ps+    }++isLoggedIn :: UserData u => Handler b (AuthManager u e b) Bool+isLoggedIn = isJust <$> currentUser++getAuthFailData+  :: Handler b (AuthManager u e b) (Maybe (AuthFailure e))+getAuthFailData = get >>= return . authFailData++resetAuthFailData+  :: Handler b (AuthManager u e b) ()+resetAuthFailData = modify $ \mgr -> mgr { authFailData = Nothing }
+ Snap/Snaplet/CustomAuth/Heist.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.CustomAuth.Heist where++import Control.Lens+import Control.Monad.Trans+import qualified Text.XmlHtml as X+import Heist+import qualified Heist.Interpreted as I+import qualified Heist.Compiled as C+import Snap.Snaplet+import Snap.Snaplet.Heist+import Snap.Snaplet.CustomAuth.Handlers+import Snap.Snaplet.CustomAuth.Types+import Snap.Snaplet.CustomAuth.AuthManager+import Data.Map.Syntax++import Snap.Snaplet.CustomAuth.User (currentUser)++addAuthSplices+  :: UserData u+  => Snaplet (Heist b)+  -> SnapletLens b (AuthManager u e b)+  -> Initializer b v ()+addAuthSplices h auth = addConfig h sc+  where+    sc = mempty & scInterpretedSplices .~ is+                & scCompiledSplices .~ cs+    is = do+      "ifLoggedIn" ## ifLoggedIn auth+      "ifLoggedOut" ## ifLoggedOut auth+      "loggedInUser" ## loggedInUser auth+    cs = compiledAuthSplices auth++compiledAuthSplices+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> Splices (SnapletCSplice b)+compiledAuthSplices auth = do+    "ifLoggedIn"   ## cIfLoggedIn auth+    "ifLoggedOut"  ## cIfLoggedOut auth+    "loggedInUser" ## cLoggedInUser auth++ifLoggedIn+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> SnapletISplice b+ifLoggedIn auth = do+  chk <- lift $ withTop auth isLoggedIn+  case chk of+   True -> getParamNode >>= return . X.childNodes+   False -> return []+++cIfLoggedIn+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> SnapletCSplice b+cIfLoggedIn auth = do+    cs <- C.runChildren+    return $ C.yieldRuntime $ do+        chk <- lift $ withTop auth isLoggedIn+        case chk of+          True -> C.codeGen cs+          False -> mempty++ifLoggedOut+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> SnapletISplice b+ifLoggedOut auth = do+    chk <- lift $ withTop auth isLoggedIn+    case chk of+      False -> getParamNode >>= return . X.childNodes+      True -> return []++cIfLoggedOut+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> SnapletCSplice b+cIfLoggedOut auth = do+    cs <- C.runChildren+    return $ C.yieldRuntime $ do+        chk <- lift $ withTop auth isLoggedIn+        case chk of+          False -> C.codeGen cs+          True -> mempty++loggedInUser+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> SnapletISplice b+loggedInUser auth = do+    u <- lift $ withTop auth currentUser+    maybe (return []) (I.textSplice . name . extractUser) $ u++cLoggedInUser+  :: UserData u+  => SnapletLens b (AuthManager u e b)+  -> SnapletCSplice b+cLoggedInUser auth =+    return $ C.yieldRuntimeText $ do+        u <- lift $ withTop auth currentUser+        return $ maybe "" (name . extractUser) u
+ Snap/Snaplet/CustomAuth/OAuth2.hs view
@@ -0,0 +1,17 @@+module Snap.Snaplet.CustomAuth.OAuth2+  (+    OAuth2Settings(..)+  , AuthFailure(Action)+  , OAuth2Failure(..)+  , OAuth2Stage(..)+  , addOAuth2Splices+  , oauth2Init+  , saveAction+  , redirectToProvider+  )+  where++import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.OAuth2.Internal+import Snap.Snaplet.CustomAuth.OAuth2.Splices+import Snap.Snaplet.CustomAuth.Types
+ Snap/Snaplet/CustomAuth/OAuth2/Internal.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TupleSections #-}++module Snap.Snaplet.CustomAuth.OAuth2.Internal+  ( oauth2Init+  , saveAction+  , redirectToProvider+  ) where++import Control.Error.Util hiding (err)+import Control.Lens+import Control.Monad.Except+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Control.Monad.State+import Data.Aeson+import qualified Data.Binary+import Data.Binary (Binary)+import Data.Binary.Orphans ()+import qualified Data.ByteString.Base64+import Data.ByteString.Lazy (toStrict, fromStrict)+import Data.Char (chr)+import qualified Data.Configurator as C+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as M+import Data.Maybe (isJust, isNothing, catMaybes)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeLatin1, decodeUtf8', encodeUtf8)+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)+import Network.HTTP.Client (Manager)+import Network.OAuth.OAuth2+import Prelude hiding (lookup)+import Snap hiding (path)+import Snap.Snaplet.Session+import System.Random+import URI.ByteString++import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.Types hiding (name)+import Snap.Snaplet.CustomAuth.User (setUser, currentUser, recoverSession)+import Snap.Snaplet.CustomAuth.Util (getStateName, getParamText, setFailure)++oauth2Init+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Initializer b (AuthManager u e b) (HashMap Text Provider)+oauth2Init s = do+  cfg <- getSnapletUserConfig+  root <- getSnapletRootURL+  hostname <- liftIO $ C.require cfg "hostname"+  scheme <- liftIO $ C.lookupDefault "http" cfg "protocol"+  names <- liftIO $ C.lookupDefault [] cfg "oauth2.providers"+  -- TODO: use discovery+  let makeProvider name = let+        name' = "oauth2." <> name+        lk = MaybeT . C.lookup cfg . (name' <>)+        lku n = lk n >>=+          MaybeT . return . hush . parseURI strictURIParserOptions . encodeUtf8+        callback = URI (Scheme scheme)+                   (Just $ Authority Nothing (Host hostname) Nothing)+                   ("/" <> root <> "/oauth2callback/" <> (encodeUtf8 name))+                   mempty Nothing+        in Provider+           <$> (MaybeT $ return $ pure $ T.toLower $ name)+           <*> (MaybeT $ return $ pure $ Nothing)+           <*> lk ".scope"+           <*> lku ".endpoint.identity"+           <*> lk ".identityField"+           <*> (OAuth2+                <$> lk ".clientId"+                <*> lk ".clientSecret"+                <*> lku ".endpoint.auth"+                <*> lku ".endpoint.access"+                <*> (pure $ Just callback))+  addRoutes $ mapped._2 %~ (bracket s) $+    [ ("oauth2createaccount", oauth2CreateAccount s)+    , ("oauth2callback/:provider", oauth2Callback s)+    , ("oauth2login/:provider", redirectLogin)+    ]+  liftIO $ M.fromList . map (\x -> (providerName x, x)) . catMaybes <$>+    (mapM (runMaybeT . makeProvider) names)++redirectLogin+  :: Handler b (AuthManager u e b) ()+redirectLogin = do+  provs <- gets providers+  provider <- (flip M.lookup provs =<<) <$> getParamText "provider"+  maybe pass toProvider provider+  where+    toProvider p = do+      success <- redirectToProvider $ providerName p+      if success then return () else pass++getRedirUrl+  :: Provider+  -> Text+  -> URI+getRedirUrl p token =+  appendQueryParams [("state", encodeUtf8 token)+                    ,("scope", encodeUtf8 $ scope p)] $ authorizationUrl $ oauth p++redirectToProvider+  :: Text+  -> Handler b (AuthManager u e b) Bool+redirectToProvider pName = do+  maybe (return False) redirectToProvider' =<< M.lookup pName <$> gets providers++redirectToProvider'+  :: Provider+  -> Handler b (AuthManager u e b) Bool+redirectToProvider' provider = do+  -- Generate a state token and store it in SessionManager+  store <- gets stateStore'+  stamp <- liftIO $ (T.pack . show) <$> getCurrentTime+  name <- getStateName+  let randomChar i+        | i < 10 = chr (i+48)+        | i < 36 = chr (i+55)+        | otherwise = chr (i+61)+      randomText n = T.pack <$> replicateM n (randomChar <$> randomRIO (0,61))+  token <- liftIO $ randomText 20+  withTop' store $ do+    setInSession name token+    setInSession (name <> "_stamp") stamp+    commitSession+  let redirUrl = serializeURIRef' $ getRedirUrl provider token+  redirect' redirUrl 303++getUserInfo+  :: OAuth2Settings u i e b+  -> Provider+  -> AccessToken+  -> Handler b (AuthManager u e b) (Maybe Text)+getUserInfo s 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+  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++oauth2Callback+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Handler b (AuthManager u e b) ()+oauth2Callback s = do+  provs <- gets providers+  maybe pass (oauth2Callback' s) =<<+    ((flip M.lookup provs =<<) <$> getParamText "provider")++oauth2Callback'+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Provider+  -> Handler b (AuthManager u e b) ()+oauth2Callback' s provider = do+  name <- getStateName+  let ss = stateStore s+      mgr = httpManager s+  res <- runExceptT $ do+    let param = oauth provider+    expiredStamp <- lift $ withTop' ss $+      maybe (return True) (liftIO . isExpiredStamp) =<<+      fmap (read . T.unpack) <$> getFromSession (name <> "_stamp")+    when expiredStamp $ throwE ExpiredState+    hostState <- maybe (throwE StateNotStored) return =<<+      (lift $ withTop' ss $ getFromSession name)+    providerState <- maybe (throwE StateNotReceived) return =<<+      (lift $ getParamText "state")+    when (hostState /= providerState) $ throwE BadState+    _ <- runMaybeT $ do+      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)+      -- TODO: get user id (sub) from idToken in token, if+      -- available. Requires JWT handling.+      MaybeT $ lift $ getUserInfo s provider (accessToken token)+  either (setFailure ((oauth2Failure s) SCallback) (Just $ providerName provider) .+          Right . Create . OAuth2Failure)+    (oauth2Success s provider) res++-- User has successfully completed OAuth2 login.  Get the stored+-- intended action and perform it.+oauth2Success+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Provider+  -> Text+  -> Handler b (AuthManager u e b) ()+oauth2Success s provider token = do+  key <- getActionKey $ providerName provider+  store <- gets stateStore'+  name <- getStateName+  act <- withTop' store $ runMaybeT $ do+    act <- MaybeT $ getFromSession key+    lift $ deleteFromSession key >> commitSession+    return act+  withTop' store $ do+    setInSession (name <> "_provider") (providerName provider)+    setInSession (name <> "_token") token+    commitSession+  -- When there's no user defined action stored, treat this as a+  -- regular login+  maybe (doOauth2Login s provider token) (doResume s provider token) act++doOauth2Login+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Provider+  -> Text+  -> Handler b (AuthManager u e b) ()+doOauth2Login s provider token = do+  -- Sanity check: See if the user is already logged in.+  recoverSession+  currentUser >>=+    maybe proceed (const $ setFailure ((oauth2Failure s) SLogin)+                   (Just $ providerName provider) $+                   Right $ Create $ OAuth2Failure AlreadyLoggedIn)+  where+    proceed = do+      res <- runExceptT $ do+        usr <- ExceptT $ (oauth2Login s) (providerName provider) token+        maybe (return ()) (lift . setUser) usr+        return usr+      either (setFailure ((oauth2Failure s) SLogin)+              (Just $ providerName provider) . Left)+        (const $ oauth2LoginDone s) res++isExpiredStamp+  :: UTCTime+  -> IO Bool+isExpiredStamp stamp = do+  current <- getCurrentTime+  let diff = diffUTCTime current stamp+  return $ diff < 0 || diff > 300++prepareOAuth2Create'+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Provider+  -> Text+  -> Handler b (AuthManager u e b) (Either (Either e CreateFailure) i)+prepareOAuth2Create' s provider token =+  (prepareOAuth2Create s) (providerName provider) token >>=+  either checkDuplicate (return . Right)+  where+    checkDuplicate e = do+      isE <- isDuplicateError e+      return $ Left $ if isE then Right $ OAuth2Failure IdentityInUse else Left e++-- Check that stored action is not too old and that user matches+doResume+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Provider+  -> Text+  -> Text+  -> Handler b (AuthManager u e b) ()+doResume s provider token d = do+  recoverSession+  user <- currentUser+  userId <- runMaybeT $ lift . getUserId =<< (MaybeT $ return user)+  res <- runExceptT $ do+    d' <- ExceptT . return $ maybe (Left $ Right ActionDecodeError) Right $+      ((fmap $ \(_, _, x) -> x) . hush . Data.Binary.decodeOrFail . fromStrict) =<<+      (hush $ Data.ByteString.Base64.decode $ encodeUtf8 d)+    when (requireUser d' && isNothing user) $ throwE (Right AttachNotLoggedIn)+    u <- ExceptT $ return . either (Left . Left) Right =<<+      (oauth2Check s) (providerName provider) token+    -- Compare current user with action's stored user+    when (userId /= actionUser d') $+     throwE (Right ActionUserMismatch)+    case requireUser d' of+      -- Compare current user with identity owner+      True -> when (maybe True ((/= userId) . Just) u) $+        throwE (Right ActionUserMismatch)+      -- Ensure that the identity is not yet used+      False -> when (isJust u) $ throwE (Right AlreadyAttached)+    expired <- liftIO $ isExpiredStamp (actionStamp d')+    when expired $ throwE (Right ActionTimeout)+    return $ savedAction d'+  either (setFailure ((oauth2Failure s) SAction)+          (Just $ providerName provider) . fmap Action)+    ((resumeAction s) (providerName provider) token) res++-- User has successfully signed in via oauth2 and the provider/token+-- did not match with an existing user.  This is the endpoint for+-- requesting account creation afterwards.+oauth2CreateAccount+  :: IAuthBackend u i e b+  => OAuth2Settings u i e b+  -> Handler b (AuthManager u e b) ()+oauth2CreateAccount s = do+  store <- gets stateStore'+  provs <- gets providers+  usrName <- ((hush . decodeUtf8') =<<) <$>+    (getParam =<< ("_new" <>) <$> gets userField)+  name <- getStateName+  provider <- (flip M.lookup provs =<<) <$>+    (withTop' store $ getFromSession (name <> "_provider"))+  user <- runExceptT $ do+    -- Sanity check: See if the user is already logged in.+    u <- lift $ recoverSession >> currentUser+    when (isJust u) $ throwE (Right $ OAuth2Failure AlreadyUser)+    -- Get userName+    userName <- hoistEither $ note (Right MissingName) usrName+    -- Get the token and provider from session store+    res <- maybe (throwE $ Right $ OAuth2Failure NoStoredToken) return =<<+           (lift $ withTop' store $ runMaybeT $ do+               provider' <- MaybeT $ return provider+               token <- MaybeT $ getFromSession (name <> "_token")+               return (provider', token))+    ExceptT $ fmap (,userName) <$> prepareOAuth2Create' s (fst res) (snd res)+  res <- runExceptT $ do+    (i, userName) <- hoistEither user+    usr <- ExceptT $ create userName i+    lift $ setUser usr+    return usr+  case (user, res) of+    (Right (i,_), Left _) -> cancelPrepare i+    _ -> return ()+  either (setFailure ((oauth2Failure s) SCreate) (providerName <$> provider) . fmap Create)+    (oauth2AccountCreated s) res++getActionKey+  :: Text+  -> Handler b (AuthManager u e b) Text+getActionKey p = do+  path <- maybe "auth" id . hush . decodeUtf8' <$> getSnapletRootURL+  name <- maybe "auth" id <$> getSnapletName+  return $ "__" <> name <> "_" <> path <> "_action_" <> p++saveAction+  :: (IAuthBackend u i e b, Binary a)+  => Bool+  -> Text+  -> a+  -> Handler b (AuthManager u e b) ()+saveAction require provider a = do+  provs <- gets providers+  guard $ provider `elem` (M.keys provs)+  let d = Data.Binary.encode a+  key <- getActionKey provider+  store <- gets $ stateStore'+  stamp <- liftIO $ getCurrentTime+  i <- runMaybeT $ lift . getUserId =<< MaybeT currentUser+  let payload = SavedAction {+          actionProvider = provider+        , actionStamp = stamp+        , actionUser = i+        , requireUser = require+        , savedAction = toStrict d+        }+  let d' = decodeLatin1 $ Data.ByteString.Base64.encode $+        toStrict . Data.Binary.encode $ payload+  withTop' store $ do+    setInSession key d'+    commitSession
+ Snap/Snaplet/CustomAuth/OAuth2/Splices.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.CustomAuth.OAuth2.Splices (addOAuth2Splices) where++import Control.Lens+import Control.Monad.Trans+import Control.Monad.State+import Data.Map.Syntax+import Data.Maybe+import Data.Monoid+import Heist+import Heist.Compiled+import Snap+import Snap.Snaplet.Heist+import Snap.Snaplet.Session++import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.Util++addOAuth2Splices+  :: Snaplet (Heist b)+  -> SnapletLens b (AuthManager u e b)+  -> Initializer b v ()+addOAuth2Splices h auth = addConfig h sc+  where+    sc = mempty & scCompiledSplices .~ cs+    cs = do+      "ifHaveOAuth2Token" ## spliceOAuth2Token True auth+      "ifNoOAuth2Token" ## spliceOAuth2Token False auth++spliceOAuth2Token+  :: Bool+  -> SnapletLens b (AuthManager u e b)+  -> SnapletCSplice b+spliceOAuth2Token t auth = do+  cs <- runChildren+  return $ yieldRuntime $ do+    name <- lift $ (<> "_token") <$> withTop auth getStateName+    store <- lift $ withTop auth $ gets stateStore'+    chk <- lift $ withTop' store $ (fmap isJust $ getFromSession name)+    if chk == t then codeGen cs else mempty
+ Snap/Snaplet/CustomAuth/Types.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}++module Snap.Snaplet.CustomAuth.Types where++import Control.Lens.TH+import Data.Binary+import Data.Binary.Orphans ()+import Data.ByteString+import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import GHC.Generics (Generic)+import Network.OAuth.OAuth2 (OAuth2)+import URI.ByteString (URI)++import Snap.Core (Cookie(..))++data LoginFailure =+  NoSession | SessionRecoverFail | UsernameMissing | PasswordMissing | WrongPasswordOrUsername+  deriving (Show, Eq, Read)++data AuthFailure e =+    UserError e+  | Login LoginFailure+  | Create CreateFailure+  | Action OAuth2ActionFailure+  deriving (Show)++data CreateFailure =+    MissingName | InvalidName+  | DuplicateName+  | PasswordFailure PasswordFailure+  | OAuth2Failure OAuth2Failure+  deriving (Eq, Show, Read)++data OAuth2Failure =+    StateNotStored | StateNotReceived | ExpiredState | BadState+  | ConfigurationError | IdExtractionFailed | NoStoredToken+  | AlreadyUser | AlreadyLoggedIn+  | IdentityInUse+  | ProviderError (Maybe Text)+  | AccessTokenFetchError+  deriving (Show, Read, Eq)++data OAuth2ActionFailure =+  ActionTimeout | ActionDecodeError | ActionUserMismatch+  | AttachNotLoggedIn | AlreadyAttached+  deriving (Show, Eq, Read)++data PasswordFailure = Missing | Mismatch+  deriving (Show, Eq, Read)++data OAuth2Stage = SCallback | SLogin | SCreate | SAction+  deriving (Show, Eq, Read)++data Provider = Provider+  { providerName :: Text+  , discovery :: Maybe URI+  , scope :: Text+  , identityEndpoint :: URI+  , identityField :: Text+  , oauth :: OAuth2+  }+  deriving (Show)++data SavedAction = SavedAction+  { 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.+  , requireUser :: Bool+  , savedAction :: ByteString+  } deriving (Generic)++instance Binary SavedAction++data AuthUser = AuthUser+  { name :: Text+  , session :: ByteString+  , csrfToken :: ByteString+  } deriving (Show)++data AuthSettings = AuthSettings+  { _authName :: Text+  , _authSetCookie :: ByteString -> Cookie+  }++makeLenses ''AuthSettings++defAuthSettings :: AuthSettings+defAuthSettings = AuthSettings "auth" $ \x ->+  Cookie "_session" x Nothing Nothing (Just "/") False True
+ Snap/Snaplet/CustomAuth/User.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.CustomAuth.User where++import Control.Error.Util+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Data.Maybe+import Data.Text.Encoding+import Snap++import Snap.Snaplet.CustomAuth.Types (AuthUser(..))+import Snap.Snaplet.CustomAuth.AuthManager++setUser+  :: UserData u+  => u+  -> Handler b (AuthManager u e b) ()+setUser usr = do+  setter <- gets setCookie+  let udata = extractUser usr+  -- TODO+  let wafer = setter $ session udata+  modifyResponse $ addResponseCookie wafer+  modify $ \mgr -> mgr { activeUser = Just usr }++currentUser :: UserData u => Handler b (AuthManager u e b) (Maybe u)+currentUser = do+  u <- get+  return $ activeUser u++setFailure'+  :: AuthFailure e+  -> Handler b (AuthManager u e b) ()+setFailure' failure = modify $ \mgr -> mgr { authFailData = Just failure }++recoverSession+  :: IAuthBackend u i e b+  => Handler b (AuthManager u e b) ()+recoverSession = do+  sesName <- gets sessionCookieName+  let quit e = do+        ses <- getCookie sesName+        maybe (return ()) expireCookie ses+        setFailure' e+  usr <- runMaybeT $ do+    val <- MaybeT $ ((hush . decodeUtf8' . cookieValue =<<) <$> getCookie sesName)+    lift $ recover val+  modify $ \mgr -> mgr { activeUser = join $ hush <$> usr }+  maybe (return ()) (either quit (const $ return ())) usr++-- Just check if the session cookie is defined+isSessionDefined+  :: Handler b (AuthManager u e b) Bool+isSessionDefined = gets sessionCookieName >>= getCookie >>= return . isJust
+ Snap/Snaplet/CustomAuth/Util.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}++module Snap.Snaplet.CustomAuth.Util where++import Control.Error.Util+import Control.Monad.State+import Data.ByteString (ByteString)+import Data.Monoid+import Data.Text (Text)+import Data.Text.Encoding+import Snap hiding (path)++import Snap.Snaplet.CustomAuth.AuthManager++getStateName+  :: Handler b (AuthManager u e b) Text+getStateName = do+  path <- maybe "auth" id . hush . decodeUtf8' <$> getSnapletRootURL+  name <- maybe "auth" id <$> getSnapletName+  return $ "__" <> name <> "_" <> path <> "_state"++getParamText+  :: forall (f :: * -> *).+     MonadSnap f+  => ByteString+  -> f (Maybe Text)+getParamText n = (hush . decodeUtf8' =<<) <$> getParam n++setFailure+  :: Handler b (AuthManager u e b) ()+  -> Maybe Text+  -> Either e (AuthFailure e)+  -> Handler b (AuthManager u e b) ()+setFailure action provider failure = do+  let failure' = either UserError id failure+  modify $ \s -> s { oauth2Provider = provider+                   , authFailData = Just failure'+                   }+  action
+ snaplet-customauth.cabal view
@@ -0,0 +1,58 @@+Name:                snaplet-customauth+Version:             0.1.0+Synopsis:            Alternate authentication snaplet+Description:         More customizable authentication snaplet with OAuth2 support+License:             BSD3+License-File:        LICENSE+Author:              Kari Pahula+Maintainer:          kaol@iki.fi+Stability:           Experimental+Category:            Web+Build-type:          Simple+Cabal-version:       >=1.6++source-repository head+  type: git+  location: https://github.com/kaol/snaplet-customauth++library+  exposed-modules:+    Snap.Snaplet.CustomAuth,+    Snap.Snaplet.CustomAuth.OAuth2++  other-modules:+    Snap.Snaplet.CustomAuth.AuthManager,+    Snap.Snaplet.CustomAuth.Handlers,+    Snap.Snaplet.CustomAuth.Heist,+    Snap.Snaplet.CustomAuth.Types,+    Snap.Snaplet.CustomAuth.User,+    Snap.Snaplet.CustomAuth.Util,+    Snap.Snaplet.CustomAuth.OAuth2.Internal,+    Snap.Snaplet.CustomAuth.OAuth2.Splices++  Build-depends:+    base                      >= 4.4     && < 5,+    lens                      >= 3.7.6   && < 4.16,+    bytestring                >= 0.9.1   && < 0.11,+    base64-bytestring         >= 1.0.0.1 && < 1.1,+    heist                     >= 1.0.1   && < 1.1,+    mtl                       >= 2       && < 3,+    transformers              >= 0.4     && < 0.6,+    errors                    >= 2.1     && < 2.2,+    snap                      >= 1.1     && < 1.2,+    snap-core                 >= 1.0     && < 1.1,+    configurator              >= 0.3     && < 0.4,+    text                      >= 0.11    && < 1.3,+    time                      >= 1.1     && < 1.6,+    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,+    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.3,+    uri-bytestring            >= 0.2.3   && < 0.3,+    map-syntax                >= 0.2     && < 0.3,+    random                    >= 1.1     && < 1.2