snaplet-sqlite-simple 0.4.1 → 0.4.2
raw patch · 5 files changed
+84/−20 lines, 5 filesdep +aesondep −resource-pool-catchiodep ~direct-sqlitedep ~errorsdep ~sqlite-simplePVP ok
version bump matches the API change (PVP)
Dependencies added: aeson
Dependencies removed: resource-pool-catchio
Dependency ranges changed: direct-sqlite, errors, sqlite-simple
API changes (from Hackage documentation)
Files
- resources/db/devel.cfg +7/−0
- snaplet-sqlite-simple.cabal +8/−6
- src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs +42/−6
- src/Snap/Snaplet/SqliteSimple.hs +11/−7
- test/Tests.hs +16/−1
resources/db/devel.cfg view
@@ -1,1 +1,8 @@ db = "test.db"++# Enable SQLite query tracing+# (http://www.sqlite.org/c3ref/profile.html). NEVER turn this on in+# production, logging SQL queries and their parameters is be a+# security risk.++enableSqlTracing = false
snaplet-sqlite-simple.cabal view
@@ -1,5 +1,5 @@ name: snaplet-sqlite-simple-version: 0.4.1+version: 0.4.2 synopsis: sqlite-simple snaplet for the Snap Framework description: This snaplet provides support for using the SQLite database with a Snap Framework application via the@@ -47,15 +47,15 @@ Paths_snaplet_sqlite_simple build-depends:+ aeson >= 0.6 && < 0.7, base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, clientsession >= 0.8 && < 0.9, configurator >= 0.2 && < 0.3, MonadCatchIO-transformers >= 0.3 && < 0.4, mtl >= 2 && < 3,- sqlite-simple >= 0.1 && < 1.0,- direct-sqlite >= 2.2 && < 2.4,- resource-pool-catchio >= 0.2 && < 0.3,+ sqlite-simple >= 0.4.1 && < 1.0,+ direct-sqlite >= 2.3.3 && < 2.4, snap >= 0.10 && < 0.12, text >= 0.11 && < 0.12, transformers >= 0.2 && < 0.4,@@ -77,6 +77,7 @@ , SafeCWD build-depends:+ aeson >= 0.6 && < 0.7, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2 && < 0.4, base >= 4 && < 5,@@ -85,7 +86,7 @@ configurator >= 0.1 && < 0.3, containers >= 0.3, directory >= 1.0 && < 1.3,- errors >= 1.3.1 && < 1.4,+ errors >= 1.3.1 && < 1.5, lens >= 3.7.0.1 && < 3.9, mtl >= 2, snap-core,@@ -97,7 +98,8 @@ test-framework-hunit >= 0.2.7 && < 0.4, text >= 0.11 && < 0.12, time >= 1.1,- transformers >= 0.2+ transformers >= 0.2,+ unordered-containers >= 0.2 && < 0.3 default-extensions: FlexibleInstances
src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs view
@@ -39,11 +39,15 @@ ------------------------------------------------------------------------------ import Control.Concurrent+import qualified Data.Aeson as A+import Data.ByteString (ByteString) import qualified Data.Configurator as C import qualified Data.HashMap.Lazy as HM import Data.Maybe import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT import qualified Database.SQLite.Simple as S import Database.SQLite.Simple.FromField import Database.SQLite.Simple.FromRow@@ -81,7 +85,7 @@ sqliteConn $ db ^# snapletValue liftIO $ createTableIfMissing manager rng <- liftIO mkRNG- return $ AuthManager+ return AuthManager { backend = manager , session = sess , activeUser = Nothing@@ -152,6 +156,10 @@ S.execute_ conn (addColumnQ (colResetToken pam)) S.execute_ conn (addColumnQ (colResetRequestedAt pam)) + upgrade 2 = do+ S.execute_ conn (addColumnQ (colRoles pam))+ S.execute_ conn (addColumnQ (colMeta pam))+ upgrade _ = error "unknown version" addColumnQ (c,t) =@@ -161,12 +169,13 @@ ------------------------------------------------------------------------------ -- | Create the user table if it doesn't exist. createTableIfMissing :: SqliteAuthManager -> IO ()-createTableIfMissing SqliteAuthManager{..} = do+createTableIfMissing SqliteAuthManager{..} = withMVar pamConnPool $ \conn -> do authTblExists <- tableExists conn $ tblName pamTable unless authTblExists $ createInitialSchema conn pamTable upgradeSchema conn pamTable 0 upgradeSchema conn pamTable 1+ upgradeSchema conn pamTable 2 buildUid :: Int -> UserId@@ -199,8 +208,8 @@ <*> _userUpdatedAt <*> _userResetToken <*> _userResetRequestedAt- <*> _userRoles- <*> _userMeta+ <*> decodeRoles+ <*> decodeMeta where !_userId = field !_userLogin = field@@ -220,10 +229,23 @@ !_userUpdatedAt = field !_userResetToken = field !_userResetRequestedAt = field- !_userRoles = pure []- !_userMeta = pure HM.empty+ !_userRoles = field :: RowParser (Maybe LT.Text)+ !_userMeta = field :: RowParser (Maybe LT.Text) + decodeRoles :: RowParser [Role]+ decodeRoles = do+ roles <- fmap (fmap (map Role) . textDecodeBS) _userRoles+ return $ fromMaybe [] roles + decodeMeta = do+ meta <- fmap (fmap (fromMaybe HM.empty . A.decode' . LT.encodeUtf8)) _userMeta+ return $ fromMaybe HM.empty meta++ textDecodeBS :: Maybe LT.Text -> Maybe [ByteString]+ textDecodeBS Nothing = Nothing+ textDecodeBS (Just t) = A.decode' . LT.encodeUtf8 $ t++ querySingle :: (ToRow q, FromRow a) => MVar S.Connection -> Query -> q -> IO (Maybe a) querySingle pool q ps = withMVar pool $ \conn -> return . listToMaybe =<<@@ -262,6 +284,8 @@ , colUpdatedAt :: (Text, Text) , colResetToken :: (Text, Text) , colResetRequestedAt :: (Text, Text)+ , colRoles :: (Text, Text)+ , colMeta :: (Text, Text) } @@ -288,6 +312,8 @@ , colUpdatedAt = ("updated_at", "timestamp") , colResetToken = ("reset_token", "text") , colResetRequestedAt = ("reset_requested_at", "timestamp")+ , colRoles = ("roles_json", "text")+ , colMeta = ("meta_json", "text") } -- | List of deconstructors so it's easier to extract column names from an@@ -312,8 +338,17 @@ , (colUpdatedAt , S.toField . userUpdatedAt) , (colResetToken , S.toField . userResetToken) , (colResetRequestedAt, S.toField . userResetRequestedAt)+ , (colRoles , S.toField . encodeOrNull . userRoles)+ , (colMeta , S.toField . encodeOrNullHM . userMeta) ]+ where+ encodeOrNull [] = Nothing+ encodeOrNull x = Just . LT.decodeUtf8 . A.encode $ x + encodeOrNullHM hm | HM.null hm = Nothing+ | otherwise = Just . LT.decodeUtf8 . A.encode $ hm++ colNames :: AuthTable -> T.Text colNames pam = T.intercalate "," . map (\(f,_) -> fst (f pam)) $ colDef@@ -341,6 +376,7 @@ , " = ?" ] , params ++ [S.toField $ unUid uid])+ -- The list of column names cols = map (fst . ($at) . fst) $ tail colDef vals = map (const "?") cols params = map (($u) . snd) $ tail colDef
src/Snap/Snaplet/SqliteSimple.hs view
@@ -95,6 +95,7 @@ import qualified Data.Configurator as C import Data.List import Data.Maybe+import qualified Data.Text as T import Database.SQLite.Simple.ToRow import Database.SQLite.Simple.FromRow import qualified Database.SQLite.Simple as S@@ -160,17 +161,20 @@ sqliteInit :: SnapletInit b Sqlite sqliteInit = makeSnaplet "sqlite-simple" description datadir $ do config <- getSnapletUserConfig- (mci,errs) <- runWriterT $ do- db <- logErr "Must specify db filename" $ C.lookup config "db"- return $ db+ (mci,errs) <- runWriterT $+ logErr "Must specify db filename" $ C.lookup config "db" let ci = fromMaybe (error $ intercalate "\n" errs) mci-- conn <- liftIO $ (S.open ci >>= newMVar)+ tracing <- liftIO $ C.lookupDefault False config "enableSqlTracing"+ conn <- liftIO (S.open ci >>= setTracing tracing >>= newMVar) return $ Sqlite conn where description = "Sqlite abstraction"+ datadir = Just $ liftM (++"/resources/db") getDataDir + setTracing tracing conn = do+ when tracing (S.setTrace conn (Just (putStrLn . T.unpack)))+ return conn ------------------------------------------------------------------------------ -- | Convenience function for executing a function that needs a database@@ -202,7 +206,7 @@ -- -- See also 'withSqlite' for notes on concurrent access. query_ :: (HasSqlite m, FromRow r) => S.Query -> m [r]-query_ q = withSqlite (\c -> S.query_ c q)+query_ q = withSqlite (`S.query_` q) ------------------------------------------------------------------------------@@ -220,4 +224,4 @@ -- See also 'withSqlite' for notes on concurrent access. execute_ :: (HasSqlite m, MonadCatchIO m) => S.Query -> m ()-execute_ template = withSqlite (\c -> S.execute_ c template)+execute_ template = withSqlite (`S.execute_` template)
test/Tests.hs view
@@ -6,6 +6,9 @@ ------------------------------------------------------------------------------+import qualified Data.Aeson as A+import qualified Data.ByteString.Char8 as BL+import qualified Data.HashMap.Lazy as HM import qualified Data.Map as M import qualified Data.Text as T import Test.Framework@@ -129,6 +132,8 @@ assertEqual "local host ip" Nothing (userLastLoginIp u) assertEqual "locked until" Nothing (userLockedOutUntil u) assertEqual "empty email" Nothing (userEmail u)+ assertEqual "roles" [] (userRoles u)+ assertEqual "meta" HM.empty (userMeta u) ------------------------------------------------------------------------------ -- Create a user, modify it, persist it and load again, check fields ok.@@ -150,16 +155,26 @@ assertEqual "locked until" Nothing (userLockedOutUntil u) assertEqual "local host ip" (Just "127.0.0.1") (userCurrentLoginIp u) assertEqual "no previous login" Nothing (userLastLoginIp u)- let saveHdl = with auth $ saveUser (u { userLogin = "bar" })+ let saveHdl = with auth $ saveUser (u { userLogin = "bar"+ , userRoles = roles+ , userMeta = meta }) res <- evalHandler (ST.get "" M.empty) saveHdl appInit either (assertFailure . show) checkUpdatedUser res + roles = [Role $ BL.pack "Superman", Role $ BL.pack "Journalist"]+ meta = HM.fromList [ (T.pack "email-verified",+ A.toJSON $ T.pack "yes")+ , (T.pack "suppress-products",+ A.toJSON [T.pack "Kryptonite"]) ]+ checkUpdatedUser (Left _) = assertBool "failed saveUser" False checkUpdatedUser (Right u) = do assertEqual "login rename ok?" "bar" (userLogin u) assertEqual "login count" 1 (userLoginCount u) assertEqual "local host ip" (Just "127.0.0.1") (userCurrentLoginIp u) assertEqual "local host ip" Nothing (userLastLoginIp u)+ assertEqual "account roles" roles (userRoles u)+ assertEqual "account meta data" meta (userMeta u) let loginHdl = with auth $ loginByUsername "bar" (ClearText "foo") True res <- evalHandler (ST.get "" M.empty) loginHdl appInit either (assertFailure . show) (assertBool "login as 'bar' ok?" . isRight) res