happstack-authenticate 0.9.8 → 0.10.1
raw patch · 4 files changed
+165/−73 lines, 4 filesdep ~blaze-htmldep ~http-types
Dependency ranges changed: blaze-html, http-types
Files
- Happstack/Auth/Blaze/Templates.hs +11/−8
- Happstack/Auth/Core/Auth.hs +146/−55
- Happstack/Auth/Core/ProfileParts.hs +2/−2
- happstack-authenticate.cabal +6/−8
Happstack/Auth/Blaze/Templates.hs view
@@ -371,15 +371,18 @@ , parsePathSegments = parseSegments fromPathSegments } +-- | this is a simple entry point into @happstack-authenticate@ that+-- provides reasonable default behavior. A majority of the time you+-- will just call this function. authProfileHandler :: (Happstack m) =>- Text- -> Text- -> AcidState AuthState- -> AcidState ProfileState- -> (String -> Html -> Html -> m Response)- -> Maybe Credentials- -> Maybe Text- -> Text+ Text -- ^ baseURI for this server part+ -> Text -- ^ unique path prefix+ -> AcidState AuthState -- ^ handle for 'AcidState AuthState'+ -> AcidState ProfileState -- ^ handle for 'AcidState ProfileState'+ -> (String -> Html -> Html -> m Response) -- ^ template function used to render pages+ -> Maybe Credentials -- ^ optional Facebook 'Credentials'+ -> Maybe Text -- ^ optional realm to use for @OpenId@ authentication+ -> Text -- ^ url to redirect to if authentication and profile selection is successful -> m Response authProfileHandler baseURI pathPrefix acidAuth acidProfile appTemplate mFacebook realm postPickedURL = do r <- implSite_ baseURI pathPrefix (authProfileSite acidAuth acidProfile appTemplate mFacebook realm postPickedURL)
Happstack/Auth/Core/Auth.hs view
@@ -28,7 +28,6 @@ , AskAuthToken(..) , UpdateAuthToken(..) , DeleteAuthToken(..)- , AuthTokenAuthId(..) , GenAuthId(..) , AddAuthMethod(..) , NewAuthMethod(..)@@ -48,7 +47,7 @@ import Control.Applicative (Alternative, (<$>), optional) import Control.Monad (replicateM) import Control.Monad.Reader (ask)-import Control.Monad.State (get, put)+import Control.Monad.State (get, put, modify) import Control.Monad.Trans (MonadIO(..)) import Crypto.PasswordStore import Data.Acid@@ -57,21 +56,20 @@ import qualified Data.ByteString.Char8 as B import Data.Data (Data, Typeable) import qualified Data.IxSet as IxSet-import Data.IxSet (IxSet, (@=), inferIxSet, noCalcs, getOne, updateIx)+import Data.IxSet (Indexable(..), IxSet, (@=), inferIxSet, noCalcs, inferIxSet, ixFun, ixSet, noCalcs, getOne, updateIx) import Data.Map (Map) import qualified Data.Map as Map import Data.SafeCopy -- (base, deriveSafeCopy) import Data.Set (Set) import qualified Data.Set as Set-import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime,)+import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text (Text) import Facebook (UserId, Id(..))-import Network.HTTP.Types (Ascii) import Web.Authenticate.OpenId (Identifier) import Web.Routes (PathInfo(..))-import Happstack.Server (CookieLife(..), Happstack, addCookie, expireCookie, lookCookieValue, mkCookie)+import Happstack.Server (Cookie(..), CookieLife(..), Happstack, Request(rqSecure), addCookie, askRq, expireCookie, lookCookieValue, mkCookie) newtype AuthId = AuthId { unAuthId :: Integer } deriving (Eq, Ord, Read, Show, Data, Typeable)@@ -134,10 +132,10 @@ newtype FacebookId_001 = FacebookId_001 { unFacebookId_001 :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy) -newtype FacebookId_002 = FacebookId_002 { unFacebookId_002 :: Ascii }+newtype FacebookId_002 = FacebookId_002 { unFacebookId_002 :: B.ByteString } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 2 'extension ''FacebookId_002)- + instance Migrate FacebookId_002 where type MigrateFrom FacebookId_002 = FacebookId_001 migrate (FacebookId_001 fid) = FacebookId_002 (Text.encodeUtf8 fid)@@ -179,6 +177,7 @@ migrate (AuthUserPassId_v1 up) = AuthUserPassId up +-- | This links an authentication method (such as on OpenId 'Identifier', a 'FacebookId', or 'UserPassId') to an 'AuthId'. data AuthMap = AuthMap { amMethod :: AuthMethod , amAuthId :: AuthId@@ -191,18 +190,37 @@ -- * AuthToken +data AuthToken_001+ = AuthToken_001 { tokenString_001 :: String+ , tokenExpires_001 :: UTCTime+ , tokenAuthId_001 :: Maybe AuthId+ , tokenAuthMethod_001 :: AuthMethod+ }+ deriving (Eq, Ord, Data, Show, Typeable)+$(deriveSafeCopy 1 'base ''AuthToken_001)++ data AuthToken = AuthToken { tokenString :: String , tokenExpires :: UTCTime+ , tokenLifetime :: Int , tokenAuthId :: Maybe AuthId , tokenAuthMethod :: AuthMethod } deriving (Eq, Ord, Data, Show, Typeable)-$(deriveSafeCopy 1 'base ''AuthToken)+$(deriveSafeCopy 2 'extension ''AuthToken) -$(inferIxSet "AuthTokens" ''AuthToken 'noCalcs [''String, ''AuthId])+instance Migrate AuthToken where+ type MigrateFrom AuthToken = AuthToken_001+ migrate (AuthToken_001 ts te tid tam) =+ (AuthToken ts te 3600 tid tam) +instance Indexable AuthToken where+ empty = ixSet [ ixFun $ (:[]) . tokenString+ , ixFun $ (:[]) . tokenAuthId+ ] +type AuthTokens = IxSet AuthToken -- * AuthState @@ -213,16 +231,32 @@ -- Basically we can expired them on: logout and time -- -- time is tricky because we do not really want to do a db update everytime they access the site+data AuthState_1+ = AuthState_1 { userPasses_1 :: UserPasses+ , nextUserPassId_1 :: UserPassId+ , authMaps_1 :: AuthMaps+ , nextAuthId_1 :: AuthId+ , authTokens_1 :: AuthTokens+ }+ deriving (Data, Eq, Show, Typeable)+$(deriveSafeCopy 1 'base ''AuthState_1)+ data AuthState = AuthState { userPasses :: UserPasses , nextUserPassId :: UserPassId , authMaps :: AuthMaps , nextAuthId :: AuthId , authTokens :: AuthTokens+ , defaultSessionTimeout :: Int } deriving (Data, Eq, Show, Typeable)-$(deriveSafeCopy 1 'base ''AuthState)+$(deriveSafeCopy 2 'extension ''AuthState) +instance Migrate AuthState where+ type MigrateFrom AuthState = AuthState_1+ migrate (AuthState_1 up nup am nai at) =+ (AuthState up nup am nai at (60*60))+ -- | a reasonable initial 'AuthState' initialAuthState :: AuthState initialAuthState =@@ -231,6 +265,7 @@ , authMaps = IxSet.empty , authTokens = IxSet.empty , nextAuthId = AuthId 1+ , defaultSessionTimeout = 60*60 } -- ** UserPass@@ -376,6 +411,17 @@ do as@(AuthState{..}) <- ask return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= upid +-- * Default timeout++setDefaultSessionTimeout :: Int -- ^ default timout in seconds (should be >= 180)+ -> Update AuthState ()+setDefaultSessionTimeout newTimeout =+ modify $ \as@AuthState{..} -> as { defaultSessionTimeout = newTimeout }++getDefaultSessionTimeout :: Query AuthState Int+getDefaultSessionTimeout =+ defaultSessionTimeout <$> ask+ -- * AuthToken @@ -401,6 +447,16 @@ do as@AuthState{..} <- get put (as { authTokens = IxSet.deleteIx tokenStr authTokens }) +purgeExpiredTokens :: UTCTime+ -> Update AuthState ()+purgeExpiredTokens now =+ do as@AuthState{..} <- get+ let authTokens' = IxSet.fromList $ filter (\at -> (tokenExpires at) > now) (IxSet.toList authTokens)+ put as { authTokens = authTokens'}++-- | deprecated+--+-- this function is deprecated because it is not possible to check if the session has expired authTokenAuthId :: String -> Query AuthState (Maybe AuthId) authTokenAuthId tokenString = do as@(AuthState{..}) <- ask@@ -408,11 +464,49 @@ Nothing -> return Nothing (Just authToken) -> return $ (tokenAuthId authToken) +-- | generate a new, unused 'AuthId'+genAuthId :: Update AuthState AuthId+genAuthId =+ do as@(AuthState {..}) <- get+ put (as { nextAuthId = succAuthId nextAuthId })+ return nextAuthId++askAuthState :: Query AuthState AuthState+askAuthState = ask++$(makeAcidic ''AuthState [ 'askUserPass+ , 'checkUserPass+ , 'createUserPass+ , 'setUserName+ , 'setPassword+ , 'addAuthToken+ , 'askAuthToken+ , 'updateAuthToken+ , 'deleteAuthToken+ , 'purgeExpiredTokens+ , 'authTokenAuthId+ , 'genAuthId+ , 'addAuthMethod+ , 'newAuthMethod+ , 'removeAuthIdentifier+ , 'identifierAuthIds+ , 'facebookAuthIds+ , 'addAuthUserPassId+ , 'removeAuthUserPassId+ , 'userPassIdAuthIds+ , 'askAuthState+ , 'setDefaultSessionTimeout+ , 'getDefaultSessionTimeout+ ])++-- * happstack-server level stuff+ -- TODO: -- - expireAuthTokens -- - tickleAuthToken -- | generate an new authentication token+-- genAuthToken :: (MonadIO m) => Maybe AuthId -> AuthMethod -> Int -> m AuthToken genAuthToken aid authMethod lifetime = do random <- liftIO $ B.unpack . exportSalt <$> genSaltIO -- the docs promise that the salt will be base64, so 'B.unpack' should be safe@@ -423,49 +517,25 @@ (Just a) -> show (unAuthId a) return $ AuthToken { tokenString = prefix ++ random , tokenExpires = expires+ , tokenLifetime = lifetime , tokenAuthId = aid , tokenAuthMethod = authMethod } --- | generate a new, unused 'AuthId'-genAuthId :: Update AuthState AuthId-genAuthId =- do as@(AuthState {..}) <- get- put (as { nextAuthId = succAuthId nextAuthId })- return nextAuthId--askAuthState :: Query AuthState AuthState-askAuthState = ask--$(makeAcidic ''AuthState [ 'askUserPass- , 'checkUserPass- , 'createUserPass- , 'setUserName- , 'setPassword- , 'addAuthToken- , 'askAuthToken- , 'updateAuthToken- , 'deleteAuthToken- , 'authTokenAuthId- , 'genAuthId- , 'addAuthMethod- , 'newAuthMethod- , 'removeAuthIdentifier- , 'identifierAuthIds- , 'facebookAuthIds- , 'addAuthUserPassId- , 'removeAuthUserPassId- , 'userPassIdAuthIds- , 'askAuthState- ])---- * happstack-server level stuff--addAuthCookie :: (Happstack m) => AcidState AuthState -> Maybe AuthId -> AuthMethod -> m ()+-- Also calls 'PurgeExpiredTokens'+addAuthCookie :: (Happstack m) =>+ AcidState AuthState+ -> Maybe AuthId+ -> AuthMethod+ -> m () addAuthCookie acidH aid authMethod =- do authToken <- genAuthToken aid authMethod (60*60)+ do lifetime <- query' acidH GetDefaultSessionTimeout+ authToken <- genAuthToken aid authMethod lifetime+ now <- liftIO $ getCurrentTime+ update' acidH (PurgeExpiredTokens now) update' acidH (AddAuthToken authToken)- addCookie Session (mkCookie "authToken" (tokenString authToken))+ s <- rqSecure <$> askRq+ addCookie Session ((mkCookie "authToken" (tokenString authToken)) { secure = s }) return () deleteAuthCookie :: (Happstack m, Alternative m) => AcidState AuthState -> m ()@@ -476,18 +546,39 @@ (Just tokenStr) -> do expireCookie "authToken" update' acidH (DeleteAuthToken tokenStr)-+{-+getAuthCookie :: (Alternative m, Happstack m) =>+ AcidState AuthState+ -> m (Maybe AuthToken)+getAuthCookie acidH =+ do mTokenStr <- optional $ lookCookieValue "authToken"+-} getAuthToken :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthToken) getAuthToken acidH = do mTokenStr <- optional $ lookCookieValue "authToken" case mTokenStr of- Nothing -> return Nothing+ Nothing -> return Nothing (Just tokenStr) ->- query' acidH (AskAuthToken tokenStr)+ do mAuthToken <- query' acidH (AskAuthToken tokenStr)+ case mAuthToken of+ Nothing -> return Nothing+ (Just authToken) ->+ do now <- liftIO $ getCurrentTime+ if now > (tokenExpires authToken)+ then do expireCookie "authToken"+ update' acidH (DeleteAuthToken tokenStr)+ return Nothing+ else if (diffUTCTime (addUTCTime (fromIntegral $ tokenLifetime authToken) now) (tokenExpires authToken)) > 60+ then do let newAuthToken = authToken { tokenExpires = addUTCTime (fromIntegral $ tokenLifetime authToken) now }+ update' acidH (UpdateAuthToken newAuthToken)+ return (Just newAuthToken)+ else return (Just authToken) + getAuthId :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthId) getAuthId acidH =- do mTokenStr <- optional $ lookCookieValue "authToken"- case mTokenStr of- Nothing -> return Nothing- (Just tokenStr) -> query' acidH (AuthTokenAuthId tokenStr)+ do mAuthToken <- getAuthToken acidH+ case mAuthToken of+ Nothing -> return Nothing+ (Just authToken) ->+ return $ (tokenAuthId authToken)
Happstack/Auth/Core/ProfileParts.hs view
@@ -18,7 +18,7 @@ pickAuthId :: (Happstack m, Alternative m) => AcidState AuthState -> m (Either (Set AuthId) AuthId) pickAuthId authStateH =- do (Just authToken) <- getAuthToken authStateH -- FIXME: Just + do (Just authToken) <- getAuthToken authStateH -- FIXME: Just case tokenAuthId authToken of (Just authId) -> return (Right authId) Nothing ->@@ -48,7 +48,7 @@ return True else return False -data PickProfile +data PickProfile = Picked UserId | PickPersonality (Set Profile) | PickAuthId (Set AuthId)
happstack-authenticate.cabal view
@@ -1,8 +1,8 @@ Name: happstack-authenticate-Version: 0.9.8+Version: 0.10.1 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId.-Homepage: http://www.happstack.com/+Homepage: http://hub.darcs.net/stepcut/happstack-authentication License: BSD3 License-file: LICENSE Author: Jeremy Shaw.@@ -12,14 +12,12 @@ Build-type: Simple Cabal-version: >=1.6 - source-repository head type: darcs- subdir: happstack-authenticate- location: http://hub.darcs.net/stepcut/happstack-+ location: http://hub.darcs.net/stepcut/happstack-authenticate Library+ Exposed-modules: Happstack.Auth Happstack.Auth.Blaze.Templates Happstack.Auth.Core.Profile,@@ -34,13 +32,13 @@ acid-state >= 0.6, aeson >= 0.4 && < 0.7, authenticate == 1.3.*,- blaze-html == 0.5.*,+ blaze-html >= 0.5 && < 0.7, bytestring >= 0.9 && < 0.11, containers >= 0.4 && < 0.6, ixset >= 1.0 && < 1.1, happstack-server >= 6.0 && < 7.2, http-conduit >= 1.4 && < 1.9,- http-types >= 0.6 && < 0.8,+ http-types >= 0.6 && < 0.9, fb == 0.13.*, safecopy >= 0.6, mtl >= 2.0,