Something went wrong. Try again.
A Haskell Webserver Template
Something went wrong. Try again.
8.4 kB · 222 lines
Haskell
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223module Webserver.Data.Sql.Cache.Session where
----------------------------------------------------------------------------------------------------
import qualified Data.Aeson as Aesonimport qualified Data.ByteString as ByteStringimport qualified Data.Char as Charimport qualified Data.Text as Textimport qualified Data.Text.Encoding as TSEimport qualified Data.Time.Clock as Clockimport qualified Data.Time.Clock.POSIX as Posiximport qualified Data.Time.Format as TimeFimport qualified Data.UUID as UUIDimport qualified GHC.Real as Realimport qualified Hasql.Decoders as Decodersimport qualified Hasql.Encoders as Encodersimport Hasql.Generate (HasInsert (..), HasUpdate (..))import qualified Hasql.Pool as Poolimport qualified Hasql.Session as Sessionimport qualified Hasql.Statement as Statementimport qualified Jose.Jwa as JWAimport qualified Jose.Jwk as JWKimport qualified Jose.Jwt as JWTimport Network.HTTP.Types.Header (Header)import qualified System.Environment as Systemimport Webserver.Control.Nil (Nil (..))import qualified Webserver.Control.Sql as Sql
----------------------------------------------------------------------------------------------------
$(Sql.generateTable "cache" "sessions")
----------------------------------------------------------------------------------------------------
instance Nil Sessions where nil = Sessions {id = nil, token = nil, expiresOn = nil, userId = nil}
----------------------------------------------------------------------------------------------------
{- Look up a session by token via raw SQL.-}sessionByTokenStatement :: Statement.Statement Text (Maybe Sessions)sessionByTokenStatement = Statement.Statement "SELECT id, token, expires_on, user_id FROM cache.sessions WHERE token = $1" (Encoders.param (Encoders.nonNullable Encoders.text)) (Decoders.rowMaybe sessionsDecoder) True
----------------------------------------------------------------------------------------------------
jwk :: IO JWK.Jwkjwk = do mbSecret <- System.lookupEnv "JWT_SECRET" case mbSecret of Just secret -> return <| JWK.SymmetricJwk (ByteString.pack <| (Real.fromIntegral .> Char.ord) <$> secret) (Just <| JWT.KeyId "WebserverKeyId") (Just JWK.Sig) (Just <| JWA.Signed JWA.HS256) Nothing -> do JWK.generateSymmetricKey 32 (JWT.KeyId "WebserverKeyId") JWK.Sig (Just <| JWA.Signed JWA.HS256) >>= \key@(JWK.SymmetricJwk secret _ _ _) -> System.setEnv "JWT_SECRET" (show secret) >> return key
newSession :: JWK.Jwk -> Maybe UUID -> IO (Maybe Sessions)newSession key mbUserId = do timeNow <- Clock.getCurrentTime let exp = Clock.addUTCTime (Clock.secondsToNominalDiffTime <| 60 * 60 * 24 * 30) timeNow let aud = case mbUserId of Nothing -> Nothing Just uuid_ -> Just [UUID.toText uuid_] let claims = JWT.JwtClaims (Just "yourwebsite.com") Nothing aud (Just <| JWT.IntDate <| Posix.utcTimeToPOSIXSeconds exp) Nothing (Just <| JWT.IntDate <| Posix.utcTimeToPOSIXSeconds timeNow) Nothing eitherJwt <- JWT.encode [key] (JWT.JwsEncoding JWA.HS256) (JWT.Claims <| ByteString.toStrict <| Aeson.encode claims) case eitherJwt of Left _ -> return Nothing Right jwt -> return <| Just <| Sessions nil (JWT.unJwt jwt |> TSE.decodeUtf8) exp mbUserId
updateSession :: Sessions -> JWK.Jwk -> Maybe UUID -> IO (Maybe Sessions)updateSession sn key mbUserId = do oldToken <- JWT.decode [key] (Just <| JWT.JwsEncoding JWA.HS256) (TSE.encodeUtf8 sn.token) case oldToken of Right (JWT.Jws (_, claimString)) -> case (Aeson.decodeStrict claimString :: Maybe JWT.JwtClaims) of Nothing -> return Nothing Just claims -> let newAud = case mbUserId of Nothing -> Nothing Just uuid_ -> Just [UUID.toText uuid_]
newClaims = claims {JWT.jwtAud = newAud} in do JWT.encode [key] (JWT.JwsEncoding JWA.HS256) (JWT.Claims <| ByteString.toStrict <| Aeson.encode newClaims) >>= \case Left _ -> return Nothing Right jwt -> return <| Just <| sn { token = JWT.unJwt jwt |> TSE.decodeUtf8 , userId = mbUserId } _ -> return Nothing
----------------------------------------------------------------------------------------------------
createSession :: Pool.Pool -> Sessions -> IO SessionscreateSession pool sn = Sql.runSession pool (insert sn)
getSessionByToken :: Pool.Pool -> Text -> IO (Maybe Sessions)getSessionByToken pool token_ = Sql.runSession pool (Session.statement token_ sessionByTokenStatement)
updateSessionRecord :: Pool.Pool -> Sessions -> IO ()updateSessionRecord pool sn = Sql.runSession pool (update sn >> return ())
validateSession :: Pool.Pool -> JWK.Jwk -> ByteString.ByteString -> IO (Maybe Sessions)validateSession pool key token_ = let decodeToken :: ByteString.ByteString -> IO (Maybe JWT.JwtClaims) decodeToken tokenBytes = JWT.decode [key] (Just <| JWT.JwsEncoding JWA.HS256) tokenBytes >>= \case Right (JWT.Jws (_, claimString)) -> return (Aeson.decodeStrict claimString :: Maybe JWT.JwtClaims) _ -> return Nothing
isValidIssuer :: JWT.JwtClaims -> Bool isValidIssuer claims = claims.jwtIss == Just "yourwebsite.com"
isNotExpired :: Clock.UTCTime -> JWT.JwtClaims -> Sessions -> Bool isNotExpired timeNow claims session = case claims.jwtExp of Nothing -> False Just (JWT.IntDate posix) -> let expiryTime = Posix.posixSecondsToUTCTime posix sameDayExpiry = Clock.utctDay expiryTime == Clock.utctDay session.expiresOn notExpiredYet = expiryTime > timeNow in sameDayExpiry && notExpiredYet
isValidAudience :: JWT.JwtClaims -> Sessions -> Bool isValidAudience claims session = case (claims.jwtAud, session.userId) of (Just [mbUserId], Just userId_) -> mbUserId == UUID.toText userId_ (Nothing, Nothing) -> True _ -> False
validateClaims :: Clock.UTCTime -> JWT.JwtClaims -> Sessions -> Maybe Sessions validateClaims timeNow claims session = let validIssuer = isValidIssuer claims notExpired = isNotExpired timeNow claims session validAudience = isValidAudience claims session in if validIssuer && notExpired && validAudience then Just session else Nothing in do timeNow <- Clock.getCurrentTime mbSession <- getSessionByToken pool (TSE.decodeUtf8 token_) case mbSession of Nothing -> return Nothing Just session -> do mbClaims <- decodeToken token_ case mbClaims of Nothing -> return Nothing Just claims -> return (validateClaims timeNow claims session)
packSessionCookie :: Sessions -> HeaderpackSessionCookie sn = let expires = Text.pack <| TimeF.formatTime TimeF.defaultTimeLocale TimeF.rfc822DateFormat sn.expiresOn cookieValue = "WebserverToken=" <> sn.token <> "; Expires=" <> expires <> "; Path=/; Secure; HttpOnly; SameSite=Lax" in ("Set-Cookie", TSE.encodeUtf8 cookieValue)
packClearSessionCookie :: HeaderpackClearSessionCookie = ("Set-Cookie", "WebserverToken=; Expires=Thu, 01 Jan 1970 00:00:00 GMT; Path=/; Secure; HttpOnly; SameSite=Lax")