-- |
-- 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
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
'$' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Int
p
  showsPrec Int
_ (SQLExpr String
e) = String -> ShowS
showString String
"${" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
e 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 forall a. [a] -> [a] -> [a]
++ String
q) forall a. a -> [a] -> [a]
: [SQLToken]
l
String
p ++: [SQLToken]
l = String -> SQLToken
SQLToken String
p 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 forall a. a -> [a] -> [a]
: String
q) forall a. a -> [a] -> [a]
: [SQLToken]
l
Char
p +: [SQLToken]
l = String -> SQLToken
SQLToken [Char
p] 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) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
dolqCont String
s
  = Char
'$' forall a. a -> [a] -> [a]
: Char
c forall a. a -> [a] -> [a]
: String
t String -> [SQLToken] -> [SQLToken]
++: Char
'$' Char -> [SQLToken] -> [SQLToken]
+: String -> PH
xdolq (Char
cforall a. a -> [a] -> [a]
:String
t) String
r
  | Char -> Bool
isDigit Char
c
  , (String
i,String
r) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
s
  = Int -> SQLToken
SQLParam (forall a. Read a => String -> a
read forall a b. (a -> b) -> a -> b
$ Char
cforall a. a -> [a] -> [a]
:String
i) 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) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
identCont String
s
  = Char
c forall a. a -> [a] -> [a]
: String
i String -> [SQLToken] -> [SQLToken]
++: PH
x String
r
x (Char
'\\':Char
'?':String
s) = Bool -> SQLToken
SQLQMark Bool
True forall a. a -> [a] -> [a]
: PH
x String
s
x (Char
'?':String
s) = Bool -> SQLToken
SQLQMark Bool
False 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
f String
s of
  (String
p, Char
c:String
r) -> String
p 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' forall a. Eq a => a -> a -> Bool
== Char
n Bool -> Bool -> Bool
|| Char
'\r' 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
'\'' forall a. Eq a => a -> a -> Bool
==)
-- no need to handle xqdouble

xd :: PH
xd :: PH
xd = (Char -> Bool) -> PH
xthru (Char
'\"' 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 forall a. Ord a => a -> a -> Bool
>= Char
'\128' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\255' Bool -> Bool -> Bool
|| Char
c 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 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 <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
t' String
s = Char
'$'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 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 (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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t}.
(Eq t, Num t, Enum t) =>
t -> String -> (String, Maybe [SQLToken])
ex (Int
0 :: Int) where
  pr :: (String, Maybe [SQLToken]) -> [SQLToken]
pr (String
e, Maybe [SQLToken]
Nothing) = [String -> SQLToken
SQLToken (String
"${" forall a. [a] -> [a] -> [a]
++ String
e)]
  pr (String
e, Just [SQLToken]
r) = String -> SQLToken
SQLExpr String
e forall a. a -> [a] -> [a]
: [SQLToken]
r
  ex :: t -> String -> (String, Maybe [SQLToken])
ex t
0 (Char
'}':String
s) = (String
"", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PH
x String
s)
  ex t
n (Char
'}':String
s) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
'}'forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ t -> String -> (String, Maybe [SQLToken])
ex (forall a. Enum a => a -> a
pred t
n) String
s
  ex t
n (Char
'{':String
s) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
'{'forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ t -> String -> (String, Maybe [SQLToken])
ex (forall a. Enum a => a -> a
succ t
n) String
s
  ex t
n (Char
c:String
s) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
cforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ t -> String -> (String, Maybe [SQLToken])
ex t
n String
s
  ex t
_ [] = (String
"", 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