WIP: feature specs for auth
This commit is contained in:
Joe Nelson
+76
-63
@@ -75,85 +75,98 @@ filterByKeys m keys =
|
||||
if null keys then m else
|
||||
m `intersection` fromList (zip keys $ repeat undefined)
|
||||
|
||||
httpRequesterRole :: RequestHeaders -> Connection -> IO(Maybe DbRole)
|
||||
httpRequesterRole :: RequestHeaders -> Connection -> IO LoginAttempt
|
||||
httpRequesterRole hdrs conn = do
|
||||
let auth = fromMaybe "" $ lookup hAuthorization hdrs
|
||||
case BS.split ' ' (cs auth) of
|
||||
("Basic " : b64 : _) ->
|
||||
case BS.split ':' $ cs (decode $ cs b64) of
|
||||
(u:p:_) -> signInRole u p conn
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
_ -> return MalformedAuth
|
||||
_ -> return NoCredentials
|
||||
|
||||
|
||||
app :: Connection -> DbRole -> Application
|
||||
app conn anonymous req respond = do
|
||||
r <- try $ do
|
||||
role <- fromMaybe anonymous <$> httpRequesterRole hdrs conn
|
||||
attempt <- httpRequesterRole (requestHeaders req) conn
|
||||
|
||||
bracket_ (pgSetRole conn role) (pgResetRole conn) $
|
||||
case (path, verb) of
|
||||
([], _) ->
|
||||
responseLBS status200 [jsonContentType] <$> printTables ver conn
|
||||
case attempt of
|
||||
MalformedAuth ->
|
||||
respond $ responseLBS status400 [] "Malformed basic auth header"
|
||||
LoginFailed ->
|
||||
respond $ responseLBS status403 [] "Invalid username or password"
|
||||
LoginSuccess role ->
|
||||
bracket_ (pgSetRole conn role) (pgResetRole conn) $ appWithRole conn req respond
|
||||
NoCredentials ->
|
||||
bracket_ (pgSetRole conn anonymous) (pgResetRole conn) $ appWithRole conn req respond
|
||||
|
||||
([table], "OPTIONS") ->
|
||||
responseLBS status200 [jsonContentType, allOrigins] <$>
|
||||
printColumns ver (cs table) conn
|
||||
|
||||
([table], "GET") ->
|
||||
if range == Just emptyRange
|
||||
then return $ responseLBS status416 [] "HTTP Range error"
|
||||
else do
|
||||
r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
|
||||
let canonical = urlEncodeVars $ sort $
|
||||
map (join (***) cs) $
|
||||
parseSimpleQuery $
|
||||
rawQueryString req
|
||||
return $ addHeaders [
|
||||
("Content-Location",
|
||||
"/" <> cs table <> "?" <> cs canonical
|
||||
)] r
|
||||
appWithRole :: Connection -> Application
|
||||
appWithRole conn req respond = do
|
||||
r <- try $
|
||||
case (path, verb) of
|
||||
([], _) ->
|
||||
responseLBS status200 [jsonContentType] <$> printTables ver conn
|
||||
|
||||
([table], "POST") ->
|
||||
jsonBodyAction req (\row -> do
|
||||
allvals <- insert ver table row conn
|
||||
keys <- primaryKeyColumns ver (cs table) conn
|
||||
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
|
||||
return $ responseLBS status201
|
||||
[ jsonContentType
|
||||
, (hLocation, "/" <> cs table <> "?" <> cs params)
|
||||
] ""
|
||||
)
|
||||
([table], "OPTIONS") ->
|
||||
responseLBS status200 [jsonContentType, allOrigins] <$>
|
||||
printColumns ver (cs table) conn
|
||||
|
||||
([table], "PUT") ->
|
||||
jsonBodyAction req (\row -> do
|
||||
keys <- primaryKeyColumns ver (cs table) conn
|
||||
let specifiedKeys = map (cs . fst) qq
|
||||
if S.fromList keys /= S.fromList specifiedKeys
|
||||
then return $ responseLBS status405 []
|
||||
"You must speficy all and only primary keys as params"
|
||||
else
|
||||
if isJust cRange
|
||||
then return $ responseLBS status400 []
|
||||
"Content-Range is not allowed in PUT request"
|
||||
else do
|
||||
cols <- columns ver (cs table) conn
|
||||
let colNames = S.fromList $ map (cs . colName) cols
|
||||
let specifiedCols = S.fromList $ map fst $ getRow row
|
||||
if colNames == specifiedCols then do
|
||||
allvals <- upsert ver table row qq conn
|
||||
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
|
||||
return $ responseLBS status201
|
||||
[ jsonContentType
|
||||
, (hLocation, "/" <> cs table <> "?" <> cs params)
|
||||
] ""
|
||||
([table], "GET") ->
|
||||
if range == Just emptyRange
|
||||
then return $ responseLBS status416 [] "HTTP Range error"
|
||||
else do
|
||||
r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
|
||||
let canonical = urlEncodeVars $ sort $
|
||||
map (join (***) cs) $
|
||||
parseSimpleQuery $
|
||||
rawQueryString req
|
||||
return $ addHeaders [
|
||||
("Content-Location",
|
||||
"/" <> cs table <> "?" <> cs canonical
|
||||
)] r
|
||||
|
||||
else return $ if S.null colNames then responseLBS status404 [] ""
|
||||
else responseLBS status400 []
|
||||
"You must specify all columns in PUT request"
|
||||
)
|
||||
([table], "POST") ->
|
||||
jsonBodyAction req (\row -> do
|
||||
allvals <- insert ver table row conn
|
||||
keys <- primaryKeyColumns ver (cs table) conn
|
||||
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
|
||||
return $ responseLBS status201
|
||||
[ jsonContentType
|
||||
, (hLocation, "/" <> cs table <> "?" <> cs params)
|
||||
] ""
|
||||
)
|
||||
|
||||
(_, _) ->
|
||||
return $ responseLBS status404 [] ""
|
||||
([table], "PUT") ->
|
||||
jsonBodyAction req (\row -> do
|
||||
keys <- primaryKeyColumns ver (cs table) conn
|
||||
let specifiedKeys = map (cs . fst) qq
|
||||
if S.fromList keys /= S.fromList specifiedKeys
|
||||
then return $ responseLBS status405 []
|
||||
"You must speficy all and only primary keys as params"
|
||||
else
|
||||
if isJust cRange
|
||||
then return $ responseLBS status400 []
|
||||
"Content-Range is not allowed in PUT request"
|
||||
else do
|
||||
cols <- columns ver (cs table) conn
|
||||
let colNames = S.fromList $ map (cs . colName) cols
|
||||
let specifiedCols = S.fromList $ map fst $ getRow row
|
||||
if colNames == specifiedCols then do
|
||||
allvals <- upsert ver table row qq conn
|
||||
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
|
||||
return $ responseLBS status201
|
||||
[ jsonContentType
|
||||
, (hLocation, "/" <> cs table <> "?" <> cs params)
|
||||
] ""
|
||||
|
||||
else return $ if S.null colNames then responseLBS status404 [] ""
|
||||
else responseLBS status400 []
|
||||
"You must specify all columns in PUT request"
|
||||
)
|
||||
|
||||
(_, _) ->
|
||||
return $ responseLBS status404 [] ""
|
||||
|
||||
respond $ either sqlErrorHandler id r
|
||||
|
||||
|
||||
+25
-17
@@ -3,16 +3,17 @@
|
||||
-- {{{ Imports
|
||||
|
||||
module PgQuery (
|
||||
getRows,
|
||||
insert,
|
||||
upsert,
|
||||
addUser,
|
||||
signInRole,
|
||||
pgSetRole,
|
||||
pgResetRole,
|
||||
checkPass,
|
||||
RangedResult(..),
|
||||
DbRole
|
||||
getRows
|
||||
, insert
|
||||
, upsert
|
||||
, addUser
|
||||
, signInRole
|
||||
, pgSetRole
|
||||
, pgResetRole
|
||||
, checkPass
|
||||
, RangedResult(..)
|
||||
, LoginAttempt(..)
|
||||
, DbRole
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
@@ -50,6 +51,13 @@ type QuotedSql = (String, [SqlValue])
|
||||
type Schema = String
|
||||
type DbRole = BS.ByteString
|
||||
|
||||
data LoginAttempt =
|
||||
NoCredentials
|
||||
| MalformedAuth
|
||||
| LoginFailed
|
||||
| LoginSuccess DbRole
|
||||
deriving (Eq, Show)
|
||||
|
||||
getRows :: Schema -> String -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult
|
||||
getRows schema table qq range conn = do
|
||||
query <- populateSql conn
|
||||
@@ -132,18 +140,18 @@ addUser identity pass role conn = do
|
||||
]) conn
|
||||
return ()
|
||||
|
||||
checkPass :: BS.ByteString -> BS.ByteString -> Bool
|
||||
checkPass = validatePassword
|
||||
|
||||
signInRole :: BS.ByteString -> BS.ByteString -> Connection -> IO(Maybe DbRole)
|
||||
signInRole :: BS.ByteString -> BS.ByteString -> Connection -> IO LoginAttempt
|
||||
signInRole user pass conn = do
|
||||
u <- quickQuery conn "select pass, rolname from dbapi.auth where id = ?" [toSql user]
|
||||
return $ case u of
|
||||
[[hashed, role]] ->
|
||||
if checkPass (fromSql hashed) (cs pass)
|
||||
then Just $ fromSql role
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
then LoginSuccess $ fromSql role
|
||||
else LoginFailed
|
||||
_ -> LoginFailed
|
||||
|
||||
checkPass :: BS.ByteString -> BS.ByteString -> Bool
|
||||
checkPass = validatePassword
|
||||
|
||||
upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> IO (M.Map String SqlValue)
|
||||
upsert schema table row qq conn = do
|
||||
|
||||
Reference in New Issue
Block a user