133 lines
4.0 KiB
Haskell
133 lines
4.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- {{{ Imports
|
|
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 Data.Map (intersection, fromList, toList)
|
|
import Data.Convertible.Base (convert)
|
|
|
|
import Network.HTTP.Base (urlEncodeVars)
|
|
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 (Connection)
|
|
import Database.HDBC.Types (SqlError, seErrorMsg)
|
|
import Database.HDBC.SqlValue (SqlValue(..))
|
|
import PgStructure (printTables, printColumns, primaryKeyColumns)
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import Data.Text (pack, unpack)
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
|
|
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 :: Connection -> Application
|
|
app conn req respond = do
|
|
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 -> do
|
|
allvals <- insert ver table row conn
|
|
keys <- primaryKeyColumns ver (unpack table) conn
|
|
let keyvals = allvals `intersection` fromList (zip keys $ repeat SqlNull)
|
|
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList keyvals
|
|
return $ responseLBS status201
|
|
[ jsonContentType
|
|
, (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params)
|
|
] ""
|
|
)
|
|
(_, _) ->
|
|
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 status [
|
|
jsonContentType,
|
|
("Content-Range",
|
|
if total == 0 || from > total
|
|
then "*/" <> BS.pack (show total)
|
|
else BS.pack (show from) <> "-"
|
|
<> BS.pack (show to) <> "/"
|
|
<> BS.pack (show total)
|
|
)
|
|
] (rrBody rr)
|
|
|
|
where
|
|
from = rrFrom rr
|
|
to = rrTo rr
|
|
total = rrTotal rr
|
|
status
|
|
| from > total = status416
|
|
| total == 0 = status204
|
|
| (1 + to - from) < total = status206
|
|
| otherwise = status200
|
|
|
|
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)]
|