Move sources into src
This commit is contained in:
Joe Nelson
+134
@@ -0,0 +1,134 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- {{{ Imports
|
||||
|
||||
module Main where
|
||||
|
||||
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"
|
||||
<> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
|
||||
<*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
|
||||
<> help "port number on which to run HTTP server")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
conf <- execParser (info (helper <*> argParser) describe)
|
||||
|
||||
Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
|
||||
run (configPort conf) $ app conf
|
||||
|
||||
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 (pack $ show 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)]
|
||||
+130
@@ -0,0 +1,130 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- {{{ Imports
|
||||
|
||||
module PgQuery where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Functor ( (<$>) )
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.List (intersperse, intercalate)
|
||||
import Data.Monoid ((<>), mconcat)
|
||||
import Data.HashMap.Strict (fromList)
|
||||
import qualified Data.Aeson as JSON
|
||||
|
||||
import qualified RangeQuery as R
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
||||
import Database.HDBC hiding (colType, colNullable)
|
||||
import Database.HDBC.PostgreSQL
|
||||
|
||||
import qualified Network.HTTP.Types.URI as Net
|
||||
|
||||
import Types (SqlRow, getRow)
|
||||
|
||||
-- }}}
|
||||
|
||||
data RangedResult = RangedResult {
|
||||
rrFrom :: Int
|
||||
, rrTo :: Int
|
||||
, rrTotal :: Int
|
||||
, rrBody :: BL.ByteString
|
||||
}
|
||||
|
||||
type QuotedSql = (String, [SqlValue])
|
||||
|
||||
getRows :: String -> String -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult
|
||||
getRows schema table qq range conn = do
|
||||
query <- populateSql conn
|
||||
$ globalAndLimitedCounts schema table qq <>
|
||||
jsonArrayRows
|
||||
(selectStarClause schema table
|
||||
<> whereClause qq
|
||||
<> limitClause range)
|
||||
r <- quickQuery conn query []
|
||||
|
||||
return $ case r of
|
||||
[[_, _, SqlNull]] -> RangedResult 0 0 0 ""
|
||||
[[total, limited_total, json]] ->
|
||||
RangedResult offset (offset + fromSql limited_total - 1)
|
||||
(fromSql total) (fromSql json)
|
||||
_ -> RangedResult 0 0 0 ""
|
||||
|
||||
where
|
||||
offset = fromMaybe 0 $ R.offset <$> range
|
||||
|
||||
whereClause :: Net.Query -> QuotedSql
|
||||
whereClause qs =
|
||||
if null qs then ("", []) else (" where ", []) <> conjunction
|
||||
|
||||
where
|
||||
conjunction = mconcat $ intersperse (" and ", []) (map wherePred qs)
|
||||
|
||||
wherePred :: Net.QueryItem -> QuotedSql
|
||||
wherePred (column, predicate) =
|
||||
("%I " <> op <> "%L", map toSql [column, value])
|
||||
|
||||
where
|
||||
opCode:rest = BS.split ':' $ fromMaybe ":" predicate
|
||||
value = BS.intercalate ":" rest
|
||||
op = case opCode of
|
||||
"eq" -> "="
|
||||
"gt" -> ">"
|
||||
"lt" -> "<"
|
||||
"gte" -> ">="
|
||||
"lte" -> "<="
|
||||
"neq" -> "<>"
|
||||
_ -> "="
|
||||
|
||||
limitClause :: Maybe R.NonnegRange -> QuotedSql
|
||||
limitClause range =
|
||||
(" LIMIT %s OFFSET %s ", [toSql limit, toSql offset])
|
||||
|
||||
where
|
||||
limit = fromMaybe "ALL" $ show <$> (R.limit =<< range)
|
||||
offset = fromMaybe 0 $ R.offset <$> range
|
||||
|
||||
globalAndLimitedCounts :: String -> String -> Net.Query -> QuotedSql
|
||||
globalAndLimitedCounts schema table qq =
|
||||
(" select ", [])
|
||||
<> ("(select count(1) from %I.%I ", map toSql [schema, table])
|
||||
<> whereClause qq
|
||||
<> ("), count(t), ", [])
|
||||
|
||||
selectStarClause :: String -> String -> QuotedSql
|
||||
selectStarClause schema table =
|
||||
(" select * from %I.%I ", map toSql [schema, table])
|
||||
|
||||
selectCountClause :: String -> String -> QuotedSql
|
||||
selectCountClause schema table =
|
||||
(" select count(1) from %I.%I ", map toSql [schema, table])
|
||||
|
||||
jsonArrayRows :: QuotedSql -> QuotedSql
|
||||
jsonArrayRows q =
|
||||
("array_to_json(array_agg(row_to_json(t))) from (", []) <> q <> (") t", [])
|
||||
|
||||
insert :: Text -> Text -> SqlRow -> Connection -> IO BL.ByteString
|
||||
insert schema table row conn = do
|
||||
query <- populateSql conn ("insert into %I.%I ("++colIds++")", map toSql $ schema:table:cols)
|
||||
stmt <- prepare conn (query ++ " values ("++phs++") returning *")
|
||||
_ <- execute stmt values
|
||||
keys <- getColumnNames stmt
|
||||
Just vals <- fetchRow stmt
|
||||
let rowMap = fromList $ zip keys vals
|
||||
return $ JSON.encode rowMap
|
||||
where
|
||||
(cols, values) = unzip . getRow $ row
|
||||
colIds = intercalate ", " $ map (const "%I") cols
|
||||
phs = intercalate ", " $ map (const "?") values
|
||||
|
||||
populateSql :: Connection -> QuotedSql -> IO String
|
||||
populateSql conn sql = do
|
||||
[[escaped]] <- quickQuery conn q (snd sql)
|
||||
return $ fromSql escaped
|
||||
|
||||
where
|
||||
q = concat [ "select format('", fst sql, "', ", placeholders (snd sql), ")" ]
|
||||
|
||||
placeholders :: [a] -> String
|
||||
placeholders = intercalate ", " . map (const "?::varchar")
|
||||
@@ -0,0 +1,137 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module PgStructure where
|
||||
|
||||
import Data.Functor ( (<$>) )
|
||||
import Data.Maybe (mapMaybe)
|
||||
|
||||
import Control.Applicative ( (<*>) )
|
||||
|
||||
import Data.HashMap.Strict hiding (map)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
|
||||
import Database.HDBC hiding (colType, colNullable)
|
||||
import Database.HDBC.PostgreSQL
|
||||
|
||||
import Data.Aeson ((.=))
|
||||
|
||||
data Table = Table {
|
||||
tableSchema :: String
|
||||
, tableName :: String
|
||||
, tableInsertable :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
instance JSON.ToJSON Table where
|
||||
toJSON v = JSON.object [
|
||||
"schema" .= tableSchema v
|
||||
, "name" .= tableName v
|
||||
, "insertable" .= tableInsertable v ]
|
||||
|
||||
toBool :: String -> Bool
|
||||
toBool = (== "YES")
|
||||
|
||||
data Column = Column {
|
||||
colSchema :: String
|
||||
, colTable :: String
|
||||
, colName :: String
|
||||
, colPosition :: Int
|
||||
, colNullable :: Bool
|
||||
, colType :: String
|
||||
, colUpdatable :: Bool
|
||||
, colMaxLen :: Maybe Int
|
||||
, colPrecision :: Maybe Int
|
||||
} deriving (Show)
|
||||
|
||||
instance JSON.ToJSON Column where
|
||||
toJSON c = JSON.object [
|
||||
"schema" .= colSchema c
|
||||
, "name" .= colName c
|
||||
, "position" .= colPosition c
|
||||
, "nullable" .= colNullable c
|
||||
, "type" .= colType c
|
||||
, "updatable" .= colUpdatable c
|
||||
, "maxLen" .= colMaxLen c
|
||||
, "precision" .= colPrecision c ]
|
||||
|
||||
data TableOptions = TableOptions {
|
||||
tblOptcolumns :: HashMap String Column
|
||||
, tblOptpkey :: [String]
|
||||
}
|
||||
|
||||
instance JSON.ToJSON TableOptions where
|
||||
toJSON t = JSON.object [
|
||||
"columns" .= tblOptcolumns t
|
||||
, "pkey" .= tblOptpkey t ]
|
||||
|
||||
tables :: String -> Connection -> IO [Table]
|
||||
tables s conn = do
|
||||
r <- quickQuery conn
|
||||
"select table_schema, table_name,\
|
||||
\ is_insertable_into\
|
||||
\ from information_schema.tables\
|
||||
\ where table_schema = ?" [toSql s]
|
||||
return $ mapMaybe mkTable r
|
||||
|
||||
where
|
||||
mkTable [schema, name, insertable] =
|
||||
Just $ Table (fromSql schema)
|
||||
(fromSql name)
|
||||
(toBool (fromSql insertable))
|
||||
mkTable _ = Nothing
|
||||
|
||||
columns :: Int -> String -> Connection -> IO [Column]
|
||||
columns s t conn = do
|
||||
r <- quickQuery conn
|
||||
"select table_schema, table_name, column_name, ordinal_position,\
|
||||
\ is_nullable, data_type, is_updatable,\
|
||||
\ character_maximum_length, numeric_precision\
|
||||
\ from information_schema.columns\
|
||||
\ where table_schema = ?\
|
||||
\ and table_name = ?" [toSql (show s), toSql t]
|
||||
return $ mapMaybe mkColumn r
|
||||
|
||||
where
|
||||
mkColumn [schema, table, name, pos, nullable, colT, updatable, maxlen, precision] =
|
||||
Just $ Column (fromSql schema)
|
||||
(fromSql table)
|
||||
(fromSql name)
|
||||
(fromSql pos)
|
||||
(toBool (fromSql nullable))
|
||||
(fromSql colT)
|
||||
(toBool (fromSql updatable))
|
||||
(fromSql maxlen)
|
||||
(fromSql precision)
|
||||
mkColumn _ = Nothing
|
||||
|
||||
namedColumnHash :: [Column] -> HashMap String Column
|
||||
namedColumnHash = fromList . (Prelude.zip =<< Prelude.map colName)
|
||||
|
||||
printTables :: Int -> Connection -> IO BL.ByteString
|
||||
printTables schema conn = JSON.encode <$> tables (show schema) conn
|
||||
|
||||
printColumns :: Int -> String -> Connection -> IO BL.ByteString
|
||||
printColumns schema table conn =
|
||||
JSON.encode <$> (TableOptions <$> cols <*> pkey)
|
||||
where
|
||||
cols :: IO (HashMap String Column)
|
||||
cols = namedColumnHash <$> columns schema table conn
|
||||
pkey :: IO [String]
|
||||
pkey = primaryKeyColumns schema table conn
|
||||
|
||||
primaryKeyColumns :: Int -> String -> Connection -> IO [String]
|
||||
primaryKeyColumns s t conn = do
|
||||
r <- quickQuery conn
|
||||
"select kc.column_name \
|
||||
\ from \
|
||||
\ information_schema.table_constraints tc, \
|
||||
\ information_schema.key_column_usage kc \
|
||||
\where \
|
||||
\ tc.constraint_type = 'PRIMARY KEY' \
|
||||
\ and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema \
|
||||
\ and kc.constraint_name = tc.constraint_name \
|
||||
\ and kc.table_schema = ? \
|
||||
\ and kc.table_name = ?" [toSql (show s), toSql t]
|
||||
return $ map fromSql (concat r)
|
||||
@@ -0,0 +1,52 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module RangeQuery where
|
||||
|
||||
import Control.Applicative
|
||||
import Network.HTTP.Types.Header
|
||||
|
||||
import Data.Ranged.Boundaries
|
||||
import Data.Ranged.Ranges
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.Regex.TDFA ((=~))
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
|
||||
type NonnegRange = Range Int
|
||||
|
||||
rangeGeq :: Int -> NonnegRange
|
||||
rangeGeq n =
|
||||
Range (BoundaryBelow n) BoundaryAboveAll
|
||||
|
||||
rangeLeq :: Int -> NonnegRange
|
||||
rangeLeq n =
|
||||
Range BoundaryBelowAll (BoundaryAbove n)
|
||||
|
||||
parseRange :: String -> Maybe NonnegRange
|
||||
parseRange range = do
|
||||
let rangeRegex = "^([0-9]+)-([0-9]*)$" :: String
|
||||
|
||||
parsedRange <- listToMaybe (range =~ rangeRegex :: [[String]])
|
||||
|
||||
let [_, from, to] = readMaybe <$> parsedRange
|
||||
let lower = fromMaybe emptyRange (rangeGeq <$> from)
|
||||
let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
|
||||
|
||||
return $ rangeIntersection lower upper
|
||||
|
||||
requestedRange :: RequestHeaders -> Maybe NonnegRange
|
||||
requestedRange hdrs = parseRange =<< BS.unpack <$> lookup hRange hdrs
|
||||
|
||||
limit :: NonnegRange -> Maybe Int
|
||||
limit range =
|
||||
case [rangeLower range, rangeUpper range]
|
||||
of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
|
||||
_ -> Nothing
|
||||
|
||||
offset :: NonnegRange -> Int
|
||||
offset range =
|
||||
case rangeLower range
|
||||
of BoundaryBelow from -> from
|
||||
_ -> 0 -- should never happen
|
||||
@@ -0,0 +1,56 @@
|
||||
module Types(SqlRow(SqlRow), getRow) where
|
||||
|
||||
import Database.HDBC (toSql, SqlValue(..))
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Aeson.Types (Parser)
|
||||
|
||||
import Data.Scientific (toRealFloat)
|
||||
import Data.HashMap.Strict (foldlWithKey')
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Calendar (showGregorian)
|
||||
|
||||
import Control.Monad(mzero)
|
||||
|
||||
instance JSON.FromJSON SqlValue where
|
||||
parseJSON (JSON.String s) = return $ toSql s
|
||||
parseJSON (JSON.Number n) = return $ toSql (toRealFloat n::Double)
|
||||
parseJSON (JSON.Bool b) = return $ toSql b
|
||||
parseJSON JSON.Null = return SqlNull
|
||||
parseJSON (JSON.Object o) = return . toSql $ JSON.encode o
|
||||
parseJSON (JSON.Array a) = return . toSql $ JSON.encode a
|
||||
|
||||
instance JSON.ToJSON SqlValue where
|
||||
toJSON (SqlString s) = JSON.toJSON s
|
||||
toJSON (SqlByteString s) = JSON.toJSON $ decodeUtf8 s
|
||||
toJSON (SqlWord32 w) = JSON.toJSON w
|
||||
toJSON (SqlWord64 w) = JSON.toJSON w
|
||||
toJSON (SqlInt32 i) = JSON.toJSON i
|
||||
toJSON (SqlInt64 i) = JSON.toJSON i
|
||||
toJSON (SqlInteger i) = JSON.toJSON i
|
||||
toJSON (SqlChar c) = JSON.toJSON c
|
||||
toJSON (SqlBool b) = JSON.toJSON b
|
||||
toJSON (SqlDouble n) = JSON.toJSON n
|
||||
toJSON (SqlRational n) = JSON.toJSON n
|
||||
toJSON (SqlLocalDate d) = JSON.toJSON $ showGregorian d
|
||||
toJSON (SqlLocalTimeOfDay t) = JSON.toJSON $ show t
|
||||
toJSON (SqlLocalTime t) = JSON.toJSON $ show t
|
||||
toJSON SqlNull = JSON.Null
|
||||
{-toJSON (SqlZonedLocalTimeOfDay t tz)-}
|
||||
{-toJSON (SqlZonedTime t)-}
|
||||
{-toJSON (SqlDiffTime t)-}
|
||||
{-toJSON (SqlPOSIXTime t)-}
|
||||
toJSON x = JSON.toJSON $ show x
|
||||
|
||||
|
||||
newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] }
|
||||
instance JSON.FromJSON SqlRow where
|
||||
parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m
|
||||
where
|
||||
add :: Parser SqlRow -> Text -> JSON.Value -> Parser SqlRow
|
||||
add parser k v = do
|
||||
SqlRow l <- parser
|
||||
sqlV <- JSON.parseJSON v
|
||||
return . SqlRow $ (k, sqlV) : l
|
||||
parseJSON _ = mzero
|
||||
Reference in New Issue
Block a user