From cb80dba23496e1be591a960d3beae044f21f3c15 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 11 Nov 2014 00:08:51 -0800 Subject: [PATCH] WIP: converting app request handlers --- src/App.hs | 281 +++++++++++++++++++++++++++++++++++++++++++++ src/Auth.hs | 10 ++ src/Dbapi.hs | 236 ------------------------------------- src/Main.hs | 10 +- src/PgQuery.hs | 20 ++-- src/PgStructure.hs | 25 ++-- 6 files changed, 322 insertions(+), 260 deletions(-) create mode 100644 src/App.hs delete mode 100644 src/Dbapi.hs diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 000000000..6c525aad6 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,281 @@ +module App where + +-- import Types (SqlRow, getRow) + +import Control.Monad (join, mzero) +import Data.Monoid ( (<>) ) +-- import Control.Arrow ((***)) +import Control.Applicative +-- import Options.Applicative hiding (columns) + +import Data.Text hiding (map) +-- import Data.Maybe (fromMaybe, isJust) +import Text.Regex.TDFA ((=~)) +-- import Data.Map (intersection, fromList, toList, Map) +-- import Data.List (sort) +-- import qualified Data.Set as S +-- import Data.Convertible.Base (convert) +-- import Data.Text (strip, Text) + +import Network.HTTP.Types.Status +import Network.HTTP.Types.Header +-- import Network.HTTP.Types.URI + +import Network.HTTP.Base (urlEncodeVars) + +import Network.Wai +-- import Network.Wai.Internal +-- import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) + +import Data.ByteString.Char8 hiding (zip, map) +import Data.String.Conversions (cs) +-- import qualified Data.CaseInsensitive as CI + +-- import PgStructure (printTables, printColumns, primaryKeyColumns, +-- columns, Column(colName)) + +import Data.Aeson +import Database.PostgreSQL.Simple + +import PgQuery +import RangeQuery +import PgStructure +import Data.Ranged.Ranges (emptyRange) + +app :: Connection -> Application +app conn req respond = + respond =<< case (path, verb) of + ([], _) -> do + body <- encode <$> (tables conn $ cs schema) + return $ responseLBS status200 [jsonH] $ cs body + + ([table], "OPTIONS") -> do + let t = QualifiedTable schema (cs table) + cols <- columns conn t + pkey <- map cs <$> primaryKeyColumns conn t + return $ responseLBS status200 [jsonH, allOrigins] + $ encode (TableOptions cols pkey) + + ([table], "GET") -> do + if range == Just emptyRange + then return $ responseLBS status416 [] "HTTP Range error" + else do + let qt = QualifiedTable schema table + let select = + ("select ",[]) <> ( + parentheticT + $ whereT qq $ countRows qt + ) <> commaq <> ( + asJsonWithCount + $ limitT range + $ orderT (orderParse qq) + $ whereT qq + $ selectStar qt + ) + 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 <> if null canonical then "" else "?" <> cs canonical + )] r + + (_, _) -> + 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 + + +requestedSchema :: RequestHeaders -> ByteString +requestedSchema hdrs = + case verStr of + Just [[_, ver]] -> ver + _ -> "1" + + where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String + accept = lookup hAccept hdrs :: Maybe ByteString + verStr = (=~ verRegex) <$> accept :: Maybe [[ByteString]] + +parsePayload :: FromJSON j => Request -> IO (Either String j) +parsePayload = fmap eitherDecode . strictRequestBody + +jsonH :: Header +jsonH = (hContentType, "application/json") + + +data TableOptions = TableOptions { + tblOptcolumns :: [Column] +, tblOptpkey :: [Text] +} + +instance ToJSON TableOptions where + toJSON t = object [ + "columns" .= tblOptcolumns t + , "pkey" .= tblOptpkey t ] + +-- jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response +-- jsonBodyAction req handler = do +-- parse <- jsonBody req +-- case parse of +-- Left err -> return $ responseLBS status400 [jsonContentType] json +-- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] +-- Right body -> handler body + + +-- filterByKeys :: Ord a => Map a b -> [a] -> Map a b +-- filterByKeys m keys = +-- if null keys then m else +-- m `intersection` fromList (zip keys $ repeat undefined) + +-- app :: Connection -> Application +-- app conn req respond = +-- respond =<< case (path, verb) of +-- ([], _) -> +-- responseLBS status200 [jsonContentType] <$> printTables ver conn + +-- (["dbapi", "users"], "POST") -> do +-- body <- strictRequestBody req +-- let parse = JSON.eitherDecode body + +-- case parse of +-- Left err -> return $ responseLBS status400 [jsonContentType] json +-- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] +-- Right u -> do +-- addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn +-- return $ responseLBS status201 +-- [ jsonContentType +-- , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) +-- ] "" + +-- ([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 <> if null canonical then "" else "?" <> cs canonical +-- )] r + +-- ([table], "POST") -> +-- jsonBodyAction req (\row -> do +-- allvals <- insert ver table row conn +-- keys <- map cs <$> 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], "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 +-- _ <- upsert ver table row qq conn +-- return $ responseLBS status204 [ jsonContentType ] "" + +-- else return $ if S.null colNames then responseLBS status404 [] "" +-- else responseLBS status400 [] +-- "You must specify all columns in PUT request" +-- ) + +-- ([table], "PATCH") -> +-- jsonBodyAction req (\row -> do +-- _ <- update ver table row qq conn +-- return $ responseLBS status204 [ jsonContentType ] "" +-- ) + +-- (_, _) -> +-- return $ responseLBS status404 [] "" + +-- where +-- path = pathInfo req +-- verb = requestMethod req +-- qq = queryString req +-- hdrs = requestHeaders req +-- ver = fromMaybe "1" $ requestedVersion hdrs +-- range = requestedRange hdrs +-- cRange = requestedContentRange hdrs +-- allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + +-- 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 -> [] + + +-- respondWithRangedResult :: RangedResult -> Response +-- respondWithRangedResult rr = +-- responseLBS status [ +-- jsonContentType, +-- ("Content-Range", +-- if total == 0 || from > total +-- then "*/" <> cs (show total) +-- else cs (show from) <> "-" +-- <> cs (show to) <> "/" +-- <> cs (show total) +-- ) +-- ] (rrBody rr) + +-- where +-- from = rrFrom rr +-- to = rrTo rr +-- total = rrTotal rr +-- status +-- | from > total = status416 +-- | (1 + to - from) < total = status206 +-- | otherwise = status200 + + +-- addHeaders :: ResponseHeaders -> Response -> Response +-- addHeaders hdrs (ResponseFile s headers fp m) = +-- ResponseFile s (headers ++ hdrs) fp m +-- addHeaders hdrs (ResponseBuilder s headers b) = +-- ResponseBuilder s (headers ++ hdrs) b +-- addHeaders hdrs (ResponseStream s headers b) = +-- ResponseStream s (headers ++ hdrs) b +-- addHeaders hdrs (ResponseRaw s resp) = +-- ResponseRaw s (addHeaders hdrs resp) diff --git a/src/Auth.hs b/src/Auth.hs index bf75ff20b..ed7410c8a 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,6 +1,9 @@ module Auth where +import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS +import Control.Monad (mzero) +import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt import Database.PostgreSQL.Simple import GHC.Int @@ -11,6 +14,13 @@ data AuthUser = AuthUser { , userRole :: String } +instance JSON.FromJSON AuthUser where + parseJSON (JSON.Object v) = AuthUser <$> + v JSON..: "id" <*> + v JSON..: "pass" <*> + v JSON..: "role" + parseJSON _ = mzero + type DbRole = BS.ByteString data LoginAttempt = diff --git a/src/Dbapi.hs b/src/Dbapi.hs deleted file mode 100644 index c05d0872a..000000000 --- a/src/Dbapi.hs +++ /dev/null @@ -1,236 +0,0 @@ --- {{{ Imports -module Dbapi where - -import Types (SqlRow, getRow) - -import Control.Monad (join, mzero) -import Control.Arrow ((***)) -import Control.Applicative -import Options.Applicative hiding (columns) - -import Data.Maybe (fromMaybe, isJust) -import Text.Regex.TDFA ((=~)) -import Data.Map (intersection, fromList, toList, Map) -import Data.List (sort) -import qualified Data.Set as S -import Data.Convertible.Base (convert) -import Data.Text (strip, Text) - -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header -import Network.HTTP.Types.URI - -import Network.HTTP.Base (urlEncodeVars) - -import Network.Wai -import Network.Wai.Internal -import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) - -import qualified Data.ByteString.Char8 as BS -import Data.String.Conversions (cs) -import qualified Data.CaseInsensitive as CI - -import PgStructure (printTables, printColumns, primaryKeyColumns, - columns, Column(colName)) - -import qualified Data.Aeson as JSON - -import PgQuery -import RangeQuery -import Data.Ranged.Ranges (emptyRange) - --- }}} - -data AppConfig = AppConfig { - configDbUri :: String - , configPort :: Int - , configAnonRole :: String - , configSecure :: Bool - , configPool :: Int - } - -data AuthUser = AuthUser { - userId :: String - , userPass :: String - , userRole :: String - } - -instance JSON.FromJSON AuthUser where - parseJSON (JSON.Object v) = AuthUser <$> - v JSON..: "id" <*> - v JSON..: "pass" <*> - v JSON..: "role" - parseJSON _ = mzero - -jsonContentType :: (HeaderName, BS.ByteString) -jsonContentType = (hContentType, "application/json") - -jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response -jsonBodyAction req handler = do - parse <- jsonBody req - case parse of - Left err -> return $ responseLBS status400 [jsonContentType] json - where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] - Right body -> handler body - -jsonBody :: Request -> IO (Either String SqlRow) -jsonBody = fmap JSON.eitherDecode . strictRequestBody - -filterByKeys :: Ord a => Map a b -> [a] -> Map a b -filterByKeys m keys = - if null keys then m else - m `intersection` fromList (zip keys $ repeat undefined) - -app :: Connection -> Application -app conn req respond = - respond =<< case (path, verb) of - ([], _) -> - responseLBS status200 [jsonContentType] <$> printTables ver conn - - (["dbapi", "users"], "POST") -> do - body <- strictRequestBody req - let parse = JSON.eitherDecode body - - case parse of - Left err -> return $ responseLBS status400 [jsonContentType] json - where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] - Right u -> do - addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn - return $ responseLBS status201 - [ jsonContentType - , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) - ] "" - - ([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 <> if null canonical then "" else "?" <> cs canonical - )] r - - ([table], "POST") -> - jsonBodyAction req (\row -> do - allvals <- insert ver table row conn - keys <- map cs <$> 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], "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 - _ <- upsert ver table row qq conn - return $ responseLBS status204 [ jsonContentType ] "" - - else return $ if S.null colNames then responseLBS status404 [] "" - else responseLBS status400 [] - "You must specify all columns in PUT request" - ) - - ([table], "PATCH") -> - jsonBodyAction req (\row -> do - _ <- update ver table row qq conn - return $ responseLBS status204 [ jsonContentType ] "" - ) - - (_, _) -> - return $ responseLBS status404 [] "" - - where - path = pathInfo req - verb = requestMethod req - qq = queryString req - hdrs = requestHeaders req - ver = fromMaybe "1" $ requestedVersion hdrs - range = requestedRange hdrs - cRange = requestedContentRange hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - -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 -> [] - - -respondWithRangedResult :: RangedResult -> Response -respondWithRangedResult rr = - responseLBS status [ - jsonContentType, - ("Content-Range", - if total == 0 || from > total - then "*/" <> cs (show total) - else cs (show from) <> "-" - <> cs (show to) <> "/" - <> cs (show total) - ) - ] (rrBody rr) - - where - from = rrFrom rr - to = rrTo rr - total = rrTotal rr - status - | from > total = status416 - | (1 + to - from) < total = status206 - | otherwise = status200 - -requestedVersion :: RequestHeaders -> Maybe Text -requestedVersion hdrs = - case verStr of - Just [[_, ver]] -> Just ver - _ -> Nothing - - where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String - accept = cs <$> lookup hAccept hdrs :: Maybe Text - verStr = (=~ verRegex) <$> accept :: Maybe [[Text]] - - -addHeaders :: ResponseHeaders -> Response -> Response -addHeaders hdrs (ResponseFile s headers fp m) = - ResponseFile s (headers ++ hdrs) fp m -addHeaders hdrs (ResponseBuilder s headers b) = - ResponseBuilder s (headers ++ hdrs) b -addHeaders hdrs (ResponseStream s headers b) = - ResponseStream s (headers ++ hdrs) b -addHeaders hdrs (ResponseRaw s resp) = - ResponseRaw s (addHeaders hdrs resp) diff --git a/src/Main.hs b/src/Main.hs index 2ae275da5..bc12aa7f3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main where import Paths_dbapi (version) -import Dbapi +import App import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, redirectInsecure, withDBConnection, Environment(..)) import Network.Wai.Handler.Warp hiding (Connection) @@ -19,6 +19,14 @@ import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) +data AppConfig = AppConfig { + configDbUri :: String + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + } + argParser :: Parser AppConfig argParser = AppConfig <$> strOption (long "db" <> short 'd' <> metavar "URI" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 41e6a1622..87b79653f 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,13 +1,4 @@ -module PgQuery ( - CompleteQuery -, QualifiedTable(..) -, limitT -, whereT -, orderT -, countRows -, asJsonWithCount -, orderParse -) where +module PgQuery where import RangeQuery import Database.PostgreSQL.Simple @@ -64,6 +55,10 @@ orderT ts q = [EscapeIdentifier (otTerm t), Plain (fromByteString $ otDirection t)] ) +parentheticT :: CompleteQueryT +parentheticT (sql, params) = + (" (" <> sql <> ") ", params) + countRows :: QualifiedTable -> CompleteQuery countRows t = ("select count(1) from ?.?", @@ -75,6 +70,11 @@ asJsonWithCount (sql, params) = ( , params ) +selectStar :: QualifiedTable -> CompleteQuery +selectStar t = + ("select count(1) from ?.?", + [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) + wherePred :: Net.QueryItem -> CompleteQuery wherePred (col, predicate) = (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 544ed833f..f2e3cbf20 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -4,17 +4,16 @@ module PgStructure where import PgQuery (QualifiedTable(..)) import Data.Functor ( (<$>) ) import Data.Text hiding (foldl, map, zipWith, concat) +import Data.Aeson import Control.Applicative ( (<*>) ) import qualified Data.List as L -import qualified Data.Aeson as JSON import qualified Data.Map as Map import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.SqlQQ import Database.PostgreSQL.Simple.FromRow -import Data.Aeson ((.=)) foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey) foreignKeys c table = do @@ -122,12 +121,6 @@ instance FromRow Column where vanishNull :: [a] -> Maybe [a] vanishNull xs = if L.null xs then Nothing else Just xs -instance JSON.ToJSON Table where - toJSON v = JSON.object [ - "schema" .= tableSchema v - , "name" .= tableName v - , "insertable" .= tableInsertable v ] - toBool :: Text -> Bool toBool = (== "YES") @@ -135,9 +128,6 @@ data ForeignKey = ForeignKey { fkTable::Text, fkCol::Text } deriving (Eq, Show) -instance JSON.ToJSON ForeignKey where - toJSON fk = JSON.object ["table".=fkTable fk, "column".=fkCol fk] - data Column = Column { colSchema :: Text , colTable :: Text @@ -153,8 +143,8 @@ data Column = Column { , colFK :: Maybe ForeignKey } deriving (Show) -instance JSON.ToJSON Column where - toJSON c = JSON.object [ +instance ToJSON Column where + toJSON c = object [ "schema" .= colSchema c , "name" .= colName c , "position" .= colPosition c @@ -166,3 +156,12 @@ instance JSON.ToJSON Column where , "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 ]