First feature specs

dbapi.cabal

@@ -9,13 +9,7 @@ category:              Web
 build-type:            Simple
 cabal-version:         >=1.10
 
-executable dbapi
+library
-  main-is:             Main.hs
-  ghc-options:         -Wall
-  other-modules:       PgStructure
-                     , PgQuery
-                     , RangeQuery
-  other-extensions:    OverloadedStrings
   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

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)]

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)]

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}]
+    |]