diff --git a/src/App.hs b/src/App.hs index bf1359c7c..fa589da77 100644 --- a/src/App.hs +++ b/src/App.hs @@ -96,7 +96,7 @@ app req = Nothing -> return $ responseLBS status400 [jsonH] $ encode . object $ [("error", String "Failed to parse user.")] Just u -> do - _ <- liftIO $ addUser (cs $ userId u) + _ <- addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) return $ responseLBS status201 [ jsonH diff --git a/src/Auth.hs b/src/Auth.hs index 4e86d31fd..87add40f0 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,20 +1,23 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} module Auth where import Data.Aeson import Control.Monad (mzero) import Control.Applicative ( (<*>), (<$>) ) +import Control.Monad.IO.Class (liftIO) import Crypto.BCrypt import Data.Text +import Data.Monoid import qualified Hasql as H import qualified Hasql.Postgres as H import Data.String.Conversions (cs) +import PgQuery (pgFmtLit) data AuthUser = AuthUser { userId :: String , userPass :: String , userRole :: String - } + } deriving (Show) instance FromJSON AuthUser where parseJSON (Object v) = AuthUser <$> @@ -42,17 +45,17 @@ checkPass :: Text -> Text -> Bool checkPass = (. cs) . validatePassword . cs setRole :: Text -> H.Tx H.Postgres s () -setRole role = H.unit $ [H.q| set role ?|] role +setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True) resetRole :: H.Tx H.Postgres s () resetRole = H.unit [H.q|reset role|] -addUser :: Text -> Text -> Text -> IO(H.Tx H.Postgres s ()) +addUser :: Text -> Text -> Text -> H.Session H.Postgres IO () addUser identity pass role = do - Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) - return $ H.unit $ + Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) + H.tx Nothing $ H.unit $ [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|] - identity hashed role + identity (cs hashed :: Text) role signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt signInRole user pass = do diff --git a/src/Main.hs b/src/Main.hs index bd4decb9c..890f2a567 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,6 @@ module Main where import Paths_dbapi (version) import App ---import Auth import Middleware import Control.Monad (unless) @@ -50,7 +49,9 @@ main = do H.session pgSettings sessSettings $ do session' <- flip runReaderT <$> ask let runApp req respond = - respond =<< catchJust isSqlError (session' $ app req) sqlErrHandler + respond =<< catchJust isSqlError + (session' $ authenticated (cs $ configAnonRole conf) app req) + sqlErrHandler liftIO $ runSettings appSettings $ middle runApp -- . authenticated (cs $ configAnonRole conf) $ app diff --git a/src/Middleware.hs b/src/Middleware.hs index 519984964..85529de2d 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -3,23 +3,25 @@ module Middleware where --import Data.Aeson ((.=), toJSON, ToJSON, object, encode) --- import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) +import Data.Text -- import Data.Pool(withResource, Pool) import qualified Hasql as H +import qualified Hasql.Postgres as H import Data.String.Conversions(cs) ---import qualified Data.ByteString.Char8 as BS import Control.Exception (catchJust) -import Network.HTTP.Types.Header (hLocation, hContentType) -import Network.HTTP.Types.Status (status400, status301) +import Network.HTTP.Types.Header (hLocation, hContentType, hAuthorization) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Status (status400, status401, status301) import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, - rawQueryString, isSecure) + rawQueryString, isSecure, Request(..), Response) import Network.URI (URI(..), parseURI) --- import Auth (LoginAttempt(..), signInRole, setRole, resetRole) --- import Codec.Binary.Base64.String (decode) +import Auth (LoginAttempt(..), signInRole, setRole, resetRole) +import Codec.Binary.Base64.String (decode) import Debug.Trace @@ -36,30 +38,35 @@ import Debug.Trace -- else Database.PostgreSQL.Simple.withSavepoint conn go -- where go = app conn req respond --- authenticated :: BS.ByteString -> (Connection -> Application) -> --- Connection -> Application --- authenticated anon app conn req respond = do --- attempt <- httpRequesterRole (requestHeaders req) --- case attempt of --- MalformedAuth -> --- respond $ responseLBS status400 [] "Malformed basic auth header" --- LoginFailed -> --- respond $ responseLBS status401 [] "Invalid username or password" --- LoginSuccess role -> --- bracket_ (setRole conn role) (resetRole conn) $ app conn req respond --- NoCredentials -> --- bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond +authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) -> + Request -> H.Session H.Postgres IO Response +authenticated anon app req = do + attempt <- httpRequesterRole (requestHeaders req) + case attempt of + MalformedAuth -> + return $ responseLBS status400 [] "Malformed basic auth header" + LoginFailed -> + return $ responseLBS status401 [] "Invalid username or password" + LoginSuccess role -> runInRole role + NoCredentials -> runInRole anon --- where --- httpRequesterRole :: RequestHeaders -> IO LoginAttempt --- httpRequesterRole hdrs = 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 conn u p --- _ -> return MalformedAuth --- _ -> return NoCredentials + where + httpRequesterRole :: RequestHeaders -> H.Session H.Postgres IO LoginAttempt + httpRequesterRole hdrs = do + let auth = fromMaybe "" $ lookup hAuthorization hdrs + case split (==' ') (cs auth) of + ("Basic" : b64 : _) -> + case split (==':') (cs . decode . cs $ b64) of + (u:p:_) -> H.tx Nothing $ signInRole u p + _ -> return MalformedAuth + _ -> return NoCredentials + + runInRole :: Text -> H.Session H.Postgres IO Response + runInRole r = do + H.tx Nothing $ setRole r + resp <- app req + H.tx Nothing resetRole + return resp -- instance ToJSON SqlError where -- toJSON t = object [ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 73b0c139f..17998e0e1 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -8,21 +8,17 @@ import Test.Hspec.Wai.JSON import SpecHelper import Network.HTTP.Types -import Codec.Binary.Base64.String (encode) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) spec :: Spec spec = around withApp $ do - let uName = "a user" - uPass = "nobody can ever know" describe "GET /" $ - it "lists views in schema" $ - request methodGet "/" - [("Authorization", "Basic "<>(uName<>":"<>uPass))] "" + it "lists views in schema" $ do + _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |] + let auth = authHeader "jdoe" "1234" + + request methodGet "/" [auth] "" `shouldRespondWith` [json| [ - {"schema":"1","name":"authors_only","insertable":true} - , {"schema":"1","name":"auto_incrementing_pk","insertable":true} + {"schema":"1","name":"auto_incrementing_pk","insertable":true} , {"schema":"1","name":"compound_pk","insertable":true} , {"schema":"1","name":"has_fk","insertable":true} , {"schema":"1","name":"items","insertable":true} @@ -136,8 +132,7 @@ spec = around withApp $ do |] it "includes foreign key data" $ - request methodOptions "/has_fk" - [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] "" + request methodOptions "/has_fk" [] "" `shouldRespondWith` [json| { "pkey": ["id"], diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 88331e21f..12fd93049 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -27,15 +27,16 @@ import Network.Wai.Middleware.Cors (cors) import System.Process (readProcess) import App (app, sqlErrHandler, isSqlError) -import Config (corsPolicy) +import Config (AppConfig(..), corsPolicy) +import Middleware -- import Auth (addUser) isLeft :: Either a b -> Bool isLeft (Left _ ) = True isLeft _ = False --- cfg :: AppConfig --- cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 +cfg :: AppConfig +cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 testSettings :: SessionSettings testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30 @@ -48,8 +49,9 @@ withApp perform = perform $ middle $ \req resp -> H.session pgSettings testSettings $ do session' <- flip runReaderT <$> ask - liftIO $ resp =<< catchJust isSqlError (session' $ app req) - sqlErrHandler + liftIO $ resp =<< catchJust isSqlError + (session' $ authenticated (cs $ configAnonRole cfg) app req) + sqlErrHandler where middle = cors corsPolicy