Using pattern matching for routing
This commit is contained in:
@@ -14,7 +14,6 @@ import Network.Wai
|
|||||||
import Network.Wai.Handler.Warp hiding (Connection)
|
import Network.Wai.Handler.Warp hiding (Connection)
|
||||||
import Network.HTTP.Types.Status
|
import Network.HTTP.Types.Status
|
||||||
import Network.HTTP.Types.Header
|
import Network.HTTP.Types.Header
|
||||||
import Network.HTTP.Types.Method
|
|
||||||
|
|
||||||
import Options.Applicative hiding (columns)
|
import Options.Applicative hiding (columns)
|
||||||
|
|
||||||
@@ -63,16 +62,20 @@ traceThis x = trace (show x) x
|
|||||||
app :: AppConfig -> Application
|
app :: AppConfig -> Application
|
||||||
app config req respond = do
|
app config req respond = do
|
||||||
r <- try $
|
r <- try $
|
||||||
case path of
|
case (path, verb) of
|
||||||
[] -> responseLBS status200 [json] <$> (printTables ver =<< conn)
|
([], _) ->
|
||||||
[table] -> if range == Just emptyRange
|
responseLBS status200 [json] <$> (printTables ver =<< conn)
|
||||||
|
([table], "OPTIONS") ->
|
||||||
|
responseLBS status200 [json] <$> (printColumns ver table =<< conn)
|
||||||
|
([table], "GET") ->
|
||||||
|
if range == Just emptyRange
|
||||||
then return $ responseLBS status416 [] "HTTP Range error"
|
then return $ responseLBS status416 [] "HTTP Range error"
|
||||||
else responseLBS status200 [json] <$>
|
else responseLBS status200 [json] <$> (
|
||||||
( if verb == methodOptions
|
selectWhere (T.pack $ show ver) table qq range =<< conn
|
||||||
then printColumns ver table =<< conn
|
)
|
||||||
else
|
(_, _) ->
|
||||||
selectWhere (T.pack $ show ver) table qq range =<< conn )
|
return $ responseLBS status404 [] ""
|
||||||
_ -> return $ responseLBS status404 [] ""
|
|
||||||
|
|
||||||
respond $ either sqlErrorHandler id r
|
respond $ either sqlErrorHandler id r
|
||||||
|
|
||||||
|
|||||||
+9
-1
@@ -17,15 +17,23 @@ import Database.HDBC.PostgreSQL
|
|||||||
|
|
||||||
import Network.HTTP.Types.URI
|
import Network.HTTP.Types.URI
|
||||||
|
|
||||||
|
data RangedResult = RangedResult {
|
||||||
|
rrFrom :: Int
|
||||||
|
, rrTo :: Int
|
||||||
|
, rrTotal :: Int
|
||||||
|
, rrBody :: BL.ByteString
|
||||||
|
}
|
||||||
|
|
||||||
selectWhere :: T.Text -> T.Text -> Query -> Maybe R.NonnegRange -> Connection -> IO BL.ByteString
|
selectWhere :: T.Text -> T.Text -> Query -> Maybe R.NonnegRange -> Connection -> IO BL.ByteString
|
||||||
selectWhere ver table qq range conn = do
|
selectWhere ver table qq range conn = do
|
||||||
s <- selectSql
|
s <- selectSql
|
||||||
w <- whereClause conn qq
|
w <- whereClause conn qq
|
||||||
r <- quickQuery conn (BS.unpack $ s <> w) []
|
r <- quickQuery conn (BS.unpack $ s <> w) []
|
||||||
|
|
||||||
return $ case r of
|
let body = case r of
|
||||||
[[json]] -> fromSql json
|
[[json]] -> fromSql json
|
||||||
_ -> "" :: BL.ByteString
|
_ -> "" :: BL.ByteString
|
||||||
|
return body
|
||||||
|
|
||||||
where
|
where
|
||||||
limit = fromMaybe "ALL" $ show <$> (R.limit =<< range)
|
limit = fromMaybe "ALL" $ show <$> (R.limit =<< range)
|
||||||
|
|||||||
Reference in New Issue
Block a user