diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Snap/Snaplet/CustomAuth.hs b/Snap/Snaplet/CustomAuth.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth.hs
@@ -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
diff --git a/Snap/Snaplet/CustomAuth/AuthManager.hs b/Snap/Snaplet/CustomAuth/AuthManager.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/AuthManager.hs
@@ -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) ()
+  }
diff --git a/Snap/Snaplet/CustomAuth/Handlers.hs b/Snap/Snaplet/CustomAuth/Handlers.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/Handlers.hs
@@ -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 }
diff --git a/Snap/Snaplet/CustomAuth/Heist.hs b/Snap/Snaplet/CustomAuth/Heist.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/Heist.hs
@@ -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 
diff --git a/Snap/Snaplet/CustomAuth/OAuth2.hs b/Snap/Snaplet/CustomAuth/OAuth2.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/OAuth2.hs
@@ -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
diff --git a/Snap/Snaplet/CustomAuth/OAuth2/Internal.hs b/Snap/Snaplet/CustomAuth/OAuth2/Internal.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/OAuth2/Internal.hs
@@ -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
diff --git a/Snap/Snaplet/CustomAuth/OAuth2/Splices.hs b/Snap/Snaplet/CustomAuth/OAuth2/Splices.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/OAuth2/Splices.hs
@@ -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
diff --git a/Snap/Snaplet/CustomAuth/Types.hs b/Snap/Snaplet/CustomAuth/Types.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/Types.hs
@@ -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
diff --git a/Snap/Snaplet/CustomAuth/User.hs b/Snap/Snaplet/CustomAuth/User.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/User.hs
@@ -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
diff --git a/Snap/Snaplet/CustomAuth/Util.hs b/Snap/Snaplet/CustomAuth/Util.hs
new file mode 100644
--- /dev/null
+++ b/Snap/Snaplet/CustomAuth/Util.hs
@@ -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
diff --git a/snaplet-customauth.cabal b/snaplet-customauth.cabal
new file mode 100644
--- /dev/null
+++ b/snaplet-customauth.cabal
@@ -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