diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alp Mestanogullari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alp Mestanogullari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/servant-postgresql.cabal b/servant-postgresql.cabal new file mode 100644 --- /dev/null +++ b/servant-postgresql.cabal @@ -0,0 +1,26 @@ +name: servant-postgresql +version: 0.1 +synopsis: Useful functions and instances for using servant with a PostgreSQL context +description: Useful functions and instances for using servant with a PostgreSQL context +homepage: http://github.com/zalora/servant-postgresql +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alp@zalora.com +copyright: 2014 Zalora SEA +category: Web, Database +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Servant.Context.PostgreSQL, Servant.PostgreSQL.Prelude + build-depends: + base >=4 && <5 + , servant >= 0.1 + , servant-pool >= 0.1 + , servant-response >= 0.1 + , postgresql-simple >= 0.4 + , bytestring >= 0.7 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Servant/Context/PostgreSQL.hs b/src/Servant/Context/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Context/PostgreSQL.hs @@ -0,0 +1,129 @@ +{- | +Module : Servant.Context.PostgreSQL +Copyright : (c) Zalora SEA 2014 +License : BSD3 +Maintainer : Alp Mestanogullari +Stability : experimental + +Useful functions and instances for using servant with a PostgreSQL database. + +* Use 'contextOfConnInfo' or 'contextOfConnStr' to create a PostgreSQL 'Context's. +* If you want connection-pooling, use 'pooledContextOfConnInfo' and + 'pooledContextOfConnStr'. +-} +module Servant.Context.PostgreSQL + ( -- * PostgreSQL 'Context' + contextOfConnInfo + , contextOfConnStr + , -- * PostgreSQL 'Context' with connection pooling + pooledContextOfConnInfo + , pooledContextOfConnStr + + ) where + +import Control.Exception +import Data.ByteString (ByteString) +import Database.PostgreSQL.Simple +import Servant.Context +import Servant.Context.Pool + +-- | Create a @'Context' 'Connection'@ from the given +-- 'ConnectInfo'. +-- +-- This means a new connection will be fired whenever you +-- perform a database operation. If you want to avoid that, +-- see the /pooledContextOfXXX/ functions. +contextOfConnInfo :: ConnectInfo -> Context Connection +contextOfConnInfo ci = mkContext f + where f act = bracket (connect ci) close act + +-- | Create a @'Context' 'Connection'@ from the given +-- connection string. +-- +-- This means a new connection will be fired whenever you +-- perform a database operation. If you want to avoid that, +-- see the /pooledContextOfXXX/ functions. +contextOfConnStr :: ByteString -> Context Connection +contextOfConnStr str = mkContext f + where f act = bracket (connectPostgreSQL str) close act + +-- | Create a 'Context' that'll use a 'Pool' of +-- PostgreSQL 'Connection's internally, from +-- a 'ConnectInfo' value. +pooledContextOfConnInfo :: Int -- ^ Number of stripes (sub-pools). /Minimum: 1/ + -> NominalDiffTime -- ^ amount of time during which an unused + -- 'Connection' is kept open + -> Int -- ^ Maximum number of resources to keep open + -- per stripe. /Minimum: 1/ + -> ConnectInfo -- ^ connection information + -> IO (Context Connection) +pooledContextOfConnInfo nstripes idleDuration maxOpen ci = + pooledContext (connect ci) + close + nstripes + idleDuration + maxOpen + +-- | Create a 'Context' that'll use a 'Pool' of +-- PostgreSQL 'Connection's internally, from +-- a connection string (a 'ByteString'). +pooledContextOfConnStr :: Int -- ^ Number of stripes (sub-pools). /Minimum: 1/ + -> NominalDiffTime -- ^ amount of time during which an unused + -- 'Connection' is kept open + -> Int -- ^ Maximum number of resources to keep open + -- per stripe. /Minimum: 1/ + -> ByteString -- ^ connection string + -> IO (Context Connection) +pooledContextOfConnStr nstripes idleDuration maxOpen connstr = + pooledContext (connectPostgreSQL connstr) + close + nstripes + idleDuration + maxOpen + +{- +-- | Simple wrapper around @postgresql-simple@'s @['Only' 'Int']@ +newtype PGResult = + PGResult { onlyInts :: [Only Int] } + deriving (Eq, Show) + +-- | Create a 'PGResult' by simply wrapping the argument in a /newtype/ +resultOfInts :: [Only Int] -> PGResult +resultOfInts = PGResult + +-- | Send status 201 if successful, 400 if not along with an error +instance Response (UpdateResponse Add) PGResult where + toResponse result = + (UpdateResponse successful m, responseStatus) + + where affected = getSum . foldMap (Sum . fromOnly) $ onlyInts result + successful = affected > 0 + m = + if affected < 1 + then "Unknown error. please report this to maintainers" + else "" + responseStatus = + if successful then status201 else status400 + +-- | Send status 200 if successful, 404 if target not found along with "Not found" +instance Response (UpdateResponse Update) PGResult where + toResponse result = + (UpdateResponse successful m, responseStatus) + + where affected = getSum . foldMap (Sum . fromOnly) $ onlyInts result + successful = affected > 0 + m = if affected < 1 then "Not found" else "" + responseStatus = + if successful then status200 else notFound404 + +-- | Send status 200 if successful, 404 if target not found along with "Not found" +instance Response (UpdateResponse Delete) PGResult where + toResponse result = + (UpdateResponse successful m, responseStatus) + + where affected = getSum . foldMap (Sum . fromOnly) $ onlyInts result + successful = affected > 0 + m = if affected < 1 then "Not found" else "" + responseStatus = + if successful then status200 else notFound404 +-} diff --git a/src/Servant/PostgreSQL/Prelude.hs b/src/Servant/PostgreSQL/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Servant/PostgreSQL/Prelude.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleInstances, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + OverloadedStrings #-} +{- | +Module : Servant.PostgreSQL.Prelude +Copyright : (c) Zalora SEA 2014 +License : BSD3 +Maintainer : Alp Mestanogullari +Stability : experimental + +An helpful wrapper around 'Int64' that you can tie to +the standard response types in "Servant.Response.Prelude" with +the instances defined in this module. +-} +module Servant.PostgreSQL.Prelude + ( PGResult + , ToPGResult(..) + , toPGResult + , pgresultOfInts + , pgresultOfInt64 + , module Servant.Context.PostgreSQL + ) where + +import Data.Foldable +import Data.Int +import Data.Monoid +import Database.PostgreSQL.Simple +import Servant.Context.PostgreSQL +import Servant.Prelude +import Servant.Response.Prelude + +-- | A wrapper around 'Int64', which is what +-- PG hands us back when running +-- 'Database.PostgreSQL.Simple.execute'. +-- +-- The @o@ type parameter lets us tag +-- the result with the operation that +-- we're running. This lets us turn +-- results into a proper response +-- (response body + status) differently +-- for 'Add' and 'Update' for example. +newtype PGResult o = PGResult { pgres :: Int64 } + deriving (Eq, Ord, Num, Show) + +-- | Run a database action and convert its +-- result to a 'PGResult'. +-- +-- This will only typecheck on queries that +-- return 'Int64' or @['Only' 'Int']@, or a custom +-- type of yours for which you provide a 'ToPGResult' +-- instance. +toPGResult :: ToPGResult r => IO r -> IO (PGResult o) +toPGResult = fmap fromRes + +-- | Run an 'IO' action that returns @['Only' 'Int']@ +-- and convert the result to a 'PGResult'. +pgresultOfInts :: IO [Only Int] -> IO (PGResult o) +pgresultOfInts = toPGResult + +-- | Run an 'IO' action that returns 'Int64' and +-- convert the result to a 'PGResult'. +pgresultOfInt64 :: IO Int64 -> IO (PGResult o) +pgresultOfInt64 = toPGResult + +-- | Class of types that can be converted to a +-- 'PGResult'. +-- +-- This package provides instances for 'Int64' +-- and @['Only' 'Int']@ +class ToPGResult r where + fromRes :: r -> PGResult o + +instance ToPGResult Int64 where + fromRes = PGResult + +instance ToPGResult [Only Int] where + fromRes ns = PGResult n + where n = getSum $ foldMap (Sum . fromIntegral . fromOnly) ns + +-- | If the 'Int64' is smaller than 1, status 400 and a +-- suitable error message. Status 201 and empty message otherwise. +instance Response (UpdateResponse Add) (PGResult Add) where + toResponse n = (response, statuscode) + + where response = UpdateResponse successful msg + successful = n > 0 + msg = if successful then "" else "no entry added" + statuscode = if successful then status201 else status400 + +-- | If the 'Int64' is smaller than 1, status 400 and a +-- suitable error message. Status200 and empty message otherwise. +instance Response (UpdateResponse Delete) (PGResult Delete) where + toResponse n = (response, statuscode) + + where response = UpdateResponse successful msg + successful = n > 0 + msg = if successful then "" else "couldn't delete: target entry doesn't exist" + statuscode = if successful then status200 else status404 + +-- | If the 'Int64' is smaller than 1, status 400 and a +-- suitable error message. Status200 and empty message otherwise. +instance Response (UpdateResponse Update) (PGResult Update) where + toResponse n = (response, statuscode) + + where response = UpdateResponse successful msg + successful = n > 0 + msg = if successful then "" else "couldn't update: target entry doesn't exist" + statuscode = if successful then status200 else status404