mateamt/src/Model/Auth.hs

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