hasql (empty) → 0.1.0

raw patch · 8 files changed

+618/−0 lines, 8 filesdep +attoparsecdep +basedep +base-preludesetup-changed

Dependencies added: attoparsec, base, base-prelude, bytestring, ex-pool, hasql-backend, list-t, loch-th, mmorph, monad-control, mtl-prelude, placeholders, safe, template-haskell, text, time, transformers-base, vector

Files

• LICENSE +22/−0
• Setup.hs +2/−0
• hasql.cabal +101/−0
• library/Hasql.hs +277/−0
• library/Hasql/Prelude.hs +67/−0
• library/Hasql/QQ.hs +47/−0
• library/Hasql/QQ/Parser.hs +38/−0
• library/Hasql/RowParser.hs +64/−0

@@ -0,0 +1,22 @@+Copyright (c) 2014, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,101 @@+name:+  hasql+version:+  0.1.0+synopsis:+  A minimalistic general high level API for relational databases+description:+  A robust and concise yet powerful API for communication with arbitrary+  relational databases. Features:+  .+  * Concise and crisp API. Just a few functions and two monads doing all the+  boilerplate job for you.+  .+  * Automated management of resources related to connections, transactions and+  cursors.+  .+  * A built-in connections pool.+  .+  * Employment of prepared statements. Every statement you emit gets prepared+  and cached. This raises the performance of the backend.+  .+  * Support for cursors. Allows to fetch virtually limitless result sets in a+  constant memory using streaming.+  .+  * Type-level generation of templates. You just can't write a statement with an+  incorrect number of placeholders.+  .+  * Mapping to any types actually supported by the backend.+category:+  Database+homepage:+  https://github.com/nikita-volkov/hasql +bug-reports:+  https://github.com/nikita-volkov/hasql/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2014, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/hasql.git+++library+  hs-source-dirs:+    library+  other-modules:+    Hasql.Prelude+    Hasql.QQ+    Hasql.QQ.Parser+    Hasql.RowParser+  exposed-modules:+    Hasql+  build-depends:+    hasql-backend == 0.1.*,+    -- template-haskell:+    template-haskell >= 2.8 && < 2.10,+    -- parsing:+    attoparsec == 0.12.*,+    -- database:+    ex-pool == 0.2.*,+    -- data:+    vector < 0.11,+    time >= 1.4 && < 1.6,+    bytestring == 0.10.*,+    text >= 1.1 && < 1.3,+    -- control:+    list-t >= 0.2.4 && < 0.3,+    monad-control == 0.3.*,+    transformers-base == 0.4.*,+    -- errors:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    monad-control == 0.3.*,+    transformers-base == 0.4.*,+    safe >= 0.3.8 && < 0.4,+    mmorph == 1.0.*,+    mtl-prelude == 2.*,+    base-prelude >= 0.1.3 && < 0.2,+    base >= 4.5 && < 4.8+  ghc-options:+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010

@@ -0,0 +1,277 @@+module Hasql+(+  -- * Session+  Session,+  session,++  -- ** Session Settings+  SessionSettings,+  sessionSettings,++  -- ** Error+  Error(..),++  -- * Transaction+  Tx,+  Mode,+  Backend.IsolationLevel(..),+  tx,++  -- * Statement Quasi-Quoter+  QQ.q,++  -- * Statement Execution+  unit,+  count,+  single,+  list,+  stream,++  -- * Results Stream+  TxListT,++  -- * Row parser+  RowParser.RowParser(..),+)+where++import Hasql.Prelude hiding (Error)+import Hasql.Backend (Backend)+import Hasql.RowParser (RowParser)+import qualified Hasql.Backend as Backend+import qualified Hasql.RowParser as RowParser+import qualified Hasql.QQ as QQ+import qualified ListT+import qualified Data.Pool as Pool+import qualified Data.Vector as Vector+++-- * Session+-------------------------++-- |+-- A monad transformer,+-- which executes transactions.+type Session b =+  ReaderT (Pool.Pool (Backend.Connection b))++-- |+-- Given backend settings, session settings, and a session monad transformer,+-- execute it in the inner monad.+session :: +  Backend.Backend b => MonadBaseControl IO m =>+  b -> SessionSettings -> Session b m r -> m r+session backend (SessionSettings size timeout) reader =+  join $ liftM restoreM $ liftBaseWith $ \runInIO ->+    mask $ \unmask -> do+      p <- Pool.createPool (Backend.connect backend) Backend.disconnect 1 timeout size+      r <- try $ unmask $ runInIO $ runReaderT reader p+      Pool.purgePool p+      either onException return r+  where+    onException =+      \case+        Backend.CantConnect t -> throwIO $ CantConnect t+        Backend.ConnectionLost t -> throwIO $ ConnectionLost t+        Backend.ErroneousResult t -> throwIO $ ErroneousResult t+        Backend.UnexpectedResult t -> throwIO $ UnexpectedResult t+        Backend.UnparsableTemplate t -> throwIO $ UnparsableTemplate t+        Backend.TransactionConflict -> $bug "Unexpected TransactionConflict exception"+        Backend.NotInTransaction -> throwIO $ NotInTransaction+++-- ** Session Settings+-------------------------++-- |+-- Settings of a session.+data SessionSettings =+  SessionSettings !Word32 !NominalDiffTime++-- | +-- A smart constructor for session settings.+sessionSettings :: +  Word32+  -- ^+  -- The maximum number of connections to keep open. +  -- The smallest acceptable value is 1.+  -- Requests for connections will block if this limit is reached.+  -> +  NominalDiffTime+  -- ^+  -- The amount of time for which an unused connection is kept open. +  -- The smallest acceptable value is 0.5 seconds.+  -> +  Maybe SessionSettings+  -- ^+  -- Maybe session settings, if they are correct.+sessionSettings size timeout =+  if size > 0 && timeout >= 0.5+    then Just $ SessionSettings size timeout+    else Nothing+++-- ** Error+-------------------------++-- |+-- The only exception type that this API can raise.+data Error =+  -- |+  -- Cannot connect to a server.+  CantConnect Text |+  -- |+  -- The connection got interrupted.+  ConnectionLost Text |+  -- |+  -- An error returned from the database.+  ErroneousResult Text |+  -- |+  -- Unexpected result structure.+  -- Indicates usage of inappropriate statement executor.+  UnexpectedResult Text |+  -- |+  -- Incorrect statement template.+  UnparsableTemplate Text |+  -- |+  -- An operation, +  -- which requires a database transaction was executed without one.+  NotInTransaction |+  -- |+  -- Attempt to parse a row into an incompatible type.+  -- Indicates either a mismatching schema or an incorrect query.+  UnparsableRow Text+  deriving (Show, Typeable)++instance Exception Error+++-- * Transaction+-------------------------++-- |+-- A transaction specialized for backend @b@, +-- running on an anonymous state-thread @s@ +-- and producing a result @r@.+newtype Tx b s r =+  Tx (ReaderT (Backend.Connection b) IO r)+  deriving (Functor, Applicative, Monad)++-- |+-- A transaction mode defining how a transaction should be executed.+-- +-- * @Just (isolationLevel, write)@ indicates that a database transaction+-- should be established with a specified isolation level and a boolean, +-- defining, whether it would perform any modification operations.+-- +-- * @Nothing@ indicates that there should be no database transaction established on+-- the backend and therefore it should be executed with no ACID guarantees,+-- but also without any induced overhead.+type Mode =+  Maybe (Backend.IsolationLevel, Bool)++-- |+-- Execute a transaction in a session.+tx :: +  Backend.Backend b => MonadBase IO m =>+  Mode -> (forall s. Tx b s r) -> Session b m r+tx m t =+  ReaderT $ \p -> liftBase $ Pool.withResource p $ \c -> runTx c m t+  where+    runTx ::+      Backend b => +      Backend.Connection b -> Mode -> (forall s. Tx b s r) -> IO r+    runTx connection mode (Tx reader) =+      maybe (const id) inTransaction mode connection (runReaderT reader connection)+      where+        inTransaction ::+          Backend b => +          Backend.TransactionMode -> Backend.Connection b -> IO r -> IO r+        inTransaction mode c io =+          do+            Backend.beginTransaction mode c+            try io >>= \case+              Left Backend.TransactionConflict -> do+                Backend.finishTransaction False c+                inTransaction mode c io+              Left e -> throwIO e+              Right r -> do+                Backend.finishTransaction True c+                return r+++-- * Results Stream+-------------------------++-- |+-- A stream of results, +-- which fetches only those that you reach.+-- +-- It's a wrapper around 'ListT.ListT', +-- which uses the same trick as the 'ST' monad to associate with the+-- context transaction and become impossible to be used outside of it.+-- This lets the library ensure that it is safe to automatically+-- release all the resources associated with this stream.+-- +-- All the functions of the \"list-t\" library are applicable to this type,+-- amongst which are 'ListT.head', 'ListT.toList', 'ListT.fold', 'ListT.traverse_'.+newtype TxListT s m r =+  TxListT (ListT.ListT m r)+  deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus, +            Monoid, ListT.ListMonad)++instance ListT.ListTrans (TxListT s) where+  uncons = +    unsafeCoerce +      (ListT.uncons :: ListT.ListT m r -> m (Maybe (r, ListT.ListT m r)))+++-- * Statements execution+-------------------------++-- |+-- Execute a statement, which produces no result.+unit :: Backend b => Backend.Statement b -> Tx b s ()+unit s =+  Tx $ ReaderT $ Backend.execute s++-- |+-- Execute a statement and count the amount of affected rows.+-- Useful for resolving how many rows were updated or deleted.+count :: Backend b => Backend.Mapping b Word64 => Backend.Statement b -> Tx b s Word64+count s =+  Tx $ ReaderT $ Backend.executeAndCountEffects s++-- |+-- Execute a statement,+-- which produces a single result row: +-- a @SELECT@ +-- or an @INSERT@, which produces a generated value (e.g., an auto-incremented id).+single :: Backend b => RowParser b r => Backend.Statement b -> Tx b s (Maybe r)+single s =+  headMay <$> list s++-- |+-- Execute a @SELECT@ statement,+-- and produce a vector of results.+list :: Backend b => RowParser b r => Backend.Statement b -> Tx b s [r]+list s =+  Tx $ ReaderT $ \c -> do+    m <- Backend.executeAndGetMatrix s c+    traverse (either (throwIO . UnparsableRow) return . RowParser.parseRow) $ Vector.toList m++-- |+-- Execute a @SELECT@ statement with a cursor,+-- and produce a results stream.+-- +-- Cursor allows you to fetch virtually limitless results in a constant memory+-- at a cost of a small overhead.+-- Note that in most databases cursors require establishing a database transaction,+-- so a 'NotInTransaction' error will be raised if you run it improperly.+stream :: Backend b => RowParser b r => Backend.Statement b -> TxListT s (Tx b s) r+stream s =+  do+    s <- lift $ Tx $ ReaderT $ \c -> Backend.executeAndStream s c+    TxListT $ hoist (Tx . lift) $ do+      row <- s+      either (lift . throwIO . UnparsableRow) return $ RowParser.parseRow row

@@ -0,0 +1,67 @@+module Hasql.Prelude+( +  module Exports,+  bug,+  bottom,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports++-- mtl-prelude+-------------------------+import MTLPrelude as Exports hiding (shift)++-- mmorph+-------------------------+import Control.Monad.Morph as Exports++-- monad-control+-------------------------+import Control.Monad.Trans.Control as Exports++-- transformers-base+-------------------------+import Control.Monad.Base as Exports++-- safe+-------------------------+import Safe as Exports++-- list-t+-------------------------+import ListT as Exports (ListT)++-- vector+-------------------------+import Data.Vector as Exports (Vector)++-- text+-------------------------+import Data.Text as Exports (Text)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- time+-------------------------+import Data.Time as Exports++-- placeholders+-------------------------+import Development.Placeholders as Exports++-- custom+-------------------------+import qualified Debug.Trace.LocationTH+++bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]+  where+    msg = "A \"hasql\" package bug: " :: String++bottom = [e| $bug "Bottom evaluated" |]

@@ -0,0 +1,47 @@+module Hasql.QQ where++import Hasql.Prelude+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import qualified Hasql.QQ.Parser as Parser+import qualified Hasql.Backend as Backend+++-- |+-- Produces a lambda-expression, +-- which takes as many parameters as there are placeholders in the quoted text+-- and results in an expression of type 'Backend.Statement'. +-- +-- E.g.:+-- +-- >selectFive :: Statement b+-- >selectFive = [q|SELECT (? + ?)|] 2 3+-- +q :: QuasiQuoter+q = +  QuasiQuoter+    parseExp+    (const $ fail "Pattern context is not supported")+    (const $ fail "Type context is not supported")+    (const $ fail "Declaration context is not supported")+++parseExp :: String -> Q Exp+parseExp s =+  do+    n <- either (fail . showString "Parsing failure: ") return (Parser.parse (fromString s))+    return $ statementF s n++-- |+-- An expression of a function with an arbitrary arity, +-- which produces a "Backend.Statement".+statementF :: String -> Word -> Exp+statementF s n =+  LamE pats exp+  where+    vars = map (mkName . ('_' :) . show) [1 .. n]+    pats = map VarP vars+    exp  = AppE (AppE (ConE '(,)) (LitE (StringL s))) (ListE exps)+      where+        exps = map (AppE (VarE 'Backend.renderValue) . VarE) vars+

@@ -0,0 +1,38 @@+module Hasql.QQ.Parser where++import Hasql.Prelude hiding (takeWhile)+import Data.Attoparsec.Text hiding (Result)+import qualified Data.Text as Text+++-- |+-- The amount of placeholders.+type Result =+  (Word)++parse :: Text -> Either String Result+parse = +  parseOnly countPlaceholders+  where+    countPlaceholders =+      count <|> pure 0+      where+        count =+          do+            many $ void stringLit <|> void (notChar '?')+            char '?'+            fmap succ countPlaceholders++stringLit :: Parser Text+stringLit =+  do+    quote <- +      char '"' <|> char '\''+    text <- +      fmap mconcat $ many $ +        string "\\\\" <|> +        string (fromString ['\\', quote]) <|> +        (Text.singleton <$> notChar quote)+    char quote+    return text+

@@ -0,0 +1,64 @@+module Hasql.RowParser where++import Hasql.Prelude+import Language.Haskell.TH+import qualified Hasql.Backend as Backend+import qualified Data.Vector as Vector+++class RowParser b r where+  parseRow :: Vector.Vector (Backend.Result b) -> Either Text r++instance RowParser b () where+  parseRow row = +    if Vector.null row+      then Right ()+      else $bug "Not an empty row"++instance Backend.Mapping b v => RowParser b (Identity v) where+  parseRow row = do+    Identity <$> Backend.parseResult (Vector.unsafeHead row)++-- Generate tuple instaces using Template Haskell:+let+  inst :: Int -> Dec+  inst arity =+    InstanceD constraints head [parseRowDec]+    where+      varNames =+        [1 .. arity] >>= \i -> return (mkName ('_' : show i))+      varTypes =+        map VarT varNames+      backendType =+        VarT (mkName "b")+      constraints =+        map (\t -> ClassP ''Backend.Mapping [backendType, t]) varTypes+      head =+        AppT (AppT (ConT ''RowParser) backendType) (foldl AppT (TupleT arity) varTypes)+      parseRowDec =+        FunD 'parseRow [Clause [VarP n] (NormalB e) []]+        where+          n = mkName "row"+          e =+            foldQueue queue+            where+              lookups = do+                i <- [0 .. pred arity]+                return $ purify $+                  [|+                    Backend.parseResult $ +                    (Vector.unsafeIndex) $(varE n) $(litE (IntegerL $ fromIntegral i)) +                  |]+              queue =+                (ConE (tupleDataName arity) :) $+                (VarE '(<$>) :) $+                intersperse (VarE '(<*>)) $+                lookups+              foldQueue =+                \case+                  e : o : t -> UInfixE e o (foldQueue t)+                  e : [] -> e+                  _ -> $bug "Unexpected queue size"+      purify = unsafePerformIO . runQ+  in +    mapM (return . inst) [2 .. 24]