mateamt/src/Model/Auth.hs

410 lines
11 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2019-04-21 15:27:15 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-09-16 06:59:57 +00:00
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ScopedTypeVariables #-}
2022-04-17 14:38:48 +00:00
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
2023-07-07 22:16:05 +00:00
{-# LANGUAGE FlexibleInstances #-}
2019-04-21 15:27:15 +00:00
module Model.Auth where
2019-05-16 02:07:20 +00:00
import Servant
2019-05-13 20:50:24 +00:00
2019-09-16 06:59:57 +00:00
import Control.Arrow
2019-04-21 15:27:15 +00:00
2022-04-17 14:38:48 +00:00
import Control.Monad (void, foldM)
2019-05-06 21:41:05 +00:00
import Control.Monad.IO.Class (liftIO)
2019-10-14 21:34:45 +00:00
import Control.Monad.Reader (asks)
2019-05-06 21:41:05 +00:00
2019-09-07 00:48:16 +00:00
import Control.Concurrent (threadDelay)
2019-05-08 23:24:58 +00:00
import Control.Concurrent.STM
2023-07-07 22:16:05 +00:00
import Control.Lens
2022-04-17 14:38:48 +00:00
import Crypto.Error
2023-07-07 22:16:05 +00:00
import Crypto.JWT
import qualified Data.Aeson as A
import Data.ByteString as B (ByteString, fromStrict)
2022-04-17 14:38:48 +00:00
import Data.Profunctor.Product (p4, p6)
2019-04-21 15:27:15 +00:00
import qualified Database.PostgreSQL.Simple as PGS
import Data.Int (Int64)
2022-04-17 14:38:48 +00:00
import Data.String (fromString)
import qualified Data.Text as T
import Data.Text.Encoding
2019-04-21 15:27:15 +00:00
2019-05-08 23:24:58 +00:00
import qualified Data.Set as S
2019-05-06 21:41:05 +00:00
2019-05-08 23:24:58 +00:00
import Data.Time.Clock
2019-04-21 15:27:15 +00:00
import Opaleye hiding (null)
2019-04-21 15:27:15 +00:00
-- internal imports
import Types.Auth
2019-05-06 21:41:05 +00:00
import Types.Reader
import Classes
2022-04-17 11:50:18 +00:00
import Util.Crypto
2019-07-18 14:10:18 +00:00
2019-04-21 15:27:15 +00:00
initToken :: PGS.Query
2019-07-21 14:05:05 +00:00
initToken = mconcat
2019-08-10 09:41:57 +00:00
[ "CREATE TABLE IF NOT EXISTS \"token\" ("
2023-07-07 22:16:05 +00:00
, "token_id SERIAL PRIMARY KEY,"
2019-08-10 09:41:57 +00:00
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
, "token_expiry TIMESTAMPTZ NOT NULL,"
, "token_method INT NOT NULL"
2019-07-21 13:02:59 +00:00
, ")"
]
2019-04-21 15:27:15 +00:00
tokenTable :: Table
2023-07-07 22:16:05 +00:00
( Maybe (Field SqlInt4)
2019-04-21 15:27:15 +00:00
, Field SqlInt4
, Field SqlTimestamptz
, Field SqlInt4
2019-04-21 15:27:15 +00:00
)
2023-07-07 22:16:05 +00:00
( Field SqlInt4
2019-04-21 15:27:15 +00:00
, Field SqlInt4
, Field SqlTimestamptz
, Field SqlInt4
2019-04-21 15:27:15 +00:00
)
tokenTable = table "token" (
p4
2023-07-07 22:16:05 +00:00
( tableField "token_id"
, tableField "token_user"
, tableField "token_expiry"
, tableField "token_method"
2019-04-21 15:27:15 +00:00
)
)
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,"
2019-09-16 06:59:57 +00:00
, "auth_data_comment TEXT NOT NULL,"
2022-04-17 14:38:48 +00:00
, "auth_data_payload BYTEA NOT NULL,"
, "auth_data_salt BYTEA NOT NULL"
, ")"
]
authDataTable :: Table
( Maybe (Field SqlInt4)
, Field SqlInt4
, Field SqlInt4
2019-09-15 09:01:47 +00:00
, Field SqlText
, Field SqlBytea
2022-04-17 14:38:48 +00:00
, Field SqlBytea
)
( Field SqlInt4
, Field SqlInt4
, Field SqlInt4
2019-09-15 09:01:47 +00:00
, Field SqlText
, Field SqlBytea
2022-04-17 14:38:48 +00:00
, Field SqlBytea
)
authDataTable = table "auth_data" (
2022-04-17 14:38:48 +00:00
p6
( tableField "auth_data_id"
, tableField "auth_data_user"
, tableField "auth_data_method"
2019-09-16 06:59:57 +00:00
, tableField "auth_data_comment"
, tableField "auth_data_payload"
2022-04-17 14:38:48 +00:00
, tableField "auth_data_salt"
)
)
2019-04-21 15:27:15 +00:00
2019-09-07 00:48:16 +00:00
delayTime :: Int
delayTime = 1 * 10 ^ (6 :: Int)
2019-07-18 14:10:18 +00:00
2019-09-15 12:59:22 +00:00
2019-09-16 06:59:57 +00:00
selectAuthOverviews
2021-06-10 15:54:57 +00:00
:: Int -- ^ User ID
-> PGS.Connection -- ^ Connection Handler
2019-09-16 06:59:57 +00:00
-> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do
2021-06-16 16:09:08 +00:00
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
2022-04-17 14:38:48 +00:00
(adid, aduid, admethod, adcomment, _, _) <-
2021-07-14 01:08:58 +00:00
selectTable authDataTable -< ()
restrict -< aduid .== toFields uid
2021-06-16 16:09:08 +00:00
returnA -< (adid, aduid, adcomment, admethod)
)
2019-09-16 06:59:57 +00:00
2021-06-10 15:54:57 +00:00
selectAuthOverviewById
:: Int -- ^ Auth Data ID
-> PGS.Connection -- ^ Connection Handler
-> MateHandler AuthOverview
2021-06-16 16:09:08 +00:00
selectAuthOverviewById aid conn = do
2021-07-14 01:08:58 +00:00
liftIO $ fromDatabase . head <$> runSelect conn (limit 1 $ proc () -> do
2022-04-17 14:38:48 +00:00
(adid, aduid, admethod, adcomment, _, _) <-
2021-07-14 01:08:58 +00:00
selectTable authDataTable -< ()
restrict -< adid .== toFields aid
2021-06-16 16:09:08 +00:00
returnA -< (adid, aduid, adcomment, admethod)
2021-06-10 15:54:57 +00:00
)
2019-04-21 15:27:15 +00:00
getUserAuthInfo
2019-05-09 14:53:19 +00:00
:: Int
-> AuthMethod
2019-09-15 12:59:22 +00:00
-> PGS.Connection
2019-09-15 09:01:47 +00:00
-> MateHandler AuthInfo
2019-09-15 12:59:22 +00:00
getUserAuthInfo uid method conn = do
authdata <-
liftIO $ do
void $ threadDelay delayTime
map fromDatabase <$> runSelect conn (proc () -> do
2022-04-17 14:38:48 +00:00
(aid, auid, amethod, acomment, apayload, asalt) <-
2021-07-14 01:08:58 +00:00
selectTable authDataTable -< ()
restrict -<
2021-07-14 01:08:58 +00:00
auid .== toFields uid .&& amethod .== toFields (fromEnum method)
2022-04-17 14:38:48 +00:00
returnA -< (aid, auid, amethod, acomment, apayload, asalt)
) :: IO [AuthData]
if null authdata
then
2019-09-15 09:01:47 +00:00
-- generate mock AuthInfo
liftIO $ do
2022-04-16 14:40:10 +00:00
rand1 <- decodeUtf8 <$> randomString
2019-09-15 09:01:47 +00:00
rand2 <- case method of
2022-04-16 14:40:10 +00:00
ChallengeResponse -> Just . decodeUtf8 <$> randomString
2019-09-15 09:01:47 +00:00
_ -> return Nothing
return $ AuthInfo rand2 (AuthTicket rand1)
else
2019-09-15 09:01:47 +00:00
uncurry AuthInfo <$> newTicket uid method
2019-05-06 21:41:05 +00:00
2019-07-18 14:10:18 +00:00
2019-09-15 12:59:22 +00:00
putUserAuthInfo
:: Int
-> AuthMethod
-> T.Text
2022-04-17 14:38:48 +00:00
-> B.ByteString
-> B.ByteString
2019-09-15 12:59:22 +00:00
-> PGS.Connection
-> MateHandler Int
2022-04-17 14:38:48 +00:00
putUserAuthInfo uid method comment salt payload conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = authDataTable
, iRows =
[
2021-07-14 01:08:58 +00:00
( toFields (Nothing :: Maybe Int)
, toFields uid
, toFields (fromEnum method)
, toFields comment
2022-04-17 14:38:48 +00:00
, toFields payload
, toFields salt
)
]
2022-04-17 14:38:48 +00:00
, iReturning = rReturning (\(adid, _, _, _, _, _) -> adid)
, iOnConflict = Nothing
}
2019-09-15 12:59:22 +00:00
2019-09-16 06:59:57 +00:00
deleteAuthDataById
:: Int
-> PGS.Connection
-> MateHandler Int64
deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = authDataTable
2022-04-17 14:38:48 +00:00
, dWhere = \(aid, _, _, _, _, _) -> aid .== toFields adid
2019-09-16 06:59:57 +00:00
, dReturning = rCount
}
2019-05-13 20:50:24 +00:00
validateToken
:: ByteString
2023-07-07 22:16:05 +00:00
-> JWK
-> PGS.Connection
2019-09-15 12:59:22 +00:00
-> Handler (Maybe (Int, AuthMethod))
2023-07-07 22:16:05 +00:00
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 (
2022-04-15 13:35:53 +00:00
proc () -> do
2023-07-07 22:16:05 +00:00
stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
restrict -<
toFields (authUser token) .== tUser .&&
toFields (fromEnum $ authMethod token) .== tMethod
2022-04-15 13:35:53 +00:00
returnA -< stuff
)
2019-05-13 20:50:24 +00:00
case tokens of
2023-07-07 22:16:05 +00:00
[Token tid uid stamp method] -> do
2022-04-15 13:35:53 +00:00
now_ <- liftIO getCurrentTime
if diffUTCTime stamp now_ > 0
then return $ Just (uid, method)
else do
2023-07-07 22:16:05 +00:00
void $ deleteToken tid conn
2019-09-07 00:48:16 +00:00
liftIO $ threadDelay delayTime
throwError $ err401
{ errBody = "Your token expired!"
}
_ -> do
2019-09-07 00:48:16 +00:00
liftIO $ threadDelay delayTime
2019-05-16 02:07:20 +00:00
throwError $ err401
{ errBody = "No valid token found!"
}
2019-05-13 20:50:24 +00:00
2019-07-18 14:10:18 +00:00
2019-05-09 14:53:19 +00:00
generateToken
2023-07-07 22:16:05 +00:00
:: Int
-> AuthMethod
-> AuthResponse
2019-09-15 12:59:22 +00:00
-> PGS.Connection
2023-07-07 22:16:05 +00:00
-> MateHandler SignedJWT
generateToken tuid method (AuthResponse response) conn = do
authData <- liftIO $ map fromDatabase <$> runSelect conn (
2022-04-15 13:35:53 +00:00
proc () -> do
2022-04-17 14:38:48 +00:00
stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
2022-04-15 13:35:53 +00:00
restrict -< (auid .== toFields tuid .&& amethod .== toFields (fromEnum method))
returnA -< stuff
) :: MateHandler [AuthData]
2019-10-14 20:50:42 +00:00
let userPayloads = map
authDataPayload
2019-10-14 20:50:42 +00:00
authData
2022-04-17 14:38:48 +00:00
authResult <- case method of
PrimaryPass -> validatePass response authData
SecondaryPass -> validatePass response authData
ChallengeResponse -> validateChallengeResponse response userPayloads
-- liftIO $ print (response : userPayloads)
2019-09-15 09:01:47 +00:00
if authResult
2019-05-09 14:53:19 +00:00
then do
2023-07-07 22:16:05 +00:00
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
2019-05-09 14:53:19 +00:00
else
2023-07-07 22:16:05 +00:00
throwError err401
2019-09-15 09:01:47 +00:00
where
2022-04-17 14:38:48 +00:00
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
2019-10-14 20:50:42 +00:00
validateChallengeResponse _ _ =
2023-07-07 22:16:05 +00:00
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))
2019-05-09 14:53:19 +00:00
2019-07-18 14:10:18 +00:00
2019-05-09 14:53:19 +00:00
insertToken
2023-07-07 22:16:05 +00:00
:: (Int, UTCTime, AuthMethod)
2019-07-28 09:55:22 +00:00
-> PGS.Connection
2023-07-07 22:16:05 +00:00
-> MateHandler Int
insertToken (tUser, tExpiry, tMethod) conn =
2019-07-28 09:55:22 +00:00
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable
, iRows =
[
2023-07-07 22:16:05 +00:00
( toFields (Nothing :: Maybe Int)
2021-07-14 01:08:58 +00:00
, toFields tUser
, toFields tExpiry
, toFields (fromEnum tMethod)
2019-07-28 09:55:22 +00:00
)
]
2023-07-07 22:16:05 +00:00
, iReturning = rReturning (\(tid, _, _, _) -> tid)
2019-07-28 09:55:22 +00:00
, iOnConflict = Nothing
}
2019-05-08 23:24:58 +00:00
2019-07-18 14:10:18 +00:00
deleteToken
2023-07-07 22:16:05 +00:00
:: Int
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> Handler Int64
2023-07-07 22:16:05 +00:00
deleteToken dtid conn =
2019-07-28 09:55:22 +00:00
liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
2023-07-07 22:16:05 +00:00
, dWhere = \(tid, _, _, _) -> tid .== toFields dtid
2019-07-28 09:55:22 +00:00
, dReturning = rCount
}
2019-07-18 14:09:59 +00:00
deleteTokenByUserId
:: Int
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> MateHandler Int64
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
2019-07-18 14:09:59 +00:00
{ dTable = tokenTable
2021-07-14 01:08:58 +00:00
, dWhere = \(_, rid, _, _) -> rid .== toFields uid
2019-07-18 14:09:59 +00:00
, dReturning = rCount
}
2019-10-31 14:42:15 +00:00
deleteOldTokens
:: UTCTime
-> PGS.Connection
-> IO Int64
2022-04-15 13:35:53 +00:00
deleteOldTokens now_ conn = runDelete_ conn $ Delete
2019-10-31 14:42:15 +00:00
{ dTable = tokenTable
2022-04-15 13:35:53 +00:00
, dWhere = \(_, _, expiry, _) -> expiry .< toFields now_
2019-10-31 14:42:15 +00:00
, dReturning = rCount
}
2019-09-15 09:01:47 +00:00
newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do
2019-10-14 21:34:45 +00:00
store <- asks rsTicketStore
2022-04-16 14:40:10 +00:00
rand1 <- liftIO (decodeUtf8 <$> randomString)
2019-09-15 09:01:47 +00:00
rand2 <- liftIO $ case method of
2022-04-16 14:40:10 +00:00
ChallengeResponse -> Just . decodeUtf8 <$> randomString
2019-09-15 09:01:47 +00:00
_ -> return Nothing
2019-10-14 20:50:42 +00:00
later <- liftIO (addUTCTime 23 <$> getCurrentTime)
2019-05-08 23:24:58 +00:00
let ticket = Ticket
2019-09-15 09:01:47 +00:00
{ ticketId = AuthTicket rand1
2019-05-09 14:53:19 +00:00
, ticketUser = ident
2019-05-06 21:41:05 +00:00
, ticketExpiry = later
2019-09-15 09:01:47 +00:00
, ticketMethod = (method, rand2)
2019-05-06 21:41:05 +00:00
}
2019-10-14 20:50:42 +00:00
liftIO $ atomically $ modifyTVar store (S.insert ticket)
2019-09-15 09:01:47 +00:00
return (rand2, AuthTicket rand1)
2019-05-08 23:24:58 +00:00
2019-07-18 14:10:18 +00:00
2019-05-08 23:24:58 +00:00
processAuthRequest
:: AuthRequest
2019-09-15 12:59:22 +00:00
-> PGS.Connection
2023-07-07 22:16:05 +00:00
-> 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
2019-07-18 14:09:59 +00:00
processLogout
:: Int
2019-09-15 12:59:22 +00:00
-> PGS.Connection
2019-07-18 14:09:59 +00:00
-> MateHandler ()
2019-10-14 20:50:42 +00:00
processLogout uid conn =
2019-07-28 09:55:22 +00:00
void $ deleteTokenByUserId uid conn