{-# LANGUAGE OverloadedStrings #-}-------------------------------------------------------------------------------- | This is a support module meant to back all session back-end-- implementations.---- It gives us an encrypted and timestamped cookie that can store an arbitrary-- serializable payload. For security, it will:---- * Encrypt its payload together with a timestamp.---- * Check the timestamp for session expiration everytime you read from the-- cookie. This will limit intercept-and-replay attacks by disallowing-- cookies older than the timeout threshold.moduleSnap.Snaplet.Session.SecureCookiewhere------------------------------------------------------------------------------importControl.ApplicativeimportControl.MonadimportControl.Monad.TransimportData.ByteString(ByteString)importData.TimeimportData.Time.Clock.POSIXimportData.SerializeimportSnap.CoreimportWeb.ClientSession-------------------------------------------------------------------------------- | Serialize UTCTimeinstanceSerializeUTCTimewhereputt=put(round(utcTimeToPOSIXSecondst)::Integer)get=posixSecondsToUTCTime.fromInteger<$>get-------------------------------------------------------------------------------- | Arbitrary payload with timestamp.typeSecureCookiet=(UTCTime,t)-------------------------------------------------------------------------------- Get the payload backgetSecureCookie::(MonadSnapm,Serializet)=>ByteString-- ^ Cookie name->Key-- ^ Encryption key->MaybeInt-- ^ Timeout in seconds->m(Maybet)getSecureCookienamekeytimeout=dorqCookie<-getCookienamerspCookie<-getResponseCookiename<$>getResponseletck=rspCookie`mplus`rqCookieletval=fmapcookieValueck>>=decryptkey>>=return.decodeletval'=val>>=either(constNothing)Justcaseval'ofNothing->returnNothingJust(ts,t)->doto<-checkTimeouttimeouttsreturn$casetoofTrue->NothingFalse->Justt-------------------------------------------------------------------------------- | Inject the payloadsetSecureCookie::(MonadSnapm,Serializet)=>ByteString-- ^ Cookie name->Key-- ^ Encryption key->MaybeInt-- ^ Max age in seconds->t-- ^ Serializable payload->m()setSecureCookienamekeytoval=dot<-liftIOgetCurrentTimeletexpire=to>>=Just.flipaddUTCTimet.fromIntegralval'<-liftIO.encryptIOkey.encode$(t,val)letnc=Cookienameval'expireNothing(Just"/")FalseTruemodifyResponse$addResponseCookienc-------------------------------------------------------------------------------- | Validate session against timeout policy.---- * If timeout is set to 'Nothing', never trigger a time-out.---- * Otherwise, do a regular time-out check based on current time and given-- timestamp.checkTimeout::(MonadSnapm)=>MaybeInt->UTCTime->mBoolcheckTimeoutNothing_=returnFalsecheckTimeout(Justx)t0=dot1<-liftIOgetCurrentTimereturn$t1>addUTCTime(fromIntegralx)t0