diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/library/Positron.hs b/library/Positron.hs new file mode 100644 --- /dev/null +++ b/library/Positron.hs @@ -0,0 +1,201 @@ +module Positron + ( model + , Column + , Property(..) + , (//) + , Query(..) + , Condition + , (.==) + , SetValue + , (?=) + , whose + , Parameter(..) + , orderBy + , OrderBy(..) + , onConflict + , returning + + , module Positron.Alias + , module Positron.Query + , mkPositron + + , Positron + , ConnConf + , defaultConnConf + , setDBHost + , setDBPort + , setDBName + , setDBUser + , setDBPassword + , connect + , close + , withDatabase + + , PositronError(..) + , textShow + + -- re-export data types + , NonEmpty(..) + , Int16 + , Int32 + , Int64 + , Scientific + , Float + , Double + , Word16 + , Word32 + , Word64 + , ByteString + , Text + , UUID(..) + + ) where + +import Positron.Import + +-- local modules + +import Positron.Alias +import Positron.Driver +import Positron.Query +import Positron.Types +import Positron.UUID +import Positron.Unsafe +import Positron.Util + +mkPositron :: String -> Q [Dec] +mkPositron namespace = do + -- record field names that cannot be captured + connField <- newName "conn" + connType <- [t| Connection |] + lockField <- newName "lock" + lockType <- [t| MVar () |] + + let + rec fieldName fieldType = + (fieldName, Bang NoSourceUnpackedness SourceStrict, fieldType) + recs = + [ rec connField connType + , rec lockField lockType + ] + dataDec = DataD [] (mkName $ "Positron" <> namespace) [] Nothing + [RecC dataName recs] [] + + pairs <- runIO readPrepared + + createQueries <- fold . reverse . map buildCreateQuery <$> + getCurrentTableMap + instanceDec <- [d| + instance Positron $(return $ ConT dataName) where + pConn = $(return $ VarE connField) + pLock = $(return $ VarE lockField) + pPrepareds = const pairs + pCreateQueries = const createQueries + pMake conn = do + lock <- newMVar () + return $ $(return $ ConE dataName) conn lock + |] + + return $ dataDec : instanceDec + where + dataName = mkName $ "Positron" <> namespace + buildCreateQuery (tableName, columnPairs) = let + snakeTableName = snake (decap tableName) + columns = map snd columnPairs + primaryKeys = map (snake . acn) $ filter acp columns + indexedKeys = map (snake . acn) $ filter aci columns + foreignKeys = map formatForeignKey $ mapMaybe + (\ c -> fmap (\ x -> (acn c, x)) (acf c)) columns + in fold + [ "CREATE TABLE IF NOT EXISTS " + , snakeTableName + , " (\n " + , fold $ for columns $ \AC{..} -> fold + [ snake acn, " ", show act + , if acUnique then " UNIQUE" else "" + , if acnl then " NULL" else " NOT NULL" + , ",\n " + ] + , "PRIMARY KEY (" + , intercalate ", " primaryKeys + , ")" + , if foreignKeys /= [] + then foldMap (",\n " ++) foreignKeys + else mempty + , "\n);\n" + , if indexedKeys /= [] + then fold $ for indexedKeys $ \columnName -> fold + [ "CREATE INDEX IF NOT EXISTS ix_" + , snakeTableName, "_", columnName + , " ON ", snakeTableName, " (", columnName, ");\n" + ] + else mempty + ] + formatForeignKey (columnName, (targetTableName, targetColumnName)) = fold + [ "FOREIGN KEY(", snake columnName, ") REFERENCES " + , targetTableName, " (", snake targetColumnName, ")" + ] + +model :: String -> [Column] -> Q [Dec] +model tableName plainColumns = do + columns <- mapM (analyze tableName) plainColumns + thisModuleStr <- show <$> thisModule + addTable thisModuleStr (tableName, [(acn, a) | a@AC{..} <- columns]) + let + recs = for columns $ \ac@AC{..} -> + ( mkName acFullName + , Bang + (if acnl then NoSourceUnpackedness else SourceUnpack) + SourceStrict + , columnTypeCon ac + ) + + condDecs <- fmap fold <$> forM columns $ \ AC{..} -> let + condName = mkName $ acFullName ++ "EqParam" + in do + defAST <- [| Condition acn Parameter |] + return + [ SigD condName $ ConT ''Condition + , ValD (VarP condName) (NormalB defAST) [] + ] + + return $ + DataD [] dataName [] Nothing [RecC dataName recs] + [DerivClause Nothing [ConT ''Eq, ConT ''Show]] + : condDecs + where + dataName = mkName tableName + +analyze :: String -> Column -> Q AnalyzedColumn +analyze tableName (Column n t pk idx nl unique) = case t of + Psmallint -> ret DBsmallint + Pinteger -> ret DBinteger + Pbigint -> ret DBbigint + Pdecimal -> ret DBdecimal + Pnumeric -> ret DBnumeric + Preal -> ret DBreal + Pdouble -> ret DBdouble + Psmallserial -> ret DBsmallserial + Pserial -> ret DBserial + Pbigserial -> ret DBbigserial + Pvarchar len -> ret $ DBvarchar len + Ptext -> ret DBtext + Puuid -> ret DBuuid + Pforeignkey s -> do + let + (tn, dottedColName) = break (== '.') s + cn = tail dottedColName + thisModuleStr <- show <$> thisModule + lookupColumn thisModuleStr tn cn >>= \case + Nothing -> fail $ fold + ["Column \"", cn, "\" of Table \"", tn, "\" not found"] + Just AC{..} -> return $ acBase (plain act) (Just (tn, cn)) + where + ret dt = return (acBase dt Nothing) + acBase = AC n fullName pk idx nl unique + plain = \case + DBsmallserial -> DBsmallint + DBserial -> DBinteger + DBbigserial -> DBbigint + x -> x + fullName = decap tableName ++ cap n diff --git a/library/Positron/Alias.hs b/library/Positron/Alias.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Alias.hs @@ -0,0 +1,68 @@ +module Positron.Alias + ( smallint + , integer + , bigint + , decimal + , numeric + , real + , double + , serial + , bigserial + , varchar + , foreignkey + , text + , uuid + , insert + , upsert + , selectModel + , getModel + , update + , parameter + ) where + +import Positron.Types + +smallint :: String -> Column +smallint = defaultColumn Psmallint +integer :: String -> Column +integer = defaultColumn Pinteger +bigint :: String -> Column +bigint = defaultColumn Pbigint +decimal :: String -> Column +decimal = defaultColumn Pdecimal +numeric :: String -> Column +numeric = defaultColumn Pnumeric +real :: String -> Column +real = defaultColumn Preal +double :: String -> Column +double = defaultColumn Pdouble +serial :: String -> Column +serial = defaultColumn Pserial +bigserial :: String -> Column +bigserial = defaultColumn Pbigserial +varchar :: Integer -> String -> Column +varchar n = defaultColumn (Pvarchar n) +foreignkey :: String -> String -> Column +foreignkey target = defaultColumn (Pforeignkey target) +text :: String -> Column +text = defaultColumn Ptext +uuid :: String -> Column +uuid = defaultColumn Puuid + +insert :: String -> Query +insert n = Insert n Nothing [] + +upsert :: String -> Query +upsert = Upsert + +selectModel :: String -> Query +selectModel name = Select (SelectModel name) [] [] + +getModel :: String -> Query +getModel name = GetModel name [] + +update :: String -> [SetValue] -> Query +update name setValues = Update name setValues [] + +parameter :: Parameter +parameter = Parameter diff --git a/library/Positron/Binary.hs b/library/Positron/Binary.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Binary.hs @@ -0,0 +1,27 @@ +module Positron.Binary where + +import Positron.Import + +import qualified Data.ByteString as B + +class BigEndian b where + decode :: ByteString -> Maybe b +instance BigEndian Int16 where + decode = readN 2 +instance BigEndian Int32 where + decode = readN 4 +instance BigEndian Int64 where + decode = readN 8 + +readN :: Integral result => Int -> ByteString -> Maybe result +readN maxLength b + | maxLength > B.length b = Nothing + | otherwise = Just (bigEndian (B.take maxLength b)) + +bigEndian :: Integral i => ByteString -> i +bigEndian = bigEndian' 0 + where + bigEndian' :: Integral i => i -> ByteString -> i + bigEndian' acc b = case B.uncons b of + Nothing -> acc + Just (w, leftover) -> bigEndian' (acc * 256 + fromIntegral w) leftover diff --git a/library/Positron/Driver.hs b/library/Positron/Driver.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Driver.hs @@ -0,0 +1,153 @@ +module Positron.Driver + ( ConnConf + , defaultConnConf + , setDBHost + , setDBPort + , setDBName + , setDBUser + , setDBPassword + , connect + , close + , withDatabase + , unsafeExecPrepared + , unsafeExec + ) where + +import Positron.Import + +-- data types + +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-- extra modules + +import qualified Database.PostgreSQL.LibPQ as PQ + +-- local modules + +import Positron.Types +import Positron.Parser + +data ConnConf = ConnConf + { dbHost :: Maybe Text + , dbPort :: Maybe Word16 + , dbName :: Maybe Text + , dbUser :: Maybe Text + , dbPassword :: Maybe Text + } + +defaultConnConf :: ConnConf +defaultConnConf = ConnConf Nothing Nothing Nothing Nothing Nothing + +setDBHost :: ConnConf -> Maybe Text -> ConnConf +setDBHost c x = c { dbHost = x } +infixl 4 `setDBHost` + +setDBPort :: ConnConf -> Maybe Word16 -> ConnConf +setDBPort c x = c { dbPort = x } +infixl 4 `setDBPort` + +setDBName :: ConnConf -> Maybe Text -> ConnConf +setDBName c x = c { dbName = x } +infixl 4 `setDBName` + +setDBUser :: ConnConf -> Maybe Text -> ConnConf +setDBUser c x = c { dbUser = x } +infixl 4 `setDBUser` + +setDBPassword :: ConnConf -> Maybe Text -> ConnConf +setDBPassword c x = c { dbPassword = x } +infixl 4 `setDBPassword` + +connect + :: Positron positron + => ConnConf + -> IO positron +connect ConnConf{..} = do + conn <- PQ.connectdb conninfo + _ <- PQ.exec conn "SET client_min_messages TO WARNING;" + positron <- pMake conn + _ <- unsafeExec positron (pCreateQueries positron) >>= \case + Right _ -> return conn + Left err -> fail ("While executing CREATE queries: " <> show err) + forM_ (pPrepareds positron) $ \ (stmtName, stmtQuery) -> let + onError = do + -- B.putStrLn stmtName + -- PQ.errorMessage conn >>= maybe (return ()) B.putStrLn + B.putStrLn $ fold [stmtName, " failed, deallocate and retry"] + _ <- PQ.exec conn ("DEALLOCATE \"" <> stmtName <> "\";") + PQ.errorMessage conn >>= maybe (return ()) B.putStrLn + prepare + prepare = PQ.prepare conn stmtName stmtQuery Nothing >>= \ case + Nothing -> onError + Just result -> PQ.resultStatus result >>= \ case + PQ.CommandOk -> return () + PQ.TuplesOk -> return () + _ -> onError + in prepare + return positron + where + conninfo = B.intercalate " " $ mapMaybe (fmap T.encodeUtf8) sources + sources = + [ fmap ("host=" <>) dbHost + , fmap (("port=" <>) . T.pack . show) dbPort + , fmap ("dbname=" <>) dbName + , fmap ("user=" <>) dbUser + , fmap ("password=" <>) dbPassword + ] + +close :: Positron p => p -> IO () +close p = PQ.finish (pConn p) + +withDatabase :: Positron positron + => ConnConf -> (positron -> IO a) -> IO a +withDatabase connConf = bracket (connect connConf) close + +execBase + :: Positron p => p + -> ByteString + -> (Connection -> IO (Maybe PQ.Result)) + -> IO (Either PositronError PQ.Result) +execBase positron errorInfo action = withLock lock $ action conn >>= \case + Nothing -> unknownError + Just result -> PQ.resultStatus result >>= \case + PQ.CommandOk -> returnAfterError result + PQ.TuplesOk -> returnAfterError result + _ -> unknownError + where + conn = pConn positron + lock = pLock positron + unknownError = PQ.errorMessage conn >>= \case + Nothing -> hopeLost "unknown PostgreSQL error" + Just bErr -> let err = T.decodeUtf8 bErr in case parsePQError err of + Left _ -> hopeLost err + Right pErr -> return $ Left pErr + hopeLost msg = return $ Left $ UnknownPositronError msg + -- FIXME: print something better than "preparedName" for easier debugging + printStmt = B.putStr (errorInfo <> "\n") + printIf s = when (s /= "") $ printStmt >> print s + + returnAfterError result = do + PQ.errorMessage conn >>= maybe (return ()) printIf + return (Right result) + +unsafeExecPrepared + :: Positron p => p + -> ByteString -> [Maybe ByteString] -> IO (Either PositronError PQ.Result) +unsafeExecPrepared positron preparedName args = execBase positron preparedName + (\ conn -> PQ.execPrepared conn preparedName fields PQ.Binary) + where + -- FIXME: print something better than "preparedName" for easier debugging + fields :: [Maybe (ByteString, PQ.Format)] + fields = map withFormatting args + withFormatting :: Maybe ByteString -> Maybe (ByteString, PQ.Format) + withFormatting = fmap $ \ x -> (x, PQ.Binary) + +unsafeExec + :: Positron p => p -> ByteString -> IO (Either PositronError PQ.Result) +unsafeExec positron stmt = execBase positron stmt (`PQ.exec` stmt) + +withLock :: MVar () -> IO a -> IO a +withLock lock action = bracket (takeMVar lock) (putMVar lock) (const action) diff --git a/library/Positron/Import.hs b/library/Positron/Import.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Import.hs @@ -0,0 +1,49 @@ +module Positron.Import + ( module Module + , ByteString + , Builder + , Text + , Connection + , snake + , cap + , decap + ) where + +import Control.Concurrent.MVar as Module +import Control.Exception as Module hiding (interruptible) +import Control.Monad as Module +import Data.Bits as Module +import Data.Char as Module +import Data.Foldable as Module +import Data.IORef as Module +import Data.Int as Module +import Data.List as Module +import Data.List.NonEmpty as Module (NonEmpty(..)) +import Data.Maybe as Module +import Data.Monoid as Module +import Data.Scientific as Module +import Data.String as Module +import Data.Word as Module +import Language.Haskell.TH as Module +import Language.Haskell.TH.Syntax as Module + +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.Text (Text) +import Database.PostgreSQL.LibPQ (Connection) + +import Positron.Instance as Module () + +snake :: String -> String +snake [] = [] +snake (x : xs) + | isUpper x = '_' : toLower x : snake xs + | otherwise = x : snake xs + +cap :: String -> String +cap [] = [] +cap (c : cs) = toUpper c : cs + +decap :: String -> String +decap [] = [] +decap (c : cs) = toLower c : cs diff --git a/library/Positron/Instance.hs b/library/Positron/Instance.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Instance.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Positron.Instance where + +import Language.Haskell.TH.Syntax +import Data.ByteString +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +instance Lift ByteString where + lift b = [| T.encodeUtf8 (T.pack $(lift $ T.unpack $ T.decodeUtf8 b)) |] diff --git a/library/Positron/Parser.hs b/library/Positron/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Parser.hs @@ -0,0 +1,33 @@ +module Positron.Parser + ( parsePQError + ) where + +import Positron.Import + +-- extra modules + +import qualified Data.Attoparsec.Text as A + +-- local modules + +import Positron.Types + +parsePQError :: Text -> Either String PositronError +parsePQError = A.parseOnly pqError + +pqError :: A.Parser PositronError +pqError = do + _ <- A.string "ERROR: " + _ <- A.takeWhile isSpace + A.choice [duplicateKeyParser] + where + duplicateKeyParser = do + _ <- A.string "duplicate key" + _ <- A.takeTill (== ':') + _ <- A.takeTill (== '(') + _ <- A.anyChar + key <- A.takeTill (== ')') + _ <- A.takeTill (== '(') + _ <- A.anyChar + value <- A.takeTill (== ')') + return $ DuplicateKey key value diff --git a/library/Positron/Query.hs b/library/Positron/Query.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Query.hs @@ -0,0 +1,539 @@ +module Positron.Query + ( query + , queryInsert + , queryUpsert + , queryGet + ) where + +import Positron.Import + +-- data types + +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-- extra modules + +import qualified Database.PostgreSQL.LibPQ as PQ + +-- local modules + +import Positron.Driver +import Positron.Store +import Positron.Types +import Positron.Unsafe +import Positron.Util + +queryInsert :: String -> String -> Q [Dec] +queryInsert = queryUpsertBase False + +queryUpsert :: String -> String -> Q [Dec] +queryUpsert = queryUpsertBase True + +query :: String -> Query -> Q [Dec] +query funcStr = \case + Insert tableStr conflict returningCols -> getTable tableStr >>= + prepareXxsert False conflict returningCols funcStr tableStr + Upsert tableStr -> getTable tableStr >>= + prepareXxsert True Nothing [] funcStr tableStr + Select (SelectModel tableStr) conds orderBys -> + prepareSelectModel funcStr tableStr conds orderBys False + GetModel tableStr orderBys -> prepareGet funcStr tableStr orderBys + Select (SelectFields _) _ _ -> error + "selecting fields is not implemented yet" + Update tableStr setValues conds -> getTable tableStr >>= + prepareUpdate funcStr tableStr setValues conds + +mkPrepare + :: String + -> ByteString + -> (Name -> ByteString -> Q (Type, [Pat], Exp)) + -> Q [Dec] +mkPrepare funcStr queryStr construct = do + preparedName <- getPreparedName funcStr + addPrepared (preparedName, queryStr) + + positronArg <- newName "_positron" + (typeSignature, patterns, bodyExp) <- construct positronArg preparedName + return + [ SigD funcName (positronContext typeSignature) + , FunD funcName + [Clause (VarP positronArg : patterns) (NormalB bodyExp) []] + ] + + where + funcName = mkName funcStr + +prepareUpdate + :: String -> String -> [SetValue] -> [Condition] -> Table -> Q [Dec] +prepareUpdate funcStr tableStr setValues conds table = + mkPrepare funcStr queryStr $ \ positronArg preparedName -> do + keyTHArgs <- forM params $ \ ac -> do + thName <- newName $ "_" <> acn ac + return (thName, ac) + let encodedArgs = ListE $ map argumentAST keyTHArgs + typeSignature <- let + argTypes = map columnTypeCon params + applyArgs t = foldr (\ x y -> AppT (AppT ArrowT x) y) t argTypes + returnValueType = [t| IO (Either PositronError ()) |] + in applyArgs <$> returnValueType + mainContentExp <- [| fmap (const ()) <$> unsafeExecPrepared + $(return $ VarE positronArg) + $(return $ LitE $ StringL $ T.unpack $ T.decodeUtf8 preparedName) + $(return encodedArgs) + |] + return (typeSignature, map (VarP . fst) keyTHArgs, mainContentExp) + where + queryStr = toByteString $ fold + [ "update " + , B.string7 $ snake $ decap tableStr + , " set " + , fold $ intersperse ", " $ condBuilder 1 setValueConds + , if not (null conds) then + " where " <> fold + (intersperse " and " $ condBuilder condStartsAt conds) + else mempty + , ";" + ] + condStartsAt = length setValues + 1 + setValueConds = map unSetValue setValues + params = getParamColumns table (setValueConds ++ conds) + +prepareGet :: String -> String -> [OrderBy] -> Q [Dec] +prepareGet funcStr tableStr orderBys = do + columns <- fmap (map snd) $ getTable tableStr + let pkConds = map ((`Condition` Parameter) . acn) $ filter acp columns + prepareSelectModel funcStr tableStr pkConds orderBys True + +prepareSelectModel + :: String -> String -> [Condition] -> [OrderBy] -> Bool -> Q [Dec] +prepareSelectModel funcStr tableStr conds orderBys oneRow = do + -- TODO: support column selection + table <- getTable tableStr + let + columns = map snd table + -- params: the parameters of this function. They are the parametric + -- ("$1", "$2", etc.) part of the "where" clause. + params = getParamColumns table conds + queryStr = toByteString $ fold + [ "select " + , fold $ intersperse ", " $ map (B.string7 . snake . acn) columns + , " from " + , B.string7 $ snake $ decap tableStr + , if not (null conds) then + " where " <> fold (intersperse " and " $ condBuilder 1 conds) + else mempty + , if not (null orderBys) then let + msg name = error $ fold + [ "column ", name, " is not in table ", tableStr + , " (", intercalate ", " $ map fst table + ] + fLookup name = fromMaybe (msg name) $ lookup name table + f2 name = B.string7 (snake $ acn $ fLookup name) + f (Asc name) = f2 name <> " asc" + f (Desc name) = f2 name <> " desc" + in " order by " <> fold + (intersperse ", " $ map f orderBys) + else mempty + , ";" + ] + + -- register to the list of prepareds + preparedName <- getPreparedName funcStr + addPrepared (preparedName, queryStr) + + -- construct AST for this function + -- positronArg: The argument of the type "Positron" + positronArg <- newName "_positron" + -- keyTHArgs: The arguments that are used in the "where" clause + keyTHArgs <- forM params $ \ ac -> do + thName <- newName $ "_" <> acn ac + return (thName, ac) + -- encodedArgs: All function arguments that are converted into + -- "Maybe ByteString" so that they can be passed to unsafeExecPrepared + -- immediately. + let encodedArgs = ListE $ map argumentAST keyTHArgs + + -- execResult: The name to bind the execPrepared result + execResultName <- newName "execResult" + let execResult = return $ VarE execResultName + + -- typeSignature: The type signature of the resulting function. + -- For example, + -- "Positron p => p -> Int64 -> IO (Either PositronError [MyModel])" + typeSignature <- let + argTypes = map columnTypeCon params + applyArgs t = foldr (\ x y -> AppT (AppT ArrowT x) y) t argTypes + returnValueType = if oneRow + then [t| IO (Maybe $(return (ConT tableName))) |] + else [t| IO [$(return (ConT tableName))] |] + in positronContext . applyArgs <$> returnValueType + + rowIndexName <- newName "rowIndex" + let rowIndex = if oneRow then [| 0 |] else return $ VarE rowIndexName + + -- bindPairs: pairs of binding for each field in one row. + -- For example, "c1 <- dbUnstore <$> PQ.getvalue' result 0 1" + bindPairs <- forM (zip [0 :: Int16 ..] columns) $ \ (i, AC{..}) -> do + fname <- newName acn + unstoreExp <- if acnl + then [| fmap binaryUnstore |] + else [| binaryUnstore . fromMaybe (error msgNull) |] + getvalueExp <- [| fmap $(return unstoreExp) + (PQ.getvalue' $(execResult) $(rowIndex) i) |] + return (fname, getvalueExp) + + ntuples <- newName "ntuples" + let + ntuplesP = return $ VarP ntuples + ntuplesE = return $ VarE ntuples + + -- When "oneRow" is true, the select query must return a "Maybe x" + -- Otherwise, it must return a "[x]" + resultProcessingAST <- if oneRow + then do + resultExp <- do + prefix <- [| return . Just |] + return $ NoBindS $ AppE prefix $ + foldl' (\ x y -> AppE x (VarE y)) (ConE tableName) + (map fst bindPairs) + [| if $(ntuplesE) > 0 + then $(return $ DoE $ + [BindS (VarP x) y | (x, y) <- bindPairs] ++ [resultExp]) + else return Nothing + |] + else let + oneRowResultExp = NoBindS $ AppE (VarE 'return) $ + foldl' (\ x y -> AppE x (VarE y)) (ConE tableName) $ + map fst bindPairs + oneRowGetterAST = LamE [VarP rowIndexName] $ DoE $ + [BindS (VarP x) y | (x, y) <- bindPairs] ++ [oneRowResultExp] + in + [| if $(ntuplesE) > 0 + then forM [0 .. $(ntuplesE) - 1] $(return oneRowGetterAST) + else return [] + |] + + execPreparedAST <- [| do + $(return (VarP execResultName)) <- unsafeExecPrepared + $(return $ VarE positronArg) preparedName $(return encodedArgs) + >>= either (fail . show) return + $(ntuplesP) <- PQ.ntuples $(execResult) + $(return resultProcessingAST) + |] + + return + [ SigD funcName typeSignature + , FunD funcName + [ Clause + (VarP positronArg : map (VarP . fst) keyTHArgs) + (NormalB execPreparedAST) + [] + ] + ] + where + funcName = mkName funcStr + tableName = mkName tableStr + +prepareXxsert + :: Bool -> Maybe (NonEmpty String, NonEmpty String) -> [String] + -> String -> String -> Table -> Q [Dec] +prepareXxsert isUpsert conflict returningCols funcStr tableStr rawTable = do + mkPrepare funcStr queryStr $ \ positronArg preparedName -> do + + -- Build AST for the query function + -- columnTHArgs: The arguments that will appear on the left side and the + -- right side of the function definition. "Points" as in point-free. + columnTHArgs <- forM columns $ \ ac -> do + thName <- newName $ "_" <> acn ac + return (thName, ac) + -- encodedArgs: The list of arguments for the prepared statement. + -- Its type is [Maybe ByteString]. + let encodedArgs = ListE $ map argumentAST columnTHArgs + + execResult <- newName "execResult" + + typeSignature <- let + serialsType = return $ foldl AppT (TupleT $ length resultCols) $ + map columnTypeCon resultCols + in do + result <- [t| IO (Either PositronError $(serialsType)) |] + return $ + foldr ((\ x y -> AppT (AppT ArrowT x) y) . columnTypeCon) + result columns + + bindPairs <- forM (zip [0 :: Word16 ..] resultCols) $ \ (i, AC{..}) -> do + fieldName <- newName acn + unstoreExp <- let msg = "NOT NULL field is NULL: " <> acn in if acnl + then [| fmap binaryUnstore |] + else [| binaryUnstore . fromMaybe (error msg) |] + getvalueExp <- [| fmap $(return unstoreExp) + (PQ.getvalue $(return (VarE execResult)) 0 i) |] + return (fieldName, getvalueExp) + let + resultExp = NoBindS $ AppE (VarE 'return) $ AppE (ConE 'Right) $ + TupE $ map (VarE . fst) bindPairs + -- When this query function has a return value (RETURNING clause), the + -- result needs to be bound. Otherwise, the binding will only cause + -- the unused binding warning. The definition below chooses + -- accordingly. + execResultBinding = if null resultCols then WildP else VarP execResult + + mainContentExp <- [| unsafeExecPrepared + $(return $ VarE positronArg) preparedName + $(return encodedArgs) >>= \case + Left e -> return (Left e) + Right $(return execResultBinding) -> $(return $ DoE $ + [BindS (VarP x) y | (x, y) <- bindPairs] ++ [resultExp]) + |] + + return (typeSignature, map (VarP . fst) columnTHArgs, mainContentExp) + + where + isSerial AC{..} = case act of + DBsmallserial -> True + DBserial -> True + DBbigserial -> True + _ -> False + + (table, serialPairs) = partition (not . isSerial . snd) rawTable + columns = map snd table + analyze = acLookup tableStr table + resultCols = if null returningCols then map snd serialPairs + else map analyze returningCols + allPKs = filter acp columns + columnNames = map (snake . fst) table + queryStr = toByteString $ fold + [ "insert into ", B.string7 $ snake $ decap tableStr, " (" + , fold $ B.string7 <$> intersperse ", " columnNames + , ") values (" + , fold $ intersperse ", " $ map ("$" <>) + [B.intDec x | x <- [1 .. length columnNames]] + , ")" + , if isUpsert then conflictClause allPKs columns + else case conflict of + Nothing -> mempty + Just (conflictCols, updateCols) -> conflictClause + (toList $ fmap analyze conflictCols) + (toList $ fmap analyze updateCols) + , if null resultCols + then mempty + else (" RETURNING " <>) $ fold $ intersperse ", " $ + map (B.string7 . snake . acn) resultCols + , ";" + ] + conflictClause conflictCols updateCols = fold + [ " ON CONFLICT (" + , fold $ intersperse ", " $ + map (B.string7 . snake . acn) conflictCols + , ") DO UPDATE SET " + , fold $ intersperse ", " $ map + ( (\ name -> fold [name, " = EXCLUDED.", name]) + . B.string7 . snake . acn + ) + updateCols + ] + +queryUpsertBase :: Bool -> String -> String -> Q [Dec] +queryUpsertBase upsert queryStr tableName = getTable tableName >>= + \ rawTable -> let + table = filter (not . isSerial . snd) rawTable + acols = map snd table + allPKNames :: String + allPKNames = mconcat $ intersperse ", " $ + map (snake . acn) $ filter acp acols + columnTypes = map columnTypeCon acols + columnArgs = map (VarP . mkName . ("_" ++) . fst) table + columnNames = map (snake . fst) table + insertHeadPart = LitE $ StringL $ mconcat + [ "insert into ", snake $ decap tableName, " (" + , mconcat $ intersperse ", " columnNames, ") values (" + ] + upsertClause = LitE $ StringL $ if upsert then mconcat + [ ") ON CONFLICT (" + , allPKNames + , ") DO UPDATE SET " + , mconcat $ intersperse ", " $ for columnNames $ + \colName -> mconcat [colName, " = EXCLUDED.", colName] + , ";" + ] + else ");" + in do + conn <- newName "conn" + mainQueryExp <- [| mconcat + [ $(return insertHeadPart) + , toByteString $ mconcat $ intersperse ", " + $(return $ ListE $ map expMake acols) + , ")" + , $(return upsertClause) + ] + |] + mainContentExp <- [| fmap (const ()) <$> + unsafeExec $(return $ VarE conn) $(return mainQueryExp) |] + resultTypeSignature <- [t| IO (Either PositronError ()) |] + return + [ SigD queryName $ positronContext $ + foldr (\x y -> AppT (AppT ArrowT x) y) + resultTypeSignature + columnTypes + , FunD queryName + [Clause (VarP conn : columnArgs) (NormalB mainContentExp) []] + ] + where + queryName = mkName queryStr + expMake AC{..} = case act of + DBsmallint -> defaultWrapVarE 'B.int16Dec + DBinteger -> defaultWrapVarE 'B.int32Dec + DBbigint -> defaultWrapVarE 'B.int64Dec + DBsmallserial -> defaultWrapVarE 'B.int16Dec + DBserial -> defaultWrapVarE 'B.int32Dec + DBbigserial -> defaultWrapVarE 'B.int64Dec + DBvarchar _ -> textMake + DBtext -> textMake + _ -> defaultWrap bShow + where + textMake = wrap + (VarE 'T.encodeUtf8Builder) + (AppE + (if acnl then AppE (VarE 'fmap) sanitize else sanitize) + (VarE $ mkName ("_" ++ acn)) + ) + bShow = InfixE + (Just (VarE 'B.byteString)) + (VarE '(.)) + (Just (InfixE + (Just (VarE 'B.pack)) + (VarE '(.)) + (Just (VarE 'show)) + )) + sanitize = InfixE (Just quote) (VarE '(.)) (Just escape) + quote = InfixE + (Just (InfixE (Just (LitE (StringL "'"))) (VarE '(<>)) Nothing)) + (VarE '(.)) + (Just (InfixE Nothing (VarE '(<>)) (Just (LitE (StringL "'"))))) + escape = AppE + (AppE (VarE 'T.replace) (AppE (VarE 'T.pack) (LitE (StringL "'")))) + (AppE (VarE 'T.pack) (LitE (StringL "''"))) + + defaultWrapVarE = defaultWrap . VarE + defaultWrap f = wrap f (VarE $ mkName $ "_" ++ acn) + wrap converter value = if acnl + then AppE + (AppE (AppE (VarE 'maybe) (LitE (StringL "null"))) converter) + value + else AppE converter value + isSerial AC{..} = case act of + DBsmallserial -> True + DBserial -> True + DBbigserial -> True + _ -> False + +queryGet :: String -> String -> Q [Dec] +queryGet funcStr tableStr = getTable tableStr >>= \ columnMap -> do + let + columnNames = map (snake . fst) columnMap + acols = map snd columnMap + -- FIXME: support composite key (multiple primary keys) + pk = head $ filter acp acols + pkType = return $ columnTypeCon pk + resultTypeSignature <- positronContext <$> [t| + $(pkType) -> IO (Maybe $(return $ ConT tableName)) + |] + connArg <- newName "connArg" + keyArg <- newName "keyArg" + resultName <- newName "resultName" + queryAST <- [| toByteString $ mconcat + [ $( return $ LitE $ StringL $ mconcat + [ "select ", mconcat $ intersperse ", " columnNames + , " from ", snake $ decap tableStr, " where ", acn pk, " = " + ] + ) + , dbStore $( return $ VarE keyArg ) + , ";" + ] + |] + bindPairs <- forM (zip [0 :: Integer ..] acols) $ \ (i, AC{..}) -> do + fname <- newName acn + unstoreExp <- if acnl + then [| fmap dbUnstore |] + else [| dbUnstore . fromMaybe (error "NOT NULL field is NULL") |] + getvalueExp <- [| fmap $(return unstoreExp) + (PQ.getvalue' $(return $ VarE resultName) 0 i) |] + return (fname, getvalueExp) + resultExp <- do + prefix <- [| return . Just |] + return $ NoBindS $ AppE prefix $ + foldl' (\ x y -> AppE x (VarE y)) + (ConE tableName) (map fst bindPairs) + doExp <- [| do + $(return (VarP resultName)) <- unsafeExec + $(return $ VarE connArg) $(return queryAST) >>= + either (fail . show) return + ntuples <- fmap (> 0) (PQ.ntuples $(return $ VarE resultName)) + if ntuples + then $(return $ DoE $ + [BindS (VarP x) y | (x, y) <- bindPairs] ++ [resultExp]) + else return Nothing + |] + return + [ SigD funcName resultTypeSignature + , FunD funcName + [ Clause [VarP connArg, VarP keyArg] (NormalB doExp) [] + ] + ] + where + funcName = mkName funcStr + tableName = mkName tableStr + +getTable :: String -> Q Table +getTable tableName = do + currentTableMap <- getCurrentTableMap + return $ fromMaybe (error noTable) $ lookup tableName currentTableMap + where + noTable = "Can't find the table: " ++ tableName + + +-- positronContext: The "Positron p => p ->" part of type signature. +positronContext :: Type -> Type +positronContext = let p = mkName "p" in + ForallT [PlainTV p] [AppT (ConT ''Positron) (VarT p)] . + AppT (AppT ArrowT (VarT p)) + + +-- argumentAST: Build AST of a function argument +argumentAST :: (Name, AnalyzedColumn) -> Exp +argumentAST (thName, AC{..}) = wrapper (VarE thName) + where + wrapper = if acnl + then AppE (AppE (VarE 'fmap) binaryEncodeAST) + else AppE (ConE 'Just) . AppE binaryEncodeAST + binaryEncodeAST = VarE 'binaryStore + +getPreparedName :: String -> Q ByteString +getPreparedName funcStr = do + moduleName <- B.string7 . (\ (Module _ (ModName s)) -> s) <$> thisModule + return $ toByteString $ fold [moduleName, ".", B.string7 funcStr] + +condBuilder :: Int -> [Condition] -> [Builder] +condBuilder _ [] = [] +condBuilder ctr (x : xs) = case x of + Condition fieldName Parameter -> + fold [B.string7 (snake fieldName), " = $", B.intDec ctr] : + condBuilder (ctr + 1) xs + _ -> + -- TODO: type checking + error "Fixed parameter is not implemented" + +getParamColumns + :: [(String, AnalyzedColumn)] -> [Condition] -> [AnalyzedColumn] +getParamColumns table conds = catMaybes $ for conds $ \case + Condition fieldName Parameter -> let + msg = "parameter column not found: " <> fieldName + in Just $ fromMaybe (error msg) $ lookup fieldName table + _ -> Nothing + +-- messages +msgNull :: String +msgNull = "NOT NULL field is NULL" diff --git a/library/Positron/Store.hs b/library/Positron/Store.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Store.hs @@ -0,0 +1,73 @@ +module Positron.Store where + +import Positron.Import + +-- external modules + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Builder as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-- local modules + +import Positron.Binary +import Positron.UUID (UUID(..)) +import Positron.Util + +import qualified Positron.UUID as UUID + +-- Convert the result from the database to a Haskell type. +class DBStorable c where + dbStore :: c -> Builder + dbUnstore :: ByteString -> c + +instance DBStorable Int16 where + dbStore = B.int16Dec + dbUnstore = decimal +instance DBStorable Int32 where + dbStore = B.int32Dec + dbUnstore = decimal +instance DBStorable Int64 where + dbStore = B.int64Dec + dbUnstore = decimal +instance DBStorable Text where + dbStore = T.encodeUtf8Builder . sanitize + where + sanitize = quote . escape + quote = ("'" <>) . (<> "'") + escape = T.replace "'" "''" + dbUnstore = T.decodeUtf8 + +-- Encode a Haskell value to a data in PostgreSQL's binary format. +class BinaryStorable c where + binaryStore :: c -> ByteString + binaryUnstore :: ByteString -> c + +instance BinaryStorable Int16 where + binaryStore = toByteString . B.int16BE + binaryUnstore = unsafeDecode +instance BinaryStorable Int32 where + binaryStore = toByteString . B.int32BE + binaryUnstore = unsafeDecode +instance BinaryStorable Int64 where + binaryStore = toByteString . B.int64BE + binaryUnstore = unsafeDecode +instance BinaryStorable Text where + binaryStore = T.encodeUtf8 + binaryUnstore = T.decodeUtf8 +instance BinaryStorable UUID where + binaryStore = uuidByteString + binaryUnstore = UUID.unsafeFromByteString + +unsafeDecode :: BigEndian t => ByteString -> t +unsafeDecode = fromMaybe (error msg) . decode + where + msg = "ByteString decoding fail due to insufficient length " <> + "(perhaps type mismatch?)" + +decimal :: Integral n => ByteString -> n +-- Warning: This function is intentionally partial and should not be exposed +-- outside the library. +decimal = B.foldl' step 0 . B.takeWhile isDigit + where step a c = a * 10 + fromIntegral (ord c - 48) diff --git a/library/Positron/Types.hs b/library/Positron/Types.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Types.hs @@ -0,0 +1,244 @@ +module Positron.Types + ( Positron(..) + , Column(..) + , ColumnType(..) + , DBColumnType(..) + , Property(..) + , (//) + , defaultColumn + , AnalyzedColumn(..) + , columnTypeCon + , PositronError(..) + , textShow + , Query(..) + , SelectTarget(..) + , whose + , orderBy + , Parameter(..) + , Condition(..) + , (.==) + , SetValue(..) + , (?=) + , OrderBy(..) + , onConflict + , returning + ) where + +import Positron.Import + +import Positron.UUID + +import Positron.Types.MissingMethods + +class Positron p where + pConn :: p -> Connection + pLock :: p -> MVar () + pPrepareds :: p -> [(ByteString, ByteString)] + -- NOTE: Later we might be able to make this faster by using a better + -- container type than a list + pCreateQueries :: p -> ByteString + pMake :: Connection -> IO p + +data Column = Column + { columnName :: String + , columnType :: ColumnType + , columnPrimary :: Bool + , columnIndexed :: Bool + , columnNullable :: Bool + , columnUnique :: Bool + } deriving Show + +data ColumnType + = Psmallint + | Pinteger + | Pbigint + | Pdecimal + | Pnumeric + | Preal + | Pdouble + | Psmallserial + | Pserial + | Pbigserial + | Pvarchar Integer + | Ptext + | Pforeignkey String + | Puuid + deriving Show + +data DBColumnType + = DBsmallint + | DBinteger + | DBbigint + | DBdecimal + | DBnumeric + | DBreal + | DBdouble + | DBsmallserial + | DBserial + | DBbigserial + | DBtext + | DBvarchar Integer + | DBuuid + +instance Show DBColumnType where + show t = case t of + DBsmallint -> "smallint" + DBinteger -> "integer" + DBbigint -> "bigint" + DBdecimal -> "decimal" + DBnumeric -> "numeric" + DBreal -> "real" + DBdouble -> "double" + DBsmallserial -> "smallserial" + DBserial -> "serial" + DBbigserial -> "bigserial" + DBvarchar len -> "varchar(" ++ show len ++ ")" + DBtext -> "text" + DBuuid -> "uuid" + +data Property + = Primary + | Indexed + | Nullable + | Unique + deriving Show + +(//) :: Column -> [Property] -> Column +(//) = foldl' f + where + f c p = case p of + Primary -> c { columnPrimary = True } + Indexed -> c { columnIndexed = True } + Nullable -> c { columnNullable = True } + Unique -> c { columnUnique = True } + +defaultColumn :: ColumnType -> String -> Column +defaultColumn t s = Column + { columnName = s + , columnType = t + , columnPrimary = False + , columnIndexed = False + , columnNullable = False + , columnUnique = False + } + +data AnalyzedColumn = AC + { acn :: !String -- column name + , acFullName :: !String -- column name prefixed with table name + , acp :: !Bool -- primary key? + , aci :: !Bool -- indexed? + , acnl :: !Bool -- nullable? + , acUnique :: !Bool -- unique? + , act :: !DBColumnType + , acf :: !(Maybe (String, String)) -- foreign key? + } deriving Show + +columnTypeCon :: AnalyzedColumn -> Type +columnTypeCon AC{..} = constructor $ case act of + DBsmallint -> ''Int16 + DBinteger -> ''Int32 + DBbigint -> ''Int64 + DBdecimal -> ''Scientific + DBnumeric -> ''Scientific + DBreal -> ''Float + DBdouble -> ''Double + DBsmallserial -> ''Int16 + DBserial -> ''Int32 + DBbigserial -> ''Int64 + DBvarchar _ -> ''Text + DBtext -> ''Text + DBuuid -> ''UUID + where + constructor = if acnl + then AppT (ConT ''Maybe) . ConT + else ConT + +data PositronError + = DuplicateKey + { duplicateKey :: Text + , duplicateKeyValue :: Text + } + | UnknownPositronError Text + deriving Show + +textShow :: PositronError -> Text +textShow (DuplicateKey k v) = fold + ["Value ", v, " already exists for ", k] +textShow (UnknownPositronError t) = t + +data Query + = Insert + { insertTarget :: String + , insertOnConflict :: Maybe (NonEmpty String, NonEmpty String) + , insertReturning :: [String] + } + | Upsert String + | Select + { selectTarget :: SelectTarget + , selectConditions :: [Condition] + , selectOrderBys :: [OrderBy] + } + | GetModel + { getModelTarget :: String + , getModelOrderBys :: [OrderBy] + } + | Update + { updateTable :: String + , updateColumns :: [SetValue] + , updateConditions :: [Condition] + } + deriving Show + +queryTypeStr :: Query -> String +queryTypeStr Insert {} = "Insert" +queryTypeStr Upsert {} = "Upsert" +queryTypeStr Select {} = "Select" +queryTypeStr GetModel {} = "GetModel" +queryTypeStr Update {} = "Update" + +data SelectTarget + = SelectModel String + | SelectFields [String] + deriving Show + +-- These functions may look like they have runtime errors, but in fact only +-- used in the Template Haskell stage. All errors are therefore compile-time. +whose :: Query -> [Condition] -> Query +whose q conds = case q of + Insert name _ _ -> error (name ++ ": Insert cannot have conditions") + Upsert name -> error (name ++ ": Insert cannot have conditions") + s@Select {} -> s { selectConditions = selectConditions s ++ conds } + GetModel{..} -> error + (getModelTarget ++ ": GetModel cannot have conditions") + u@Update {} -> u { updateConditions = updateConditions u ++ conds } + +orderBy :: Query -> [OrderBy] -> Query +orderBy q orderBys = case q of + s@Select {} -> s { selectOrderBys = selectOrderBys s ++ orderBys } + g@GetModel {} -> g { getModelOrderBys = getModelOrderBys g ++ orderBys } + _ -> error "only select query can have \"order by\" clause" + +data Condition = Condition String Parameter + deriving Show + +(.==) :: String -> Parameter -> Condition +(.==) = Condition + +newtype SetValue = SetValue { unSetValue :: Condition } + deriving Show + +(?=) :: String -> Parameter -> SetValue +name ?= parameter = SetValue (Condition name parameter) + +data OrderBy = Asc String | Desc String + deriving Show + +onConflict :: Query -> (NonEmpty String, NonEmpty String) -> Query +onConflict q params = case q of + i@Insert {} -> i { insertOnConflict = Just params } + x -> error (queryTypeStr x <> " cannot have ON CONFLICT") + +returning :: Query -> [String] -> Query +returning q params = case q of + i@Insert {} -> i { insertReturning = params } + x -> error (queryTypeStr x <> " cannot have RETURNING") diff --git a/library/Positron/Types/MissingMethods.hs b/library/Positron/Types/MissingMethods.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Types/MissingMethods.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +module Positron.Types.MissingMethods where + +import Positron.Import + +data Parameter + = Parameter + | FixedString String + | FixedNum Integer + deriving Show + +instance IsString Parameter where + fromString = FixedString +instance Num Parameter where + fromInteger = FixedNum diff --git a/library/Positron/UUID.hs b/library/Positron/UUID.hs new file mode 100644 --- /dev/null +++ b/library/Positron/UUID.hs @@ -0,0 +1,74 @@ +module Positron.UUID + ( UUID(..) + , fromByteString + , unsafeFromByteString + , fromText + ) where + +import Positron.Import + +-- external modules + +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-- local modules + +import Positron.Util + +data UUID = UUID + { uuidByteString :: ByteString + , uuidText :: Text + } + deriving Eq + +instance Show UUID where + show u = T.unpack $ "UUID <" <> uuidText u <> ">" + +fromByteString :: ByteString -> Maybe UUID +fromByteString b + | B.length b == 16 = Just $ UUID b text + | otherwise = Nothing + where + text = T.decodeLatin1 $ + fold [hex1, "-", hex2, "-", hex3, "-", hex4, "-", hex5] + hex1 = B.take 8 hexed + hex2 = B.take 4 $ B.drop 8 hexed + hex3 = B.take 4 $ B.drop 12 hexed + hex4 = B.take 4 $ B.drop 16 hexed + hex5 = B.drop 20 hexed + hexed = toByteString $ B.byteStringHex b + +unsafeFromByteString :: ByteString -> UUID +unsafeFromByteString = fromMaybe err . fromByteString + where + err = error "UUID ByteString is not 16 bytes long" + +fromText :: Text -> Maybe UUID +fromText t + | T.length t /= 36 = Nothing + | not (B.all isValidHexWord8 packed) = Nothing + | otherwise = Just $ UUID (B.pack $ forPairs (B.unpack packed) unhex) t + where + rawBytes = T.encodeUtf8 t + packed = fold [hex1, hex2, hex3, hex4, hex5] + hex1 = B.take 8 rawBytes + hex2 = B.take 4 $ B.drop (8 + 1) rawBytes + hex3 = B.take 4 $ B.drop (8 + 1 + 4 + 1) rawBytes + hex4 = B.take 4 $ B.drop (8 + 1 + 4 + 1 + 4 + 1) rawBytes + hex5 = B.drop (8 + 1 + 4 + 1 + 4 + 1 + 4 + 1) rawBytes + isValidHexWord8 w = (0x29 < w && w < 0x40) || (0x60 < w && w < 0x67) + +unhex :: Word8 -> Word8 -> Word8 +unhex upper lower = (trueValue upper `shiftL` 4) .|. trueValue lower + where + trueValue x + | x < 0x40 = x - 0x30 -- x is a digit; subtract the ord of 0 + | otherwise = 0xa + x - 0x61 -- x is an alphabet; subtract the ord of a + +forPairs :: [a] -> (a -> a -> b) -> [b] +forPairs [] _ = [] +forPairs [_] _ = [] +forPairs (x : y : xs) f = f x y : forPairs xs f diff --git a/library/Positron/Unsafe.hs b/library/Positron/Unsafe.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Unsafe.hs @@ -0,0 +1,73 @@ +module Positron.Unsafe + ( TableMap + , Table + , addTable + , lookupColumn + , lookupTableMap + , getCurrentTableMap + , addPrepared + , readPrepared + , acLookup + ) where + +import Positron.Import + +-- base modules + +import System.IO.Unsafe (unsafePerformIO) + +-- local modules + +import Positron.Types + +type Table = [(String, AnalyzedColumn)] +type TableMap = [(String, Table)] +type ModuleMap = [(String, TableMap)] + +{-# NOINLINE moduleMap #-} +moduleMap :: IORef ModuleMap +moduleMap = unsafePerformIO $ newIORef [] + +addTable :: String -> (String, Table) -> Q () +addTable moduleName tablePair@(tableName, _) = runIO $ + modifyIORef moduleMap modifier + where + modifier :: ModuleMap -> ModuleMap + modifier oldModuleMap = case lookup moduleName oldModuleMap of + Just oldTableMap -> let + newTableMap = tablePair : + filter (\(i, _) -> i /= tableName) oldTableMap + in (moduleName, newTableMap) : + filter (\(i, _) -> i /= moduleName) oldModuleMap + Nothing -> (moduleName, [tablePair]) : oldModuleMap + +lookupColumn :: String -> String -> String -> Q (Maybe AnalyzedColumn) +lookupColumn moduleName tabName colName = runIO $ + (lookup moduleName >=> lookup tabName >=> lookup colName) <$> + readIORef moduleMap + +lookupTableMap :: String -> Q (Maybe TableMap) +lookupTableMap moduleName = runIO $ lookup moduleName <$> readIORef moduleMap + +getCurrentTableMap :: Q TableMap +getCurrentTableMap = do + name <- show <$> thisModule + fromMaybe (error $ noModuleMsg ++ name) <$> lookupTableMap name + where + noModuleMsg = "Can't find the table map for the current module: " + +{-# NOINLINE prepareds #-} +prepareds :: IORef [(ByteString, ByteString)] +prepareds = unsafePerformIO $ newIORef [] + +addPrepared :: (ByteString, ByteString) -> Q () +addPrepared pair = runIO $ modifyIORef prepareds (pair :) + +readPrepared :: IO [(ByteString, ByteString)] +readPrepared = readIORef prepareds + +acLookup :: String -> Table -> String -> AnalyzedColumn +acLookup tableName table x = fromMaybe (error msg) $ lookup x table + where + msg = x <> " is not found in " <> tableName + diff --git a/library/Positron/Util.hs b/library/Positron/Util.hs new file mode 100644 --- /dev/null +++ b/library/Positron/Util.hs @@ -0,0 +1,17 @@ +module Positron.Util + ( toByteString + , for + ) where + +import Positron.Import + +-- data types + +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as LB (toStrict) + +toByteString :: Builder -> ByteString +toByteString = LB.toStrict . B.toLazyByteString + +for :: Functor f => f a -> (a -> b) -> f b +for = flip fmap diff --git a/positron.cabal b/positron.cabal new file mode 100644 --- /dev/null +++ b/positron.cabal @@ -0,0 +1,65 @@ +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack + +name: positron +version: 0.1.0.0 +synopsis: Experiment +description: Please see README.md +category: Database +homepage: https://github.com/xtendo-org/positron#readme +bug-reports: https://github.com/xtendo-org/positron/issues +author: XT +maintainer: e@xtendo.org +copyright: 2016 XT +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/xtendo-org/positron + +library + hs-source-dirs: + library + default-extensions: LambdaCase OverloadedStrings RecordWildCards TemplateHaskell + build-depends: + attoparsec + , bytestring + , postgresql-libpq + , scientific + , template-haskell + , text + , base >=4.7 && <5 + exposed-modules: + Positron + Positron.UUID + other-modules: + Positron.Alias + Positron.Binary + Positron.Driver + Positron.Import + Positron.Instance + Positron.Parser + Positron.Query + Positron.Store + Positron.Types + Positron.Types.MissingMethods + Positron.Unsafe + Positron.Util + Paths_positron + default-language: Haskell2010 + +test-suite positron-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: LambdaCase OverloadedStrings RecordWildCards TemplateHaskell + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , positron + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"