-- |
-- Module: Database.PostgreSQL.Typed.SQLToken
-- Copyright: 2016 Dylan Simon
-- 
-- Parsing of SQL statements to safely identify placeholders.
-- Supports both dollar-placeholders and question marks for HDBC.
{-# LANGUAGE PatternGuards #-}
module Database.PostgreSQL.Typed.SQLToken
  ( SQLToken(..)
  , sqlTokens
  ) where

import Control.Arrow (first)
import Data.Char (isDigit, isAsciiUpper, isAsciiLower)
import Data.List (stripPrefix)
import Data.String (IsString(..))

-- |A parsed SQL token.
data SQLToken
  = SQLToken String -- ^Raw (non-markup) SQL string
  | SQLParam Int -- ^A \"$N\" parameter placeholder (this is the only non-string-preserving token: \"$012\" becomes \"$12\")
  | SQLExpr String -- ^A \"${expr}\" expression placeholder
  | SQLQMark Bool -- ^A possibly-escaped question-mark: False for \"?\" or True for \"\\?\"
  deriving (SQLToken -> SQLToken -> Bool
(SQLToken -> SQLToken -> Bool)
-> (SQLToken -> SQLToken -> Bool) -> Eq SQLToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SQLToken -> SQLToken -> Bool
$c/= :: SQLToken -> SQLToken -> Bool
== :: SQLToken -> SQLToken -> Bool
$c== :: SQLToken -> SQLToken -> Bool
Eq)

-- |Produces the original SQL string
instance Show SQLToken where
  showsPrec :: Int -> SQLToken -> ShowS
showsPrec Int
_ (SQLToken String
s) = String -> ShowS
showString String
s
  showsPrec Int
_ (SQLParam Int
p) = Char -> ShowS
showChar Char
'$' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
p
  showsPrec Int
_ (SQLExpr String
e) = String -> ShowS
showString String
"${" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
  showsPrec Int
_ (SQLQMark Bool
False) = Char -> ShowS
showChar Char
'?'
  showsPrec Int
_ (SQLQMark Bool
True) = String -> ShowS
showString String
"\\?"
  showList :: [SQLToken] -> ShowS
showList = (String -> [SQLToken] -> String) -> [SQLToken] -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String -> [SQLToken] -> String) -> [SQLToken] -> ShowS)
-> (String -> [SQLToken] -> String) -> [SQLToken] -> ShowS
forall a b. (a -> b) -> a -> b
$ (SQLToken -> ShowS) -> String -> [SQLToken] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SQLToken -> ShowS
forall a. Show a => a -> ShowS
shows

instance IsString SQLToken where
  fromString :: String -> SQLToken
fromString = String -> SQLToken
SQLToken

type PH = String -> [SQLToken]

infixr 4 ++:, +:

(++:) :: String -> [SQLToken] -> [SQLToken]
String
p ++: :: String -> [SQLToken] -> [SQLToken]
++: (SQLToken String
q : [SQLToken]
l) = String -> SQLToken
SQLToken (String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
q) SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: [SQLToken]
l
String
p ++: [SQLToken]
l = String -> SQLToken
SQLToken String
p SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: [SQLToken]
l

(+:) :: Char -> [SQLToken] -> [SQLToken]
Char
p +: :: Char -> [SQLToken] -> [SQLToken]
+: (SQLToken String
q : [SQLToken]
l) = String -> SQLToken
SQLToken (Char
p Char -> ShowS
forall a. a -> [a] -> [a]
: String
q) SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: [SQLToken]
l
Char
p +: [SQLToken]
l = String -> SQLToken
SQLToken [Char
p] SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: [SQLToken]
l

x :: PH
x :: PH
x (Char
'-':Char
'-':String
s) = String
"--" String -> [SQLToken] -> [SQLToken]
++: PH
comment String
s
x (Char
'e':Char
'\'':String
s) = String
"e'" String -> [SQLToken] -> [SQLToken]
++: PH
xe String
s
x (Char
'E':Char
'\'':String
s) = String
"E'" String -> [SQLToken] -> [SQLToken]
++: PH
xe String
s
x (Char
'\'':String
s) = Char
'\'' Char -> [SQLToken] -> [SQLToken]
+: PH
xq String
s
x (Char
'$':Char
'{':String
s) = PH
expr String
s
x (Char
'$':Char
'$':String
s) = String
"$$" String -> [SQLToken] -> [SQLToken]
++: String -> PH
xdolq String
"" String
s
x (Char
'$':Char
c:String
s)
  | Char -> Bool
dolqStart Char
c
  , (String
t,Char
'$':String
r) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
dolqCont String
s
  = Char
'$' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
t String -> [SQLToken] -> [SQLToken]
++: Char
'$' Char -> [SQLToken] -> [SQLToken]
+: String -> PH
xdolq (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
t) String
r
  | Char -> Bool
isDigit Char
c
  , (String
i,String
r) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s
  = Int -> SQLToken
SQLParam (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
i) SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: PH
x String
r
x (Char
'"':String
s) = Char
'"' Char -> [SQLToken] -> [SQLToken]
+: PH
xd String
s
x (Char
'/':Char
'*':String
s) = String
"/*" String -> [SQLToken] -> [SQLToken]
++: Int -> PH
xc Int
1 String
s
x (Char
c:String
s)
  | Char -> Bool
identStart Char
c
  , (String
i,String
r) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
identCont String
s
  = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
i String -> [SQLToken] -> [SQLToken]
++: PH
x String
r
x (Char
'\\':Char
'?':String
s) = Bool -> SQLToken
SQLQMark Bool
True SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: PH
x String
s
x (Char
'?':String
s) = Bool -> SQLToken
SQLQMark Bool
False SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: PH
x String
s
x (Char
c:String
s) = Char
c Char -> [SQLToken] -> [SQLToken]
+: PH
x String
s
x [] = []

xthru :: (Char -> Bool) -> PH
xthru :: (Char -> Bool) -> PH
xthru Char -> Bool
f String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
f String
s of
  (String
p, Char
c:String
r) -> String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> [SQLToken] -> [SQLToken]
++: PH
x String
r
  (String
p, []) -> [String -> SQLToken
SQLToken String
p]

comment :: PH
comment :: PH
comment = (Char -> Bool) -> PH
xthru (\Char
n -> Char
'\n' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
n Bool -> Bool -> Bool
|| Char
'\r' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
n)

xe :: PH
xe :: PH
xe (Char
'\\':Char
c:String
s) = Char
'\\' Char -> [SQLToken] -> [SQLToken]
+: Char
c Char -> [SQLToken] -> [SQLToken]
+: PH
xe String
s
xe (Char
'\'':String
s) = Char
'\'' Char -> [SQLToken] -> [SQLToken]
+: PH
x String
s
xe (Char
c:String
s) = Char
c Char -> [SQLToken] -> [SQLToken]
+: PH
xe String
s
xe [] = []

xq :: PH
xq :: PH
xq = (Char -> Bool) -> PH
xthru (Char
'\'' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
-- no need to handle xqdouble

xd :: PH
xd :: PH
xd = (Char -> Bool) -> PH
xthru (Char
'\"' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
-- no need to handle xddouble

identStart, identCont, dolqStart, dolqCont :: Char -> Bool
identStart :: Char -> Bool
identStart Char
c = Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\128' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\255' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
dolqStart :: Char -> Bool
dolqStart = Char -> Bool
identStart
dolqCont :: Char -> Bool
dolqCont Char
c = Char -> Bool
dolqStart Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
identCont :: Char -> Bool
identCont Char
c = Char -> Bool
dolqCont Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$'

xdolq :: String -> PH
xdolq :: String -> PH
xdolq String
t = PH
dolq where
  dolq :: PH
dolq (Char
'$':String
s)
    | Just String
r <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
t' String
s = Char
'$'Char -> ShowS
forall a. a -> [a] -> [a]
:String
t' String -> [SQLToken] -> [SQLToken]
++: PH
x String
r
  dolq (Char
c:String
s) = Char
c Char -> [SQLToken] -> [SQLToken]
+: PH
dolq String
s
  dolq [] = []
  t' :: String
t' = String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"$"

xc :: Int -> PH
xc :: Int -> PH
xc Int
0 String
s = PH
x String
s
xc Int
n (Char
'/':Char
'*':String
s) = String
"/*" String -> [SQLToken] -> [SQLToken]
++: Int -> PH
xc (Int -> Int
forall a. Enum a => a -> a
succ Int
n) String
s
xc Int
n (Char
'*':Char
'/':String
s) = String
"*/" String -> [SQLToken] -> [SQLToken]
++: Int -> PH
xc (Int -> Int
forall a. Enum a => a -> a
pred Int
n) String
s
xc Int
n (Char
c:String
s) = Char
c Char -> [SQLToken] -> [SQLToken]
+: Int -> PH
xc Int
n String
s
xc Int
_ [] = []

expr :: PH
expr :: PH
expr = (String, Maybe [SQLToken]) -> [SQLToken]
pr ((String, Maybe [SQLToken]) -> [SQLToken])
-> (String -> (String, Maybe [SQLToken])) -> PH
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> (String, Maybe [SQLToken])
forall a.
(Eq a, Num a, Enum a) =>
a -> String -> (String, Maybe [SQLToken])
ex (Int
0 :: Int) where
  pr :: (String, Maybe [SQLToken]) -> [SQLToken]
pr (String
e, Maybe [SQLToken]
Nothing) = [String -> SQLToken
SQLToken (String
"${" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)]
  pr (String
e, Just [SQLToken]
r) = String -> SQLToken
SQLExpr String
e SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: [SQLToken]
r
  ex :: a -> String -> (String, Maybe [SQLToken])
ex a
0 (Char
'}':String
s) = (String
"", [SQLToken] -> Maybe [SQLToken]
forall a. a -> Maybe a
Just ([SQLToken] -> Maybe [SQLToken]) -> [SQLToken] -> Maybe [SQLToken]
forall a b. (a -> b) -> a -> b
$ PH
x String
s)
  ex a
n (Char
'}':String
s) = ShowS -> (String, Maybe [SQLToken]) -> (String, Maybe [SQLToken])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
'}'Char -> ShowS
forall a. a -> [a] -> [a]
:) ((String, Maybe [SQLToken]) -> (String, Maybe [SQLToken]))
-> (String, Maybe [SQLToken]) -> (String, Maybe [SQLToken])
forall a b. (a -> b) -> a -> b
$ a -> String -> (String, Maybe [SQLToken])
ex (a -> a
forall a. Enum a => a -> a
pred a
n) String
s
  ex a
n (Char
'{':String
s) = ShowS -> (String, Maybe [SQLToken]) -> (String, Maybe [SQLToken])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
'{'Char -> ShowS
forall a. a -> [a] -> [a]
:) ((String, Maybe [SQLToken]) -> (String, Maybe [SQLToken]))
-> (String, Maybe [SQLToken]) -> (String, Maybe [SQLToken])
forall a b. (a -> b) -> a -> b
$ a -> String -> (String, Maybe [SQLToken])
ex (a -> a
forall a. Enum a => a -> a
succ a
n) String
s
  ex a
n (Char
c:String
s) = ShowS -> (String, Maybe [SQLToken]) -> (String, Maybe [SQLToken])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:) ((String, Maybe [SQLToken]) -> (String, Maybe [SQLToken]))
-> (String, Maybe [SQLToken]) -> (String, Maybe [SQLToken])
forall a b. (a -> b) -> a -> b
$ a -> String -> (String, Maybe [SQLToken])
ex a
n String
s
  ex a
_ [] = (String
"", Maybe [SQLToken]
forall a. Maybe a
Nothing)

-- |Parse a SQL string into a series of tokens.
-- The 'showList' implementation for 'SQLToken' inverts this sequence back to a SQL string.
sqlTokens :: String -> [SQLToken]
sqlTokens :: PH
sqlTokens = PH
x