Permalink
Browse files

Adapt to sqlite-simple

  • Loading branch information...
nurpax committed Aug 19, 2012
1 parent 10cfeaa commit 4db51743fa2b097280503b11d7309aa390dd994a
Showing with 211 additions and 317 deletions.
  1. +2 −0 .gitignore
  2. +56 −0 LICENSE
  3. +2 −4 snaplet-sqlite-simple.cabal
  4. +79 −79 src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs
  5. +72 −234 src/Snap/Snaplet/SqliteSimple.hs
View
@@ -0,0 +1,2 @@
+cabal-dev/
+dist/
View
56 LICENSE
@@ -0,0 +1,56 @@
+Copyright (c) 2012, Janne Hellsten
+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 the authors nor the names of its 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 HOLDER 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.
+
+
+Copyright (c) 2012, Doug Beardsley
+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 the authors nor the names of its 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 HOLDER 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.
@@ -1,4 +1,4 @@
-name: snaplet-postgresql-simple
+name: snaplet-sqlite-simple
version: 0.1.0
synopsis: sqlite-simple snaplet for the Snap Framework
description: This snaplet contains support for using the SQLite
@@ -31,9 +31,6 @@ Library
Snap.Snaplet.SqliteSimple
Snap.Snaplet.Auth.Backends.SqliteSimple
- other-modules:
- Paths_snaplet_sqlite_simple
-
build-depends:
base >= 4 && < 5,
bytestring >= 0.9.1 && < 0.10,
@@ -42,6 +39,7 @@ Library
MonadCatchIO-transformers >= 0.3 && < 0.4,
mtl >= 2 && < 3,
sqlite-simple >= 0.1 && < 1.0,
+ direct-sqlite >= 2.0 && < 2.1,
resource-pool-catchio >= 0.2 && < 0.3,
snap >= 0.9 && < 0.10,
text >= 0.11 && < 0.12,
@@ -4,78 +4,80 @@
{-|
-This module allows you to use the auth snaplet with your user database stored
-in a PostgreSQL database. When you run your application with this snaplet, a
-config file will be copied into the the @snaplets/postgresql-auth@ directory.
-This file contains all of the configurable options for the snaplet and allows
-you to change them without recompiling your application.
+This module allows you to use the auth snaplet with your user database
+stored in a SQLite database. When you run your application with this
+snaplet, a config file will be copied into the the
+@snaplets/sqlite-auth@ directory. This file contains all of the
+configurable options for the snaplet and allows you to change them
+without recompiling your application.
-To use this snaplet in your application enable the session, postgres, and auth
-snaplets as follows:
+To use this snaplet in your application enable the session, sqlite,
+and auth snaplets as follows:
> data App = App
> { ... -- your own application state here
> , _sess :: Snaplet SessionManager
-> , _db :: Snaplet Postgres
+> , _db :: Snaplet Sqlite
> , _auth :: Snaplet (AuthManager App)
> }
Then in your initializer you'll have something like this:
-> d <- nestSnaplet "db" db pgsInit
-> a <- nestSnaplet "auth" auth $ initPostgresAuth sess d
+> d <- nestSnaplet "db" db sqliteInit
+> a <- nestSnaplet "auth" auth $ initSqliteAuth sess d
If you have not already created the database table for users, it will
-automatically be created for you the first time you run your application.
+automatically be created for you the first time you run your
+application.
-}
-module Snap.Snaplet.Auth.Backends.PostgresqlSimple
- ( initPostgresAuth
+module Snap.Snaplet.Auth.Backends.SqliteSimple
+ ( initSqliteAuth
) where
------------------------------------------------------------------------------
import qualified Data.Configurator as C
import qualified Data.HashMap.Lazy as HM
import qualified Data.Text as T
import Data.Text (Text)
-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.ToField as P
-import Database.PostgreSQL.Simple.FromField
-import Database.PostgreSQL.Simple.FromRow
-import Database.PostgreSQL.Simple.Types
+import Database.SQLite3 (SQLData(..))
+import qualified Database.SQLite.Simple as S
+import qualified Database.SQLite.Simple.ToField as S
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.FromRow
+import Database.SQLite.Simple.Types
import Snap
import Snap.Snaplet.Auth
-import Snap.Snaplet.PostgresqlSimple
+import Snap.Snaplet.SqliteSimple
import Snap.Snaplet.Session
import Web.ClientSession
-import Paths_snaplet_postgresql_simple
+import Paths_snaplet_sqlite_simple
-data PostgresAuthManager = PostgresAuthManager
+data SqliteAuthManager = SqliteAuthManager
{ pamTable :: AuthTable
- , pamConnPool :: Pool P.Connection
+ , pamConnPool :: Pool S.Connection
}
------------------------------------------------------------------------------
--- | Initializer for the postgres backend to the auth snaplet.
+-- | Initializer for the sqlite backend to the auth snaplet.
--
-initPostgresAuth
+initSqliteAuth
:: Lens b (Snaplet SessionManager) -- ^ Lens to the session snaplet
- -> Snaplet Postgres -- ^ The postgres snaplet
+ -> Snaplet Sqlite -- ^ The sqlite snaplet
-> SnapletInit b (AuthManager b)
-initPostgresAuth sess db = makeSnaplet "postgresql-auth" desc datadir $ do
+initSqliteAuth sess db = makeSnaplet "sqliteql-auth" desc datadir $ do
config <- getSnapletUserConfig
authTable <- liftIO $ C.lookupDefault "snap_auth_user" config "authTable"
authSettings <- authSettingsFromConfig
key <- liftIO $ getKey (asSiteKey authSettings)
let tableDesc = defAuthTable { tblName = authTable }
- let manager = PostgresAuthManager tableDesc $
- pgPool $ getL snapletValue db
+ let manager = SqliteAuthManager tableDesc $
+ sqlitePool $ getL snapletValue db
liftIO $ createTableIfMissing manager
rng <- liftIO mkRNG
return $ AuthManager
@@ -90,20 +92,20 @@ initPostgresAuth sess db = makeSnaplet "postgresql-auth" desc datadir $ do
, randomNumberGenerator = rng
}
where
- desc = "A PostgreSQL backend for user authentication"
+ desc = "An Sqlite backend for user authentication"
datadir = Just $ liftM (++"/resources/auth") getDataDir
------------------------------------------------------------------------------
-- | Create the user table if it doesn't exist.
-createTableIfMissing :: PostgresAuthManager -> IO ()
-createTableIfMissing PostgresAuthManager{..} = do
+createTableIfMissing :: SqliteAuthManager -> IO ()
+createTableIfMissing SqliteAuthManager{..} = do
withResource pamConnPool $ \conn -> do
- res <- P.query_ conn $ Query $ T.encodeUtf8 $
+ res <- S.query_ conn $ Query $
"select relname from pg_class where relname='"
`T.append` tblName pamTable `T.append` "'"
when (null (res :: [Only T.Text])) $
- P.execute_ conn (Query $ T.encodeUtf8 q) >> return ()
+ S.execute_ conn (Query q) >> return ()
return ()
where
q = T.concat
@@ -119,10 +121,10 @@ buildUid = UserId . T.pack . show
instance FromField UserId where
- fromField f v = buildUid <$> fromField f v
+ fromField f = buildUid <$> fromField f
instance FromField Password where
- fromField f v = Encrypted <$> fromField f v
+ fromField f = Encrypted <$> fromField f
instance FromRow AuthUser where
fromRow =
@@ -165,19 +167,19 @@ instance FromRow AuthUser where
querySingle :: (ToRow q, FromRow a)
- => Pool P.Connection -> Query -> q -> IO (Maybe a)
+ => Pool S.Connection -> Query -> q -> IO (Maybe a)
querySingle pool q ps = withResource pool $ \conn -> return . listToMaybe =<<
- P.query conn q ps
+ S.query conn q ps
authExecute :: ToRow q
- => Pool P.Connection -> Query -> q -> IO ()
+ => Pool S.Connection -> Query -> q -> IO ()
authExecute pool q ps = do
- withResource pool $ \conn -> P.execute conn q ps
+ withResource pool $ \conn -> S.execute conn q ps
return ()
-instance P.ToField Password where
- toField (ClearText bs) = P.toField bs
- toField (Encrypted bs) = P.toField bs
+instance S.ToField Password where
+ toField (ClearText bs) = S.toField bs
+ toField (Encrypted bs) = S.toField bs
-- | Datatype containing the names of the columns for the authentication table.
@@ -230,26 +232,26 @@ fDesc f = fst f `T.append` " " `T.append` snd f
-- | List of deconstructors so it's easier to extract column names from an
-- 'AuthTable'.
-colDef :: [(AuthTable -> (Text, Text), AuthUser -> P.Action)]
+colDef :: [(AuthTable -> (Text, Text), AuthUser -> SQLData)]
colDef =
- [ (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)
+ [ (colId , S.toField . fmap unUid . userId)
+ , (colLogin , S.toField . userLogin)
+ , (colPassword , S.toField . userPassword)
+ , (colActivatedAt , S.toField . userActivatedAt)
+ , (colSuspendedAt , S.toField . userSuspendedAt)
+ , (colRememberToken , S.toField . userRememberToken)
+ , (colLoginCount , S.toField . userLoginCount)
+ , (colFailedLoginCount, S.toField . userFailedLoginCount)
+ , (colLockedOutUntil , S.toField . userLockedOutUntil)
+ , (colCurrentLoginAt , S.toField . userCurrentLoginAt)
+ , (colLastLoginAt , S.toField . userLastLoginAt)
+ , (colCurrentLoginIp , S.toField . userCurrentLoginIp)
+ , (colLastLoginIp , S.toField . userLastLoginIp)
+ , (colCreatedAt , S.toField . userCreatedAt)
+ , (colUpdatedAt , S.toField . userUpdatedAt)
]
-saveQuery :: AuthTable -> AuthUser -> (Text, [P.Action])
+saveQuery :: AuthTable -> AuthUser -> (Text, [SQLData])
saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId
where
insertQuery = (T.concat [ "INSERT INTO "
@@ -271,34 +273,32 @@ saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId
, fst (colId at)
, " = ?"
]
- , params ++ [P.toField $ unUid uid])
+ , params ++ [S.toField $ unUid uid])
cols = map (fst . ($at) . fst) $ tail colDef
vals = map (const "?") cols
params = map (($u) . snd) $ tail colDef
-
+
------------------------------------------------------------------------------
--- |
-instance IAuthBackend PostgresAuthManager where
- save PostgresAuthManager{..} u@AuthUser{..} = do
+-- |
+instance IAuthBackend SqliteAuthManager where
+ save SqliteAuthManager{..} u@AuthUser{..} = do
let (qstr, params) = saveQuery pamTable u
- let q = Query $ T.encodeUtf8 qstr
+ let q = Query qstr
withResource pamConnPool $ \conn -> do
- P.begin conn
- P.execute conn q params
- let q2 = Query $ T.encodeUtf8 $ T.concat
+ S.execute conn q params
+ let q2 = Query $ T.concat
[ "select * from "
, tblName pamTable
, " where "
, fst (colLogin pamTable)
, " = ?"
]
- res <- P.query conn q2 [userLogin]
- P.commit conn
+ res <- S.query conn q2 [userLogin]
return $ fromMaybe u $ listToMaybe res
- lookupByUserId PostgresAuthManager{..} uid = do
- let q = Query $ T.encodeUtf8 $ T.concat
+ lookupByUserId SqliteAuthManager{..} uid = do
+ let q = Query $ T.concat
[ "select * from "
, tblName pamTable
, " where "
@@ -307,8 +307,8 @@ instance IAuthBackend PostgresAuthManager where
]
querySingle pamConnPool q [unUid uid]
- lookupByLogin PostgresAuthManager{..} login = do
- let q = Query $ T.encodeUtf8 $ T.concat
+ lookupByLogin SqliteAuthManager{..} login = do
+ let q = Query $ T.concat
[ "select * from "
, tblName pamTable
, " where "
@@ -317,8 +317,8 @@ instance IAuthBackend PostgresAuthManager where
]
querySingle pamConnPool q [login]
- lookupByRememberToken PostgresAuthManager{..} token = do
- let q = Query $ T.encodeUtf8 $ T.concat
+ lookupByRememberToken SqliteAuthManager{..} token = do
+ let q = Query $ T.concat
[ "select * from "
, tblName pamTable
, " where "
@@ -327,8 +327,8 @@ instance IAuthBackend PostgresAuthManager where
]
querySingle pamConnPool q [token]
- destroy PostgresAuthManager{..} AuthUser{..} = do
- let q = Query $ T.encodeUtf8 $ T.concat
+ destroy SqliteAuthManager{..} AuthUser{..} = do
+ let q = Query $ T.concat
[ "delete from "
, tblName pamTable
, " where "
Oops, something went wrong.

0 comments on commit 4db5174

Please sign in to comment.