Skip to content
Browse files

Fix to work with the latest postgresql-simple on hackage

  • Loading branch information...
1 parent f734d7a commit 1463f67e12f04f325f6dd338a9d3312022eb20a1 Oliver Charles committed Jun 4, 2012
View
8 snaplet-postgresql-simple.cabal
@@ -37,13 +37,13 @@ Library
bytestring >= 0.9.1 && < 0.10,
clientsession >= 0.7.2 && < 0.8,
configurator >= 0.2 && < 0.3,
- MonadCatchIO-transformers >= 0.2.1 && < 0.3,
- mtl > 2.0 && < 2.1,
- postgresql-simple >= 0.0 && < 0.1,
+ MonadCatchIO-transformers >= 0.3 && < 0.4,
+ mtl >= 2.1 && < 2.2,
+ postgresql-simple >= 0.1 && < 0.2,
resource-pool-catchio >= 0.2 && < 0.3,
snap >= 0.9 && < 0.10,
text >= 0.11 && < 0.12,
- transformers >= 0.2 && < 0.3,
+ transformers >= 0.3 && < 0.4,
unordered-containers >= 0.2 && < 0.3
View
100 src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs
@@ -43,9 +43,9 @@ import qualified Data.Text.Encoding as T
import Data.Maybe
import Data.Pool
import qualified Database.PostgreSQL.Simple as P
-import qualified Database.PostgreSQL.Simple.Param as P
-import Database.PostgreSQL.Simple.Result
-import Database.PostgreSQL.Simple.QueryResults
+import qualified Database.PostgreSQL.Simple.ToField as P
+import Database.PostgreSQL.Simple.FromField
+import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.Types
import Snap
import Snap.Snaplet.Auth
@@ -118,15 +118,14 @@ buildUid :: Int -> UserId
buildUid = UserId . T.pack . show
-instance Result UserId where
- convert f v = buildUid <$> convert f v
+instance FromField UserId where
+ fromField f v = buildUid <$> fromField f v
-instance Result Password where
- convert f v = Encrypted <$> convert f v
+instance FromField Password where
+ fromField f v = Encrypted <$> fromField f v
-instance QueryResults AuthUser where
- convertResults (fa:fb:fc:fd:fe:ff:fg:fh:fi:fj:fk:fl:fm:fn:fo:_)
- (va:vb:vc:vd:ve:vf:vg:vh:vi:vj:vk:vl:vm:vn:vo:_) =
+instance FromRow AuthUser where
+ fromRow =
AuthUser
<$> _userId
<*> _userLogin
@@ -146,40 +145,39 @@ instance QueryResults AuthUser where
<*> _userRoles
<*> _userMeta
where
- !_userId = convert fa va
- !_userLogin = convert fb vb
- !_userPassword = convert fc vc
- !_userActivatedAt = convert fd vd
- !_userSuspendedAt = convert fe ve
- !_userRememberToken = convert ff vf
- !_userLoginCount = convert fg vg
- !_userFailedLoginCount = convert fh vh
- !_userLockedOutUntil = convert fi vi
- !_userCurrentLoginAt = convert fj vj
- !_userLastLoginAt = convert fk vk
- !_userCurrentLoginIp = convert fl vl
- !_userLastLoginIp = convert fm vm
- !_userCreatedAt = convert fn vn
- !_userUpdatedAt = convert fo vo
- !_userRoles = Right []
- !_userMeta = Right HM.empty
- convertResults fs vs = convertError fs vs 15
-
-
-querySingle :: (QueryParams q, QueryResults a)
+ !_userId = field
+ !_userLogin = field
+ !_userPassword = field
+ !_userActivatedAt = field
+ !_userSuspendedAt = field
+ !_userRememberToken = field
+ !_userLoginCount = field
+ !_userFailedLoginCount = field
+ !_userLockedOutUntil = field
+ !_userCurrentLoginAt = field
+ !_userLastLoginAt = field
+ !_userCurrentLoginIp = field
+ !_userLastLoginIp = field
+ !_userCreatedAt = field
+ !_userUpdatedAt = field
+ !_userRoles = pure []
+ !_userMeta = pure HM.empty
+
+
+querySingle :: (ToRow q, FromRow a)
=> Pool P.Connection -> Query -> q -> IO (Maybe a)
querySingle pool q ps = withResource pool $ \conn -> return . listToMaybe =<<
P.query conn q ps
-authExecute :: QueryParams q
+authExecute :: ToRow q
=> Pool P.Connection -> Query -> q -> IO ()
authExecute pool q ps = do
withResource pool $ \conn -> P.execute conn q ps
return ()
-instance P.Param Password where
- render (ClearText bs) = P.render bs
- render (Encrypted bs) = P.render bs
+instance P.ToField Password where
+ toField (ClearText bs) = P.toField bs
+ toField (Encrypted bs) = P.toField bs
-- | Datatype containing the names of the columns for the authentication table.
@@ -234,21 +232,21 @@ fDesc f = fst f `T.append` " " `T.append` snd f
-- 'AuthTable'.
colDef :: [(AuthTable -> (Text, Text), AuthUser -> P.Action)]
colDef =
- [ (colId , P.render . fmap unUid . userId)
- , (colLogin , P.render . userLogin)
- , (colPassword , P.render . userPassword)
- , (colActivatedAt , P.render . userActivatedAt)
- , (colSuspendedAt , P.render . userSuspendedAt)
- , (colRememberToken , P.render . userRememberToken)
- , (colLoginCount , P.render . userLoginCount)
- , (colFailedLoginCount, P.render . userFailedLoginCount)
- , (colLockedOutUntil , P.render . userLockedOutUntil)
- , (colCurrentLoginAt , P.render . userCurrentLoginAt)
- , (colLastLoginAt , P.render . userLastLoginAt)
- , (colCurrentLoginIp , P.render . userCurrentLoginIp)
- , (colLastLoginIp , P.render . userLastLoginIp)
- , (colCreatedAt , P.render . userCreatedAt)
- , (colUpdatedAt , P.render . userUpdatedAt)
+ [ (colId , P.toField . fmap unUid . userId)
+ , (colLogin , P.toField . userLogin)
+ , (colPassword , P.toField . userPassword)
+ , (colActivatedAt , P.toField . userActivatedAt)
+ , (colSuspendedAt , P.toField . userSuspendedAt)
+ , (colRememberToken , P.toField . userRememberToken)
+ , (colLoginCount , P.toField . userLoginCount)
+ , (colFailedLoginCount, P.toField . userFailedLoginCount)
+ , (colLockedOutUntil , P.toField . userLockedOutUntil)
+ , (colCurrentLoginAt , P.toField . userCurrentLoginAt)
+ , (colLastLoginAt , P.toField . userLastLoginAt)
+ , (colCurrentLoginIp , P.toField . userCurrentLoginIp)
+ , (colLastLoginIp , P.toField . userLastLoginIp)
+ , (colCreatedAt , P.toField . userCreatedAt)
+ , (colUpdatedAt , P.toField . userUpdatedAt)
]
saveQuery :: AuthTable -> AuthUser -> (Text, [P.Action])
@@ -273,7 +271,7 @@ saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId
, fst (colId at)
, " = ?"
]
- , params ++ [P.render $ unUid uid])
+ , params ++ [P.toField $ unUid uid])
cols = map (fst . ($at) . fst) $ tail colDef
vals = map (const "?") cols
params = map (($u) . snd) $ tail colDef
View
38 src/Snap/Snaplet/PostgresqlSimple.hs
@@ -97,8 +97,8 @@ module Snap.Snaplet.PostgresqlSimple (
, P.TransactionMode(..)
, P.IsolationLevel(..)
, P.ReadWriteMode(..)
- , QueryParams(..)
- , QueryResults(..)
+ , ToRow(..)
+ , FromRow(..)
, P.defaultConnectInfo
, P.defaultTransactionMode
@@ -120,8 +120,8 @@ import Data.Int
import Data.List
import Data.Maybe
import Data.Pool
-import Database.PostgreSQL.Simple.QueryParams
-import Database.PostgreSQL.Simple.QueryResults
+import Database.PostgreSQL.Simple.ToRow
+import Database.PostgreSQL.Simple.FromRow
import qualified Database.PostgreSQL.Simple as P
import Snap.Snaplet
import Paths_snaplet_postgresql_simple
@@ -195,22 +195,22 @@ withPG f = do
------------------------------------------------------------------------------
-- | See 'P.query'
-query :: (HasPostgres m, QueryParams q, QueryResults r)
+query :: (HasPostgres m, ToRow q, FromRow r)
=> P.Query -> q -> m [r]
query q params = withPG (\c -> P.query c q params)
------------------------------------------------------------------------------
-- | See 'P.query_'
-query_ :: (HasPostgres m, QueryResults r) => P.Query -> m [r]
+query_ :: (HasPostgres m, FromRow r) => P.Query -> m [r]
query_ q = withPG (\c -> P.query_ c q)
------------------------------------------------------------------------------
-- |
fold :: (HasPostgres m,
- QueryResults row,
- QueryParams params,
+ FromRow row,
+ ToRow params,
MonadCatchIO m)
=> P.Query -> params -> b -> (b -> row -> IO b) -> m b
fold template qs a f = withPG (\c -> P.fold c template qs a f)
@@ -219,8 +219,8 @@ fold template qs a f = withPG (\c -> P.fold c template qs a f)
------------------------------------------------------------------------------
-- |
foldWithOptions :: (HasPostgres m,
- QueryResults row,
- QueryParams params,
+ FromRow row,
+ ToRow params,
MonadCatchIO m)
=> P.FoldOptions
-> P.Query
@@ -235,7 +235,7 @@ foldWithOptions opts template qs a f =
------------------------------------------------------------------------------
-- |
fold_ :: (HasPostgres m,
- QueryResults row,
+ FromRow row,
MonadCatchIO m)
=> P.Query -> b -> (b -> row -> IO b) -> m b
fold_ template a f = withPG (\c -> P.fold_ c template a f)
@@ -244,7 +244,7 @@ fold_ template a f = withPG (\c -> P.fold_ c template a f)
------------------------------------------------------------------------------
-- |
foldWithOptions_ :: (HasPostgres m,
- QueryResults row,
+ FromRow row,
MonadCatchIO m)
=> P.FoldOptions
-> P.Query
@@ -258,8 +258,8 @@ foldWithOptions_ opts template a f =
------------------------------------------------------------------------------
-- |
forEach :: (HasPostgres m,
- QueryResults r,
- QueryParams q,
+ FromRow r,
+ ToRow q,
MonadCatchIO m)
=> P.Query -> q -> (r -> IO ()) -> m ()
forEach template qs f = withPG (\c -> P.forEach c template qs f)
@@ -268,15 +268,15 @@ forEach template qs f = withPG (\c -> P.forEach c template qs f)
------------------------------------------------------------------------------
-- |
forEach_ :: (HasPostgres m,
- QueryResults r,
+ FromRow r,
MonadCatchIO m)
=> P.Query -> (r -> IO ()) -> m ()
forEach_ template f = withPG (\c -> P.forEach_ c template f)
------------------------------------------------------------------------------
-- |
-execute :: (HasPostgres m, QueryParams q, MonadCatchIO m)
+execute :: (HasPostgres m, ToRow q, MonadCatchIO m)
=> P.Query -> q -> m Int64
execute template qs = withPG (\c -> P.execute c template qs)
@@ -290,7 +290,7 @@ execute_ template = withPG (\c -> P.execute_ c template)
------------------------------------------------------------------------------
-- |
-executeMany :: (HasPostgres m, QueryParams q, MonadCatchIO m)
+executeMany :: (HasPostgres m, ToRow q, MonadCatchIO m)
=> P.Query -> [q] -> m Int64
executeMany template qs = withPG (\c -> P.executeMany c template qs)
@@ -337,12 +337,12 @@ withTransactionMode mode act = do
return r
-formatMany :: (QueryParams q, HasPostgres m, MonadCatchIO m)
+formatMany :: (ToRow q, HasPostgres m, MonadCatchIO m)
=> P.Query -> [q] -> m ByteString
formatMany q qs = withPG (\c -> P.formatMany c q qs)
-formatQuery :: (QueryParams q, HasPostgres m, MonadCatchIO m)
+formatQuery :: (ToRow q, HasPostgres m, MonadCatchIO m)
=> P.Query -> q -> m ByteString
formatQuery q qs = withPG (\c -> P.formatQuery c q qs)

0 comments on commit 1463f67

Please sign in to comment.
Something went wrong with that request. Please try again.