module Snap.Snaplet.SqliteSimple.JwtAuth.JwtAuth (
SqliteJwt(..)
, User(..)
, AuthFailure(..)
, defaults
, sqliteJwtInit
, requireAuth
, registerUser
, loginUser
, createUser
, login
, jsonResponse
, writeJSON
, reqJSON
) where
import Control.Lens hiding ((.=), (??))
import Control.Monad.Except
import Control.Monad.State (gets)
import Control.Error hiding (err)
import qualified Crypto.BCrypt as BC
import Data.Aeson
import Data.Aeson.Types (parseEither)
import qualified Data.Attoparsec.ByteString.Char8 as AP
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import Data.Maybe
import Data.Map as M
import Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as LT
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import Snap
import Snap.Snaplet.SqliteSimple (Sqlite, sqliteConn)
import qualified Web.JWT as JWT
import Snap.Snaplet.SqliteSimple.JwtAuth.Util
import Snap.Snaplet.SqliteSimple.JwtAuth.Types
import qualified Snap.Snaplet.SqliteSimple.JwtAuth.Db as Db
defaults :: Options
defaults = Options {
hashingPolicy = BC.fastBcryptHashingPolicy
, signingKeyFilename = "jwt_secret.txt"
, maxTokenExpiration = 60*60*24*14
}
sqliteJwtInit
:: Options
-> Snaplet Sqlite
-> SnapletInit b SqliteJwt
sqliteJwtInit options db = makeSnaplet "sqlite-simple-jwt" description Nothing $ do
k <- liftIO $ (JWT.binarySecret <$> getKey (signingKeyFilename options))
let conn = sqliteConn $ db ^# snapletValue
liftIO $ Db.createTableIfMissing conn
return $ SqliteJwt k conn options
where
description = "sqlite-simple jwt auth"
createUser
:: T.Text
-> T.Text
-> Handler b SqliteJwt (Either AuthFailure User)
createUser loginName password = do
user <- Db.queryUser loginName
hashPolicy <- hashingPolicy <$> gets options
case user of
Nothing -> do
hashedPass <- liftIO $ BC.hashPasswordUsingPolicy hashPolicy (LT.encodeUtf8 password)
Db.insertUser loginName (fromJust hashedPass)
u <- Db.queryUser loginName
return (Right (Db.fromDbUser . fromJust $ u))
Just _ ->
return (Left DuplicateLogin)
login
:: T.Text
-> T.Text
-> Handler b SqliteJwt (Either AuthFailure User)
login loginName password = do
user <- Db.queryUser loginName
case user of
Nothing ->
return (Left UnknownUser)
Just u -> do
if BC.validatePassword (Db.dbuserHashedPass u) (LT.encodeUtf8 password) then
passwordOk (Db.fromDbUser u)
else
passwordFail
where
passwordOk u = return (Right u)
passwordFail = return (Left WrongPassword)
parseBearerJwt :: ByteString -> Either String T.Text
parseBearerJwt s = AP.parseOnly (AP.string "Bearer " *> payload) s
where
payload = LT.decodeUtf8 <$> AP.takeWhile1 (AP.inClass base64)
base64 = "A-Za-z0-9+/_=.-"
jwtFromUser :: User -> POSIXTime -> Handler b SqliteJwt JWT.JSON
jwtFromUser (User uid loginName) expiresOn = do
key <- gets siteSecret
let cs = JWT.def {
JWT.unregisteredClaims = M.fromList [("id", Number (fromIntegral uid)), ("login", String loginName)]
, JWT.exp = JWT.intDate $ expiresOn
}
return $ JWT.encodeSigned JWT.HS256 key cs
requireAuth :: (User -> Handler b SqliteJwt a) -> Handler b SqliteJwt a
requireAuth action = do
key <- gets siteSecret
req <- getRequest
res <- runExceptT $ do
curTime <- liftIO $ getPOSIXTime
authHdr <- getHeader "Authorization" (rqHeaders req) ?? "missing Authorization header"
encPayload <- hoistEither . parseBearerJwt $ authHdr
jwt <- JWT.decode encPayload ?? "malformed JWT"
verifJwt <- JWT.verify key jwt ?? "JWT verification failed"
exp <- JWT.exp (JWT.claims verifJwt) ?? "exp not set in JWT"
assertZ (JWT.secondsSinceEpoch exp >= curTime) ?? "token has expired"
let unregClaims = JWT.unregisteredClaims (JWT.claims verifJwt)
hoistEither . parseEither parseJSON $ (toObject unregClaims)
either (finishEarly 401 . BS8.pack) action res
where
toObject = Object . HM.fromList . M.toList
handleLoginError :: AuthFailure -> H b ()
handleLoginError err =
case err of
DuplicateLogin -> failLogin dupeError
UnknownUser -> failLogin failedPassOrUserError
WrongPassword -> failLogin failedPassOrUserError
where
dupeError = "Duplicate login"
failedPassOrUserError = "Unknown user or wrong password"
failLogin :: T.Text -> H b ()
failLogin msg = do
jsonResponse
modifyResponse $ setResponseStatus 401 "bad login"
writeJSON $ object [ "error" .= msg]
loginOK :: User -> Handler b SqliteJwt ()
loginOK user = do
expiresIn <- maxTokenExpiration <$> gets options
curTime <- liftIO getPOSIXTime
jwt <- jwtFromUser user (curTime + (fromIntegral expiresIn))
writeJSON $ object [ "token" .= jwt ]
registerUser :: Handler b SqliteJwt ()
registerUser = method POST newUser
where
newUser = do
params <- reqJSON
userOrErr <- createUser (lpLogin params) (lpPass params)
either handleLoginError loginOK userOrErr
loginUser :: Handler b SqliteJwt ()
loginUser = method POST $ do
params <- reqJSON
userOrErr <- login (lpLogin params) (lpPass params)
either handleLoginError loginOK userOrErr