change auth response type

This commit is contained in:
nek0 2019-09-15 14:59:22 +02:00
parent 39341751ee
commit ffb559cb36
9 changed files with 134 additions and 82 deletions

View file

@ -88,20 +88,20 @@ app initState =
mateApi :: Proxy MateAPI mateApi :: Proxy MateAPI
mateApi = Proxy mateApi = Proxy
authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ] authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
authProxy = Proxy authProxy = Proxy
genAuthServerContext genAuthServerContext
:: Connection :: Connection
-> Context '[ AuthHandler Request (Maybe Int) ] -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
type instance AuthServerData (AuthProtect "header-auth") = Maybe Int type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
authHandler :: Connection -> AuthHandler Request (Maybe Int) authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
authHandler conn = mkAuthHandler handler authHandler conn = mkAuthHandler handler
where where
handler :: Request -> Handler (Maybe Int) handler :: Request -> Handler (Maybe (Int, AuthMethod))
handler req = do handler req = do
let headers = requestHeaders req let headers = requestHeaders req
res <- case lookup "Authentication" headers of res <- case lookup "Authentication" headers of

View file

@ -20,8 +20,7 @@ import Types
type MateAPI = type MateAPI =
"auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo "auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
:<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
:<|> "auth" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] ()
:> Delete '[JSON] ()
:<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int :<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
:<|> "user" :> AuthProtect "header-auth" :<|> "user" :> AuthProtect "header-auth"

View file

@ -3,28 +3,36 @@ module Control.Auth where
import Servant import Servant
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO)
-- internal imports -- internal imports
import Types import Types
import Model import Model
authGet :: TicketRequest -> MateHandler AuthInfo authGet
:: TicketRequest
-> MateHandler AuthInfo
authGet (TicketRequest uid method) = do authGet (TicketRequest uid method) = do
getUserAuthInfo uid method getUserAuthInfo uid method =<< (rsConnection <$> ask)
authSend :: AuthRequest -> MateHandler AuthResult authSend
authSend = processAuthRequest :: AuthRequest
-> MateHandler AuthResult
authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
(liftIO . readTVarIO =<< rsTicketStore <$> ask) <*>
(rsConnection <$> ask)
)
authLogout :: Maybe Int -> Int -> MateHandler () authLogout
authLogout (Just muid) luid = do :: Maybe (Int, AuthMethod)
if muid == luid -> MateHandler ()
then authLogout (Just (muid, method)) = do
processLogout luid processLogout muid =<< (rsConnection <$> ask)
else authLogout Nothing = do
throwError $ err401
{ errBody = "Unauthorized access"
}
authLogout Nothing _ = do
throwError $ err401 throwError $ err401
{ errBody = "Unauthorized access" { errBody = "Unauthorized access"
} }

View file

@ -43,7 +43,7 @@ avatarGet aid = do
) :: Application) ) :: Application)
avatarInsert avatarInsert
:: Maybe Int :: Maybe (Int, AuthMethod)
-> AvatarData -> AvatarData
-> MateHandler Int -> MateHandler Int
avatarInsert (Just _) ad = do avatarInsert (Just _) ad = do
@ -55,7 +55,7 @@ avatarInsert Nothing _ =
} }
avatarUpdate avatarUpdate
:: Maybe Int :: Maybe (Int, AuthMethod)
-> Int -> Int
-> AvatarData -> AvatarData
-> MateHandler () -> MateHandler ()

View file

@ -11,10 +11,10 @@ import Types
import Model import Model
buy buy
:: Maybe Int :: Maybe (Int, AuthMethod)
-> [PurchaseDetail] -> [PurchaseDetail]
-> MateHandler PurchaseResult -> MateHandler PurchaseResult
buy (Just auid) pds = do buy (Just (auid, _)) pds = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
(missing, real) <- foldM (\(ms, rs) pd -> do (missing, real) <- foldM (\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn mmiss <- checkProductAvailability pd conn

View file

@ -11,7 +11,7 @@ import Types
import Model.Journal import Model.Journal
journalShow journalShow
:: Maybe Int :: Maybe (Int, AuthMethod)
-> Maybe Int -> Maybe Int
-> Maybe Int -> Maybe Int
-> MateHandler [JournalEntry] -> MateHandler [JournalEntry]

View file

@ -14,7 +14,10 @@ import Data.Maybe (fromMaybe)
import Types import Types
import Model import Model
productNew :: Maybe Int -> ProductSubmit -> MateHandler Int productNew
:: Maybe (Int, AuthMethod)
-> ProductSubmit
-> MateHandler Int
productNew (Just _) bevsub = do productNew (Just _) bevsub = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
bevid <- insertProduct bevsub conn bevid <- insertProduct bevsub conn
@ -23,12 +26,17 @@ productNew (Just _) bevsub = do
productNew Nothing _ = productNew Nothing _ =
throwError $ err401 throwError $ err401
productOverview :: Int -> MateHandler ProductOverview productOverview
:: Int
-> MateHandler ProductOverview
productOverview pid = do productOverview pid = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
productOverviewSelectSingle pid conn productOverviewSelectSingle pid conn
productStockRefill :: Maybe Int -> [AmountRefill] -> MateHandler () productStockRefill
:: Maybe (Int, AuthMethod)
-> [AmountRefill]
-> MateHandler ()
productStockRefill (Just _) amorefs = do productStockRefill (Just _) amorefs = do
if all ((>= 0) . amountRefillAmount) amorefs if all ((>= 0) . amountRefillAmount) amorefs
then do then do
@ -43,7 +51,10 @@ productStockRefill Nothing _ =
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
productStockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler () productStockUpdate
:: Maybe (Int, AuthMethod)
-> [AmountUpdate]
-> MateHandler ()
productStockUpdate (Just _) amoups = do productStockUpdate (Just _) amoups = do
if all ((>= 0) . amountUpdateRealAmount) amoups if all ((>= 0) . amountUpdateRealAmount) amoups
then do then do
@ -58,7 +69,9 @@ productStockUpdate Nothing _ =
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
productList :: Maybe ProductRefine -> MateHandler [ProductOverview] productList
:: Maybe ProductRefine
-> MateHandler [ProductOverview]
productList mrefine = do productList mrefine = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
productOverviewSelect (fromMaybe AvailableProducts mrefine) conn productOverviewSelect (fromMaybe AvailableProducts mrefine) conn

View file

@ -20,19 +20,24 @@ import qualified Data.Text as T
import Types import Types
import Model import Model
userNew :: UserSubmit -> MateHandler Int userNew
:: UserSubmit
-> MateHandler Int
userNew us = do userNew us = do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
insertUser us (utctDay now) conn insertUser us (utctDay now) conn
userGet :: Maybe Int -> Int -> MateHandler UserDetails userGet
:: Maybe (Int, AuthMethod)
-> Int
-> MateHandler UserDetails
userGet Nothing _ = userGet Nothing _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
userGet (Just aid) uid = userGet (Just (aid, method)) uid =
if aid == uid if aid == uid && any (== method) [PrimaryPass, ChallengeResponse]
then do then do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
userDetailsSelect uid conn userDetailsSelect uid conn
@ -41,13 +46,17 @@ userGet (Just aid) uid =
{ errBody = "Wrong Authentication present." { errBody = "Wrong Authentication present."
} }
userUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler () userUpdate
:: Maybe (Int, AuthMethod)
-> Int
-> UserDetailsSubmit
-> MateHandler ()
userUpdate Nothing _ _ = userUpdate Nothing _ _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
userUpdate (Just aid) uid uds = userUpdate (Just (aid, method)) uid uds =
if aid == uid if aid == uid && any (== method) [PrimaryPass, ChallengeResponse]
then do then do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
@ -57,13 +66,18 @@ userUpdate (Just aid) uid uds =
{ errBody = "Wrong Authentication present." { errBody = "Wrong Authentication present."
} }
userList :: Maybe UserRefine -> MateHandler [UserSummary] userList
:: Maybe UserRefine
-> MateHandler [UserSummary]
userList ref = do userList ref = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
userSelect (fromMaybe ActiveUsers ref) conn userSelect (fromMaybe ActiveUsers ref) conn
userRecharge :: Maybe Int -> UserRecharge -> MateHandler () userRecharge
userRecharge (Just auid) (UserRecharge amount) = :: Maybe (Int, AuthMethod)
-> UserRecharge
-> MateHandler ()
userRecharge (Just (auid, _)) (UserRecharge amount) =
if amount >= 0 if amount >= 0
then do then do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
@ -85,32 +99,41 @@ userRecharge Nothing _ =
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
userTransfer :: Maybe Int -> UserTransfer -> MateHandler () userTransfer
userTransfer (Just auid) (UserTransfer target amount) = :: Maybe (Int, AuthMethod)
-> UserTransfer
-> MateHandler ()
userTransfer (Just (auid, method)) (UserTransfer target amount) =
if amount >= 0 if amount >= 0
then then
if auid /= target if auid /= target
then do then
conn <- rsConnection <$> ask if any (== method) [PrimaryPass, ChallengeResponse]
user <- userDetailsSelect auid conn
if amount < userDetailsBalance user
then do then do
mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn conn <- rsConnection <$> ask
if not (null mtarget) user <- userDetailsSelect auid conn
if amount < userDetailsBalance user
then do then do
void $ addToUserBalance auid (-amount) conn mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn
void $ addToUserBalance target amount conn if not (null mtarget)
then do
void $ addToUserBalance auid (-amount) conn
void $ addToUserBalance target amount conn
else
throwError $ err400
{ errBody = "Target user not found."
}
else else
throwError $ err400 throwError $ err400
{ errBody = "Target user not found." { errBody = "Not enough credit balance."
} }
else else
throwError $ err400 throwError $ err400
{ errBody = "Not enough credit balance." { errBody = "You can not transfer yourself money."
} }
else else
throwError $ err400 throwError $ err401
{ errBody = "You can not transfer yourself money." { errBody = "No Authentication present."
} }
else else
throwError $ err400 throwError $ err400

View file

@ -28,14 +28,11 @@ import Data.Text.Encoding
import qualified Data.Set as S import qualified Data.Set as S
import Data.Time.Calendar (Day)
import Data.Time.Clock import Data.Time.Clock
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteString.Random import Data.ByteString.Random
import Data.Maybe (fromMaybe)
import Opaleye hiding (null) import Opaleye hiding (null)
import qualified Opaleye.Constant as C import qualified Opaleye.Constant as C
@ -44,8 +41,6 @@ import qualified Opaleye.Constant as C
import Types.Auth import Types.Auth
import Types.Reader import Types.Reader
import Model.User
initToken :: PGS.Query initToken :: PGS.Query
initToken = mconcat initToken = mconcat
@ -112,12 +107,17 @@ authDataTable = table "auth_data" (
delayTime :: Int delayTime :: Int
delayTime = 1 * 10 ^ (6 :: Int) delayTime = 1 * 10 ^ (6 :: Int)
generateRandomText :: IO T.Text
generateRandomText = decodeUtf8 <$> random 23
getUserAuthInfo getUserAuthInfo
:: Int :: Int
-> AuthMethod -> AuthMethod
-> PGS.Connection
-> MateHandler AuthInfo -> MateHandler AuthInfo
getUserAuthInfo uid method = do getUserAuthInfo uid method conn = do
conn <- rsConnection <$> ask
authdata <- liftIO $ do authdata <- liftIO $ do
void $ threadDelay delayTime void $ threadDelay delayTime
runSelect conn ( runSelect conn (
@ -135,19 +135,27 @@ getUserAuthInfo uid method = do
then then
-- generate mock AuthInfo -- generate mock AuthInfo
liftIO $ do liftIO $ do
rand1 <- decodeUtf8 <$> random 23 rand1 <- generateRandomText
rand2 <- case method of rand2 <- case method of
ChallengeResponse -> Just <$> decodeUtf8 <$> random 23 ChallengeResponse -> Just <$> generateRandomText
_ -> return Nothing _ -> return Nothing
return $ AuthInfo rand2 (AuthTicket rand1) return $ AuthInfo rand2 (AuthTicket rand1)
else else
uncurry AuthInfo <$> newTicket uid method uncurry AuthInfo <$> newTicket uid method
putUserAuthInfo
:: Int
-> AuthMethod
-> PGS.Connection
-> MateHandler Int
putUserAuthInfo uid method conn = error "Not yet implemented: putUserAuthInfo"
validateToken validateToken
:: ByteString :: ByteString
-> PGS.Connection -> PGS.Connection
-> Handler (Maybe Int) -> Handler (Maybe (Int, AuthMethod))
validateToken header conn = do validateToken header conn = do
tokens <- liftIO $ runSelect conn ( tokens <- liftIO $ runSelect conn (
keepWhen (\(tstr, _, _, _) -> keepWhen (\(tstr, _, _, _) ->
@ -163,7 +171,7 @@ validateToken header conn = do
[(_, uid, stamp, method)] -> do [(_, uid, stamp, method)] -> do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
if diffUTCTime stamp now > 0 if diffUTCTime stamp now > 0
then return $ Just uid then return $ Just (uid, toEnum method)
else do else do
void $ deleteToken (decodeUtf8 header) conn void $ deleteToken (decodeUtf8 header) conn
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
@ -180,9 +188,9 @@ validateToken header conn = do
generateToken generateToken
:: Ticket :: Ticket
-> AuthResponse -> AuthResponse
-> PGS.Connection
-> MateHandler AuthResult -> MateHandler AuthResult
generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) = do generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
conn <- rsConnection <$> ask
authData <- liftIO $ runSelect conn ( authData <- liftIO $ runSelect conn (
keepWhen (\(_, auid, amethod, _) -> keepWhen (\(_, auid, amethod, _) ->
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
@ -202,7 +210,7 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) = do
if authResult if authResult
then do then do
token <- liftIO $ Token token <- liftIO $ Token
<$> (decodeUtf8 <$> random 23) <$> generateRandomText
<*> pure tuid <*> pure tuid
<*> (addUTCTime (23*60) <$> getCurrentTime) <*> (addUTCTime (23*60) <$> getCurrentTime)
<*> pure method <*> pure method
@ -263,9 +271,9 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket) newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do newTicket ident method = do
store <- rsTicketStore <$> ask store <- rsTicketStore <$> ask
rand1 <- liftIO $ (decodeUtf8 <$> random 23) rand1 <- liftIO $ generateRandomText
rand2 <- liftIO $ case method of rand2 <- liftIO $ case method of
ChallengeResponse -> Just <$> (decodeUtf8 <$> random 23) ChallengeResponse -> Just <$> generateRandomText
_ -> return Nothing _ -> return Nothing
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime) later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
let ticket = Ticket let ticket = Ticket
@ -280,9 +288,10 @@ newTicket ident method = do
processAuthRequest processAuthRequest
:: AuthRequest :: AuthRequest
-> S.Set Ticket
-> PGS.Connection
-> MateHandler AuthResult -> MateHandler AuthResult
processAuthRequest (AuthRequest aticket hash) = do processAuthRequest (AuthRequest aticket hash) store conn = do
store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
let mticket = S.filter (\st -> ticketId st == aticket) store let mticket = S.filter (\st -> ticketId st == aticket) store
case S.toList mticket of case S.toList mticket of
[ticket] -> do [ticket] -> do
@ -297,12 +306,12 @@ processAuthRequest (AuthRequest aticket hash) = do
pure 1 <*> pure 1 <*>
liftIO getCurrentTime <*> liftIO getCurrentTime <*>
pure (PrimaryPass, Nothing) pure (PrimaryPass, Nothing)
generateToken mockticket hash generateToken mockticket hash conn
#else #else
return Denied return Denied
#endif #endif
else else
generateToken ticket hash generateToken ticket hash conn
_ -> do _ -> do
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
#if defined(DEVELOP) #if defined(DEVELOP)
@ -312,14 +321,14 @@ processAuthRequest (AuthRequest aticket hash) = do
pure 1 <*> pure 1 <*>
liftIO getCurrentTime <*> liftIO getCurrentTime <*>
pure (PrimaryPass, Nothing) pure (PrimaryPass, Nothing)
generateToken mockticket hash generateToken mockticket hash conn
#else #else
return Denied return Denied
#endif #endif
processLogout processLogout
:: Int :: Int
-> PGS.Connection
-> MateHandler () -> MateHandler ()
processLogout uid = do processLogout uid conn = do
conn <- rsConnection <$> ask
void $ deleteTokenByUserId uid conn void $ deleteTokenByUserId uid conn