├── .ghci ├── .gitignore ├── README.md ├── snap-auth.cabal └── src └── Snap ├── Auth.hs ├── Auth ├── Handlers.hs └── Password.hs └── Extension ├── Session.hs └── Session ├── Common.hs ├── CookieSession.hs ├── Helpers.hs ├── SecureCookie.hs └── Types.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -XOverloadedStrings 2 | :set -XGeneralizedNewtypeDeriving 3 | :set -XDeriveDataTypeable 4 | :set -XMultiParamTypeClasses 5 | :set -XFunctionalDependencies 6 | :set -Wall 7 | :set -isrc 8 | :set -itest/suite 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | .*.swp 4 | dist 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Snap-auth provides authentication and session management functionality for 2 | Snap. Eventually this will probably be moved into the snap package. But we're 3 | starting it off in a separate package until we get a better sense of how snap 4 | code will be organized. 5 | 6 | 7 | ## The Concept 8 | 9 | User/session management has two basic levels (potentially more if you add 10 | permissions/roles/etc.): 11 | 12 | - Making sure an established session between any user - authenticated or 13 | otherwise - and the server stays secure. 14 | - Authenticating users, which means having proof that a user is who she says 15 | she is before we grant her some important priveleges in our application. 16 | 17 | This package both of these challenges. It will likely be integrated into Snap 18 | as the stock solution, possibly in the 0.5 release. 19 | 20 | 21 | ## Session Management 22 | 23 | First, let's demonstrate the session management piece. 24 | 25 | ### Introduction 26 | 27 | For those familiar with Rails, the functionality is similar to 28 | 29 | session[:user_id] = 1234 30 | session[:last_query] = "johnpollak" 31 | 32 | The difference, however, is that we can't just store arbitrary data -types and 33 | instead use only ByteStrings. 34 | 35 | 36 | We define a type Session as 37 | 38 | type Session = Map ByteString ByteString 39 | 40 | which gives us all the convenience and power of Haskell's standard Map library. 41 | 42 | It is yet to be seen if this is effective and/or efficient in the long run but 43 | has worked well so far. 44 | 45 | 46 | ### Setting Up Your Application With Sessions 47 | 48 | Let's setup the session functionality using the CookieSession backend. 49 | 50 | -- Define a field to hold the session state in your application state 51 | data ApplicationState = ApplicationState 52 | { appSessionSt :: CookieSessionState } 53 | 54 | -- Instantiate your app as a MonadSession 55 | instance HasCookieSessionState ApplicationState where 56 | getCookieSessionState = appSessionSt 57 | 58 | -- Add some simple initializer code 59 | appInit :: Initializer ApplicationState 60 | appInit = do 61 | cs <- cookieSessionStateInitializer $ defCookieSessionState 62 | { csKeyPath = "config/site-key.txt" 63 | , csCookieName = "myapp-session" } 64 | return $ ApplicationState cs 65 | 66 | 67 | And you are done. While you have to do this manually for now, we will in the 68 | future have the snap executable auto-generate some of this boiler plate 69 | for you. 70 | 71 | 72 | ### Usage Example 73 | 74 | Let's assume we have an odd desire to persist our user's age in our session 75 | store: 76 | 77 | import qualified Data.Map as M 78 | import Snap.Extension.CookieSession 79 | 80 | ... 81 | 82 | myHandler = do 83 | setInSession "user_age" "32" -- that's all we have to do! 84 | render "pages/myPage" 85 | 86 | The "user_age" field will now be available in this user's session until we 87 | delete it or expire the session. 88 | 89 | We can now retrieve it at any point with: 90 | 91 | myHandler2 = do 92 | uage <- getFromSession "user_age" 93 | doSomethingWithUid uage 94 | render "pages/myPage2" 95 | 96 | 97 | 98 | ### Backends 99 | 100 | 101 | #### CookieSession 102 | 103 | There is currently a single back-end: Snap.Extension.Session.CookieSession. It 104 | uses Data.Serialize to serialize the Session data type and Michael Snoyman's 105 | Web.ClientSession to encrypt the cookie. The cookie is encrypted, which means 106 | it is fully secure and can't be read by the client/end-user. 107 | 108 | Since this method has no need for a DB back-end, it works out of the box and is 109 | pretty much the simplest session persistence back-end to use. For those 110 | familiar, this method is the default behavior in Ruby on Rails as well. 111 | 112 | Please see the Haddock documentation for more information. 113 | 114 | 115 | ### Other Backends 116 | 117 | The idea would be to add various other back-ends as desired. Redis, MongoDB, 118 | SQL-based databases, etc. should all be straightforward enough to implement. We 119 | would just need a scheme to presist the session type in the respective 120 | database. 121 | 122 | 123 | 124 | ## Authentication 125 | 126 | The second layer of thic package provides for user athentication. It defines an 127 | AuthUser datatype that holds all of the core authentication fields for 128 | a "user". Let's look at it so we can get a sense for what is possible: 129 | 130 | 131 | data AuthUser = AuthUser 132 | { userId :: Maybe UserId 133 | , userEmail :: Maybe ByteString 134 | , userPassword :: Maybe Password 135 | , userSalt :: Maybe ByteString 136 | , userActivatedAt :: Maybe UTCTime 137 | , userSuspendedAt :: Maybe UTCTime 138 | , userLoginCount :: Int 139 | , userFailedLoginCount :: Int 140 | , userCurrentLoginAt :: Maybe UTCTime 141 | , userLastLoginAt :: Maybe UTCTime 142 | , userCurrentLoginIp :: Maybe ByteString 143 | , userLastLoginIp :: Maybe ByteString 144 | , userCreatedAt :: Maybe UTCTime 145 | , userUpdatedAt :: Maybe UTCTime 146 | } deriving (Read,Show,Ord,Eq) 147 | 148 | 149 | The authentication piece has two key typeclasses that we need to be aware of. 150 | 151 | ### MonadAuth Typeclass 152 | 153 | To enable authentication, we need to make our application monad an instance of 154 | MonadAuth. While doing so, we get to choose/customize various authentication 155 | parameters. The simplest way to instantiate our application is simply: 156 | 157 | instance MonadAuth Application 158 | 159 | and done. That's right, we have all the sensible defaults set up so you could 160 | potentially just do that. More typically, here is what you would 161 | specify: 162 | 163 | instance MonadAuth Application where 164 | authAuthenticationKeys = return ["login", "domain"] 165 | authUserTable = return "myusers" 166 | 167 | and so on. Take a look at haddocks to see what can be specified. 168 | 169 | NOTE: We are still working on implementing some of these options, but it should 170 | be complete soon enough. 171 | 172 | ### MonadAuthUser Typeclass 173 | 174 | Now onto the database integration. This typeclass is all about persisting users 175 | in some form of storage. Whatever snap database extension is being used would 176 | be expected to instantiate this typeclass and have nice integration with 177 | MonadAuth. 178 | 179 | As an example, Snap.Extension.DB.MongoDB has ongoing support for MonadAuth and 180 | instantiates MonadAuthUser for free. See the repo at: 181 | 182 | https://github.com/ozataman/snap-extension-mongodb 183 | 184 | A couple of key ideas to understand this typeclass are as follows: 185 | 186 | 1. User can be looked up in 2 ways: 187 | - With an internal/db-provided unique bytestring identifier. This is the 188 | "id" field in most db systems. 189 | - A Map of key, value pairs that can be used to look up a user in the db. 190 | This is the external interface and is typically submitted through a web 191 | form. This is how the user of you application will identify herself 192 | during login. 193 | 1. The user table in the DB can contain more fields than necessary for 194 | authentication. This is both natural and typical. So the saveAuthUser 195 | function takes a (AuthUser, t) input. AuthUser contains the core 196 | authentication fields and t is passed directly to the DB back-end to be 197 | included in the save. As an example, in MongoDB implementation t is the 198 | Document datatype and is merged with the AuthUser fields prior to database 199 | save. 200 | 201 | Again, this typeclass is instantiated by the DB extension you are using, so 202 | normally you should not need to implement it. 203 | 204 | ### Usage Example 205 | 206 | Here is a simple example. We'll provide more thorough documentation as things 207 | crystallize. 208 | 209 | 210 | data User = User 211 | { authUser :: AuthUser 212 | , myField1 :: ByteStrings 213 | , myField2 :: ByteStrings 214 | } 215 | 216 | -- Construct your 'User' from the given parameters 217 | -- Make sure you do validation as well - at least for now. 218 | makeUser ps = return $ User { .... } 219 | 220 | additionalUserFields :: User -> Document 221 | additionalUserFields u = [ "myField1" =: myField1 u 222 | , "myField2" =: myField2 u ] 223 | 224 | site = routes $ 225 | [ ("/signup", method GET $ newSignupH) 226 | , ("/signup", method POST $ signupH) 227 | 228 | , ("/login", method GET $ newSessionH) 229 | , ("/login", method POST $ loginHandler "password" newSessionH redirHome) 230 | ] 231 | 232 | redirHome = redirect "/" 233 | 234 | -- Make sure you have a 'password' field in there 235 | newSessionH = render "login" 236 | 237 | -- Assuming you have a signup.tpl template 238 | newSignupH = render "signup" 239 | 240 | -- Save user and redirect as appropriate 241 | signupH :: Application () 242 | signupH = do 243 | ps <- getParams 244 | let u = makeUser ps 245 | au <- saveAuthUser (u, additionalUserFields u) 246 | case au of 247 | Nothing -> newSignupH 248 | Just au' -> do setSessionUserId $ userId au' 249 | redirect "/" 250 | 251 | 252 | 253 | ## TODO/ROADMAP 254 | 255 | ### Session-related 256 | 257 | #### General 258 | 259 | - Splices/handlers for easy CSRF protection token integration: 260 | - csrf_meta_tag for unobtrusive JS based binding to forms (like in Rails 3) 261 | - csrf_token_tag for a hidden field inside forms (in progress) 262 | - verify_authenticity handler to be chained before your destructive handlers 263 | 264 | #### Planned Back-ends 265 | - MongoDB backend 266 | - HDBC-based SQL back-ends once extension-hdbc is in place 267 | 268 | #### Open Questions/Considerations 269 | - Possibility of using JSON-like datatype for session store. 270 | 271 | ### Auth-related 272 | 273 | - Challenge/response authentication (http://pajhome.org.uk/crypt/md5/auth.html) 274 | This is needed to provide secure authentication without SSL. The goal is to 275 | take as much of the burden as possible off the end user, which probably 276 | means including some Javascript code for use on the client side. If the 277 | client is not javascript-enabled, then the user should have the option to 278 | failover seamlessly to less secure authentication (that transmits cleartext 279 | passwords across the network) or alert the user and disallow logins.. 280 | 281 | - Support for "remember me" and "password reset" tokens. 282 | - Perhaps make Password / Salt opaque field with a Show/Read instance for DB 283 | serialization - users should really never need that stuff 284 | 285 | -------------------------------------------------------------------------------- /snap-auth.cabal: -------------------------------------------------------------------------------- 1 | Name: snap-auth 2 | Version: 0.1.2 3 | Synopsis: An authentication/session management system for Snap 4 | Author: Doug Beardsley, Ozgun Ataman 5 | Maintainer: Ozgun Ataman 6 | Stability: Experimental 7 | Category: Web 8 | Build-type: Simple 9 | Cabal-Version: >= 1.6 10 | Description: 11 | Snap.Auth provides two pieces of major functionality for Snap applications: 12 | - Sessions support 13 | - User authentication 14 | 15 | This library will be ported over to the new Snaplets infrastructure when our 16 | work there is complete. 17 | 18 | Library 19 | hs-source-dirs: 20 | src 21 | exposed-modules: 22 | Snap.Auth 23 | Snap.Auth.Handlers 24 | Snap.Extension.Session.CookieSession 25 | Snap.Extension.Session.Helpers 26 | other-modules: 27 | Snap.Auth.Password 28 | Snap.Extension.Session 29 | Snap.Extension.Session.Common 30 | Snap.Extension.Session.SecureCookie 31 | Snap.Extension.Session.Types 32 | 33 | Build-Depends: 34 | Crypto >= 4.2.0, 35 | base >= 4 && < 5, 36 | bytestring >= 0.9, 37 | cereal >= 0.3, 38 | clientsession >= 0.4.1 && < 0.5, 39 | containers >= 0.3, 40 | haskell98, 41 | heist >= 0.5.1, 42 | mtl >= 2 && < 3, 43 | xmlhtml >= 0.1.3, 44 | old-locale, 45 | snap-core == 0.5.*, 46 | snap == 0.5.*, 47 | syb, 48 | time, 49 | text >= 0.11, 50 | transformers >= 0.2.2 51 | 52 | ghc-options: -Wall -funbox-strict-fields -O2 -optc-O3 -funfolding-use-threshold=16 53 | 54 | extensions: 55 | OverloadedStrings 56 | , MultiParamTypeClasses 57 | , FunctionalDependencies 58 | , DeriveDataTypeable 59 | -------------------------------------------------------------------------------- /src/Snap/Auth.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This module provides simple and secure high-level authentication 4 | functionality for Snap applications. 5 | 6 | -} 7 | module Snap.Auth 8 | ( 9 | 10 | -- * Higher Level Functions 11 | -- $higherlevel 12 | mkAuthCredentials 13 | , performLogin 14 | , performLogout 15 | , currentAuthUser 16 | , isLoggedIn 17 | , authenticatedUserId 18 | 19 | -- * MonadAuth Class 20 | , MonadAuth(..) 21 | , MonadAuthUser(..) 22 | 23 | -- * Types 24 | , AuthUser(..) 25 | , emptyAuthUser 26 | , UserId(..) 27 | , ExternalUserId(..) 28 | , Password(..) 29 | , AuthFailure(..) 30 | 31 | -- * Crypto Stuff You May Need 32 | , HashFunc 33 | 34 | ) where 35 | 36 | import Maybe 37 | 38 | import Control.Applicative 39 | import Control.Monad.Reader 40 | import Data.ByteString.Char8 (ByteString) 41 | import qualified Data.ByteString as B 42 | import Data.Time 43 | 44 | import Snap.Auth.Password 45 | import Snap.Types 46 | import Snap.Extension.Session 47 | import Snap.Extension.Session.Common 48 | import Snap.Extension.Session.SecureCookie 49 | import Snap.Extension.Session.Types 50 | 51 | ------------------------------------------------------------------------------ 52 | -- | External / end-user-facing identifier for a 'AuthUser'. 53 | -- 54 | -- For example, this could be a (\"username\", \"john.doe\") pair submitted 55 | -- through a web form. 56 | newtype ExternalUserId = EUId { unEuid :: Params } 57 | deriving (Read,Show,Ord,Eq) 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | -- | Password is clear when supplied by the user and encrypted later when 62 | -- returned from the db. 63 | data Password = ClearText ByteString 64 | | Encrypted ByteString 65 | deriving (Read, Show, Ord, Eq) 66 | 67 | 68 | ------------------------------------------------------------------------------ 69 | -- | Authentication failures indicate what went wrong during authentication. 70 | -- They may provide useful information to the developer, although it is 71 | -- generally not advisable to show the user the exact details about why login 72 | -- failed. 73 | data AuthFailure = ExternalIdFailure 74 | | PasswordFailure 75 | deriving (Read, Show, Ord, Eq) 76 | 77 | ------------------------------------------------------------------------------ 78 | -- | Type representing the concept of a User in your application. 79 | data AuthUser = AuthUser 80 | { userId :: Maybe UserId 81 | , userEmail :: Maybe ByteString 82 | , userPassword :: Maybe Password 83 | , userSalt :: Maybe ByteString 84 | , userActivatedAt :: Maybe UTCTime 85 | , userSuspendedAt :: Maybe UTCTime 86 | {-, userPerishableToken :: Maybe ByteString-} 87 | , userPersistenceToken :: Maybe ByteString 88 | {-, userSingleAccessToken :: Maybe ByteString-} 89 | , userLoginCount :: Int 90 | , userFailedLoginCount :: Int 91 | , userCurrentLoginAt :: Maybe UTCTime 92 | , userLastLoginAt :: Maybe UTCTime 93 | , userCurrentLoginIp :: Maybe ByteString 94 | , userLastLoginIp :: Maybe ByteString 95 | , userCreatedAt :: Maybe UTCTime 96 | , userUpdatedAt :: Maybe UTCTime 97 | } deriving (Read,Show,Ord,Eq) 98 | 99 | 100 | ------------------------------------------------------------------------------ 101 | -- | A blank 'User' as a starting point 102 | emptyAuthUser :: AuthUser 103 | emptyAuthUser = AuthUser 104 | { userId = Nothing 105 | , userEmail = Nothing 106 | , userPassword = Nothing 107 | , userSalt = Nothing 108 | , userActivatedAt = Nothing 109 | , userSuspendedAt = Nothing 110 | {-, userPerishableToken = Nothing-} 111 | , userPersistenceToken = Nothing 112 | {-, userSingleAccessToken = Nothing-} 113 | , userLoginCount = 0 114 | , userFailedLoginCount = 0 115 | , userCurrentLoginAt = Nothing 116 | , userLastLoginAt = Nothing 117 | , userCurrentLoginIp = Nothing 118 | , userLastLoginIp = Nothing 119 | , userCreatedAt = Nothing 120 | , userUpdatedAt = Nothing 121 | } 122 | 123 | 124 | ------------------------------------------------------------------------------ 125 | -- | Make 'SaltedHash' from 'AuthUser' 126 | mkSaltedHash :: AuthUser -> SaltedHash 127 | mkSaltedHash u = SaltedHash s p' 128 | where s = Salt . B.unpack $ s' 129 | s' = maybe (error "No user salt") id $ userSalt u 130 | p' = case p of 131 | ClearText x -> 132 | error "Can't mkSaltedHash with a ClearText user password" 133 | Encrypted x -> B.unpack x 134 | p = maybe (error "Can't mkSaltedHash with empty password") id $ 135 | userPassword u 136 | 137 | 138 | 139 | class (MonadAuth m) => MonadAuthUser m t | m -> t where 140 | 141 | -------------------------------------------------------------------------- 142 | -- | Define a function that can resolve to a 'AuthUser' from an internal 143 | -- 'UserId'. 144 | -- 145 | -- The 'UserId' is persisted in your application's session 146 | -- to check for the existence of an authenticated user in your handlers. 147 | -- A typical 'UserId' would be the unique database key given to your user's 148 | -- record. 149 | getUserInternal :: UserId -> m (Maybe (AuthUser, t)) 150 | 151 | 152 | -------------------------------------------------------------------------- 153 | -- | Define a function that can resolve to a 'AuthUser' using the external, 154 | -- user supplied 'ExternalUserId' identifier. 155 | -- 156 | -- This is typically passed directly from the POST request. 157 | getUserExternal :: ExternalUserId -> m (Maybe (AuthUser, t)) 158 | 159 | 160 | -------------------------------------------------------------------------- 161 | -- | A way to find users by the remember token. 162 | getUserByRememberToken :: ByteString -> m (Maybe (AuthUser, t)) 163 | 164 | 165 | -------------------------------------------------------------------------- 166 | -- | Implement a way to save given user in the DB. 167 | saveAuthUser :: (AuthUser, t) -> m (Maybe AuthUser) 168 | 169 | 170 | 171 | ------------------------------------------------------------------------------ 172 | -- | Typeclass for authentication and user session functionality. 173 | -- 174 | -- Your have to make your Application's monad a member of this typeclass. 175 | -- Minimum complete definition: 'getUserInternal', 'getUserExternal' 176 | -- 177 | -- Requirements: 178 | -- 179 | -- - Your app monad has to be a 'MonadSnap'. 180 | -- 181 | -- - Your app monad has to be a 'MonadSession'. See 'Snap.Extension.Session'. 182 | -- This is needed so we can persist your users' login in session. 183 | class (MonadSnap m, MonadSession m) => MonadAuth m where 184 | 185 | -------------------------------------------------------------------------- 186 | -- | Define a hash function to be used. Defaults to 'defaultHash', which 187 | -- should be quite satisfactory for most purposes. 188 | authHash :: m HashFunc 189 | authHash = return defaultHash 190 | 191 | 192 | -- | Name of the table that will store user data 193 | authUserTable :: m String 194 | authUserTable = return "users" 195 | 196 | 197 | -- | Password length range 198 | authPasswordRange :: m (Int, Int) 199 | authPasswordRange = return (7, 25) 200 | 201 | 202 | -- | What are the database fields and the user-supplied ExternalUserId 203 | -- fields that are going to be used to find a user? 204 | authAuthenticationKeys :: m [ByteString] 205 | authAuthenticationKeys = return ["email"] 206 | 207 | 208 | -- | Cookie name for the remember token 209 | authRememberCookieName :: m ByteString 210 | authRememberCookieName = return "auth_remember_token" 211 | 212 | 213 | -- | Remember period in seconds. Defaults to 2 weeks. 214 | authRememberPeriod :: m Int 215 | authRememberPeriod = return $ 60 * 60 * 24 * 14 216 | 217 | 218 | -- | Should it be possible to login multiple times? 219 | authRememberAcrossBrowsers :: m Bool 220 | authRememberAcrossBrowsers = return True 221 | 222 | 223 | authEmailValidationRegex :: m ByteString 224 | authEmailValidationRegex = 225 | return "^([\\w\\.%\\+\\-]+)@([\\w\\-]+\\.)+([\\w]{2,})$" 226 | 227 | 228 | -- | Lockout after x tries, re-allow entry after y seconds 229 | authLockoutStrategy :: m (Maybe (Int, Int)) 230 | authLockoutStrategy = return Nothing 231 | 232 | 233 | 234 | 235 | ------------------------------------------------------------------------------ 236 | -- | Authenticates a user using user-supplied 'ExternalUserId'. 237 | -- 238 | -- Returns the internal 'UserId' if successful, 'Nothing' otherwise. 239 | -- Note that this will not persist the authentication. See 'performLogin' for 240 | -- that. 241 | authenticate :: MonadAuthUser m t 242 | => ExternalUserId -- ^ External user identifiers 243 | -> ByteString -- ^ Password 244 | -> Bool -- ^ Remember user? 245 | -> m (Either AuthFailure (AuthUser, t)) 246 | authenticate uid password remember = do 247 | hf <- authHash 248 | user <- getUserExternal uid 249 | case user of 250 | Nothing -> return $ Left ExternalIdFailure 251 | Just user'@(u', _) -> case check hf password u' of 252 | True -> do 253 | markLogin user' 254 | return $ Right user' 255 | False -> do 256 | markLoginFail user' 257 | return $ Left PasswordFailure 258 | where 259 | check hf p u = checkSalt hf p $ mkSaltedHash u 260 | 261 | markLoginFail (u,d) = do 262 | u' <- incFailLogCtr u 263 | saveAuthUser (u', d) 264 | 265 | markLogin :: (MonadAuthUser m t) => (AuthUser, t) -> m (Maybe AuthUser) 266 | markLogin (u,d) = do 267 | u' <- (incLogCtr >=> updateIP >=> updateLoginTS >=> 268 | setPersistenceToken) u 269 | saveAuthUser (u', d) 270 | 271 | incLogCtr :: (MonadAuthUser m t) => AuthUser -> m AuthUser 272 | incLogCtr u = return $ u { userLoginCount = userLoginCount u + 1 } 273 | 274 | incFailLogCtr :: (MonadAuthUser m t) => AuthUser -> m AuthUser 275 | incFailLogCtr u = return $ 276 | u { userFailedLoginCount = userFailedLoginCount u + 1 } 277 | 278 | updateIP :: (MonadAuthUser m t) => AuthUser -> m AuthUser 279 | updateIP u = do 280 | ip <- getRequest >>= return . rqRemoteAddr 281 | return $ 282 | u { userCurrentLoginIp = Just ip 283 | , userLastLoginIp = userCurrentLoginIp u } 284 | 285 | updateLoginTS :: (MonadAuthUser m t) => AuthUser -> m AuthUser 286 | updateLoginTS u = do 287 | t <- liftIO getCurrentTime 288 | return $ 289 | u { userCurrentLoginAt = Just t 290 | , userLastLoginAt = userCurrentLoginAt u } 291 | 292 | setPersistenceToken u = do 293 | multi_logon <- authRememberAcrossBrowsers 294 | to <- authRememberPeriod 295 | site_key <- secureSiteKey 296 | cn <- authRememberCookieName 297 | rt <- liftIO $ randomToken 15 298 | token <- case userPersistenceToken u of 299 | Nothing -> return rt 300 | Just x -> if multi_logon then return x else return rt 301 | case remember of 302 | False -> return u 303 | True -> do 304 | setSecureCookie cn site_key token (Just to) 305 | return $ u { userPersistenceToken = Just token } 306 | 307 | 308 | 309 | -- $higherlevel 310 | -- These are the key functions you will use in your handlers. Once you have set 311 | -- up your application's monad with 'MonadAuth', you really should not need to 312 | -- use anything other than what is in this section. 313 | 314 | 315 | ------------------------------------------------------------------------------ 316 | -- | Given an 'ExternalUserId', authenticates the user and persists the 317 | -- authentication in the session if successful. 318 | performLogin :: MonadAuthUser m t 319 | => ExternalUserId -- ^ External user identifiers 320 | -> ByteString -- ^ Password 321 | -> Bool -- ^ Remember user? 322 | -> m (Either AuthFailure (AuthUser, t)) 323 | performLogin euid p r = authenticate euid p r >>= either (return . Left) login 324 | where 325 | login x@(user, _) = do 326 | setSessionUserId (userId user) 327 | return (Right x) 328 | 329 | 330 | ------------------------------------------------------------------------------ 331 | -- | Logs a user out from the current session. 332 | performLogout :: MonadAuthUser m t => m () 333 | performLogout = do 334 | cn <- authRememberCookieName 335 | let ck = Cookie cn "" Nothing Nothing (Just "/") 336 | modifyResponse $ addResponseCookie ck 337 | setSessionUserId Nothing 338 | 339 | 340 | ------------------------------------------------------------------------------ 341 | -- | Takes a clean-text password and returns a fresh pair of password and salt 342 | -- to be stored in your app's DB. 343 | mkAuthCredentials :: MonadAuthUser m t 344 | => ByteString 345 | -- ^ A given password 346 | -> m (ByteString, ByteString) 347 | -- ^ (Salt, Encrypted password) 348 | mkAuthCredentials pwd = do 349 | hf <- authHash 350 | SaltedHash (Salt s) pwd' <- liftIO $ buildSaltAndHash hf pwd 351 | return $ (B.pack s, B.pack pwd') 352 | 353 | 354 | ------------------------------------------------------------------------------ 355 | -- | True if a user is present in current session. 356 | isLoggedIn :: MonadAuthUser m t => m Bool 357 | isLoggedIn = authenticatedUserId >>= return . maybe False (const True) 358 | 359 | 360 | ------------------------------------------------------------------------------ 361 | -- | Get the current 'AuthUser' if authenticated, 'Nothing' otherwise. 362 | currentAuthUser :: MonadAuthUser m t => m (Maybe (AuthUser, t)) 363 | currentAuthUser = authenticatedUserId >>= maybe (return Nothing) getUserInternal 364 | 365 | 366 | ------------------------------------------------------------------------------ 367 | -- | Return if there is an authenticated user id. Try to remember the user 368 | -- if possible. 369 | authenticatedUserId :: MonadAuthUser m t => m (Maybe UserId) 370 | authenticatedUserId = getSessionUserId >>= maybe rememberUser (return . Just) 371 | 372 | ------------------------------------------------------------------------------ 373 | -- | Remember user from remember token if possible. 374 | rememberUser :: MonadAuthUser m t => m (Maybe UserId) 375 | rememberUser = do 376 | to <- authRememberPeriod 377 | key <- secureSiteKey 378 | cn <- authRememberCookieName 379 | remToken <- getSecureCookie cn key (Just to) 380 | u <- maybe (return Nothing) getUserByRememberToken remToken 381 | case u of 382 | Nothing -> return Nothing 383 | Just (au, _) -> do 384 | setSessionUserId $ userId au 385 | return $ userId au 386 | -------------------------------------------------------------------------------- /src/Snap/Auth/Handlers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | Provides generic, somewhat customizable handlers that can be plugged 4 | directly into Snap applications. 5 | 6 | The core 'Snap.Auth' module is pretty much stand-alone and taking these as 7 | starting point examples, you should be able to write your own custom 8 | handlers. 9 | 10 | -} 11 | 12 | module Snap.Auth.Handlers 13 | ( loginHandler 14 | , logoutHandler 15 | , requireUser 16 | ) where 17 | 18 | import Control.Applicative ( (<|>) ) 19 | import Control.Monad (when) 20 | 21 | import Data.ByteString (ByteString) 22 | 23 | import Snap.Types 24 | import Snap.Auth 25 | import Snap.Extension.Session.CookieSession (sessionCSRFToken) 26 | 27 | ------------------------------------------------------------------------------ 28 | -- | A 'MonadSnap' handler that processes a login form. 29 | -- 30 | -- The request paremeters are passed to 'performLogin' 31 | loginHandler :: MonadAuthUser m t 32 | => ByteString 33 | -- ^ The password param field 34 | -> Maybe ByteString 35 | -- ^ Remember field; Nothing if you want to remember function. 36 | -> (AuthFailure -> m a) 37 | -- ^ Upon failure 38 | -> m a 39 | -- ^ Upon success 40 | -> m a 41 | loginHandler pwdf remf loginFailure loginSuccess = do 42 | euid <- getParams >>= return . EUId 43 | password <- getParam pwdf 44 | remember <- maybe (return Nothing) getParam remf 45 | let r = maybe False (=="1") remember 46 | mMatch <- case password of 47 | Nothing -> return $ Left PasswordFailure 48 | Just p -> performLogin euid p r 49 | either loginFailure (const loginSuccess) mMatch 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | -- | Simple handler to log the user out. Deletes user from session. 54 | logoutHandler :: MonadAuthUser m t 55 | => m a 56 | -- ^ What to do after logging out 57 | -> m a 58 | logoutHandler target = performLogout >> target 59 | 60 | 61 | ------------------------------------------------------------------------------ 62 | -- | Require that an authenticated 'AuthUser' is present in the current session. 63 | -- 64 | -- This function has no DB cost - only checks to see if a user_id is present in 65 | -- the current session. 66 | requireUser :: MonadAuthUser m t => m a 67 | -- ^ Do this if no authenticated user is present. 68 | -> m a 69 | -- ^ Do this if an authenticated user is present. 70 | -> m a 71 | requireUser bad good = authenticatedUserId >>= maybe bad (const good) 72 | -------------------------------------------------------------------------------- /src/Snap/Auth/Password.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | {-| 4 | 5 | Defines functions for generating and checking salted hashes. Salted hashes 6 | are used to store passwords in a way that prevents passwords from being 7 | deduced even if the user/password database is disclosed. 8 | 9 | -} 10 | 11 | module Snap.Auth.Password 12 | ( SaltedHash(..) 13 | , Salt(..) 14 | , buildSaltAndHash 15 | , hashPassword 16 | , checkSalt 17 | , HashFunc 18 | , defaultHash 19 | ) where 20 | 21 | import Numeric 22 | import Random 23 | 24 | import Codec.Utils 25 | import Data.ByteString.Internal (c2w) 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString as B 28 | import Data.Digest.SHA512 29 | import Data.Generics 30 | 31 | 32 | ------------------------------------------------------------------------------ 33 | -- | Type alias for hash functions. 34 | type HashFunc = [Octet] -> [Octet] 35 | 36 | 37 | ------------------------------------------------------------------------------ 38 | -- | Salt newtype gives us type safety and allows us to control how salts are 39 | -- accessed. 40 | newtype Salt = Salt { unSalt :: [Octet] } 41 | deriving (Read,Show,Ord,Eq,Typeable,Data) 42 | 43 | 44 | ------------------------------------------------------------------------------ 45 | -- | Data structure representing a salted hash. 46 | data SaltedHash = SaltedHash 47 | { shSalt :: Salt 48 | , shHash :: [Octet] 49 | } deriving (Read,Show,Ord,Eq,Typeable,Data) 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | -- | The length of our salts. 54 | sALT_LENGTH :: Int 55 | sALT_LENGTH = 64 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | -- | Converts a String to an array of Octets. 60 | --strToOctets :: String -> [Octet] 61 | --strToOctets = listToOctets . (map c2w) 62 | 63 | 64 | ------------------------------------------------------------------------------ 65 | -- | An slow, iterated SHA512 hash function to make dictionary attacks more 66 | -- difficult. 67 | defaultHash :: HashFunc 68 | defaultHash a = (iterate hash a) !! 512 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | -- | Generates a random salt. 73 | randomSalt :: IO Salt 74 | randomSalt = do 75 | chars <- sequence $ take sALT_LENGTH $ repeat $ 76 | randomRIO (0::Int,15) >>= return . flip showHex "" 77 | return $ Salt $ map c2w $ concat chars 78 | 79 | ------------------------------------------------------------------------------ 80 | -- | Generates a random salt, hashes it, and returns a 'SaltedHash'. 81 | buildSaltAndHash :: HashFunc -> ByteString -> IO SaltedHash 82 | buildSaltAndHash hf str = do 83 | salt <- randomSalt 84 | return $ hashPassword hf salt str 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | -- | Hash the given salt ++ password and wrap into a 'SaltedHash'. 89 | hashPassword :: HashFunc -> Salt -> ByteString -> SaltedHash 90 | hashPassword hf s pwd = SaltedHash s h 91 | where h = hf ((unSalt s) ++ pwd') 92 | pwd' = B.unpack pwd 93 | 94 | 95 | ------------------------------------------------------------------------------ 96 | -- | Checks that the input string is the same as the SaltedHash. 97 | checkSalt :: HashFunc -> ByteString -> SaltedHash -> Bool 98 | checkSalt hf str (SaltedHash (Salt salt) h) = 99 | h == (hf $ salt++(B.unpack str)) 100 | 101 | -------------------------------------------------------------------------------- /src/Snap/Extension/Session.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | -} 4 | 5 | module Snap.Extension.Session 6 | ( 7 | SessionShell(..) 8 | , defSessionShell 9 | , Session 10 | , MonadSession(..) 11 | ) where 12 | 13 | import Control.Monad 14 | import Control.Monad.Trans 15 | import Data.ByteString (ByteString) 16 | import qualified Data.Map as Map 17 | 18 | import Snap.Types 19 | import Snap.Extension.Session.Types 20 | import Snap.Extension.Session.Common (randomToken) 21 | 22 | 23 | ------------------------------------------------------------------------------ 24 | -- | The 'MonadCookieSession' class. 25 | class MonadSnap m => MonadSession m where 26 | 27 | ---------------------------------------------------------------------------- 28 | getSessionShell :: m SessionShell 29 | 30 | 31 | ---------------------------------------------------------------------------- 32 | setSessionShell :: SessionShell -> m () 33 | 34 | 35 | ---------------------------------------------------------------------------- 36 | -- | Return a secure encryption key specific to this application. 37 | secureSiteKey :: m ByteString 38 | 39 | 40 | ---------------------------------------------------------------------------- 41 | updateSessionShell :: (SessionShell -> SessionShell) -> m () 42 | updateSessionShell f = do 43 | ssh <- getSessionShell 44 | setSessionShell $ f ssh 45 | 46 | 47 | ---------------------------------------------------------------------------- 48 | getSessionUserId :: m (Maybe UserId) 49 | getSessionUserId = fmap sesUserId getSessionShell 50 | 51 | 52 | ---------------------------------------------------------------------------- 53 | setSessionUserId :: Maybe UserId -> m () 54 | setSessionUserId uid = updateSessionShell f 55 | where f s = s { sesUserId = uid } 56 | 57 | 58 | ---------------------------------------------------------------------------- 59 | sessionCSRFToken :: m ByteString 60 | sessionCSRFToken = do 61 | csrf <- liftM sesCSRFToken getSessionShell 62 | case csrf of 63 | Nothing -> do 64 | t <- liftIO $ randomToken 35 65 | updateSessionShell (\s -> s { sesCSRFToken = Just t }) 66 | return t 67 | Just t -> return t 68 | 69 | 70 | ---------------------------------------------------------------------------- 71 | -- | Function to get the session in your app's monad. 72 | -- 73 | -- This will return a @Map ByteString ByteString@ data type, which you can 74 | -- then use freely to read/write values. 75 | getSession :: m Session 76 | getSession = fmap sesSession getSessionShell 77 | 78 | 79 | ---------------------------------------------------------------------------- 80 | -- | Set the session in your app's monad. 81 | setSession :: Session -> m () 82 | setSession s = updateSessionShell f 83 | where f ssh = ssh { sesSession = s } 84 | 85 | 86 | ------------------------------------------------------------------------------ 87 | -- | Get a value associated with given key from the 'Session'. 88 | getFromSession :: ByteString -> m (Maybe ByteString) 89 | getFromSession k = Map.lookup k `liftM` getSession 90 | 91 | 92 | ------------------------------------------------------------------------------ 93 | -- | Remove the given key from 'Session' 94 | deleteFromSession :: ByteString -> m () 95 | deleteFromSession k = Map.delete k `liftM` getSession >>= setSession 96 | 97 | 98 | ------------------------------------------------------------------------------ 99 | -- | Set a value in the 'Session'. 100 | setInSession :: ByteString 101 | -> ByteString 102 | -> m () 103 | setInSession k v = Map.insert k v `liftM` getSession >>= setSession 104 | 105 | 106 | ---------------------------------------------------------------------------- 107 | -- | Clear the active session. Uses 'setSession'. 108 | clearSession :: m () 109 | clearSession = setSession Map.empty 110 | 111 | 112 | ---------------------------------------------------------------------------- 113 | -- | Touch session to reset the timeout. You can chain a handler to call this 114 | -- in every authenticated route to keep prolonging the session with each 115 | -- request. 116 | touchSession :: m () 117 | touchSession = getSession >>= setSession 118 | 119 | 120 | 121 | -------------------------------------------------------------------------------- /src/Snap/Extension/Session/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This module contains functionality common among multiple back-ends. 4 | 5 | -} 6 | 7 | module Snap.Extension.Session.Common where 8 | 9 | 10 | import Numeric 11 | import Random 12 | import Data.ByteString (ByteString) 13 | import qualified Data.ByteString.Char8 as B 14 | 15 | 16 | ------------------------------------------------------------------------------ 17 | -- | Generates a random salt. 18 | randomToken :: Int -> IO ByteString 19 | randomToken n = do 20 | chars <- sequence $ take n $ repeat $ 21 | randomRIO (0::Int,15) >>= return . flip showHex "" 22 | return $ B.pack $ concat chars 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /src/Snap/Extension/Session/CookieSession.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This module provides an implementation of 'Snap.Extension.Session' using 4 | secure cookies shuttled back-and-forth between the web server and the user of 5 | your application. 6 | 7 | The resulting cookie contents will not be readable to the end-user. However, 8 | you should still never put critical information inside the session. Storing 9 | a user_id may be fine, but never put, say the remaining balance on an account 10 | in a session. 11 | 12 | Note that this method leaves your system open to replay, aka session 13 | hi-jacking attacks. To prevent this, consider always on SSL. 14 | 15 | -} 16 | 17 | module Snap.Extension.Session.CookieSession 18 | ( 19 | 20 | -- * Important Types 21 | Session 22 | , UserId(..) 23 | 24 | -- * Key Functionality 25 | , MonadSession( 26 | getSession 27 | , setSession 28 | , getFromSession 29 | , setInSession 30 | , deleteFromSession 31 | , touchSession 32 | , clearSession 33 | , getSessionUserId 34 | , setSessionUserId 35 | , sessionCSRFToken) 36 | 37 | 38 | -- * Cookie-based Session Instance 39 | , CookieSessionState(..) 40 | , defCookieSessionState 41 | , HasCookieSessionState(..) 42 | , cookieSessionStateInitializer 43 | ) where 44 | 45 | import Control.Monad.Reader 46 | import Data.ByteString (ByteString) 47 | 48 | import Web.ClientSession 49 | 50 | import Snap.Extension 51 | import Snap.Extension.Session 52 | import Snap.Extension.Session.SecureCookie 53 | import Snap.Extension.Session.Types 54 | 55 | 56 | ------------------------------------------------------------------------------ 57 | -- | 58 | data CookieSessionState = CookieSessionState 59 | { csSiteKey :: Key -- ^ Cookie encryption key 60 | , csKeyPath :: FilePath -- ^ Where the encryption key is stored 61 | , csCookieName :: ByteString -- ^ Cookie name for your app's session 62 | , csTimeout :: Maybe Int -- ^ Replay-attack timeout in seconds 63 | } 64 | 65 | 66 | ------------------------------------------------------------------------------ 67 | -- | 'defCookieSessionState' is a good starting point when initializing your 68 | -- app. The default configuration is: 69 | -- 70 | -- > csKeyPath = "site_key.txt" 71 | -- > csCookieName = "snap-session" 72 | -- > csTimeout = Just 30 73 | -- > csAuthToken = True 74 | defCookieSessionState :: CookieSessionState 75 | defCookieSessionState = CookieSessionState 76 | { csKeyPath = "site_key.txt" 77 | , csSiteKey = "" 78 | , csCookieName = "snap-session" 79 | , csTimeout = Just (30 * 60) 80 | } 81 | 82 | 83 | ------------------------------------------------------------------------------ 84 | -- | 85 | class HasCookieSessionState s where 86 | 87 | ---------------------------------------------------------------------------- 88 | -- | Getter to get 'CookieSessionState' from your app's state. 89 | getCookieSessionState :: s -> CookieSessionState 90 | 91 | ------------------------------------------------------------------------------ 92 | -- | Initializes the given 'CookieSessionState'. It will read the encryption 93 | -- key if present, create one at random and save if missing. 94 | cookieSessionStateInitializer 95 | :: CookieSessionState 96 | -> Initializer CookieSessionState 97 | cookieSessionStateInitializer cs = do 98 | st <- liftIO $ do 99 | k <- getKey (csKeyPath cs) 100 | return $ cs { csSiteKey = k } 101 | mkInitializer st 102 | 103 | 104 | ------------------------------------------------------------------------------ 105 | -- | Register CookieSessionState as an Extension. 106 | instance InitializerState CookieSessionState where 107 | extensionId = const "Session/CookieSession" 108 | mkCleanup = const $ return () 109 | mkReload = const $ return () 110 | 111 | 112 | ------------------------------------------------------------------------------ 113 | -- | 114 | instance HasCookieSessionState s => MonadSession (SnapExtend s) where 115 | 116 | ---------------------------------------------------------------------------- 117 | -- | Serialize the session, inject into cookie, modify response. 118 | setSessionShell t = do 119 | cs <- asks getCookieSessionState 120 | key <- secureSiteKey 121 | setSecureCookie (csCookieName cs) key t (csTimeout cs) 122 | 123 | 124 | ---------------------------------------------------------------------------- 125 | -- | Read the session from the cookie. If none is present, return default 126 | -- (empty) session. 127 | getSessionShell = do 128 | cs <- asks getCookieSessionState 129 | key <- secureSiteKey 130 | let cn = csCookieName cs 131 | let timeout = csTimeout cs 132 | d <- getSecureCookie cn key timeout 133 | return $ maybe defSessionShell id d 134 | 135 | 136 | secureSiteKey = asks $ csSiteKey . getCookieSessionState 137 | 138 | 139 | -------------------------------------------------------------------------------- /src/Snap/Extension/Session/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | Convenience Splices to be used in your views. They go hand-in hand with 4 | handlers defined in this package to help automate some common patterns. 5 | 6 | -} 7 | 8 | module Snap.Extension.Session.Helpers 9 | ( metaCSRFTag 10 | , hiddenCSRFTag 11 | , checkCSRF 12 | ) where 13 | 14 | 15 | import Control.Applicative ( (<|>) ) 16 | import Control.Monad (when) 17 | import Control.Monad.Trans.Class (lift) 18 | import Data.Text.Encoding as T 19 | 20 | 21 | import Snap.Types 22 | import Snap.Extension.Session (MonadSession(..), sessionCSRFToken) 23 | 24 | import qualified Text.XmlHtml as X 25 | import Text.Templating.Heist 26 | 27 | 28 | ------------------------------------------------------------------------------ 29 | -- Use this 'Splice' in your section to insert a meta tag with the 30 | -- authenticity token. 31 | -- 32 | -- Use-case similar to Rails 3; you can use unobtrusive JS bindings to extract 33 | -- the token from the webpage and add to your buttons/forms. 34 | metaCSRFTag 35 | :: (MonadSession m) 36 | => Splice m 37 | metaCSRFTag = do 38 | embeddedToken <- lift sessionCSRFToken 39 | let param = "authenticity_token" 40 | let metaToken = X.Element "meta" 41 | [ ("name", "csrf-token") 42 | , ("content", T.decodeUtf8 embeddedToken) ] [] 43 | let metaParam = X.Element "meta" 44 | [ ("name", "csrf-param") 45 | , ("content", param) ] [] 46 | return $ [metaParam, metaToken] 47 | 48 | 49 | ------------------------------------------------------------------------------ 50 | -- Use in your forms to insert a hidden "authenticity_token" field. 51 | hiddenCSRFTag 52 | :: (MonadSession m) 53 | => Splice m 54 | hiddenCSRFTag = do 55 | embeddedToken <- lift sessionCSRFToken 56 | let param = "authenticity_token" 57 | return . return $ X.Element "input" 58 | [ ("type", "hidden") 59 | , ("name", T.decodeUtf8 param) 60 | , ("value", T.decodeUtf8 embeddedToken) 61 | ] [] 62 | 63 | 64 | 65 | ------------------------------------------------------------------------------ 66 | -- | Handler to protect against CSRF attacks. Chain this handler at the 67 | -- beginning of your routing table to enable. 68 | -- 69 | -- Example: 70 | -- 71 | -- @redirError = logError "Someone tried to bypass CSRF" >> redirect "/" 72 | -- 73 | -- checkCSRF redirError >> route [myHandler, myHandler2, ...] 74 | -- @ 75 | -- 76 | -- The convention is to submit an "authenticity_token" parameter with each 77 | -- 'POST' request. This action will confirm its presence against what is safely 78 | -- embedded in the session and execute the given action if they don't match. 79 | -- The exact name of the parameter is defined by 'authAuthenticityTokenParam'. 80 | checkCSRF :: MonadSession m => m () 81 | -- ^ Do this if CSRF token does not match. 82 | -> m () 83 | checkCSRF failAct = method POST doCheck <|> return () 84 | where 85 | doCheck = do 86 | embeddedToken <- sessionCSRFToken 87 | let param = "authenticity_token" 88 | submitted <- maybe "" id `fmap` getParam param 89 | when (submitted /= embeddedToken) failAct 90 | -------------------------------------------------------------------------------- /src/Snap/Extension/Session/SecureCookie.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | This is a support module meant to back all session back-end implementations. 4 | 5 | It gives us an encrypted and timestamped cookie that can store an arbitrary 6 | serializable payload. For security, it will: 7 | 8 | * Encrypt its payload together with a timestamp. 9 | 10 | * Check the timestamp for session expiration everytime you read from the 11 | cookie. This will limit intercept-and-replay attacks by disallowing cookies 12 | older than the timeout threshold. 13 | 14 | -} 15 | 16 | module Snap.Extension.Session.SecureCookie where 17 | 18 | import Control.Applicative 19 | import Control.Monad 20 | import Control.Monad.Trans 21 | 22 | import Data.ByteString (ByteString) 23 | import Data.Time 24 | import Data.Time.Clock.POSIX 25 | 26 | import Data.Serialize 27 | import Web.ClientSession 28 | 29 | import Snap.Types 30 | 31 | 32 | 33 | ------------------------------------------------------------------------------ 34 | -- | Serialize UTCTime 35 | instance Serialize UTCTime where 36 | put t = put (round (utcTimeToPOSIXSeconds t) :: Integer) 37 | get = posixSecondsToUTCTime . fromInteger <$> get 38 | 39 | 40 | ------------------------------------------------------------------------------ 41 | -- | Arbitrary payload with timestamp. 42 | type SecureCookie t = (UTCTime, t) 43 | 44 | 45 | ------------------------------------------------------------------------------ 46 | -- Get the payload back 47 | getSecureCookie :: (MonadSnap m, Serialize t) 48 | => ByteString -- ^ Cookie name 49 | -> Key -- ^ Encryption key 50 | -> Maybe Int -- ^ Timeout in seconds 51 | -> m (Maybe t) 52 | getSecureCookie name key timeout = do 53 | rqCookie <- getCookie name 54 | rspCookie <- getResponseCookie name `fmap` getResponse 55 | let ck = rspCookie `mplus` rqCookie 56 | let val = fmap cookieValue ck >>= decrypt key >>= return . decode 57 | let val' = val >>= either (const Nothing) Just 58 | case val' of 59 | Nothing -> return Nothing 60 | Just (ts, t) -> do 61 | to <- checkTimeout timeout ts 62 | return $ case to of 63 | True -> Nothing 64 | False -> Just t 65 | 66 | 67 | ------------------------------------------------------------------------------ 68 | -- | Inject the payload 69 | setSecureCookie :: (MonadSnap m, Serialize t) 70 | => ByteString -- ^ Cookie name 71 | -> Key -- ^ Encryption key 72 | -> t -- ^ Serializable payload 73 | -> Maybe Int -- ^ Max age in seconds 74 | -> m () 75 | setSecureCookie name key val to = do 76 | t <- liftIO getCurrentTime 77 | let expire = to >>= Just . flip addUTCTime t . fromIntegral 78 | let val' = encrypt key . encode $ (t, val) 79 | let nc = Cookie name val' expire Nothing (Just "/") 80 | modifyResponse $ addResponseCookie nc 81 | 82 | 83 | ------------------------------------------------------------------------------ 84 | -- | Validate session against timeout policy. 85 | -- 86 | -- * If timeout is set to 'Nothing', never trigger a time-out. 87 | -- * Othwerwise, do a regular time-out check based on current time and given 88 | -- timestamp. 89 | checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool 90 | checkTimeout Nothing _ = return False 91 | checkTimeout (Just x) t0 = 92 | let x' = fromIntegral x 93 | in do 94 | t1 <- liftIO getCurrentTime 95 | return $ t1 > addUTCTime x' t0 96 | -------------------------------------------------------------------------------- /src/Snap/Extension/Session/Types.hs: -------------------------------------------------------------------------------- 1 | module Snap.Extension.Session.Types where 2 | 3 | import Data.ByteString (ByteString) 4 | import Data.Generics 5 | import qualified Data.Map as Map 6 | import Data.Map (Map) 7 | import Data.Serialize 8 | 9 | ------------------------------------------------------------------------------ 10 | -- | Internal representation of a 'User'. By convention, we demand that the 11 | -- application is able to directly fetch a 'User' using this identifier. 12 | -- 13 | -- Think of this type as a secure, authenticated user. You should normally 14 | -- never see this type unless a user has been authenticated. 15 | newtype UserId = UserId { unUid :: ByteString } 16 | deriving (Read,Show,Ord,Eq,Typeable,Data) 17 | 18 | 19 | ------------------------------------------------------------------------------ 20 | -- | Base session on the fast and capable Map library. 21 | -- 22 | -- This is the user-exposed universal and simple session type 23 | type Session = Map ByteString ByteString 24 | 25 | 26 | ------------------------------------------------------------------------------ 27 | -- | The internal session datatype 28 | data SessionShell = SessionShell 29 | { sesSession :: Session -- ^ User exposed bit 30 | , sesUserId :: Maybe UserId -- ^ Opaque user id 31 | , sesCSRFToken :: Maybe ByteString -- ^ For CSRF protection 32 | } deriving (Eq, Show) 33 | 34 | 35 | ------------------------------------------------------------------------------ 36 | -- | A default 'SessionShell' 37 | defSessionShell :: SessionShell 38 | defSessionShell = SessionShell 39 | { sesSession = Map.empty 40 | , sesUserId = Nothing 41 | , sesCSRFToken = Nothing 42 | } 43 | 44 | 45 | ------------------------------------------------------------------------------ 46 | -- | Serialize 'SessionShell' 47 | instance Serialize UserId where 48 | put (UserId u) = put u 49 | get = UserId `fmap` get 50 | 51 | 52 | 53 | ------------------------------------------------------------------------------ 54 | -- | Serialize 'SessionShell' 55 | instance Serialize SessionShell where 56 | put (SessionShell a b c) = put (a,b,c) 57 | get = (\(a,b,c) -> SessionShell a b c) `fmap` get 58 | --------------------------------------------------------------------------------