rework auth
This commit is contained in:
parent
ac6034761d
commit
c3322a54de
6 changed files with 170 additions and 15 deletions
|
@ -62,6 +62,10 @@ app initState =
|
|||
authSend :<|>
|
||||
authLogout :<|>
|
||||
|
||||
authManageList :<|>
|
||||
authManageNewAuth :<|>
|
||||
authManageDeleteAuth :<|>
|
||||
|
||||
userNew :<|>
|
||||
userGet :<|>
|
||||
userUpdate :<|>
|
||||
|
|
|
@ -22,11 +22,18 @@ type MateAPI =
|
|||
:<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
|
||||
:<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] ()
|
||||
|
||||
:<|> "auth" :> "manage" :> AuthProtect "header-auth"
|
||||
:> Get '[JSON] [AuthOverview]
|
||||
:<|> "auth" :> "manage" :> AuthProtect "header-auth"
|
||||
:> ReqBody '[JSON] AuthSubmit :> Post '[JSON] Int
|
||||
:<|> "auth" :> "manage" :> AuthProtect "header-auth"
|
||||
:> ReqBody '[JSON] Int :> Delete '[JSON] ()
|
||||
|
||||
:<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
|
||||
:<|> "user" :> AuthProtect "header-auth"
|
||||
:> Capture "uid'" Int :> Get '[JSON] UserDetails
|
||||
:<|> "user" :> AuthProtect "header-auth"
|
||||
:> Capture "uid'" Int :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] ()
|
||||
:> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] ()
|
||||
:<|> "user" :> "list" :> QueryParam "refine" UserRefine :> Get '[JSON] [UserSummary]
|
||||
:<|> "user" :> "recharge" :> AuthProtect "header-auth"
|
||||
:> ReqBody '[JSON] UserRecharge :> Post '[JSON] ()
|
||||
|
|
|
@ -3,6 +3,8 @@ module Control.Auth where
|
|||
|
||||
import Servant
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
|
@ -36,3 +38,76 @@ authLogout Nothing = do
|
|||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
|
||||
authManageList
|
||||
:: Maybe (Int, AuthMethod)
|
||||
-> MateHandler [AuthOverview]
|
||||
authManageList (Just (uid, method)) =
|
||||
if any (== method) [PrimaryPass, ChallengeResponse]
|
||||
then do
|
||||
conn <- rsConnection <$> ask
|
||||
selectAuthOverviews uid conn
|
||||
else
|
||||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
authManageList Nothing =
|
||||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
|
||||
authManageNewAuth
|
||||
:: Maybe (Int, AuthMethod)
|
||||
-> AuthSubmit
|
||||
-> MateHandler Int
|
||||
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = do
|
||||
if any (== method) [PrimaryPass, ChallengeResponse]
|
||||
then do
|
||||
conn <- rsConnection <$> ask
|
||||
putUserAuthInfo uid asmethod ascomment aspayload conn
|
||||
else
|
||||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
authManageNewAuth Nothing _ =
|
||||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
|
||||
authManageDeleteAuth
|
||||
:: Maybe (Int, AuthMethod)
|
||||
-> Int
|
||||
-> MateHandler ()
|
||||
authManageDeleteAuth (Just (uid, method)) adid = do
|
||||
if any (== method) [PrimaryPass, ChallengeResponse]
|
||||
then do
|
||||
conn <- rsConnection <$> ask
|
||||
ads <- selectAuthOverviews uid conn
|
||||
let currentad = head (filter (\ad -> authOverviewId ad == adid) ads)
|
||||
case authOverviewMethod currentad of
|
||||
PrimaryPass -> if validateDeletion ads
|
||||
then void (deleteAuthDataById adid conn)
|
||||
else throwError $ err406
|
||||
{ errBody = "You need at least one primary password or challenge response authentication"
|
||||
}
|
||||
ChallengeResponse -> if validateDeletion ads
|
||||
then void (deleteAuthDataById adid conn)
|
||||
else throwError $ err406
|
||||
{ errBody = "You need at least one primary password or challenge response authentication"
|
||||
}
|
||||
_ -> void $ deleteAuthDataById adid conn
|
||||
else
|
||||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
where
|
||||
validateDeletion ads =
|
||||
2 <= length (filter
|
||||
(\ad -> authOverviewMethod ad == PrimaryPass ||
|
||||
authOverviewMethod ad == ChallengeResponse)
|
||||
ads
|
||||
)
|
||||
authManageDeleteAuth Nothing _ = do
|
||||
throwError $ err401
|
||||
{ errBody = "Unauthorized access"
|
||||
}
|
||||
|
|
|
@ -27,7 +27,7 @@ userNew (UserSubmit ident email passhash) = do
|
|||
now <- liftIO $ getCurrentTime
|
||||
conn <- rsConnection <$> ask
|
||||
uid <- insertUser ident email (utctDay now) conn
|
||||
void $ putUserAuthInfo uid PrimaryPass passhash conn
|
||||
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
|
||||
return uid
|
||||
|
||||
userGet
|
||||
|
@ -50,19 +50,18 @@ userGet (Just (aid, method)) uid =
|
|||
|
||||
userUpdate
|
||||
:: Maybe (Int, AuthMethod)
|
||||
-> Int
|
||||
-> UserDetailsSubmit
|
||||
-> MateHandler ()
|
||||
userUpdate Nothing _ _ =
|
||||
userUpdate Nothing _ =
|
||||
throwError $ err401
|
||||
{ errBody = "No Authentication present."
|
||||
}
|
||||
userUpdate (Just (aid, method)) uid uds =
|
||||
if aid == uid && any (== method) [PrimaryPass, ChallengeResponse]
|
||||
userUpdate (Just (aid, method)) uds =
|
||||
if any (== method) [PrimaryPass, ChallengeResponse]
|
||||
then do
|
||||
now <- liftIO $ getCurrentTime
|
||||
conn <- rsConnection <$> ask
|
||||
void $ updateUserDetails uid uds (utctDay now) conn
|
||||
void $ updateUserDetails aid uds (utctDay now) conn
|
||||
else
|
||||
throwError $ err401
|
||||
{ errBody = "Wrong Authentication present."
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
module Model.Auth where
|
||||
|
||||
import Servant
|
||||
|
||||
import Control.Arrow ((<<<))
|
||||
import Control.Arrow
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
|
@ -17,7 +18,7 @@ import Control.Concurrent (threadDelay)
|
|||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
import Data.Profunctor.Product (p4)
|
||||
import Data.Profunctor.Product (p4, p5)
|
||||
|
||||
import qualified Database.PostgreSQL.Simple as PGS
|
||||
|
||||
|
@ -79,6 +80,7 @@ initAuthData = mconcat
|
|||
, "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 TEXT NOT NULL"
|
||||
, ")"
|
||||
]
|
||||
|
@ -88,17 +90,20 @@ authDataTable :: Table
|
|||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlText
|
||||
, Field SqlText
|
||||
)
|
||||
( Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlText
|
||||
, Field SqlText
|
||||
)
|
||||
authDataTable = table "auth_data" (
|
||||
p4
|
||||
p5
|
||||
( tableField "auth_data_id"
|
||||
, tableField "auth_data_user"
|
||||
, tableField "auth_data_method"
|
||||
, tableField "auth_data_comment"
|
||||
, tableField "auth_data_payload"
|
||||
)
|
||||
)
|
||||
|
@ -112,6 +117,29 @@ generateRandomText :: IO T.Text
|
|||
generateRandomText = decodeUtf8 <$> random 23
|
||||
|
||||
|
||||
selectAuthOverviews
|
||||
:: Int
|
||||
-> PGS.Connection
|
||||
-> MateHandler [AuthOverview]
|
||||
selectAuthOverviews uid conn = do
|
||||
authData <- liftIO $ runSelect conn ( proc () -> do
|
||||
(adid, aduid, admethod, adcomment, adpayload) <-
|
||||
queryTable authDataTable -< ()
|
||||
restrict -< aduid .== C.constant uid
|
||||
returnA -< (adid, adcomment, admethod)
|
||||
) :: MateHandler
|
||||
[ ( Int
|
||||
, T.Text
|
||||
, Int
|
||||
)
|
||||
]
|
||||
return $ map
|
||||
(\(adid, adcomment, admethod) ->
|
||||
AuthOverview adid adcomment (toEnum admethod)
|
||||
)
|
||||
authData
|
||||
|
||||
|
||||
getUserAuthInfo
|
||||
:: Int
|
||||
-> AuthMethod
|
||||
|
@ -121,7 +149,7 @@ getUserAuthInfo uid method conn = do
|
|||
authdata <- liftIO $ do
|
||||
void $ threadDelay delayTime
|
||||
runSelect conn (
|
||||
keepWhen (\(_, duid, dmethod, _) ->
|
||||
keepWhen (\(_, duid, dmethod, _, _) ->
|
||||
duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method))
|
||||
<<< queryTable authDataTable
|
||||
) :: IO
|
||||
|
@ -129,6 +157,7 @@ getUserAuthInfo uid method conn = do
|
|||
, Int
|
||||
, Int
|
||||
, T.Text
|
||||
, T.Text
|
||||
)
|
||||
]
|
||||
if null authdata
|
||||
|
@ -148,9 +177,10 @@ putUserAuthInfo
|
|||
:: Int
|
||||
-> AuthMethod
|
||||
-> T.Text
|
||||
-> T.Text
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
putUserAuthInfo uid method payload conn =
|
||||
putUserAuthInfo uid method comment payload conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = authDataTable
|
||||
, iRows =
|
||||
|
@ -158,14 +188,26 @@ putUserAuthInfo uid method payload conn =
|
|||
( C.constant (Nothing :: Maybe Int)
|
||||
, C.constant uid
|
||||
, C.constant (fromEnum method)
|
||||
, C.constant comment
|
||||
, C.constant payload
|
||||
)
|
||||
]
|
||||
, iReturning = rReturning (\(adid, _, _, _) -> adid)
|
||||
, iReturning = rReturning (\(adid, _, _, _, _) -> adid)
|
||||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
|
||||
deleteAuthDataById
|
||||
:: Int
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int64
|
||||
deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
|
||||
{ dTable = authDataTable
|
||||
, dWhere = (\(aid, _, _, _, _) -> aid .== C.constant adid)
|
||||
, dReturning = rCount
|
||||
}
|
||||
|
||||
|
||||
validateToken
|
||||
:: ByteString
|
||||
-> PGS.Connection
|
||||
|
@ -206,7 +248,7 @@ generateToken
|
|||
-> MateHandler AuthResult
|
||||
generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
|
||||
authData <- liftIO $ runSelect conn (
|
||||
keepWhen (\(_, auid, amethod, _) ->
|
||||
keepWhen (\(_, auid, amethod, _, _) ->
|
||||
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
|
||||
<<< queryTable authDataTable
|
||||
) :: MateHandler
|
||||
|
@ -214,9 +256,10 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
|
|||
, Int
|
||||
, Int
|
||||
, T.Text
|
||||
, T.Text
|
||||
)
|
||||
]
|
||||
let userPayloads = map (\(_, _, _, payload) -> payload) authData
|
||||
let userPayloads = map (\(_, _, _, _, payload) -> payload) authData
|
||||
authResult = case method of
|
||||
PrimaryPass -> validatePass response userPayloads
|
||||
SecondaryPass -> validatePass response userPayloads
|
||||
|
|
|
@ -53,6 +53,19 @@ instance ToJSON AuthMethod where
|
|||
instance FromJSON AuthMethod
|
||||
|
||||
|
||||
data AuthSubmit = AuthSubmit
|
||||
{ authSubmitMethod :: AuthMethod
|
||||
, authSubmitComment :: T.Text
|
||||
, authSubmitPayload :: T.Text
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthSubmit where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthSubmit
|
||||
|
||||
|
||||
newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord)
|
||||
|
||||
instance ToJSON AuthTicket where
|
||||
|
@ -130,6 +143,20 @@ data AuthData = AuthData
|
|||
{ authDataId :: Int
|
||||
, authDataUser :: Int
|
||||
, authDataMethod :: AuthMethod
|
||||
, authDataComment :: T.Text
|
||||
, authDataPayload :: T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
data AuthOverview = AuthOverview
|
||||
{ authOverviewId :: Int
|
||||
, authOverviewComment :: T.Text
|
||||
, authOverviewMethod :: AuthMethod
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthOverview where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthOverview
|
||||
|
|
Loading…
Reference in a new issue