-- |
-- Parse some high-level information out of a query, for use in tracing.
-- We try to find the query method (SELECT / INSERT / ...) and queried table
-- in the root SQL query. We assume the root query to be the first query not
-- in a sub query. We assume everything between parens `( ... )` to be a
-- sub query.
module Postgres.QueryParser
  ( parse,
    QueryMeta (..),
  )
where

import Control.Applicative
import Control.Monad (void)
import Data.Attoparsec.Text (Parser, anyChar, asciiCI, char, inClass, manyTill, skipSpace, space, takeWhile)
import qualified Data.Attoparsec.Text as Attoparsec
import Data.Foldable (asum)
import qualified List
import qualified Maybe
import qualified Text
import Prelude (Either (Left, Right))

parse :: Text -> QueryMeta
parse :: Text -> QueryMeta
parse Text
query =
  case Parser QueryMeta -> Text -> Either String QueryMeta
forall a. Parser a -> Text -> Either String a
Attoparsec.parseOnly Parser QueryMeta
parser Text
query of
    Left String
_ ->
      QueryMeta :: Text -> Text -> QueryMeta
QueryMeta
        { queriedRelation :: Text
queriedRelation =
            Text -> List Text
Text.lines Text
query
              List Text -> (List Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> List Text -> Maybe Text
forall a. List a -> Maybe a
List.head
              Maybe Text -> (Maybe Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.withDefault Text
"",
          sqlOperation :: Text
sqlOperation = Text
"UNKNOWN"
        }
    Right QueryMeta
result -> QueryMeta
result

data QueryMeta = QueryMeta
  { QueryMeta -> Text
queriedRelation :: Text,
    QueryMeta -> Text
sqlOperation :: Text
  }
  deriving (QueryMeta -> QueryMeta -> Bool
(QueryMeta -> QueryMeta -> Bool)
-> (QueryMeta -> QueryMeta -> Bool) -> Eq QueryMeta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueryMeta -> QueryMeta -> Bool
$c/= :: QueryMeta -> QueryMeta -> Bool
== :: QueryMeta -> QueryMeta -> Bool
$c== :: QueryMeta -> QueryMeta -> Bool
Eq, Int -> QueryMeta -> ShowS
[QueryMeta] -> ShowS
QueryMeta -> String
(Int -> QueryMeta -> ShowS)
-> (QueryMeta -> String)
-> ([QueryMeta] -> ShowS)
-> Show QueryMeta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryMeta] -> ShowS
$cshowList :: [QueryMeta] -> ShowS
show :: QueryMeta -> String
$cshow :: QueryMeta -> String
showsPrec :: Int -> QueryMeta -> ShowS
$cshowsPrec :: Int -> QueryMeta -> ShowS
Show)

parser :: Parser QueryMeta
parser :: Parser QueryMeta
parser =
  Parser QueryMeta -> Parser QueryMeta
forall a. Parser a -> Parser a
keepLooking
    (Parser QueryMeta -> Parser QueryMeta)
-> Parser QueryMeta -> Parser QueryMeta
forall a b. (a -> b) -> a -> b
<| [Parser QueryMeta] -> Parser QueryMeta
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ Parser QueryMeta
delete,
        Parser QueryMeta
insert,
        Parser QueryMeta
select,
        Parser QueryMeta
truncate',
        Parser QueryMeta
update
      ]

keepLooking :: Parser a -> Parser a
keepLooking :: Parser a -> Parser a
keepLooking Parser a
p = do
  Parser ()
skipSpace
  [Parser a] -> Parser a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ -- 1. If we encounter sub queries (bounded in parens), skip them first.
      do
        Parser Text [()] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text [()] -> Parser ()) -> Parser Text [()] -> Parser ()
forall a b. (a -> b) -> a -> b
<| Parser () -> Parser Text [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser ()
skipSubExpression
        Parser a -> Parser a
forall a. Parser a -> Parser a
keepLooking Parser a
p,
      -- 2. Try to run the target parser.
      Parser a
p,
      -- 3. Failing all else, move forward a word and try again.
      do
        Parser Text String -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text String -> Parser ())
-> Parser Text String -> Parser ()
forall a b. (a -> b) -> a -> b
<| Parser Text Char -> Parser Text Char -> Parser Text String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Text Char
anyChar (Parser Text Char
space Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
'(')
        Parser a -> Parser a
forall a. Parser a -> Parser a
keepLooking Parser a
p
    ]

skipSubExpression :: Parser ()
skipSubExpression :: Parser ()
skipSubExpression = do
  Parser Text Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser ()) -> Parser Text Char -> Parser ()
forall a b. (a -> b) -> a -> b
<| Char -> Parser Text Char
char Char
'('
  Parser Text Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser ()) -> Parser Text Char -> Parser ()
forall a b. (a -> b) -> a -> b
<| Parser Text Char -> Parser Text Char
forall a. Parser a -> Parser a
keepLooking (Char -> Parser Text Char
char Char
')')

delete :: Parser QueryMeta
delete :: Parser QueryMeta
delete = do
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"DELETE"
  Parser ()
skipSpace
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"FROM"
  Parser ()
skipSpace
  Text
queriedRelation <- Parser Text Text
tableName
  QueryMeta -> Parser QueryMeta
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryMeta :: Text -> Text -> QueryMeta
QueryMeta {Text
queriedRelation :: Text
queriedRelation :: Text
queriedRelation, sqlOperation :: Text
sqlOperation = Text
"DELETE"}

insert :: Parser QueryMeta
insert :: Parser QueryMeta
insert = do
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"INSERT"
  Parser ()
skipSpace
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"INTO"
  Parser ()
skipSpace
  Text
queriedRelation <- Parser Text Text
tableName
  QueryMeta -> Parser QueryMeta
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryMeta :: Text -> Text -> QueryMeta
QueryMeta {Text
queriedRelation :: Text
queriedRelation :: Text
queriedRelation, sqlOperation :: Text
sqlOperation = Text
"INSERT"}

select :: Parser QueryMeta
select :: Parser QueryMeta
select = do
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"SELECT"
  Parser QueryMeta -> Parser QueryMeta
forall a. Parser a -> Parser a
keepLooking (Parser QueryMeta -> Parser QueryMeta)
-> Parser QueryMeta -> Parser QueryMeta
forall a b. (a -> b) -> a -> b
<| do
    Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"FROM"
    Parser QueryMeta -> Parser QueryMeta
forall a. Parser a -> Parser a
keepLooking (Parser QueryMeta -> Parser QueryMeta)
-> Parser QueryMeta -> Parser QueryMeta
forall a b. (a -> b) -> a -> b
<| do
      Text
queriedRelation <- Parser Text Text
tableName
      QueryMeta -> Parser QueryMeta
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryMeta :: Text -> Text -> QueryMeta
QueryMeta {Text
queriedRelation :: Text
queriedRelation :: Text
queriedRelation, sqlOperation :: Text
sqlOperation = Text
"SELECT"}

tableName :: Parser Text
tableName :: Parser Text Text
tableName =
  (Char -> Bool) -> Parser Text Text
takeWhile (String -> Char -> Bool
inClass String
"a-zA-Z0-9._")

truncate' :: Parser QueryMeta
truncate' :: Parser QueryMeta
truncate' = do
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"UPDATE"
  Parser ()
skipSpace
  (Text -> Parser Text Text
asciiCI Text
"ONLY" Parser Text Text -> (Parser Text Text -> Parser ()) -> Parser ()
forall a b. a -> (a -> b) -> b
|> Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Parser ()
skipSpace
  Text
queriedRelation <- Parser Text Text
tableName
  QueryMeta -> Parser QueryMeta
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryMeta :: Text -> Text -> QueryMeta
QueryMeta {Text
queriedRelation :: Text
queriedRelation :: Text
queriedRelation, sqlOperation :: Text
sqlOperation = Text
"UPDATE"}

update :: Parser QueryMeta
update :: Parser QueryMeta
update = do
  Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Text -> Parser ()) -> Parser Text Text -> Parser ()
forall a b. (a -> b) -> a -> b
<| Text -> Parser Text Text
asciiCI Text
"TRUNCATE"
  Parser ()
skipSpace
  (Text -> Parser Text Text
asciiCI Text
"TABLE" Parser Text Text -> (Parser Text Text -> Parser ()) -> Parser ()
forall a b. a -> (a -> b) -> b
|> Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  (Text -> Parser Text Text
asciiCI Text
"ONLY" Parser Text Text -> (Parser Text Text -> Parser ()) -> Parser ()
forall a b. a -> (a -> b) -> b
|> Parser Text Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Parser ()
skipSpace
  Text
queriedRelation <- Parser Text Text
tableName
  QueryMeta -> Parser QueryMeta
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryMeta :: Text -> Text -> QueryMeta
QueryMeta {Text
queriedRelation :: Text
queriedRelation :: Text
queriedRelation, sqlOperation :: Text
sqlOperation = Text
"TRUNCATE"}