module Servant.DB.PostgreSQL.Context(
Argument(..)
, QueryArg(..)
, QueryContext(..)
, newQueryContext
, addQueryArgument
, queryStoredFunction
) where
import Data.Foldable
import Data.Kind
import Data.List (intersperse)
import Data.Monoid
import Data.Sequence (Seq)
import qualified Data.Sequence as S
import Data.Text (Text)
import Database.PostgreSQL.Query
import Database.PostgreSQL.Simple.Types hiding (Default)
import GHC.Generics
import Servant.DB.PostgreSQL.Variadic
data Argument a =
ArgVariadic (Variadic a)
| ArgDefault (Maybe a)
| ArgSimple a
deriving (Generic, Eq, Show)
data QueryArg (r :: * -> Constraint) = forall a . r a => QueryArg (Argument a)
isDefaultArg :: QueryArg r -> Bool
isDefaultArg (QueryArg (ArgDefault Nothing)) = True
isDefaultArg _ = False
data QueryContext (r :: * -> Constraint) = QueryContext {
queryArguments :: !(Seq (Maybe Text, QueryArg r))
, querySchema :: !(Maybe Text)
, queryVoid :: !Bool
}
newQueryContext :: QueryContext r
newQueryContext = QueryContext {
queryArguments = mempty
, querySchema = Nothing
, queryVoid = False
}
addQueryArgument :: r a
=> Maybe Text
-> Argument a
-> QueryContext r
-> QueryContext r
addQueryArgument name a ctx = ctx {
queryArguments = queryArguments ctx S.|> (name, QueryArg a)
}
querySplitArguments :: QueryContext r
-> (Seq (QueryArg r), Seq (Text, QueryArg r))
querySplitArguments QueryContext{..} = foldl' go (mempty, mempty) queryArguments
where
go :: (Seq (QueryArg r), Seq (Text, QueryArg r)) -> (Maybe Text, QueryArg r)
-> (Seq (QueryArg r), Seq (Text, QueryArg r))
go (!posed, !named) (mn, a) = case mn of
Nothing -> (posed S.|> a, named)
Just n -> (posed, named S.|> (n, a))
queryStoredFunction
:: forall r . r ~ ToField
=> Text
-> QueryContext r
-> SqlBuilder
queryStoredFunction name ctx =
"SELECT "
<> (if queryVoid ctx then mempty else "* FROM ")
<> toSqlBuilder (QualifiedIdentifier (querySchema ctx) name)
<> "("
<> (if S.null posed then mempty
else posedBuilder <> (if S.null named then mempty else ", "))
<> (if S.null named then mempty else namedBuilder)
<> ")"
<> (if queryVoid ctx then ";" else " as t;")
where
(posed', named') = querySplitArguments ctx
posed = S.filter (not . isDefaultArg) posed'
named = S.filter (not . isDefaultArg . snd) named'
posedBuilder = mconcat (addCommas $ argPosedBuilder <$> toList posed)
namedBuilder = mconcat (addCommas $ uncurry argNamedBuilder <$> toList named)
addCommas = intersperse ", "
argPosedBuilder :: QueryArg r -> SqlBuilder
argPosedBuilder (QueryArg marg) = case marg of
ArgVariadic (Variadic va) -> "VARIADIC " <> mkValue va
ArgDefault da -> case da of
Nothing -> ""
Just a -> mkValue a
ArgSimple a -> mkValue a
argNamedBuilder :: Text -> QueryArg r -> SqlBuilder
argNamedBuilder aname (QueryArg marg) = case marg of
ArgVariadic (Variadic a) -> "VARIADIC " <> toSqlBuilder (Identifier aname) <> " => " <> mkValue a
ArgDefault da -> case da of
Nothing -> ""
Just a -> toSqlBuilder (Identifier aname) <> " => " <> mkValue a
ArgSimple a -> toSqlBuilder (Identifier aname) <> " => " <> mkValue a