module Database.TemplatePG.SQL ( queryTuples
, queryTuple
, execute
, insertIgnore
, withTransaction
, rollback
, thConnection
) where
import Database.TemplatePG.Protocol
import Database.TemplatePG.Types
import Control.Exception
import Control.Monad
import Data.ByteString.Lazy.UTF8 hiding (length, decode, take, foldr)
import Data.Maybe
import Language.Haskell.Meta.Parse
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (returnQ)
import Network
import System.Environment
import System.IO
import System.IO.Error (isDoesNotExistError)
import Text.ParserCombinators.Parsec
import Prelude hiding (exp)
thConnection :: IO Handle
thConnection = do
database <- getEnv "TPG_DB"
hostName <- catchUndef (getEnv "TPG_HOST") (\ _ -> return "localhost")
portNum <- catchUndef (getEnv "TPG_PORT") (\ _ -> return "5432")
username <- catchUndef (getEnv "TPG_USER") (\ _ -> return "postgres")
password <- catchUndef (getEnv "TPG_PASS") (\ _ -> return "")
let portNum' = PortNumber $ fromIntegral $ ((read portNum)::Integer)
pgConnect hostName portNum' database username password
where catchUndef = catchJust (\e -> if isDoesNotExistError e
then Just ()
else Nothing)
prepareSQL :: String
-> Q (Exp, [(String, PGType, Bool)])
prepareSQL sql = do
h <- runIO thConnection
let (sqlStrings, expStrings) = parseSql sql
(pTypes, fTypes) <- runIO $ describeStatement h $ holdPlaces sqlStrings expStrings
s <- weaveString sqlStrings =<< zipWithM stringify pTypes expStrings
return (s, fTypes)
where holdPlaces ss es = concat $ weave ss (take (length es) placeholders)
placeholders = map (('$' :) . show) ([1..]::[Integer])
stringify typ s = [| $(pgTypeToString typ) $(returnQ $ parseExp' s) |]
parseExp' e = (either (\ _ -> error ("Failed to parse expression: " ++ e)) id) $ parseExp e
weave :: [a] -> [a] -> [a]
weave x [] = x
weave [] y = y
weave (x:xs) (y:ys) = x:y:(weave xs ys)
weaveString :: [String]
-> [Exp]
-> Q Exp
weaveString [x] [] = [| x |]
weaveString [] [y] = returnQ y
weaveString (x:[]) (y:[]) = [| x ++ $(returnQ y) |]
weaveString (x:xs) (y:ys) = [| x ++ $(returnQ y) ++ $(weaveString xs ys) |]
weaveString _ _ = error "Weave mismatch (possible parse problem)"
queryTuples :: String -> Q Exp
queryTuples sql = do
(sql', types) <- prepareSQL sql
[| liftM (map $(convertRow types)) . executeSimpleQuery $(returnQ sql') |]
queryTuple :: String -> Q Exp
queryTuple sql = [| liftM maybeHead . $(queryTuples sql) |]
maybeHead :: [a] -> Maybe a
maybeHead [] = Nothing
maybeHead (x:_) = Just x
execute :: String -> Q Exp
execute sql = do
(sql', types) <- prepareSQL sql
case types of
[] -> [| executeSimpleStatement $(returnQ sql') |]
_ -> error "Execute can't be used on queries, only statements."
withTransaction :: Handle -> IO a -> IO a
withTransaction h a =
onException (do executeSimpleStatement "BEGIN" h
c <- a
executeSimpleStatement "COMMIT" h
return c)
(executeSimpleStatement "ROLLBACK" h)
rollback :: Handle -> IO ()
rollback = executeSimpleStatement "ROLLBACK"
insertIgnore :: IO () -> IO ()
insertIgnore q = catchJust uniquenessError q (\ _ -> return ())
where uniquenessError e = case e of
(PGException c _) -> case c of
"23505" -> Just e
_ -> Nothing
convertRow :: [(String, PGType, Bool)]
-> Q Exp
convertRow types = do
n <- newName "result"
lamE [varP n] $ tupE $ map (convertColumn n) $ zip types [0..]
convertColumn :: Name
-> ((String, PGType, Bool), Int)
-> Q Exp
convertColumn name ((_, typ, nullable), i) = [| $(pgStringToType' typ nullable) ($(varE name) !! i) |]
pgStringToType' :: PGType
-> Bool
-> Q Exp
pgStringToType' t False = [| ($(pgStringToType t)) . toString . fromJust |]
pgStringToType' t True = [| liftM (($(pgStringToType t)) . toString) |]
parseSql :: String -> ([String], [String])
parseSql sql = case (parse sqlStatement "" sql) of
Left err -> error (show err)
Right ss -> every2nd ss
every2nd :: [a] -> ([a], [a])
every2nd = foldr (\a ~(x,y) -> (a:y,x)) ([],[])
sqlStatement :: Parser [String]
sqlStatement = many1 $ choice [sqlText, sqlParameter]
sqlText :: Parser String
sqlText = many1 (noneOf "{")
sqlParameter :: Parser String
sqlParameter = between (char '{') (char '}') $ many1 (noneOf "}")