positron (empty) → 0.1.0.0
raw patch · 18 files changed
+1848/−0 lines, 18 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, positron, postgresql-libpq, scientific, template-haskell, text
Files
- LICENSE +201/−0
- Setup.hs +2/−0
- library/Positron.hs +201/−0
- library/Positron/Alias.hs +68/−0
- library/Positron/Binary.hs +27/−0
- library/Positron/Driver.hs +153/−0
- library/Positron/Import.hs +49/−0
- library/Positron/Instance.hs +11/−0
- library/Positron/Parser.hs +33/−0
- library/Positron/Query.hs +539/−0
- library/Positron/Store.hs +73/−0
- library/Positron/Types.hs +244/−0
- library/Positron/Types/MissingMethods.hs +16/−0
- library/Positron/UUID.hs +74/−0
- library/Positron/Unsafe.hs +73/−0
- library/Positron/Util.hs +17/−0
- positron.cabal +65/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ library/Positron.hs view
@@ -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
+ library/Positron/Alias.hs view
@@ -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
+ library/Positron/Binary.hs view
@@ -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
+ library/Positron/Driver.hs view
@@ -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)
+ library/Positron/Import.hs view
@@ -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
+ library/Positron/Instance.hs view
@@ -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)) |]
+ library/Positron/Parser.hs view
@@ -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
+ library/Positron/Query.hs view
@@ -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"
+ library/Positron/Store.hs view
@@ -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)
+ library/Positron/Types.hs view
@@ -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")
+ library/Positron/Types/MissingMethods.hs view
@@ -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
+ library/Positron/UUID.hs view
@@ -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
+ library/Positron/Unsafe.hs view
@@ -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+
+ library/Positron/Util.hs view
@@ -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
+ positron.cabal view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"