392 lines
10 KiB
Haskell
392 lines
10 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE Arrows #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
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 Crypto.Error
|
|
|
|
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 Data.ByteString as B (ByteString)
|
|
import Data.ByteString.Base64 (encode)
|
|
|
|
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_string BYTEA NOT NULL PRIMARY KEY,"
|
|
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
|
|
, "token_expiry TIMESTAMPTZ NOT NULL,"
|
|
, "token_method INT NOT NULL"
|
|
, ")"
|
|
]
|
|
|
|
tokenTable :: Table
|
|
( Field SqlBytea
|
|
, Field SqlInt4
|
|
, Field SqlTimestamptz
|
|
, Field SqlInt4
|
|
)
|
|
( Field SqlBytea
|
|
, Field SqlInt4
|
|
, Field SqlTimestamptz
|
|
, Field SqlInt4
|
|
)
|
|
tokenTable = table "token" (
|
|
p4
|
|
( tableField "token_string"
|
|
, 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
|
|
-> PGS.Connection
|
|
-> Handler (Maybe (Int, AuthMethod))
|
|
validateToken header conn = do
|
|
tokens <- liftIO $ map fromDatabase <$> runSelect conn (
|
|
proc () -> do
|
|
stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
|
|
restrict -< toFields header .== tstr
|
|
returnA -< stuff
|
|
)
|
|
case tokens of
|
|
[Token _ uid stamp method] -> do
|
|
now_ <- liftIO getCurrentTime
|
|
if diffUTCTime stamp now_ > 0
|
|
then return $ Just (uid, method)
|
|
else do
|
|
void $ deleteToken header conn
|
|
liftIO $ threadDelay delayTime
|
|
throwError $ err401
|
|
{ errBody = "Your token expired!"
|
|
}
|
|
_ -> do
|
|
liftIO $ threadDelay delayTime
|
|
throwError $ err401
|
|
{ errBody = "No valid token found!"
|
|
}
|
|
|
|
|
|
generateToken
|
|
:: Ticket
|
|
-> AuthResponse
|
|
-> PGS.Connection
|
|
-> MateHandler AuthResult
|
|
generateToken (Ticket _ 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
|
|
token <- liftIO $ Token
|
|
<$> (decodeUtf8 <$> randomString)
|
|
<*> pure tuid
|
|
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
|
<*> pure method
|
|
void $ insertToken token conn
|
|
return $ Granted (AuthToken $ tokenString token)
|
|
else
|
|
return Denied
|
|
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 _ _ =
|
|
error "Validation of challenge response authentication not yet implemented"
|
|
|
|
|
|
insertToken
|
|
:: Token
|
|
-> PGS.Connection
|
|
-> MateHandler ByteString
|
|
insertToken (Token tString tUser tExpiry tMethod) conn =
|
|
fmap head $ liftIO $ runInsert_ conn $ Insert
|
|
{ iTable = tokenTable
|
|
, iRows =
|
|
[
|
|
( toFields (encodeUtf8 tString)
|
|
, toFields tUser
|
|
, toFields tExpiry
|
|
, toFields (fromEnum tMethod)
|
|
)
|
|
]
|
|
, iReturning = rReturning (\(ident, _, _, _) -> ident)
|
|
, iOnConflict = Nothing
|
|
}
|
|
|
|
|
|
deleteToken
|
|
:: ByteString
|
|
-> PGS.Connection
|
|
-> Handler Int64
|
|
deleteToken tstr conn =
|
|
liftIO $ runDelete_ conn $ Delete
|
|
{ dTable = tokenTable
|
|
, dWhere = \(rtstr, _, _, _) -> rtstr .== toFields tstr
|
|
, 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
|
|
-> S.Set Ticket
|
|
-> PGS.Connection
|
|
-> MateHandler AuthResult
|
|
processAuthRequest (AuthRequest aticket pass) store conn = do
|
|
let mticket = S.filter (\st -> ticketId st == aticket) store
|
|
case S.toList mticket of
|
|
[ticket] -> do
|
|
-- liftIO $ putStrLn "there is a ticket..."
|
|
now_ <- liftIO getCurrentTime
|
|
liftIO $ threadDelay delayTime
|
|
if now_ > ticketExpiry ticket
|
|
then
|
|
return Denied
|
|
else
|
|
-- liftIO $ putStrLn "...and it is valid"
|
|
generateToken ticket pass conn
|
|
_ -> do
|
|
liftIO $ threadDelay delayTime
|
|
return Denied
|
|
|
|
processLogout
|
|
:: Int
|
|
-> PGS.Connection
|
|
-> MateHandler ()
|
|
processLogout uid conn =
|
|
void $ deleteTokenByUserId uid conn
|