packages feed

preql (empty) → 0.1

raw patch · 16 files changed

+939/−0 lines, 16 filesdep +aesondep +arraydep +basesetup-changed

Dependencies added: aeson, array, base, binary-parser, bytestring, bytestring-strict-builder, contravariant, free, mtl, postgresql-binary, postgresql-libpq, postgresql-simple, syb, template-haskell, text, th-lift-instances, time, transformers, uuid, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Daniel Bergey++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Daniel Bergey nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ preql.cabal view
@@ -0,0 +1,58 @@+cabal-version: 1.12+name: preql+version: 0.1+license: BSD3+license-file: LICENSE+maintainer: bergey@teallabs.org+author: Daniel Bergey+homepage: https://github.com/bergey/preql#readme+bug-reports: https://github.com/bergey/preql/issues+synopsis: experiments with SQL+build-type: Simple++source-repository head+    type: git+    location: https://github.com/bergey/preql++library+    exposed-modules:+        Preql+        Preql.Effect+        Preql.Imports+        Preql.PQResultUtils+        Preql.QuasiQuoter.Raw.Lex+        Preql.QuasiQuoter.Raw.TH+        Preql.Wire+        Preql.Wire.Connection+        Preql.Wire.FromSql+        Preql.Wire.Internal+        Preql.Wire.Query+        Preql.Wire.ToSql+        Preql.Wire.Types+    build-tools: alex -any, happy -any+    hs-source-dirs: src+    other-modules:+        Paths_preql+    default-language: Haskell2010+    default-extensions: OverloadedStrings+    build-depends:+        aeson >=1.4.6.0 && <1.5,+        array >=0.5.4.0 && <0.6,+        base >=4.13.0.0 && <4.14,+        binary-parser >=0.5.5 && <0.6,+        bytestring >=0.10.10.0 && <0.11,+        bytestring-strict-builder >=0.4.5.3 && <0.5,+        contravariant >=1.5.2 && <1.6,+        free >=5.1.3 && <5.2,+        mtl >=2.2.2 && <2.3,+        postgresql-binary >=0.12.2 && <0.13,+        postgresql-libpq >=0.9.4.2 && <0.10,+        postgresql-simple >=0.6.2 && <0.7,+        syb >=0.7.1 && <0.8,+        template-haskell >=2.15.0.0 && <2.16,+        text >=1.2.4.0 && <1.3,+        th-lift-instances >=0.1.14 && <0.2,+        time >=1.9.3 && <1.10,+        transformers >=0.5.6.2 && <0.6,+        uuid >=1.3.13 && <1.4,+        vector >=0.12.1.2 && <0.13
+ src/Preql.hs view
@@ -0,0 +1,5 @@+module Preql (module X) where++import Preql.Wire as X+import Preql.QuasiQuoter.Raw.TH as X (sql)+import Preql.Effect as X
+ src/Preql/Effect.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+-- | SQL Effect class, basically capturing some way of accessing a database.++module Preql.Effect+    ( Query, SQL(..)+    ) where++import           Preql.Wire++import           Control.Exception (throwIO)+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Except (ExceptT)+import           Control.Monad.Trans.Maybe (MaybeT)+import           Control.Monad.Trans.Reader (ReaderT, ask)+import           Control.Monad.Trans.State (StateT)+import           Control.Monad.Trans.Writer (WriterT)+import           Data.Vector (Vector)+import           Database.PostgreSQL.LibPQ (Connection)++import qualified Preql.Wire.Query as W++-- | An Effect class for running SQL queries.  You can think of this+-- as a context specifying a particular Postgres connection (or connection+-- pool).+class Monad m => SQL (m :: * -> *) where+    query :: (ToSql p, FromSql r) => (Query, p) -> m (Vector r)+    query_ :: ToSql p => (Query, p) -> m ()++    default query :: (MonadTrans t, SQL m', m ~ t m', ToSql p, FromSql r) => (Query, p) -> m (Vector r)+    query qp = lift (query qp)++    default query_ :: (MonadTrans t, SQL m', m ~ t m', ToSql p) => (Query, p) -> m ()+    query_ qp = lift (query_ qp)++-- | Most larger applications will define an instance; this one is suitable to test out the library.+instance SQL (ReaderT Connection IO) where+    query (q, p) = do+        conn <- ask+        lift (either throwIO pure =<< W.query conn q p)+    query_ (q, p) = do+        conn <- ask+        lift (either throwIO pure =<< W.query_ conn q p)++instance SQL m => SQL (ExceptT e m)+instance SQL m => SQL (MaybeT m)+instance SQL m => SQL (StateT s m)+instance (Monoid w, SQL m) => SQL (WriterT w m)+instance {-# OVERLAPPABLE #-} SQL m => SQL (ReaderT r m)
+ src/Preql/Imports.hs view
@@ -0,0 +1,23 @@+-- |  Common imports, so I don't need to repeat them everywhere++module Preql.Imports+    ( module X+    , decodeUtf8With, lenientDecode+    , Vector, Text, ByteString+    )++where++import Control.Applicative as X+import Control.Exception as X (Exception)+import Control.Monad.IO.Class as X (liftIO, MonadIO)+import Data.Bifunctor as X+import Data.ByteString (ByteString)+import Data.Functor as X+import Data.Maybe as X (catMaybes)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Traversable as X+import Data.Typeable as X+import Data.Vector (Vector)
+ src/Preql/PQResultUtils.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | taken verbatim from Database.PostgreSQL.Simple.Internal.PQResultUtils++module Preql.PQResultUtils where++import           Control.Exception                    as E+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.State.Strict+import           Data.ByteString                      (ByteString)+import qualified Data.ByteString.Char8                as B+import           Data.Foldable                        (for_)+import qualified Data.Vector                          as V+import qualified Data.Vector.Mutable                  as MV+import qualified Data.Vector.Unboxed                  as VU+import qualified Data.Vector.Unboxed.Mutable          as MVU+import qualified Database.PostgreSQL.LibPQ            as PQ+import           Database.PostgreSQL.Simple.FromField (ResultError (..))+import           Database.PostgreSQL.Simple.Internal  as Base hiding (result,+                                                               row)+import           Database.PostgreSQL.Simple.Ok+import           Database.PostgreSQL.Simple.TypeInfo+import           Database.PostgreSQL.Simple.Types     (Query (..))++finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]+finishQueryWith parser conn q result = finishQueryWith' q result $ do+    nrows <- PQ.ntuples result+    ncols <- PQ.nfields result+    forM' 0 (nrows-1) $ \row ->+        getRowWith parser row ncols conn result++finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)+finishQueryWithV parser conn q result = finishQueryWith' q result $ do+    nrows <- PQ.ntuples result+    let PQ.Row nrows' = nrows+    ncols <- PQ.nfields result+    mv <- MV.unsafeNew (fromIntegral nrows')+    for_ [ 0 .. nrows-1 ] $ \row -> do+        let PQ.Row row' = row+        value <- getRowWith parser row ncols conn result+        MV.unsafeWrite mv (fromIntegral row') value+    V.unsafeFreeze mv++finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)+finishQueryWithVU parser conn q result = finishQueryWith' q result $ do+    nrows <- PQ.ntuples result+    let PQ.Row nrows' = nrows+    ncols <- PQ.nfields result+    mv <- MVU.unsafeNew (fromIntegral nrows')+    for_ [ 0 .. nrows-1 ] $ \row -> do+        let PQ.Row row' = row+        value <- getRowWith parser row ncols conn result+        MVU.unsafeWrite mv (fromIntegral row') value+    VU.unsafeFreeze mv++finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a+finishQueryWith' q result k = do+  status <- PQ.resultStatus result+  case status of+    PQ.TuplesOk -> k+    PQ.EmptyQuery    -> queryErr "query: Empty query"+    PQ.CommandOk     -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)"+    PQ.CopyOut       -> queryErr "query: COPY TO is not supported"+    PQ.CopyIn        -> queryErr "query: COPY FROM is not supported"+#if MIN_VERSION_postgresql_libpq(0,9,3)+    PQ.CopyBoth      -> queryErr "query: COPY BOTH is not supported"+#endif+#if MIN_VERSION_postgresql_libpq(0,9,2)+    PQ.SingleTuple   -> queryErr "query: single-row mode is not supported"+#endif+    PQ.BadResponse   -> throwResultError "query" result status+    PQ.NonfatalError -> throwResultError "query" result status+    PQ.FatalError    -> throwResultError "query" result status+  where+    queryErr msg = throwIO $ QueryError msg q++getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r+getRowWith parser row ncols conn result = do+  let rw = Row row result+  let unCol (PQ.Col x) = fromIntegral x :: Int+  okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn+  case okvc of+    Ok (val,col) | col == ncols -> return val+                 | otherwise -> do+                     vals <- forM' 0 (ncols-1) $ \c -> do+                         tinfo <- getTypeInfo conn =<< PQ.ftype result c+                         v <- PQ.getvalue result row c+                         return ( tinfo+                                , fmap ellipsis v       )+                     throw (ConversionFailed+                      (show (unCol ncols) ++ " values: " ++ show vals)+                      Nothing+                      ""+                      (show (unCol col) ++ " slots in target type")+                      "mismatch between number of columns to convert and number in target type")+    Errors []  -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"+    Errors [x] -> throwIO x+    Errors xs  -> throwIO $ ManyErrors xs++ellipsis :: ByteString -> ByteString+ellipsis bs+    | B.length bs > 15 = B.take 10 bs `B.append` "[...]"+    | otherwise        = bs++forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]+forM' lo hi m = loop hi []+  where+    loop !n !as+      | n < lo = return as+      | otherwise = do+           a <- m n+           loop (n-1) (a:as)+{-# INLINE forM' #-}
+ src/Preql/QuasiQuoter/Raw/Lex.x view
@@ -0,0 +1,105 @@+{+module Preql.QuasiQuoter.Raw.Lex where++import           Prelude hiding (LT, GT, lex)++}++%wrapper "monadUserState"++$digit = [0-9]+$haskell = $printable # [\}]+$sql = $printable # [\$]++tokens :-++    "$" $digit+ { lex' (NumberedParam . read . tail) }+    "${" $haskell+ "}" { lex' (HaskellParam . init . drop 2) }+    $sql+ { lex' Sql }+++{++data LocToken = LocToken+     { loc :: AlexPosn+     , unLoc :: Token+     } deriving Show++data Token = Sql String+     | NumberedParam Word | HaskellParam String+     | EOF+     deriving (Show, Eq, Ord)++/* from https://github.com/dagit/happy-plus-alex/blob/master/src/Lexer.x */++-- To improve error messages, We keep the path of the file we are+-- lexing in our own state.+data AlexUserState = AlexUserState { filePath :: FilePath }++alexInitUserState :: AlexUserState+alexInitUserState = AlexUserState "<unknown>"++getFilePath :: Alex FilePath+getFilePath = filePath <$> alexGetUserState++setFilePath :: FilePath -> Alex ()+setFilePath = alexSetUserState . AlexUserState++-- For nice parser error messages.+unLex :: Token -> String+unLex t = case t of+    Sql s -> s+    NumberedParam i -> '$' : show i+    HaskellParam s -> "${" ++ s ++ "}"+    EOF -> "<EOF>"++-- Unfortunately, we have to extract the matching bit of string ourselves...+lex' :: (String -> Token) -> AlexAction LocToken+lex' f = \(p,_,_,s) i -> return $ LocToken p (f (take i s))++-- We rewrite alexMonadScan' to delegate to alexError' when lexing fails+-- (the default implementation just returns an error message).+alexMonadScan' :: Alex LocToken+alexMonadScan' = do+  inp <- alexGetInput+  sc <- alexGetStartCode+  case alexScan inp sc of+    AlexEOF -> alexEOF+    AlexError (p, _, _, s) ->+        alexError' p ("lexical error at character '" ++ take 1 s ++ "'")+    AlexSkip  inp' len -> do+        alexSetInput inp'+        alexMonadScan'+    AlexToken inp' len action -> do+        alexSetInput inp'+        action (ignorePendingBytes inp) len++alexEOF :: Alex LocToken+alexEOF = do+  (p,_,_,_) <- alexGetInput+  return $ LocToken p EOF++-- Signal an error, including a commonly accepted source code position.+alexError' :: AlexPosn -> String -> Alex a+alexError' (AlexPn _ l c) msg = do+  fp <- getFilePath+  alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)++-- A variant of runAlex, keeping track of the path of the file we are lexing.+runAlex' :: Alex a -> FilePath -> String -> Either String a+runAlex' a fp input = runAlex input (setFilePath fp >> a)++lexAll :: Alex [LocToken]+lexAll = do+    token <- alexMonadScan+    case unLoc token of+        EOF -> return [token]+        _ -> fmap (token :) lexAll++parseQuery' :: FilePath -> String -> Either String [LocToken]+parseQuery' fp s = runAlex' lexAll fp s++parseQuery :: FilePath -> String -> Either String [Token]+parseQuery fp s = map unLoc <$> parseQuery' fp s++}
+ src/Preql/QuasiQuoter/Raw/TH.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields    #-}+{-# LANGUAGE NamedFieldPuns           #-}+{-# LANGUAGE TemplateHaskell          #-}++module Preql.QuasiQuoter.Raw.TH where++import           Preql.QuasiQuoter.Raw.Lex (Token(..), unLex, parseQuery)+import           Preql.Wire (Query(..))++import           Data.String (IsString (..))+import           Data.Word (Word)+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Language.Haskell.TH.Syntax (Lift (..))++import qualified Data.Text as T++-- | A list of n Names beginning with the given character+cNames :: Char -> Int -> Q [Name]+cNames c n = traverse newName (replicate n (c : ""))++-- | Convert a rewritten SQL string to a ByteString+makeQuery :: String -> Q Exp+makeQuery string = [e|(fromString string :: Query) |]++-- | Given a SQL query with ${} antiquotes, splice a pair @(Query+-- p r, p)@ or a function @\p' -> (Query p r, p)@ if the SQL+-- string includes both antiquote and positional parameters.+sql  :: QuasiQuoter+sql  = expressionOnly "aritySql " $ \raw -> do+    loc <- location+    let e_ast = parseQuery (show loc) raw+    case e_ast of+        Right parsed -> do+            let+                positionalCount = maxParam parsed+                (rewritten, haskellExpressions) = numberAntiquotes positionalCount parsed+                -- mkName, because we intend to capture what's in scope+                antiNames = map mkName haskellExpressions+            query <- makeQuery rewritten+            case positionalCount of+                0 -> -- only antiquotes (or no params)+                    return $ TupE [query, tupleOrSingle antiNames]+                1 -> do -- one positional param, doesn't take a tuple+                    patternName <- newName "c"+                    return $ LamE [VarP patternName]+                        (TupE [query, tupleOrSingle (patternName : antiNames)])+                _ -> do -- at least two positional parameters+                    patternNames <- cNames 'q' (fromIntegral positionalCount)+                    return $ LamE+                        [TupP (map VarP patternNames)]+                        (TupE [query, tupleOrSingle (patternNames ++ antiNames)])+        Left err -> error err++tupleOrSingle :: [Name] -> Exp+tupleOrSingle names = case names of+    [name] -> VarE name+    vs -> TupE $ map VarE vs++expressionOnly :: String -> (String -> Q Exp) -> QuasiQuoter+expressionOnly name qq = QuasiQuoter+    { quoteExp = qq+    , quotePat = \_ -> error $ "qq " ++ name ++ " cannot be used in pattern context"+    , quoteType = \_ -> error $ "qq " ++ name ++ " cannot be used in type context"+    , quoteDec = \_ -> error $ "qq " ++ name ++ " cannot be used in declaration context"+    }++maxParam :: [Token] -> Word+maxParam = foldr nextParam 0 where+  nextParam token maxParam =+      case token of+          NumberedParam i -> max i maxParam+          _ -> maxParam++numberAntiquotes :: Word -> [Token] -> (String, [String])+numberAntiquotes mp ts = (concat sqlStrings, variableNames) where+  (sqlStrings, variableNames) = go mp ts+  go _maxParam [] = ([], [])+  go maxParam (token : ts) =+      case token of+          HaskellParam name -> let+              newParam = maxParam + 1+              (ss, ns) = go newParam ts+              in (unLex (NumberedParam newParam) : ss, name : ns)+          EOF -> go maxParam ts+          _ -> let (ss, ns) = go maxParam ts in (unLex token : ss, ns)
+ src/Preql/Wire.hs view
@@ -0,0 +1,8 @@+-- | This module re-exports definitions from Wire.* that are expected to be useful++module Preql.Wire (module X) where++import Preql.Wire.FromSql as X+import Preql.Wire.Internal as X (Query, RowDecoder, DecoderState(..), LocatedError(..), FieldError(..))+import Preql.Wire.ToSql as X+import Preql.Wire.Types as X
+ src/Preql/Wire/Connection.hs view
@@ -0,0 +1,8 @@+-- | For now, re-export Connection code from postgresql-simple++module Preql.Wire.Connection+    ( Connection(..), ConnectInfo(..), defaultConnectInfo+    , connect, connectPostgreSQL+    ) where++import           Database.PostgreSQL.Simple.Internal
+ src/Preql/Wire/FromSql.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# HLINT ignore "Use camelCase" #-}++{-# LANGUAGE DeriveFunctor     #-}+-- | Decoding values from Postgres wire format to Haskell.++module Preql.Wire.FromSql where++import           Preql.Wire.Internal+import           Preql.Wire.Types++import           Control.Applicative.Free+import           Control.Monad.Except+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.State+import           Data.Int+import           Data.Time (Day, TimeOfDay, UTCTime)+import           Data.UUID (UUID)+import           Preql.Imports++import qualified BinaryParser as BP+import qualified Data.Aeson as JSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as OID+import qualified PostgreSQL.Binary.Decoding as PGB++data FieldDecoder a = FieldDecoder PQ.Oid (BP.BinaryParser a)+    deriving Functor++data DecoderError = FieldError (LocatedError FieldError) | PgTypeMismatch [TypeMismatch]+    deriving (Show, Eq, Typeable)+instance Exception DecoderError++data TypeMismatch = TypeMismatch+    { expected :: PQ.Oid+    , actual :: PQ.Oid+    , column :: PQ.Column+    , columnName :: Maybe Text+    } deriving (Eq, Show, Typeable)++throwLocated :: FieldError -> InternalDecoder a+throwLocated failure = do+    DecoderState{..} <- get+    throwError (LocatedError row column failure)++decodeVector :: RowDecoder a -> PQ.Result -> ExceptT DecoderError IO (Vector a)+decodeVector rd@(RowDecoder oids parsers) result = do+    mismatches <- fmap catMaybes $ for (zip [PQ.Col 0 ..] oids) $ \(column, expected) -> do+        actual <- liftIO $ PQ.ftype result column+        if actual == expected+            then return Nothing+            else do+                m_name <- liftIO $ PQ.fname result column+                let columnName = decodeUtf8With lenientDecode <$> m_name+                return $ Just (TypeMismatch{..})+    unless (null mismatches) (throwError (PgTypeMismatch mismatches))+    (PQ.Row ntuples) <- liftIO $ PQ.ntuples result+    let toRow = PQ.toRow . fromIntegral+    withExceptT FieldError $+        V.generateM (fromIntegral ntuples) (decodeRow rd result . toRow)++notNull :: FieldDecoder a -> RowDecoder a+notNull (FieldDecoder oid parser) = RowDecoder [oid] $ do+    m_bs <- getNextValue+    case m_bs of+        Nothing -> throwLocated UnexpectedNull+        Just bs -> either (throwLocated . ParseFailure) pure (BP.run parser bs)++nullable :: FieldDecoder a -> RowDecoder (Maybe a)+nullable (FieldDecoder oid parser) = RowDecoder [oid] $ do+    m_bs <- getNextValue+    case m_bs of+        Nothing -> return Nothing+        Just bs -> either (throwLocated . ParseFailure) (pure . Just) (BP.run parser bs)++class FromSqlField a where+    fromSqlField :: FieldDecoder a++class FromSql a where+    fromSql :: RowDecoder a++instance FromSqlField Bool where+    fromSqlField = FieldDecoder OID.boolOid PGB.bool+instance FromSql Bool where fromSql = notNull fromSqlField++instance FromSqlField Int16 where+    fromSqlField = FieldDecoder OID.int2Oid PGB.int+instance FromSql Int16 where fromSql = notNull fromSqlField++instance FromSqlField Int32 where+    fromSqlField = FieldDecoder OID.int4Oid PGB.int+instance FromSql Int32 where fromSql = notNull fromSqlField++instance FromSqlField Int64  where+    fromSqlField = FieldDecoder OID.int8Oid PGB.int+instance FromSql Int64 where fromSql = notNull fromSqlField++instance FromSqlField Float where+    fromSqlField = FieldDecoder OID.float4Oid PGB.float4+instance FromSql Float where fromSql = notNull fromSqlField++instance FromSqlField Double where+    fromSqlField = FieldDecoder OID.float8Oid PGB.float8+instance FromSql Double where fromSql = notNull fromSqlField++instance FromSqlField Char where+    fromSqlField = FieldDecoder OID.charOid PGB.char+instance FromSql Char where fromSql = notNull fromSqlField++instance FromSqlField String where+    fromSqlField = FieldDecoder OID.textOid (T.unpack <$> PGB.text_strict)+instance FromSql String where fromSql = notNull fromSqlField++instance FromSqlField Text where+    fromSqlField = FieldDecoder OID.textOid PGB.text_strict+instance FromSql Text where fromSql = notNull fromSqlField++instance FromSqlField TL.Text where+    fromSqlField = FieldDecoder OID.textOid PGB.text_lazy+instance FromSql TL.Text where fromSql = notNull fromSqlField++-- | If you want to encode some more specific Haskell type via JSON,+-- it is more efficient to use 'Data.Aeson.encode' and+-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- instance.+instance FromSqlField ByteString where+    fromSqlField = FieldDecoder OID.byteaOid (BS.copy <$> BP.remainders)+instance FromSql ByteString where fromSql = notNull fromSqlField++instance FromSqlField BSL.ByteString where+    fromSqlField = FieldDecoder OID.byteaOid (BSL.fromStrict . BS.copy <$> BP.remainders)+instance FromSql BSL.ByteString where fromSql = notNull fromSqlField++-- TODO check for integer_datetimes setting+instance FromSqlField UTCTime where+    fromSqlField = FieldDecoder OID.timestamptzOid PGB.timestamptz_int+instance FromSql UTCTime where fromSql = notNull fromSqlField++instance FromSqlField Day where+    fromSqlField = FieldDecoder OID.dateOid PGB.date+instance FromSql Day where fromSql = notNull fromSqlField++instance FromSqlField TimeOfDay where+    fromSqlField = FieldDecoder OID.timeOid PGB.time_int+instance FromSql TimeOfDay where fromSql = notNull fromSqlField++instance FromSqlField TimeTZ where+    fromSqlField = FieldDecoder OID.timetzOid (uncurry TimeTZ <$> PGB.timetz_int)+instance FromSql TimeTZ where fromSql = notNull fromSqlField++instance FromSqlField UUID where+    fromSqlField = FieldDecoder OID.uuidOid PGB.uuid+instance FromSql UUID where fromSql = notNull fromSqlField++-- | If you want to encode some more specific Haskell type via JSON,+-- it is more efficient to use 'Data.Aeson.encode' and+-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- instance.+instance FromSqlField JSON.Value where+    fromSqlField = FieldDecoder OID.jsonbOid PGB.jsonb_ast+instance FromSql JSON.Value where fromSql = notNull fromSqlField++-- Overlappable so applications can write Maybe for multi-field domain types+instance {-# OVERLAPPABLE #-} FromSqlField a => FromSql (Maybe a) where+    fromSql = nullable fromSqlField++instance (FromSql a, FromSql b) => FromSql (a, b) where+    fromSql = (,) <$> fromSql <*> fromSql++instance (FromSql a, FromSql b, FromSql c) => FromSql (a, b, c) where+    fromSql = (,,) <$> fromSql <*> fromSql <*> fromSql++instance (FromSql a, FromSql b, FromSql c, FromSql d) => FromSql (a, b, c, d) where+    fromSql = (,,,) <$> fromSql <*> fromSql <*> fromSql <*> fromSql++instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e) => FromSql (a, b, c, d, e) where+    fromSql = (,,,,) <$> fromSql <*> fromSql <*> fromSql <*> fromSql <*> fromSql++-- -- TODO more tuple instances+-- -- TODO TH to make this less tedious
+ src/Preql/Wire/Internal.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |++module Preql.Wire.Internal where++import           Control.Monad.Trans.Except+import           Control.Monad.Trans.State+import           Data.String (IsString)+import            Preql.Imports++import qualified Database.PostgreSQL.LibPQ as PQ++-- TODO less ambiguous name (or rename others)+-- | The IsString instance does no validation; the limited instances+-- discourage directly manipulating strings, with the high risk of SQL+-- injection.+newtype Query = Query ByteString+    deriving (Show, IsString)++-- TODO PgType for non-builtin types+data RowDecoder a = RowDecoder [PQ.Oid] (InternalDecoder a)+    deriving Functor++instance Applicative RowDecoder where+    pure a = RowDecoder [] (pure a)+    RowDecoder t1 p1 <*> RowDecoder t2 p2 = RowDecoder (t1 <> t2) (p1 <*> p2)++-- TODO can I use ValidationT instead of ExceptT, since I ensure Column is incremented before errors?+type InternalDecoder =  StateT DecoderState (ExceptT (LocatedError FieldError) IO)++data DecoderState = DecoderState+    { result :: PQ.Result+    , row :: PQ.Row+    , column :: PQ.Column+    } deriving (Show, Eq)++data LocatedError a = LocatedError+    { errorRow :: PQ.Row+    , errorColumn :: PQ.Column+    , failure :: a+    } deriving (Eq, Show, Typeable)+instance (Show a, Typeable a) => Exception (LocatedError a)++data FieldError+    = UnexpectedNull+    | ParseFailure Text+    deriving (Eq, Show, Typeable)++decodeRow :: RowDecoder a -> PQ.Result -> PQ.Row -> ExceptT (LocatedError FieldError) IO a+decodeRow (RowDecoder _ parsers) result row =+    evalStateT parsers (DecoderState result row 0)++getNextValue :: InternalDecoder (Maybe ByteString)+getNextValue = do+    s@DecoderState{..} <- get+    put (s { column = column + 1 } :: DecoderState)+    liftIO $ PQ.getvalue result row column
+ src/Preql/Wire/Query.hs view
@@ -0,0 +1,51 @@+module Preql.Wire.Query where++import            Preql.Wire.FromSql+import            Preql.Wire.Internal+import            Preql.Wire.ToSql++import           Control.Concurrent.MVar+import           Control.Monad+import           Control.Monad.Trans.Except+import            Preql.Imports++import qualified Database.PostgreSQL.LibPQ as PQ++queryWith :: RowEncoder p -> RowDecoder r -> PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r))+queryWith enc dec conn (Query query) params = runExceptT $ do+    -- TODO safer Connection type+    -- withMVar (connectionHandle conn) $ \connRaw -> do+        result <- execParams enc conn query params+        withExceptT DecoderError (decodeVector dec result)++-- If there is no result, we don't need a Decoder+queryWith_ :: RowEncoder p -> PQ.Connection -> Query -> p -> IO (Either QueryError ())+queryWith_ enc conn (Query query) params =+    runExceptT (void (execParams enc conn query params))++execParams :: RowEncoder p -> PQ.Connection -> ByteString -> p -> ExceptT QueryError IO PQ.Result+execParams enc conn query params = do+    result <- queryError conn =<< liftIO (PQ.execParams conn query (runEncoder enc params) PQ.Binary)+    status <- liftIO (PQ.resultStatus result)+    unless (status == PQ.CommandOk || status == PQ.TuplesOk) $ do+        msg <- liftIO (PQ.resStatus status)+        throwE (QueryError (decodeUtf8With lenientDecode msg))+    return result++query :: (ToSql p, FromSql r) => PQ.Connection -> Query -> p -> IO (Either QueryError (Vector r))+query = queryWith toSql fromSql++query_ :: ToSql p => PQ.Connection -> Query -> p -> IO (Either QueryError ())+query_ = queryWith_ toSql++data QueryError = QueryError Text | DecoderError DecoderError+    deriving (Eq, Show, Typeable)+instance Exception QueryError++queryError :: PQ.Connection -> Maybe a -> ExceptT QueryError IO a+queryError _conn (Just a) = return a+queryError conn Nothing = do+    m_msg <- liftIO $ PQ.errorMessage conn+    case m_msg of+        Just msg -> throwE (QueryError (decodeUtf8With lenientDecode msg))+        Nothing -> throwE (QueryError "No error message available")
+ src/Preql/Wire/ToSql.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Preql.Wire.ToSql where++import           Preql.Imports+import           Preql.Wire.Types++import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Divisible+import           Data.Int+import           Data.Time (Day, TimeOfDay, UTCTime, TimeZone)+import           Data.UUID (UUID)++import qualified ByteString.StrictBuilder as B+import qualified Data.Aeson as JSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as OID+import qualified PostgreSQL.Binary.Encoding as PGB++data FieldEncoder a = FieldEncoder PQ.Oid (a -> B.Builder)++instance Contravariant FieldEncoder where+    contramap f (FieldEncoder oid enc) = FieldEncoder oid (enc . f)++runFieldEncoder :: FieldEncoder p -> p -> (PQ.Oid, ByteString)+runFieldEncoder (FieldEncoder oid enc) p = (oid, B.builderBytes (enc p))++type RowEncoder a = a -> [(PQ.Oid, ByteString)]++runEncoder :: RowEncoder p -> p -> [Maybe (PQ.Oid, ByteString, PQ.Format)]+runEncoder fields p = fields p <&> \(oid, bs) -> Just (oid, bs, PQ.Binary)++oneField :: FieldEncoder a -> RowEncoder a+oneField enc = \p -> [runFieldEncoder enc p]++class ToSqlField a where+    toSqlField :: FieldEncoder a++class ToSql a where+    toSql :: RowEncoder a++instance ToSqlField Int16 where+    toSqlField = FieldEncoder OID.int2Oid PGB.int2_int16+instance ToSql Int16 where toSql = oneField toSqlField++instance ToSqlField Int32 where+    toSqlField = FieldEncoder OID.int4Oid PGB.int4_int32+instance ToSql Int32 where toSql = oneField toSqlField++instance ToSqlField Int64 where+    toSqlField = FieldEncoder OID.int8Oid PGB.int8_int64+instance ToSql Int64 where toSql = oneField toSqlField++instance ToSqlField Float where+    toSqlField = FieldEncoder OID.float4Oid PGB.float4+instance ToSql Float where toSql = oneField toSqlField++instance ToSqlField Double where+    toSqlField = FieldEncoder OID.float8Oid PGB.float8+instance ToSql Double where toSql = oneField toSqlField++instance ToSqlField Char where+    toSqlField = FieldEncoder OID.charOid PGB.char_utf8+instance ToSql Char where toSql = oneField toSqlField++instance ToSqlField String where+    toSqlField = FieldEncoder OID.textOid (PGB.text_strict . T.pack)+instance ToSql String where toSql = oneField toSqlField++instance ToSqlField Text where+    toSqlField = FieldEncoder OID.textOid PGB.text_strict+instance ToSql Text where toSql = oneField toSqlField++instance ToSqlField TL.Text where+    toSqlField = FieldEncoder OID.textOid PGB.text_lazy+instance ToSql TL.Text where toSql = oneField toSqlField++-- | If you want to encode some more specific Haskell type via JSON,+-- it is more efficient to use 'Data.Aeson.encode' and+-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- instance.+instance ToSqlField ByteString where+    toSqlField = FieldEncoder OID.byteaOid PGB.bytea_strict+instance ToSql ByteString where toSql = oneField toSqlField++instance ToSqlField BSL.ByteString where+    toSqlField = FieldEncoder OID.byteaOid PGB.bytea_lazy+instance ToSql BSL.ByteString where toSql = oneField toSqlField++-- TODO check for integer_datetimes setting+instance ToSqlField UTCTime where+    toSqlField = FieldEncoder OID.timestamptzOid PGB.timestamptz_int+instance ToSql UTCTime where toSql = oneField toSqlField++instance ToSqlField Day where+    toSqlField = FieldEncoder OID.dateOid PGB.date+instance ToSql Day where toSql = oneField toSqlField++instance ToSqlField TimeOfDay where+    toSqlField = FieldEncoder OID.timeOid PGB.time_int+instance ToSql TimeOfDay where toSql = oneField toSqlField++instance ToSqlField TimeTZ where+    toSqlField = FieldEncoder OID.timetzOid (\(TimeTZ tod tz) -> PGB.timetz_int (tod, tz))+instance ToSql TimeTZ where toSql = oneField toSqlField++instance ToSqlField UUID where+    toSqlField = FieldEncoder OID.uuidOid PGB.uuid+instance ToSql UUID where toSql = oneField toSqlField++-- | If you want to encode some more specific Haskell type via JSON,+-- it is more efficient to use 'Data.Aeson.encode' and+-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this+-- instance.+instance ToSqlField JSON.Value where+    toSqlField = FieldEncoder OID.jsonbOid PGB.jsonb_ast+instance ToSql JSON.Value where toSql = oneField toSqlField++instance ToSql () where+    toSql () = []++instance (ToSqlField a, ToSqlField b) => ToSql (a, b) where+    toSql (a, b) = [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b]++instance (ToSqlField a, ToSqlField b, ToSqlField c) => ToSql (a, b, c) where+    toSql (a, b, c) =+        [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b, runFieldEncoder toSqlField c]++instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d) => ToSql (a, b, c, d) where+    toSql (a, b, c, d) =+        [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b, runFieldEncoder toSqlField c+        , runFieldEncoder toSqlField d]++instance (ToSqlField a, ToSqlField b, ToSqlField c, ToSqlField d, ToSqlField e) =>+    ToSql (a, b, c, d, e) where+    toSql (a, b, c, d, e) =+        [runFieldEncoder toSqlField a, runFieldEncoder toSqlField b, runFieldEncoder toSqlField c+        , runFieldEncoder toSqlField d, runFieldEncoder toSqlField e]
+ src/Preql/Wire/Types.hs view
@@ -0,0 +1,5 @@+module Preql.Wire.Types where++import           Data.Time (TimeOfDay, TimeZone)++data TimeTZ = TimeTZ !TimeOfDay !TimeZone