mateamt/src/Model/Auth.hs
2023-07-08 00:16:05 +02:00

410 lines
11 KiB
Haskell

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Model.Auth where
import Servant
import Control.Arrow
import Control.Monad (void, foldM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (asks)
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import Control.Lens
import Crypto.Error
import Crypto.JWT
import qualified Data.Aeson as A
import Data.ByteString as B (ByteString, fromStrict)
import Data.Profunctor.Product (p4, p6)
import qualified Database.PostgreSQL.Simple as PGS
import Data.Int (Int64)
import Data.String (fromString)
import qualified Data.Text as T
import Data.Text.Encoding
import qualified Data.Set as S
import Data.Time.Clock
import Opaleye hiding (null)
-- internal imports
import Types.Auth
import Types.Reader
import Classes
import Util.Crypto
initToken :: PGS.Query
initToken = mconcat
[ "CREATE TABLE IF NOT EXISTS \"token\" ("
, "token_id SERIAL PRIMARY KEY,"
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
, "token_expiry TIMESTAMPTZ NOT NULL,"
, "token_method INT NOT NULL"
, ")"
]
tokenTable :: Table
( Maybe (Field SqlInt4)
, Field SqlInt4
, Field SqlTimestamptz
, Field SqlInt4
)
( Field SqlInt4
, Field SqlInt4
, Field SqlTimestamptz
, Field SqlInt4
)
tokenTable = table "token" (
p4
( tableField "token_id"
, tableField "token_user"
, tableField "token_expiry"
, tableField "token_method"
)
)
initAuthData :: PGS.Query
initAuthData = mconcat
[ "CREATE TABLE IF NOT EXISTS \"auth_data\" ("
, "auth_data_id SERIAL PRIMARY KEY,"
, "auth_data_user INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
, "auth_data_method INTEGER NOT NULL,"
, "auth_data_comment TEXT NOT NULL,"
, "auth_data_payload BYTEA NOT NULL,"
, "auth_data_salt BYTEA NOT NULL"
, ")"
]
authDataTable :: Table
( Maybe (Field SqlInt4)
, Field SqlInt4
, Field SqlInt4
, Field SqlText
, Field SqlBytea
, Field SqlBytea
)
( Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, Field SqlText
, Field SqlBytea
, Field SqlBytea
)
authDataTable = table "auth_data" (
p6
( tableField "auth_data_id"
, tableField "auth_data_user"
, tableField "auth_data_method"
, tableField "auth_data_comment"
, tableField "auth_data_payload"
, tableField "auth_data_salt"
)
)
delayTime :: Int
delayTime = 1 * 10 ^ (6 :: Int)
selectAuthOverviews
:: Int -- ^ User ID
-> PGS.Connection -- ^ Connection Handler
-> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, _, _) <-
selectTable authDataTable -< ()
restrict -< aduid .== toFields uid
returnA -< (adid, aduid, adcomment, admethod)
)
selectAuthOverviewById
:: Int -- ^ Auth Data ID
-> PGS.Connection -- ^ Connection Handler
-> MateHandler AuthOverview
selectAuthOverviewById aid conn = do
liftIO $ fromDatabase . head <$> runSelect conn (limit 1 $ proc () -> do
(adid, aduid, admethod, adcomment, _, _) <-
selectTable authDataTable -< ()
restrict -< adid .== toFields aid
returnA -< (adid, aduid, adcomment, admethod)
)
getUserAuthInfo
:: Int
-> AuthMethod
-> PGS.Connection
-> MateHandler AuthInfo
getUserAuthInfo uid method conn = do
authdata <-
liftIO $ do
void $ threadDelay delayTime
map fromDatabase <$> runSelect conn (proc () -> do
(aid, auid, amethod, acomment, apayload, asalt) <-
selectTable authDataTable -< ()
restrict -<
auid .== toFields uid .&& amethod .== toFields (fromEnum method)
returnA -< (aid, auid, amethod, acomment, apayload, asalt)
) :: IO [AuthData]
if null authdata
then
-- generate mock AuthInfo
liftIO $ do
rand1 <- decodeUtf8 <$> randomString
rand2 <- case method of
ChallengeResponse -> Just . decodeUtf8 <$> randomString
_ -> return Nothing
return $ AuthInfo rand2 (AuthTicket rand1)
else
uncurry AuthInfo <$> newTicket uid method
putUserAuthInfo
:: Int
-> AuthMethod
-> T.Text
-> B.ByteString
-> B.ByteString
-> PGS.Connection
-> MateHandler Int
putUserAuthInfo uid method comment salt payload conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = authDataTable
, iRows =
[
( toFields (Nothing :: Maybe Int)
, toFields uid
, toFields (fromEnum method)
, toFields comment
, toFields payload
, toFields salt
)
]
, iReturning = rReturning (\(adid, _, _, _, _, _) -> adid)
, iOnConflict = Nothing
}
deleteAuthDataById
:: Int
-> PGS.Connection
-> MateHandler Int64
deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = authDataTable
, dWhere = \(aid, _, _, _, _, _) -> aid .== toFields adid
, dReturning = rCount
}
validateToken
:: ByteString
-> JWK
-> PGS.Connection
-> Handler (Maybe (Int, AuthMethod))
validateToken authHeader key conn = do
token <- either (error . show) id <$> liftIO (runJOSE $ do
jwt <- (decodeCompact (fromStrict authHeader) :: JOSE JWTError IO SignedJWT)
liftIO $ print jwt
let chk = defaultJWTValidationSettings (const True)
verifyJWT chk key jwt :: JOSE JWTError IO AuthResult
)
tokens <- liftIO $ map fromDatabase <$> runSelect conn (
proc () -> do
stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
restrict -<
toFields (authUser token) .== tUser .&&
toFields (fromEnum $ authMethod token) .== tMethod
returnA -< stuff
)
case tokens of
[Token tid uid stamp method] -> do
now_ <- liftIO getCurrentTime
if diffUTCTime stamp now_ > 0
then return $ Just (uid, method)
else do
void $ deleteToken tid conn
liftIO $ threadDelay delayTime
throwError $ err401
{ errBody = "Your token expired!"
}
_ -> do
liftIO $ threadDelay delayTime
throwError $ err401
{ errBody = "No valid token found!"
}
generateToken
:: Int
-> AuthMethod
-> AuthResponse
-> PGS.Connection
-> MateHandler SignedJWT
generateToken tuid method (AuthResponse response) conn = do
authData <- liftIO $ map fromDatabase <$> runSelect conn (
proc () -> do
stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
restrict -< (auid .== toFields tuid .&& amethod .== toFields (fromEnum method))
returnA -< stuff
) :: MateHandler [AuthData]
let userPayloads = map
authDataPayload
authData
authResult <- case method of
PrimaryPass -> validatePass response authData
SecondaryPass -> validatePass response authData
ChallengeResponse -> validateChallengeResponse response userPayloads
-- liftIO $ print (response : userPayloads)
if authResult
then do
key <- asks rsJWTSecret
issuedAt <- liftIO getCurrentTime
let preToken =
( tuid
, (addUTCTime (23*60) issuedAt)
, method
)
liftIO $ print $ A.encode key
void $ insertToken preToken conn
let result = AuthResult issuedAt tuid method -- (AuthToken $ tokenString token)
signedJWT <- liftIO $ runJOSE (do
algo <- (bestJWSAlg key :: JOSE JWTError IO Alg)
signJWT key (newJWSHeader ((), algo)) result)
return $ either (error "Signing JWT failed") id signedJWT
else
throwError err401
where
validatePass resp =
foldM
(\acc AuthData{..} ->
let mresponseHash = argon2 (encodeUtf8 authDataSalt) (encodeUtf8 resp)
in case mresponseHash of
CryptoPassed responseHash ->
return $ acc || responseHash == encodeUtf8 authDataPayload
CryptoFailed err ->
throwError $ err500
{ errBody = "Crypto error: " <> fromString (show err)
}
)
False
validateChallengeResponse _ _ =
throwError err501
{ errBody = "Validation of challenge response authentication not yet implemented"
}
-- signJWT :: JWK -> AuthResult -> MateHandler (Either JWTError SignedJWT)
-- signJWT key result = liftIO $ runExceptT $ do
-- algo <- bestJWSAlg key
-- signJWS (A.encode result) (Identity (newJWSHeader ((), algo), key))
insertToken
:: (Int, UTCTime, AuthMethod)
-> PGS.Connection
-> MateHandler Int
insertToken (tUser, tExpiry, tMethod) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable
, iRows =
[
( toFields (Nothing :: Maybe Int)
, toFields tUser
, toFields tExpiry
, toFields (fromEnum tMethod)
)
]
, iReturning = rReturning (\(tid, _, _, _) -> tid)
, iOnConflict = Nothing
}
deleteToken
:: Int
-> PGS.Connection
-> Handler Int64
deleteToken dtid conn =
liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = \(tid, _, _, _) -> tid .== toFields dtid
, dReturning = rCount
}
deleteTokenByUserId
:: Int
-> PGS.Connection
-> MateHandler Int64
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = \(_, rid, _, _) -> rid .== toFields uid
, dReturning = rCount
}
deleteOldTokens
:: UTCTime
-> PGS.Connection
-> IO Int64
deleteOldTokens now_ conn = runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = \(_, _, expiry, _) -> expiry .< toFields now_
, dReturning = rCount
}
newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do
store <- asks rsTicketStore
rand1 <- liftIO (decodeUtf8 <$> randomString)
rand2 <- liftIO $ case method of
ChallengeResponse -> Just . decodeUtf8 <$> randomString
_ -> return Nothing
later <- liftIO (addUTCTime 23 <$> getCurrentTime)
let ticket = Ticket
{ ticketId = AuthTicket rand1
, ticketUser = ident
, ticketExpiry = later
, ticketMethod = (method, rand2)
}
liftIO $ atomically $ modifyTVar store (S.insert ticket)
return (rand2, AuthTicket rand1)
processAuthRequest
:: AuthRequest
-> PGS.Connection
-> MateHandler SignedJWT
processAuthRequest (AuthRequest user method pass) conn = do
-- liftIO $ putStrLn "there is a ticket..."
now_ <- liftIO getCurrentTime
liftIO $ threadDelay delayTime
-- liftIO $ putStrLn "...and it is valid"
generateToken user method pass conn
processLogout
:: Int
-> PGS.Connection
-> MateHandler ()
processLogout uid conn =
void $ deleteTokenByUserId uid conn