summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikeLedger <>2015-04-05 11:20:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-04-05 11:20:00 (GMT)
commit579e70f86eaaa7f313533507475f53e40397ee52 (patch)
tree11b2a3c1c6f29126c62f547bfea7c289760ec497
version 0.0.10.0.1
-rw-r--r--LICENSE20
-rw-r--r--Setup.hs2
-rw-r--r--snaplet-hasql.cabal21
-rw-r--r--src/Snap/Snaplet/Hasql.hs59
4 files changed, 102 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..4add64a
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2015 Mike Ledger
+
+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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/snaplet-hasql.cabal b/snaplet-hasql.cabal
new file mode 100644
index 0000000..c0237bd
--- /dev/null
+++ b/snaplet-hasql.cabal
@@ -0,0 +1,21 @@
+name: snaplet-hasql
+version: 0.0.1
+synopsis: A Hasql snaplet
+license: MIT
+license-file: LICENSE
+author: Mike Ledger
+maintainer: eleventynine@gmail.com
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ exposed-modules: Snap.Snaplet.Hasql
+ build-depends: base >=4.7 && <4.8,
+ lens >=4.7 && <5.0,
+ mtl >=2.2 && <2.3,
+ hasql >=0.7 && <0.8,
+ hasql-backend >=0.4 && <0.5,
+ snap >=0.13 && <0.15
+ hs-source-dirs: src
+ default-language: Haskell2010
diff --git a/src/Snap/Snaplet/Hasql.hs b/src/Snap/Snaplet/Hasql.hs
new file mode 100644
index 0000000..2f83bdb
--- /dev/null
+++ b/src/Snap/Snaplet/Hasql.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Snap.Snaplet.Hasql
+ ( HasPool(..)
+ , hasqlInit
+ , session
+ , session'
+ , module H
+ ) where
+import Control.Lens
+import Control.Monad.Reader
+import Hasql as H hiding (session)
+import qualified Hasql
+import Hasql.Backend hiding (Tx)
+import Snap
+
+class (Show (CxError db), Show (TxError db), CxTx db, Cx db) =>
+ HasPool s db | s -> db where
+ poolLens :: Lens' s (Pool db)
+
+instance (Cx db, CxTx db, Show (CxError db), Show (TxError db)) =>
+ HasPool (Pool db) db where
+ poolLens = id
+
+hasqlInit
+ :: HasPool c db
+ => CxSettings db
+ -> PoolSettings
+ -> SnapletInit c (Pool db)
+hasqlInit cx p =
+ makeSnaplet "hasql" "" Nothing $ do
+ pool <- liftIO (acquirePool cx p)
+ onUnload (releasePool pool)
+ return pool
+
+{-# INLINE session #-}
+-- | Wrapper around 'session' that just calls 'fail' on failure, and
+-- uses the available 'poolLens'. Most useful inside 'Handler`s.
+session :: (HasPool v db, MonadReader v m) => Session db m r -> m r
+session f = do
+ db <- view poolLens
+ r <- Hasql.session db f
+ case r of
+ Right a -> return a
+ Left er -> fail (show er)
+
+{-# INLINE session' #-}
+-- | Wrapper around 'session'.
+session' :: (HasPool v db, MonadReader v m)
+ => Session db m r
+ -> m (Either (SessionError db) r)
+session' f = do
+ db <- view poolLens
+ Hasql.session db f
+