WIP: converting app request handlers

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)

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 =

src/Dbapi.hs

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

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"

src/PgQuery.hs

@@ -1,13 +1,4 @@
-module PgQuery (
+module PgQuery where
-  CompleteQuery
-, QualifiedTable(..)
-, limitT
-, whereT
-, orderT
-, countRows
-, asJsonWithCount
-, orderParse
-) 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])

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
+instance ToJSON Column where
-  toJSON c = JSON.object [
+  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 ]