From 011c7acec9ca9db2f09059d8d2a6876c03a994df Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 16 Aug 2014 22:33:37 -0700 Subject: [PATCH] First feature specs --- dbapi.cabal | 34 +++++++++--- src/Dbapi.hs | 108 ++++++++++++++++++++++++++++++++++++++ src/Main.hs | 108 +------------------------------------- test/Feature/RangeSpec.hs | 25 +++++++++ 4 files changed, 161 insertions(+), 114 deletions(-) create mode 100644 src/Dbapi.hs create mode 100644 test/Feature/RangeSpec.hs diff --git a/dbapi.cabal b/dbapi.cabal index 4adf8e74a..2e85241a3 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -9,13 +9,7 @@ category: Web build-type: Simple cabal-version: >=1.10 -executable dbapi - main-is: Main.hs - ghc-options: -Wall - other-modules: PgStructure - , PgQuery - , RangeQuery - other-extensions: OverloadedStrings +library build-depends: base >=4.6 && <5 , HDBC, HDBC-postgresql , warp, wai >= 3.0.1 && < 3.0.2 @@ -27,16 +21,40 @@ executable dbapi , http-media, regex-tdfa , Ranged-sets , transformers + exposed-modules: Dbapi + , PgStructure + , PgQuery + , RangeQuery + other-extensions: OverloadedStrings hs-source-dirs: src - default-language: Haskell2010 +executable dbapi + main-is: Main.hs + ghc-options: -Wall + build-depends: base >=4.6 && <5 + , HDBC, HDBC-postgresql + , warp, wai >= 3.0.1 && < 3.0.2 + , http-types, scientific, time + , bytestring, aeson, network + , text, optparse-applicative + , unordered-containers + , regex-base + , http-media, regex-tdfa + , Ranged-sets + , transformers + Other-Modules: Dbapi + hs-source-dirs: src + default-language: Haskell2010 + Test-Suite spec Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: src , test Ghc-Options: -Wall Main-Is: Spec.hs + Other-Modules: Dbapi Build-Depends: base, hspec2 + , hspec-wai , HDBC, HDBC-postgresql , warp, wai >= 3.0.1 && < 3.0.2 , http-types, scientific, time diff --git a/src/Dbapi.hs b/src/Dbapi.hs new file mode 100644 index 000000000..e50129170 --- /dev/null +++ b/src/Dbapi.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dbapi where + +import Types (SqlRow) + +import Control.Exception (try) +import Control.Applicative +import Options.Applicative hiding (columns) + +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) +import Text.Regex.TDFA ((=~)) + +import Network.HTTP.Types.Status +import Network.HTTP.Types.Header + +import Network.Wai + +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS + +import Database.HDBC.PostgreSQL (connectPostgreSQL) +import Database.HDBC.Types (SqlError, seErrorMsg) +import PgStructure (printTables, printColumns) + +import qualified Data.Aeson as JSON +import Data.Text (pack, unpack) + +import PgQuery +import RangeQuery +import Data.Ranged.Ranges (emptyRange) + +data AppConfig = AppConfig { + configDbUri :: String + , configPort :: Int } + +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 $ pack err)] + Right body -> handler body + +jsonBody :: Request -> IO (Either String SqlRow) +jsonBody = (fmap JSON.eitherDecode) . strictRequestBody + +app :: AppConfig -> Application +app config req respond = do + conn <- connectPostgreSQL $ configDbUri config + r <- try $ + case (path, verb) of + ([], _) -> + responseLBS status200 [jsonContentType] <$> (printTables ver conn) + ([table], "OPTIONS") -> + responseLBS status200 [jsonContentType] <$> ( + printColumns ver (unpack table) conn) + ([table], "GET") -> + if range == Just emptyRange + then return $ responseLBS status416 [] "HTTP Range error" + else respondWithRangedResult <$> + (getRows (show ver) (unpack table) qq range conn) + ([table], "POST") -> + jsonBodyAction req (\row -> + responseLBS status200 [jsonContentType] <$> ( + insert ver table row conn)) + (_, _) -> + return $ responseLBS status404 [] "" + + respond $ either sqlErrorHandler id r + + where + path = pathInfo req + verb = requestMethod req + qq = queryString req + ver = fromMaybe 1 $ requestedVersion (requestHeaders req) + range = requestedRange (requestHeaders req) + +respondWithRangedResult :: RangedResult -> Response +respondWithRangedResult rr = + responseLBS status206 [ + jsonContentType, + ("Content-Range", + if rrTotal rr == 0 + then "*/0" + else (BS.pack . show . rrFrom ) rr <> "-" + <> (BS.pack . show . rrTo ) rr <> "/" + <> (BS.pack . show . rrTotal) rr + ) + ] (rrBody rr) + +requestedVersion :: RequestHeaders -> Maybe Int +requestedVersion hdrs = + case verStr of + Just [[_, ver]] -> readMaybe ver + _ -> Nothing + + where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String + accept = BS.unpack <$> lookup hAccept hdrs :: Maybe String + verStr = (=~ verRegex) <$> accept :: Maybe [[String]] + +sqlErrorHandler :: SqlError -> Response +sqlErrorHandler e = + responseLBS status400 [] $ BL.fromChunks [BS.pack (seErrorMsg e)] diff --git a/src/Main.hs b/src/Main.hs index 3b01f9356..27af79cf6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,44 +3,14 @@ -- {{{ Imports module Main where +import Dbapi +import Network.Wai.Handler.Warp hiding (Connection) import Control.Applicative -import Control.Exception (try) - -import Database.HDBC.PostgreSQL (connectPostgreSQL) -import Database.HDBC.Types (SqlError, seErrorMsg) - -import Network.Wai -import Network.Wai.Handler.Warp hiding (Connection) -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header - import Options.Applicative hiding (columns) -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as BS - -import PgStructure (printTables, printColumns) -import PgQuery -import RangeQuery -import Types (SqlRow) - -import Data.Maybe (fromMaybe) -import Text.Regex.TDFA ((=~)) -import Text.Read (readMaybe) -import Data.Text (pack, unpack) -import qualified Data.Aeson as JSON - -import Data.Ranged.Ranges (emptyRange) - -import Debug.Trace - -- }}} -data AppConfig = AppConfig { - configDbUri :: String - , configPort :: Int } - argParser :: Parser AppConfig argParser = AppConfig <$> strOption (long "db" <> short 'd' <> metavar "URI" @@ -58,77 +28,3 @@ main = do where describe = progDesc "create a REST API to an existing Postgres database" -traceThis :: (Show a) => a -> a -traceThis x = trace (show x) x - -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 $ pack err)] - Right body -> handler body - -jsonBody :: Request -> IO (Either String SqlRow) -jsonBody = (fmap JSON.eitherDecode) . strictRequestBody - -app :: AppConfig -> Application -app config req respond = do - conn <- connectPostgreSQL $ configDbUri config - r <- try $ - case (path, verb) of - ([], _) -> - responseLBS status200 [jsonContentType] <$> (printTables ver conn) - ([table], "OPTIONS") -> - responseLBS status200 [jsonContentType] <$> ( - printColumns ver (unpack table) conn) - ([table], "GET") -> - if range == Just emptyRange - then return $ responseLBS status416 [] "HTTP Range error" - else respondWithRangedResult <$> - (getRows (show ver) (unpack table) qq range conn) - ([table], "POST") -> - jsonBodyAction req (\row -> - responseLBS status200 [jsonContentType] <$> ( - insert ver table row conn)) - (_, _) -> - return $ responseLBS status404 [] "" - - respond $ either sqlErrorHandler id r - - where - path = pathInfo req - verb = requestMethod req - qq = queryString req - ver = fromMaybe 1 $ requestedVersion (requestHeaders req) - range = requestedRange (requestHeaders req) - -respondWithRangedResult :: RangedResult -> Response -respondWithRangedResult rr = - responseLBS status206 [ - jsonContentType, - ("Content-Range", - if rrTotal rr == 0 - then "*/0" - else (BS.pack . show . rrFrom ) rr <> "-" - <> (BS.pack . show . rrTo ) rr <> "/" - <> (BS.pack . show . rrTotal) rr - ) - ] (rrBody rr) - -requestedVersion :: RequestHeaders -> Maybe Int -requestedVersion hdrs = - case verStr of - Just [[_, ver]] -> readMaybe ver - _ -> Nothing - - where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String - accept = BS.unpack <$> lookup hAccept hdrs :: Maybe String - verStr = (=~ verRegex) <$> accept :: Maybe [[String]] - -sqlErrorHandler :: SqlError -> Response -sqlErrorHandler e = - responseLBS status400 [] $ BL.fromChunks [BS.pack (seErrorMsg e)] diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs new file mode 100644 index 000000000..4d6f5a26f --- /dev/null +++ b/test/Feature/RangeSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module Feature.RangeSpec where + +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import Dbapi (AppConfig(..), app) + +main :: IO () +main = hspec spec + +cfg :: AppConfig +cfg = AppConfig "postgres://postgres:@localhost:5432/dbapi_test" 9000 + +spec :: Spec +spec = with (return $ app cfg) $ do + describe "GET /" $ do + it "responds with 200" $ do + get "/" `shouldRespondWith` 200 + + it "responds with 'hello'" $ do + get "/" `shouldRespondWith` [json| + [{"schema":"1","name":"auto_incrementing_pk","insertable":true}] + |]