diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Joe Nelson + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/postgrest.cabal b/postgrest.cabal new file mode 100644 --- /dev/null +++ b/postgrest.cabal @@ -0,0 +1,93 @@ +name: postgrest +description: Reads the schema of a PostgreSQL database and creates RESTful routes + for the tables and views, supporting all HTTP verbs that security + permits. +version: 0.2.5.0 +synopsis: REST API for any Postgres database +license: MIT +license-file: LICENSE +author: Joe Nelson, Adam Baker +homepage: https://github.com/begriffs/postgrest +maintainer: cred+github@begriffs.com +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable postgrest + main-is: Main.hs + ghc-options: -Wall -W -O2 + default-language: Haskell2010 + default-extensions: OverloadedStrings + other-extensions: QuasiQuotes + build-depends: base >=4.6 && <5 + , hasql == 0.4.*, hasql-backend + , hasql-postgres == 0.8.* + , warp >= 3.0.2, wai >= 3.0.1 + , wai-extra, wai-cors + , wai-middleware-static >= 0.6.0 + , HTTP, convertible, http-types + , case-insensitive + , scientific, time + , aeson, network >= 2.6 + , bytestring, text, split, string-conversions + , stringsearch, parsec + , containers, unordered-containers + , optparse-applicative >= 0.9.1 && < 0.10 + , regex-base, regex-tdfa + , regex-tdfa-text + , Ranged-sets + , transformers + , bcrypt, base64-string + , network-uri >= 2.6 + , resource-pool + , blaze-builder + , vector + , mtl + Other-Modules: App + , Auth + , Config + , PgStructure + , PgQuery + , PgError + , RangeQuery + , Middleware + hs-source-dirs: src + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + default-extensions: OverloadedStrings + other-extensions: QuasiQuotes + Hs-Source-Dirs: test, src + ghc-options: -Wall -W -Werror + Main-Is: Main.hs + Other-Modules: App, Auth, Config, Spec, SpecHelper + Build-Depends: base, hspec >= 2.1.2, QuickCheck + , hspec-wai >= 0.5.0, hspec-wai-json + , hasql == 0.4.*, hasql-backend + , hasql-postgres == 0.8.* + , warp >= 3.0.2, wai >= 3.0.1 + , HTTP, convertible + , case-insensitive + , wai-extra, wai-cors, containers + , wai-middleware-static >= 0.6.0 + , http-types, scientific, time + , bytestring, aeson, network >= 2.6 + , text, optparse-applicative + , stringsearch, parsec + , unordered-containers + , regex-base + , string-conversions + , http-media, regex-tdfa + , regex-tdfa-text + , Ranged-sets + , transformers + , bcrypt + , base64-string + , split + , network-uri >= 2.6 + , resource-pool + , blaze-builder + , vector + , mtl + , process diff --git a/src/App.hs b/src/App.hs new file mode 100644 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE FlexibleContexts #-} +module App (app, sqlError, isSqlError) where + +import Control.Monad (join) +import Control.Arrow ((***)) +import Control.Applicative + +import Data.Text hiding (map) +import Data.Maybe (fromMaybe) +import Text.Regex.TDFA ((=~)) +import Data.Ord (comparing) +import Data.Ranged.Ranges (emptyRange) +import Data.HashMap.Strict (keys, elems, filterWithKey, toList) +import Data.String.Conversions (cs) +import Data.List (sortBy) +import Data.Functor.Identity +import qualified Data.Set as S +import qualified Data.ByteString.Lazy as BL + +import Network.HTTP.Types.Status +import Network.HTTP.Types.Header +import Network.HTTP.Types.URI (parseSimpleQuery) +import Network.HTTP.Base (urlEncodeVars) +import Network.Wai + +import Data.Aeson +import Data.Monoid +import qualified Hasql as H +import qualified Hasql.Postgres as H + +import Auth +import PgQuery +import RangeQuery +import PgStructure +import PgError +import Text.Parsec hiding (Column) + +app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response +app reqBody req = + case (path, verb) of + ([], _) -> do + body <- encode <$> tables (cs schema) + return $ responseLBS status200 [jsonH] $ cs body + + ([table], "OPTIONS") -> do + let t = QualifiedTable schema (cs table) + cols <- columns t + pkey <- map cs <$> primaryKeyColumns t + return $ responseLBS status200 [jsonH, allOrigins] + $ encode (TableOptions cols pkey) + + ([table], "GET") -> + if range == Just emptyRange + then return $ responseLBS status416 [] "HTTP Range error" + else do + let qt = QualifiedTable schema (cs table) + let select = coerce $ + ("select ",[],mempty) <> + parentheticT ( + whereT qq $ countRows qt + ) <> commaq <> ( + asJsonWithCount + . limitT range + . orderT (orderParse qq) + . whereT qq + $ selectStar qt + ) + row <- H.single select + let (tableTotal, queryTotal, body) = + fromMaybe (0, 0, Just "" :: Maybe Text) row + from = fromMaybe 0 $ rangeOffset <$> range + to = from+queryTotal-1 + contentRange = contentRangeH from to tableTotal + status = rangeStatus from to tableTotal + canonical = urlEncodeVars + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + return $ responseLBS status + [jsonH, contentRange, + ("Content-Location", + "/" <> cs table <> + if Prelude.null canonical then "" else "?" <> cs canonical + ) + ] (cs $ fromMaybe "[]" body) + + (["postgrest", "users"], "POST") -> do + let user = decode reqBody :: Maybe AuthUser + + case user of + Nothing -> return $ responseLBS status400 [jsonH] $ + encode . object $ [("message", String "Failed to parse user.")] + Just u -> do + _ <- addUser (cs $ userId u) + (cs $ userPass u) (cs $ userRole u) + return $ responseLBS status201 + [ jsonH + , (hLocation, "/postgrest/users?id=eq." <> cs (userId u)) + ] "" + + ([table], "POST") -> + handleJsonObj reqBody $ \obj -> do + let qt = QualifiedTable schema (cs table) + query = coerce $ + insertInto qt (map cs $ keys obj) (elems obj) + row <- H.single query + let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row + Just inserted = decode (cs insertedJson) :: Maybe Object + + primaryKeys <- map cs <$> primaryKeyColumns qt + let primaries = if Prelude.null primaryKeys + then inserted + else filterWithKey (const . (`elem` primaryKeys)) inserted + let params = urlEncodeVars + $ map (\t -> (cs $ fst t, "eq." <> cs (unquoted $ snd t))) + $ sortBy (comparing fst) $ toList primaries + return $ responseLBS status201 + [ jsonH + , (hLocation, "/" <> cs table <> "?" <> cs params) + ] "" + + ([table], "PUT") -> + handleJsonObj reqBody $ \obj -> do + let qt = QualifiedTable schema (cs table) + primaryKeys <- primaryKeyColumns qt + let specifiedKeys = map (cs . fst) qq + if S.fromList primaryKeys /= S.fromList specifiedKeys + then return $ responseLBS status405 [] + "You must speficy all and only primary keys as params" + else do + tableCols <- map (cs . colName) <$> columns qt + let cols = map cs $ keys obj + if S.fromList tableCols == S.fromList cols + then do + let vals = elems obj + H.unit . coerce $ iffNotT + (whereT qq $ update qt cols vals) + (insertSelect qt cols vals) + return $ responseLBS status204 [ jsonH ] "" + + else return $ if Prelude.null tableCols + then responseLBS status404 [] "" + else responseLBS status400 [] + "You must specify all columns in PUT request" + + ([table], "PATCH") -> + handleJsonObj reqBody $ \obj -> do + let qt = QualifiedTable schema (cs table) + H.unit + $ coerce + $ whereT qq + $ update qt (map cs $ keys obj) (elems obj) + return $ responseLBS status204 [ jsonH ] "" + + ([table], "DELETE") -> do + let qt = QualifiedTable schema (cs table) + let del = coerce $ countT + . returningStarT + . whereT qq + $ deleteFrom qt + row <- H.single del + let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row + return $ if deletedCount == 0 + then responseLBS status404 [] "" + else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] "" + + (_, _) -> + return $ responseLBS status404 [] "" + + where + path = pathInfo req + verb = requestMethod req + qq = queryString req + hdrs = requestHeaders req + schema = requestedSchema hdrs + range = rangeRequested hdrs + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + coerce (q, args, All b) = (q, args, b) + + +isSqlError :: H.Error -> Maybe H.Error +isSqlError = Just + +sqlError :: H.Error -> Response +sqlError err = + let inside = case err of + H.CantConnect _ -> + "Message: \"Cannot connect to postgres server\"" + H.ConnectionLost t -> t + H.ErroneousResult t -> t + H.UnexpectedResult t -> t + H.UnparsableTemplate t -> t + H.UnparsableRow t -> t + H.NotInTransaction -> "An operation which requires a" + <> "database transaction was executed without one" in + either + (\hint -> + responseLBS status500 + [(hContentType, "application/json")] + (cs . encode . object $ [ + ("message", String $ + "Failed to parse exception:" <> inside) + , ("hint", String . cs . show $ hint)])) + (\msg -> + responseLBS (httpStatus msg) + [(hContentType, "application/json")] + (encode msg)) + (parse message "" inside) + + +rangeStatus :: Int -> Int -> Int -> Status +rangeStatus from to total + | from > total = status416 + | (1 + to - from) < total = status206 + | otherwise = status200 + +contentRangeH :: Int -> Int -> Int -> Header +contentRangeH from to total = + ("Content-Range", + if total == 0 || from > total + then "*/" <> cs (show total) + else cs (show from) <> "-" + <> cs (show to) <> "/" + <> cs (show total) + ) + +requestedSchema :: RequestHeaders -> Text +requestedSchema hdrs = + case verStr of + Just [[_, ver]] -> ver + _ -> "1" + + where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String + accept = cs <$> lookup hAccept hdrs :: Maybe Text + verStr = (=~ verRegex) <$> accept :: Maybe [[Text]] + +jsonH :: Header +jsonH = (hContentType, "application/json") + +handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response) + -> H.Tx H.Postgres s Response +handleJsonObj reqBody handler = do + let p = eitherDecode reqBody + case p of + Left err -> + return $ responseLBS status400 [jsonH] jErr + where + jErr = encode . object $ + [("message", String $ "Failed to parse JSON payload. " <> cs err)] + Right (Object o) -> handler o + Right _ -> + return $ responseLBS status400 [jsonH] jErr + where + jErr = encode . object $ + [("message", String "Expecting a JSON object")] + +data TableOptions = TableOptions { + tblOptcolumns :: [Column] +, tblOptpkey :: [Text] +} + +instance ToJSON TableOptions where + toJSON t = object [ + "columns" .= tblOptcolumns t + , "pkey" .= tblOptpkey t ] diff --git a/src/Auth.hs b/src/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Auth.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} +module Auth where + +import Data.Aeson +import Control.Monad (mzero) +import Control.Applicative ( (<*>), (<$>) ) +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) + +import System.IO.Unsafe + +data AuthUser = AuthUser { + userId :: String + , userPass :: String + , userRole :: String + } deriving (Show) + +instance FromJSON AuthUser where + parseJSON (Object v) = AuthUser <$> + v .: "id" <*> + v .: "pass" <*> + v .: "role" + parseJSON _ = mzero + +instance ToJSON AuthUser where + toJSON u = object [ + "id" .= userId u + , "pass" .= userPass u + , "role" .= userRole u ] + +type DbRole = Text + +data LoginAttempt = + NoCredentials + | MalformedAuth + | LoginFailed + | LoginSuccess DbRole + deriving (Eq, Show) + +checkPass :: Text -> Text -> Bool +checkPass = (. cs) . validatePassword . cs + +setRole :: Text -> H.Tx H.Postgres s () +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.Tx H.Postgres s () +addUser identity pass role = do + let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) + H.unit $ + [H.q|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|] + identity (cs hashed :: Text) role + +signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt +signInRole user pass = do + u <- H.single $ [H.q|select pass, rolname from postgrest.auth where id = ?|] user + return $ maybe LoginFailed (\r -> + let (hashed, role) = r in + if checkPass hashed pass + then LoginSuccess role + else LoginFailed + ) u diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,54 @@ +module Config where + +import Network.Wai +import Control.Applicative +import Data.Text (strip) +import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Char8 as BS +import Data.String.Conversions (cs) +import Options.Applicative hiding (columns) +import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) + +data AppConfig = AppConfig { + configDbName :: String + , configDbPort :: Int + , configDbUser :: String + , configDbPass :: String + , configDbHost :: String + + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + } + +argParser :: Parser AppConfig +argParser = AppConfig + <$> strOption (long "db-name" <> short 'd' <> help "name of database") + <*> option (long "db-port" <> short 'P' <> value 5432 <> help "postgres server port") + <*> strOption (long "db-user" <> short 'U' <> help "postgres authenticator role") + <*> strOption (long "db-pass" <> value "" <> help "password for authenticator role") + <*> strOption (long "db-host" <> short 'h' <> value "localhost" <> help "postgres server hostname") + + <*> option (long "port" <> short 'p' <> value 3000 <> help "port number on which to run HTTP server") + <*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests") + <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS") + <*> option (long "db-pool" <> value 10 <> help "Max connections in database pool") + +defaultCorsPolicy :: CorsResourcePolicy +defaultCorsPolicy = CorsResourcePolicy Nothing + ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing + (Just $ 60*60*24) False False True + +corsPolicy :: Request -> Maybe CorsResourcePolicy +corsPolicy req = case lookup "origin" headers of + Just origin -> Just defaultCorsPolicy { + corsOrigins = Just ([origin], True) + , corsRequestHeaders = "Authentication":accHeaders + } + Nothing -> Nothing + where + headers = requestHeaders req + accHeaders = case lookup "access-control-request-headers" headers of + Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs + Nothing -> [] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,64 @@ +module Main where + +import Paths_postgrest (version) + +import App +import Middleware + +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) +import Network.Wai.Middleware.Static (staticPolicy, only) +import Data.List (intercalate) +import Data.Version (versionBranch) +import qualified Hasql as H +import qualified Hasql.Postgres as H +import Options.Applicative hiding (columns) + +import Config (AppConfig(..), argParser, corsPolicy) + +main :: IO () +main = do + conf <- execParser (info (helper <*> argParser) describe) + let port = configPort conf + + unless (configSecure conf) $ + putStrLn "WARNING, running in insecure mode, auth will be in plaintext" + Prelude.putStrLn $ "Listening on port " ++ + (show $ configPort conf :: String) + + let pgSettings = H.ParamSettings (cs $ configDbHost conf) + (fromIntegral $ configDbPort conf) + (cs $ configDbUser conf) + (cs $ configDbPass conf) + (cs $ configDbName conf) + + sessSettings <- maybe (fail "Improper session settings") return $ + H.sessionSettings (fromIntegral $ configPool conf) 30 + + let appSettings = setPort port + . setServerName (cs $ "postgrest/" <> prettyVersion) + $ defaultSettings + middle = + (if configSecure conf then redirectInsecure else id) + . gzip def . cors corsPolicy + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) + anonRole = cs $ configAnonRole conf + currRole = cs $ configDbUser conf + + H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift -> + liftIO $ runSettings appSettings $ middle $ \req respond -> do + body <- strictRequestBody req + respond =<< catchJust isSqlError + (unlift $ H.tx Nothing + $ authenticated currRole anonRole (app body) req) + (return . sqlError) + + where + describe = progDesc "create a REST API to an existing Postgres database" + prettyVersion = intercalate "." $ map show $ versionBranch version diff --git a/src/Middleware.hs b/src/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/Middleware.hs @@ -0,0 +1,76 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Middleware where + +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 Network.HTTP.Types.Header (hLocation, hAuthorization) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Status (status400, status401, status301) +import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, + rawQueryString, isSecure, Request(..), Response) +import Network.URI (URI(..), parseURI) + +import Auth (LoginAttempt(..), signInRole, setRole, resetRole) +import Codec.Binary.Base64.String (decode) + +authenticated :: forall s. Text -> Text -> + (Request -> H.Tx H.Postgres s Response) -> + Request -> H.Tx H.Postgres s Response +authenticated currentRole 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 -> if role /= currentRole then runInRole role else app req + NoCredentials -> if anon /= currentRole then runInRole anon else app req + + where + 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:_) -> signInRole u p + _ -> return MalformedAuth + _ -> return NoCredentials + + runInRole :: Text -> H.Tx H.Postgres s Response + runInRole r = do + setRole r + res <- app req + resetRole + return res + + +redirectInsecure :: Application -> Application +redirectInsecure app req respond = do + let hdrs = requestHeaders req + host = lookup "host" hdrs + uriM = parseURI . cs =<< mconcat [ + Just "https://", + host, + Just $ rawPathInfo req, + Just $ rawQueryString req] + isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https" + + if not (isSecure req || isHerokuSecure) + then case uriM of + Just uri -> + respond $ responseLBS status301 [ + (hLocation, cs . show $ uri { uriScheme = "https:" }) + ] "" + Nothing -> + respond $ responseLBS status400 [] "SSL is required" + else app req respond diff --git a/src/PgError.hs b/src/PgError.hs new file mode 100644 --- /dev/null +++ b/src/PgError.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PgError (Message(..), message, httpStatus) where + +import Text.Parsec +import Text.Parsec.Text +import qualified Data.Map as M +import Text.Regex.TDFA.Text () +import Data.Text hiding (drop, concat, head) +import Data.Aeson +import Data.Maybe +import Control.Monad (void) + +import Data.String.Conversions (cs) +import Data.CaseInsensitive (CI, mk) + +import Network.HTTP.Types.Status + +data Message = Message { + msgStatus :: Maybe Text + , msgCode :: Text + , msgText :: Maybe Text + , msgHint :: Maybe Text +} deriving (Show, Eq) + +message :: Parser Message +message = do + ps <- sepBy valPair (char ';') + let m = M.fromList ps + return $ Message + (M.lookup "status" m) + (fromMaybe "" $ M.lookup "code" m) + (M.lookup "message" m) + (M.lookup "hint" m) + +valPair :: Parser (CI Text, Text) +valPair = do + _ <- spaces + name <- many1 letter + _ <- char ':' + spaces + _ <- many $ char '"' + val <- manyTill anyChar $ + try + (void $ many (char '"') >> ( + (void . lookAhead $ (char ';')) + <|> ((optional $ char '.') >> eof) + )) + return (mk (cs name), cs val) + + +instance ToJSON Message where + toJSON t = object [ + "message" .= msgText t + , "code" .= msgCode t + , "status" .= msgStatus t + , "hint" .= msgHint t + ] + +httpStatus :: Message -> Status +httpStatus m = + let code = cs $ msgCode m :: String in + case code of + '0' : '8' : _ -> status503 -- pg connection err + '0' : '9' : _ -> status500 -- triggered action exception + '0' : 'L' : _ -> status403 -- invalid grantor + '0' : 'P' : _ -> status403 -- invalid role specification + '2' : '5' : _ -> status500 -- invalid tx state + '2' : '8' : _ -> status403 -- invalid auth specification + '2' : 'D' : _ -> status500 -- invalid tx termination + '3' : '8' : _ -> status500 -- external routine exception + '3' : '9' : _ -> status500 -- external routine invocation + '3' : 'B' : _ -> status500 -- savepoint exception + '4' : '0' : _ -> status500 -- tx rollback + '5' : '3' : _ -> status503 -- insufficient resources + '5' : '4' : _ -> status413 -- too complex + '5' : '5' : _ -> status500 -- obj not on prereq state + '5' : '7' : _ -> status500 -- operator intervention + '5' : '8' : _ -> status500 -- system error + 'F' : '0' : _ -> status500 -- conf file error + 'H' : 'V' : _ -> status500 -- foreign data wrapper error + 'P' : '0' : _ -> status500 -- PL/pgSQL Error + 'X' : 'X' : _ -> status500 -- internal Error + "42P01" -> status404 -- undefined table + "42501" -> status404 -- insufficient privilege + _ -> status400 diff --git a/src/PgQuery.hs b/src/PgQuery.hs new file mode 100644 --- /dev/null +++ b/src/PgQuery.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module PgQuery where + +import RangeQuery + +import qualified Hasql.Postgres as H +import qualified Hasql.Backend as H + +import Data.Text hiding (map) +import Text.Regex.TDFA ( (=~) ) +import Text.Regex.TDFA.Text () +import qualified Network.HTTP.Types.URI as Net +import qualified Data.ByteString.Char8 as BS +import Data.Monoid +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Functor ( (<$>) ) +import Control.Monad (join) +import Data.String.Conversions (cs) +import qualified Data.Aeson as JSON +import qualified Data.List as L +import Data.Scientific (isInteger, formatScientific, FPFormat(..)) + +type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All) + +type StatementT = DynamicSQL -> DynamicSQL + +data QualifiedTable = QualifiedTable { + qtSchema :: Text +, qtName :: Text +} deriving (Show) + +data OrderTerm = OrderTerm { + otTerm :: Text +, otDirection :: BS.ByteString +} + +limitT :: Maybe NonnegRange -> StatementT +limitT r q = + q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty) + where + limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r + offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r + +whereT :: Net.Query -> StatementT +whereT params q = + if L.null cols + then q + else q <> (" where ",[],mempty) <> conjunction + where + cols = [ col | col <- params, fst col `notElem` ["order"] ] + conjunction = mconcat $ L.intersperse andq (map wherePred cols) + +orderT :: [OrderTerm] -> StatementT +orderT ts q = + if L.null ts + then q + else q <> (" order by ",[],mempty) <> clause + where + clause = mconcat $ L.intersperse commaq (map queryTerm ts) + queryTerm :: OrderTerm -> DynamicSQL + queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " " + <> otDirection t <> " " + , [], mempty) + +parentheticT :: StatementT +parentheticT (sql, params, pre) = + (" (" <> sql <> ") ", params, pre) + +iffNotT :: DynamicSQL -> StatementT +iffNotT (aq, ap, apre) (bq, bp, bpre) = + ("WITH aaa AS (" <> aq <> " returning *) " <> + bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)" + , ap ++ bp + , All $ getAll apre && getAll bpre + ) + +countT :: StatementT +countT (sql, params, pre) = + ("WITH qqq AS (" <> sql <> ") SELECT count(1) FROM qqq" + , params + , pre) + +countRows :: QualifiedTable -> DynamicSQL +countRows t = + ("select count(1) from " <> fromQt t, [], mempty) + +asJsonWithCount :: StatementT +asJsonWithCount (sql, params, pre) = ( + "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" + , params, pre + ) + +asJsonRow :: StatementT +asJsonRow (sql, params, pre) = ( + "row_to_json(t) from (" <> sql <> ") t", params, pre + ) + +selectStar :: QualifiedTable -> DynamicSQL +selectStar t = + ("select * from " <> fromQt t, [], mempty) + +returningStarT :: StatementT +returningStarT (sql, params, pre) = + (sql <> " RETURNING *", params, pre) + +deleteFrom :: QualifiedTable -> DynamicSQL +deleteFrom t = + ("delete from " <> fromQt t, [], mempty) + +insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL +insertInto t [] _ = + ("insert into " <> fromQt t <> " default values returning *", [], mempty) +insertInto t cols vals = + ("insert into " <> fromQt t <> " (" <> + cs (intercalate ", " (map pgFmtIdent cols)) <> + ") values (" <> + cs ( + intercalate ", " (map + ((<> "::unknown") . pgFmtLit . unquoted) + vals) + ) <> ") returning row_to_json(" <> fromQt t <> ".*)" + , [] + , mempty + ) + +insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL +insertSelect t [] _ = + ("insert into " <> fromQt t <> " default values returning *", [], mempty) +insertSelect t cols vals = + ("insert into " <> fromQt t <> " (" <> + cs (intercalate ", " (map pgFmtIdent cols)) <> + ") select " <> + cs ( + intercalate ", " (map + ((<> "::unknown") . pgFmtLit . unquoted) + vals) + ) + , [] + , mempty + ) + +update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL +update t cols vals = + ("update " <> fromQt t <> " set (" <> + cs (intercalate ", " (map pgFmtIdent cols)) <> + ") = (" <> + cs ( + intercalate ", " (map + ((<> "::unknown") . pgFmtLit . unquoted) + vals) + ) <> ")" + , [] + , mempty + ) + +wherePred :: Net.QueryItem -> DynamicSQL +wherePred (col, predicate) = + (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ", [], mempty) + + where + opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate + value = intercalate "." rest + op = case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + _ -> "=" + +orderParse :: Net.Query -> [OrderTerm] +orderParse q = + mapMaybe orderParseTerm . split (==',') $ cs order + where + order = fromMaybe "" $ join (lookup "order" q) + +orderParseTerm :: Text -> Maybe OrderTerm +orderParseTerm s = + case split (=='.') s of + [d,c] -> + if d `elem` ["asc", "desc"] + then Just $ OrderTerm c $ + if d == "asc" then "asc" else "desc" + else Nothing + _ -> Nothing + +commaq :: DynamicSQL +commaq = (", ", [], mempty) + +andq :: DynamicSQL +andq = (" and ", [], mempty) + +pgFmtIdent :: Text -> Text +pgFmtIdent x = + let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in + if escaped =~ danger + then "\"" <> escaped <> "\"" + else escaped + + where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text + +pgFmtLit :: Text -> Text +pgFmtLit x = + let trimmed = trimNullChars x + escaped = "'" <> replace "'" "''" trimmed <> "'" + slashed = replace "\\" "\\\\" escaped in + cs $ if escaped =~ ("\\\\" :: Text) + then "E" <> slashed + else slashed + +trimNullChars :: Text -> Text +trimNullChars = Data.Text.takeWhile (/= '\x0') + +fromQt :: QualifiedTable -> BS.ByteString +fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) + +unquoted :: JSON.Value -> Text +unquoted (JSON.String t) = t +unquoted (JSON.Number n) = + cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n +unquoted (JSON.Bool b) = cs . show $ b +unquoted _ = "" + +pgParam :: JSON.Value -> H.StatementArgument H.Postgres +pgParam (JSON.Number n) = H.renderValue + (cs $ formatScientific Fixed + (if isInteger n then Just 0 else Nothing) n :: Text) +pgParam (JSON.String s) = H.renderValue s +pgParam (JSON.Bool b) = H.renderValue $ + if b then "t" else "f" :: Text +pgParam JSON.Null = H.renderValue (Nothing :: Maybe Text) +pgParam (JSON.Object o) = H.renderValue $ JSON.encode o +pgParam (JSON.Array a) = H.renderValue $ JSON.encode a diff --git a/src/PgStructure.hs b/src/PgStructure.hs new file mode 100644 --- /dev/null +++ b/src/PgStructure.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances, + MultiParamTypeClasses, ScopedTypeVariables #-} +module PgStructure where + +import PgQuery (QualifiedTable(..)) +import Data.Functor ( (<$>) ) +import Data.Text hiding (foldl, map, zipWith, concat) +import Data.Aeson +import Data.Functor.Identity +import qualified Data.Vector as V +import Data.String.Conversions (cs) + +import Control.Applicative ( (<*>) ) + +import qualified Data.List as L +import qualified Data.Map as Map + +import qualified Hasql as H +import qualified Hasql.Backend as H +import qualified Hasql.Postgres as H + +foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey) +foreignKeys table = do + r :: [(Text, Text, Text)] <- H.list $ [H.q| + select kcu.column_name, ccu.table_name AS foreign_table_name, + ccu.column_name AS foreign_column_name + from information_schema.table_constraints AS tc + join information_schema.key_column_usage AS kcu + on tc.constraint_name = kcu.constraint_name + join information_schema.constraint_column_usage AS ccu + on ccu.constraint_name = tc.constraint_name + where constraint_type = 'FOREIGN KEY' + and tc.table_name=? and tc.table_schema = ? + order by kcu.column_name + |] (qtName table) (qtSchema table) + + return $ foldl addKey Map.empty r + where + addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m + + +tables :: Text -> H.Tx H.Postgres s [Table] +tables schema = + H.list $ [H.q| + select table_schema, table_name, + is_insertable_into + from information_schema.tables + where table_schema = ? + order by table_name + |] schema + + +columns :: QualifiedTable -> H.Tx H.Postgres s [Column] +columns table = do + cols <- H.list $ [H.q| + select info.table_schema as schema, info.table_name as table_name, + info.column_name as name, info.ordinal_position as position, + info.is_nullable as nullable, info.data_type as col_type, + info.is_updatable as updatable, + info.character_maximum_length as max_len, + info.numeric_precision as precision, + info.column_default as default_value, + array_to_string(enum_info.vals, ',') as enum + from ( + select table_schema, table_name, column_name, ordinal_position, + is_nullable, data_type, is_updatable, + character_maximum_length, numeric_precision, + column_default, udt_name + from information_schema.columns + where table_schema = ? and table_name = ? + ) as info + left outer join ( + select n.nspname as s, + t.typname as n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals + from pg_type t + join pg_enum e on t.oid = e.enumtypid + join pg_catalog.pg_namespace n ON n.oid = t.typnamespace + group by s, n + ) as enum_info + on (info.udt_name = enum_info.n) + order by position |] (qtSchema table) (qtName table) + + fks <- foreignKeys table + return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols + + +primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text] +primaryKeyColumns table = do + r :: [Identity Text] <- H.list $ [H.q| + select kc.column_name + from + information_schema.table_constraints tc, + information_schema.key_column_usage kc + where + tc.constraint_type = 'PRIMARY KEY' + and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema + and kc.constraint_name = tc.constraint_name + and kc.table_schema = ? + and kc.table_name = ? |] (qtSchema table) (qtName table) + return $ map runIdentity r + + +vanishNull :: [a] -> Maybe [a] +vanishNull xs = if L.null xs then Nothing else Just xs + +toBool :: Text -> Bool +toBool = (== "YES") + +data Table = Table { + tableSchema :: Text +, tableName :: Text +, tableInsertable :: Bool +} deriving (Show) + +data ForeignKey = ForeignKey { + fkTable::Text, fkCol::Text +} deriving (Eq, Show) + +data Column = Column { + colSchema :: Text +, colTable :: Text +, colName :: Text +, colPosition :: Int +, colNullable :: Bool +, colType :: Text +, colUpdatable :: Bool +, colMaxLen :: Maybe Int +, colPrecision :: Maybe Int +, colDefault :: Maybe Text +, colEnum :: [Text] +, colFK :: Maybe ForeignKey +} deriving (Show) + +instance H.RowParser H.Postgres Column where + parseRow r = + let schema = H.parseResult $ r V.! 0 + table = H.parseResult $ r V.! 1 + name = H.parseResult $ r V.! 2 + position = H.parseResult $ r V.! 3 + nullable = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text) + typ = H.parseResult $ r V.! 5 + updatable = toBool <$> (H.parseResult $ r V.! 6 :: Either Text Text) + maxLen = H.parseResult $ r V.! 7 + precision = H.parseResult $ r V.! 8 + defValue = H.parseResult $ r V.! 9 + enum = either (const $ Right []) (Right . split (==',')) + (H.parseResult $ r V.! 10 :: Either Text Text) + in + if V.length r /= 11 + then Left "Wrong number of fields in Column" + else Column <$> schema <*> table <*> name <*> position <*> nullable + <*> typ <*> updatable <*> maxLen <*> precision + <*> defValue <*> enum + <*> return Nothing + + +instance H.RowParser H.Postgres Table where + parseRow r = + let schema = H.parseResult $ r V.! 0 + name = H.parseResult $ r V.! 1 + insertable = toBool <$> (H.parseResult $ r V.! 2 :: Either Text Text) in + if V.length r /= 3 + then Left "Wrong number of fields in Table" + else Table <$> schema <*> name <*> insertable + +instance ToJSON Column where + toJSON c = object [ + "schema" .= colSchema c + , "name" .= colName c + , "position" .= colPosition c + , "nullable" .= colNullable c + , "type" .= colType c + , "updatable" .= colUpdatable c + , "maxLen" .= colMaxLen c + , "precision" .= colPrecision c + , "references".= colFK c + , "default" .= colDefault c + , "enum" .= colEnum c ] + +instance ToJSON ForeignKey where + toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] + +instance ToJSON Table where + toJSON v = object [ + "schema" .= tableSchema v + , "name" .= tableName v + , "insertable" .= tableInsertable v ] diff --git a/src/RangeQuery.hs b/src/RangeQuery.hs new file mode 100644 --- /dev/null +++ b/src/RangeQuery.hs @@ -0,0 +1,58 @@ +module RangeQuery ( + rangeParse +, rangeRequested +, rangeLimit +, rangeOffset +, NonnegRange +) where + +import Control.Applicative +import Network.HTTP.Types.Header + +import qualified Data.ByteString.Char8 as BS + +import Data.Ranged.Boundaries +import Data.Ranged.Ranges + +import Data.String.Conversions (cs) +import Text.Regex.TDFA ((=~)) +import Text.Read (readMaybe) + +import Data.Maybe (fromMaybe, listToMaybe) + +type NonnegRange = Range Int + +rangeParse :: BS.ByteString -> Maybe NonnegRange +rangeParse range = do + let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString + + parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) + + let [_, from, to] = readMaybe . cs <$> parsedRange + let lower = fromMaybe emptyRange (rangeGeq <$> from) + let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) + + return $ rangeIntersection lower upper + +rangeRequested :: RequestHeaders -> Maybe NonnegRange +rangeRequested = (rangeParse =<<) . lookup hRange + +rangeLimit :: NonnegRange -> Maybe Int +rangeLimit range = + case [rangeLower range, rangeUpper range] + of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + _ -> Nothing + +rangeOffset :: NonnegRange -> Int +rangeOffset range = + case rangeLower range + of BoundaryBelow from -> from + _ -> error "range without lower bound" -- should never happen + +rangeGeq :: Int -> NonnegRange +rangeGeq n = + Range (BoundaryBelow n) BoundaryAboveAll + +rangeLeq :: Int -> NonnegRange +rangeLeq n = + Range BoundaryBelowAll (BoundaryAbove n) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import Test.Hspec +import SpecHelper +import Spec + +main :: IO () +main = resetDb >> hspec spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 --- /dev/null +++ b/test/SpecHelper.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} + +module SpecHelper where + +import Network.Wai +import Test.Hspec +import Test.Hspec.Wai + +import Hasql as H +import Hasql.Postgres as H + +import Data.String.Conversions (cs) +import Data.Monoid +-- import Control.Exception.Base (bracket, finally) +import Control.Monad (void) +import Control.Exception + +import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, + hRange, hAuthorization) +import Codec.Binary.Base64.String (encode) +import Data.CaseInsensitive (CI(..)) +import Data.Maybe (fromMaybe) +import Text.Regex.TDFA ((=~)) +import qualified Data.ByteString.Char8 as BS +import Network.Wai.Middleware.Cors (cors) +import System.Process (readProcess) + +import App (app, sqlError, isSqlError) +import Config (AppConfig(..), corsPolicy) +import Middleware +-- import Auth (addUser) + +isLeft :: Either a b -> Bool +isLeft (Left _ ) = True +isLeft _ = False + +cfg :: AppConfig +cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 + +testSettings :: SessionSettings +testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30 + +pgSettings :: Postgres +pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test" + +withApp :: ActionWith Application -> IO () +withApp perform = + let anonRole = cs $ configAnonRole cfg + currRole = cs $ configDbUser cfg in + perform $ middle $ \req resp -> + H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift -> + liftIO $ do + body <- strictRequestBody req + resp =<< catchJust isSqlError + (unlift $ H.tx Nothing + $ authenticated currRole anonRole (app body) req) + (return . sqlError) + + where middle = cors corsPolicy + + +resetDb :: IO () +resetDb = do + H.session pgSettings testSettings $ + H.tx Nothing $ do + H.unit [H.q| drop schema if exists "1" cascade |] + H.unit [H.q| drop schema if exists private cascade |] + H.unit [H.q| drop schema if exists postgrest cascade |] + + loadFixture "roles" + loadFixture "schema" + + +loadFixture :: FilePath -> IO() +loadFixture name = + void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] + + +rangeHdrs :: ByteRange -> [Header] +rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] + +rangeUnit :: Header +rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items") + +matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool +matchHeader name valRegex headers = + maybe False (=~ valRegex) $ lookup name headers + +authHeader :: String -> String -> Header +authHeader u p = + (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p)) + +clearTable :: BS.ByteString -> IO () +clearTable table = H.session pgSettings testSettings $ H.tx Nothing $ + H.unit ("delete from \"1\"."<>table, [], True) + +createItems :: Int -> IO () +createItems n = H.session pgSettings testSettings $ H.tx Nothing txn + where + txn = sequence_ $ map H.unit stmts + stmts = map [H.q|insert into "1".items (id) values (?)|] [1..n] + +-- for hspec-wai +pending_ :: WaiSession () +pending_ = liftIO Test.Hspec.pending + +-- for hspec-wai +pendingWith_ :: String -> WaiSession () +pendingWith_ = liftIO . Test.Hspec.pendingWith