diff --git a/Happstack/Auth/Blaze/Templates.hs b/Happstack/Auth/Blaze/Templates.hs --- a/Happstack/Auth/Blaze/Templates.hs +++ b/Happstack/Auth/Blaze/Templates.hs @@ -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) diff --git a/Happstack/Auth/Core/Auth.hs b/Happstack/Auth/Core/Auth.hs --- a/Happstack/Auth/Core/Auth.hs +++ b/Happstack/Auth/Core/Auth.hs @@ -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) diff --git a/Happstack/Auth/Core/ProfileParts.hs b/Happstack/Auth/Core/ProfileParts.hs --- a/Happstack/Auth/Core/ProfileParts.hs +++ b/Happstack/Auth/Core/ProfileParts.hs @@ -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) diff --git a/happstack-authenticate.cabal b/happstack-authenticate.cabal --- a/happstack-authenticate.cabal +++ b/happstack-authenticate.cabal @@ -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,