234 lines
7.8 KiB
Haskell
234 lines
7.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- {{{ Imports
|
|
module Dbapi where
|
|
|
|
import Types (SqlRow, getRow)
|
|
|
|
import Control.Exception (try)
|
|
import Control.Monad (join)
|
|
import Control.Exception.Base (bracket_)
|
|
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)
|
|
|
|
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 Database.HDBC.PostgreSQL (Connection)
|
|
import Database.HDBC.Types (SqlError, seErrorMsg)
|
|
import PgStructure (printTables, printColumns, primaryKeyColumns,
|
|
columns, Column(colName))
|
|
|
|
import qualified Data.Aeson as JSON
|
|
|
|
import PgQuery
|
|
import RangeQuery
|
|
import Data.Ranged.Ranges (emptyRange)
|
|
import Codec.Binary.Base64.String (decode)
|
|
|
|
-- }}}
|
|
|
|
data AppConfig = AppConfig {
|
|
configDbUri :: String
|
|
, configPort :: Int
|
|
, configSslCert :: FilePath
|
|
, configSslKey :: FilePath
|
|
, configAnonRole :: String
|
|
}
|
|
|
|
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 $ 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)
|
|
|
|
httpRequesterRole :: RequestHeaders -> Connection -> IO(Maybe DbRole)
|
|
httpRequesterRole hdrs conn = do
|
|
let auth = fromMaybe "" $ lookup hAuthorization hdrs
|
|
case BS.split ' ' (cs auth) of
|
|
("Basic " : b64 : _) ->
|
|
case BS.split ':' $ cs (decode $ cs b64) of
|
|
(u:p:_) -> signInRole u p conn
|
|
_ -> return Nothing
|
|
_ -> return Nothing
|
|
|
|
app :: Connection -> DbRole -> Application
|
|
app conn anonymous req respond = do
|
|
r <- try $ do
|
|
role <- fromMaybe anonymous <$> httpRequesterRole hdrs conn
|
|
|
|
bracket_ (pgSetRole conn role) (pgResetRole conn) $
|
|
case (path, verb) of
|
|
([], _) ->
|
|
responseLBS status200 [jsonContentType] <$> printTables ver conn
|
|
|
|
([table], "OPTIONS") ->
|
|
responseLBS status200 [jsonContentType] <$>
|
|
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 <> "?" <> cs canonical
|
|
)] r
|
|
|
|
([table], "POST") ->
|
|
jsonBodyAction req (\row -> do
|
|
allvals <- insert ver table row conn
|
|
keys <- 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
|
|
allvals <- upsert ver table row qq 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)
|
|
] ""
|
|
|
|
else return $ if S.null colNames then responseLBS status404 [] ""
|
|
else responseLBS status400 []
|
|
"You must specify all columns in PUT request"
|
|
)
|
|
|
|
(_, _) ->
|
|
return $ responseLBS status404 [] ""
|
|
|
|
respond $ either sqlErrorHandler id r
|
|
|
|
where
|
|
path = pathInfo req
|
|
verb = requestMethod req
|
|
qq = queryString req
|
|
hdrs = requestHeaders req
|
|
ver = fromMaybe "1" $ requestedVersion hdrs
|
|
range = requestedRange hdrs
|
|
cRange = requestedContentRange hdrs
|
|
|
|
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
|
|
| total == 0 = status204
|
|
| (1 + to - from) < total = status206
|
|
| otherwise = status200
|
|
|
|
requestedVersion :: RequestHeaders -> Maybe String
|
|
requestedVersion hdrs =
|
|
case verStr of
|
|
Just [[_, ver]] -> Just ver
|
|
_ -> Nothing
|
|
|
|
where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
|
|
accept = cs <$> lookup hAccept hdrs :: Maybe String
|
|
verStr = (=~ verRegex) <$> accept :: Maybe [[String]]
|
|
|
|
sqlErrorHandler :: SqlError -> Response
|
|
sqlErrorHandler e =
|
|
responseLBS status400 [] $ cs (seErrorMsg e)
|
|
|
|
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)
|