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
authProxy :: Proxy '[ AuthHandler Request (Maybe Int) ]
authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
authProxy = Proxy
genAuthServerContext
:: Connection
-> Context '[ AuthHandler Request (Maybe Int) ]
-> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
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
where
handler :: Request -> Handler (Maybe Int)
handler :: Request -> Handler (Maybe (Int, AuthMethod))
handler req = do
let headers = requestHeaders req
res <- case lookup "Authentication" headers of

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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