diff --git a/dbapi.cabal b/postgrest.cabal similarity index 98% rename from dbapi.cabal rename to postgrest.cabal index a3b6c8f59..2de6598d9 100644 --- a/dbapi.cabal +++ b/postgrest.cabal @@ -1,4 +1,4 @@ -name: dbapi +name: postgrest version: 0.2.4.6 synopsis: The database is your api license: MIT @@ -9,7 +9,7 @@ category: Web build-type: Simple cabal-version: >=1.10 -executable dbapi +executable postgrest main-is: Main.hs ghc-options: -Wall -W -Werror -O2 default-language: Haskell2010 diff --git a/src/App.hs b/src/App.hs index 473024ace..783658da9 100644 --- a/src/App.hs +++ b/src/App.hs @@ -4,8 +4,6 @@ module App (app, sqlErrHandler, isSqlError) where import Control.Monad (join) import Control.Arrow ((***)) import Control.Applicative -import Control.Monad.IO.Class (liftIO, MonadIO) --- import Control.Exception.Base import Data.Text hiding (map) import Data.Maybe (fromMaybe) @@ -18,6 +16,7 @@ import Data.List (sortBy) import Data.Functor.Identity import Data.Scientific (isInteger, formatScientific, FPFormat(..)) import qualified Data.Set as S +import qualified Data.ByteString.Lazy as BL import Network.HTTP.Types.Status import Network.HTTP.Types.Header @@ -35,20 +34,19 @@ import RangeQuery import PgStructure import Auth -app :: Request -> H.Session H.Postgres s IO Response -app req = +app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response +app reqBody req = case (path, verb) of ([], _) -> do - body <- H.tx Nothing $ encode <$> tables (cs schema) + body <- encode <$> tables (cs schema) return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do let t = QualifiedTable schema (cs table) - H.tx Nothing $ do - cols <- columns t - pkey <- map cs <$> primaryKeyColumns t - return $ responseLBS status200 [jsonH, allOrigins] - $ encode (TableOptions cols pkey) + cols <- columns t + pkey <- map cs <$> primaryKeyColumns t + return $ responseLBS status200 [jsonH, allOrigins] + $ encode (TableOptions cols pkey) ([table], "GET") -> if range == Just emptyRange @@ -66,7 +64,7 @@ app req = . whereT qq $ selectStar qt ) - row <- H.tx Nothing $ H.single select + row <- H.single select let (tableTotal, queryTotal, body) = fromMaybe (0, 0, Just "" :: Maybe Text) row from = fromMaybe 0 $ rangeOffset <$> range @@ -87,8 +85,7 @@ app req = ] (cs $ fromMaybe "[]" body) (["dbapi", "users"], "POST") -> do - body <- liftIO $ strictRequestBody req - let user = decode body :: Maybe AuthUser + let user = decode reqBody :: Maybe AuthUser case user of Nothing -> return $ responseLBS status400 [jsonH] $ @@ -102,7 +99,7 @@ app req = ] "" ([table], "POST") -> - handleJsonObj req $ \obj -> H.tx Nothing $ do + handleJsonObj reqBody $ \obj -> do let qt = QualifiedTable schema (cs table) query = coerce $ insertInto qt (map cs $ keys obj) (elems obj) @@ -123,7 +120,7 @@ app req = ] "" ([table], "PUT") -> - handleJsonObj req $ \obj -> H.tx Nothing $ do + handleJsonObj reqBody $ \obj -> do let qt = QualifiedTable schema (cs table) primaryKeys <- primaryKeyColumns qt let specifiedKeys = map (cs . fst) qq @@ -147,7 +144,7 @@ app req = "You must specify all columns in PUT request" ([table], "PATCH") -> - handleJsonObj req $ \obj -> H.tx Nothing $ do + handleJsonObj reqBody $ \obj -> do let qt = QualifiedTable schema (cs table) H.unit $ coerce @@ -209,9 +206,10 @@ requestedSchema hdrs = jsonH :: Header jsonH = (hContentType, "application/json") -handleJsonObj :: MonadIO m => Request -> (Object -> m Response) -> m Response -handleJsonObj req handler = do - parse <- liftIO $ fmap eitherDecode . strictRequestBody $ req +handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response) + -> H.Tx H.Postgres s Response +handleJsonObj reqBody handler = do + let parse = eitherDecode reqBody case parse of Left err -> return $ responseLBS status400 [jsonH] jErr diff --git a/src/Auth.hs b/src/Auth.hs index 00fbeec7a..0de069752 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -4,7 +4,6 @@ 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 @@ -13,6 +12,8 @@ import qualified Hasql.Postgres as H import Data.String.Conversions (cs) import PgQuery (pgFmtLit) +import System.IO.Unsafe + data AuthUser = AuthUser { userId :: String , userPass :: String @@ -50,10 +51,10 @@ 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 -> H.Session H.Postgres s IO () +addUser :: Text -> Text -> Text -> H.Tx H.Postgres s () addUser identity pass role = do - Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) - H.tx Nothing $ H.unit $ + let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) + H.unit $ [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|] identity (cs hashed :: Text) role diff --git a/src/Main.hs b/src/Main.hs index d1b663607..abf796d85 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,6 +9,7 @@ import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Exception import Data.String.Conversions (cs) +import Network.Wai (strictRequestBody) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.Gzip (gzip, def) @@ -43,11 +44,14 @@ main = do (if configSecure conf then redirectInsecure else id) . gzip def . cors corsPolicy . clientErrors . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) + anonRole = cs $ configAnonRole conf H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift -> - liftIO $ runSettings appSettings $ middle $ \req respond -> + liftIO $ runSettings appSettings $ middle $ \req respond -> do + body <- strictRequestBody req respond =<< catchJust isSqlError - (unlift $ authenticated (cs $ configAnonRole conf) app req) + (unlift $ H.tx Nothing + $ authenticated anonRole (app body) req) sqlErrHandler where diff --git a/src/Middleware.hs b/src/Middleware.hs index ac5aab73c..ccbb51ca4 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} module Middleware where @@ -38,8 +39,8 @@ import Debug.Trace -- else Database.PostgreSQL.Simple.withSavepoint conn go -- where go = app conn req respond -authenticated :: Text -> (Request -> H.Session H.Postgres s IO Response) -> - Request -> H.Session H.Postgres s IO Response +authenticated :: forall s. Text -> (Request -> H.Tx H.Postgres s Response) -> + Request -> H.Tx H.Postgres s Response authenticated anon app req = do attempt <- httpRequesterRole (requestHeaders req) case attempt of @@ -51,21 +52,22 @@ authenticated anon app req = do NoCredentials -> runInRole anon where - httpRequesterRole :: RequestHeaders -> H.Session H.Postgres s IO LoginAttempt + httpRequesterRole :: RequestHeaders -> H.Tx H.Postgres s 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 + (u:p:_) -> signInRole u p _ -> return MalformedAuth _ -> return NoCredentials + runInRole :: Text -> H.Tx H.Postgres s Response runInRole r = do - H.tx Nothing $ setRole r - resp <- app req - H.tx Nothing resetRole - return resp + setRole r + res <- app req + resetRole + return res -- instance ToJSON SqlError where -- toJSON t = object [ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 3c7e5271e..b9d46065a 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -31,7 +31,7 @@ spec = before resetDb $ around withApp $ do request methodGet "/" [auth] "" `shouldRespondWith` [json| [ - {"schema":"1","name":"authors_only","insertable":true} + {"schema":"1","name":"authors_only","insertable":true} ] |] {matchStatus = 200} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 7108e9032..1139657f8 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -44,10 +44,14 @@ pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" withApp :: ActionWith Application -> IO () withApp perform = + let anonRole = cs $ configAnonRole cfg in perform $ middle $ \req resp -> H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift -> - liftIO $ resp =<< catchJust isSqlError - (unlift $ authenticated (cs $ configAnonRole cfg) app req) + liftIO $ do + body <- strictRequestBody req + resp =<< catchJust isSqlError + (unlift $ H.tx Nothing + $ authenticated anonRole (app body) req) sqlErrHandler where middle = cors corsPolicy