From ffb559cb360ede79708895a09cbb5d5ed1834ba4 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 15 Sep 2019 14:59:22 +0200 Subject: [PATCH] change auth response type --- app/Main.hs | 10 +++--- src/API.hs | 3 +- src/Control/Auth.hs | 36 +++++++++++-------- src/Control/Avatar.hs | 4 +-- src/Control/Buy.hs | 4 +-- src/Control/Journal.hs | 2 +- src/Control/Product.hs | 23 +++++++++--- src/Control/User.hs | 79 +++++++++++++++++++++++++++--------------- src/Model/Auth.hs | 55 +++++++++++++++++------------ 9 files changed, 134 insertions(+), 82 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 82606c3..3c7965e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/API.hs b/src/API.hs index 8d5ef63..4481b7c 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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" diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 0380f4e..4e60134 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -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" } diff --git a/src/Control/Avatar.hs b/src/Control/Avatar.hs index ecfa05c..2a1c49c 100644 --- a/src/Control/Avatar.hs +++ b/src/Control/Avatar.hs @@ -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 () diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index a89fa54..df5f30d 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -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 diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 31cd2b6..563a581 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -11,7 +11,7 @@ import Types import Model.Journal journalShow - :: Maybe Int + :: Maybe (Int, AuthMethod) -> Maybe Int -> Maybe Int -> MateHandler [JournalEntry] diff --git a/src/Control/Product.hs b/src/Control/Product.hs index c92043b..84f21eb 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -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 diff --git a/src/Control/User.hs b/src/Control/User.hs index fc012fe..711a5be 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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 diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index ed3a436..fe30428 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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