rework auth

This commit is contained in:
nek0 2019-09-16 08:59:57 +02:00
parent ac6034761d
commit c3322a54de
6 changed files with 170 additions and 15 deletions

View file

@ -62,6 +62,10 @@ app initState =
authSend :<|>
authLogout :<|>
authManageList :<|>
authManageNewAuth :<|>
authManageDeleteAuth :<|>
userNew :<|>
userGet :<|>
userUpdate :<|>

View file

@ -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] ()

View file

@ -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"
}

View file

@ -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."

View file

@ -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

View file

@ -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