diff --git a/resources/db/devel.cfg b/resources/db/devel.cfg --- a/resources/db/devel.cfg +++ b/resources/db/devel.cfg @@ -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 diff --git a/snaplet-sqlite-simple.cabal b/snaplet-sqlite-simple.cabal --- a/snaplet-sqlite-simple.cabal +++ b/snaplet-sqlite-simple.cabal @@ -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 diff --git a/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs b/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs --- a/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs +++ b/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs @@ -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 diff --git a/src/Snap/Snaplet/SqliteSimple.hs b/src/Snap/Snaplet/SqliteSimple.hs --- a/src/Snap/Snaplet/SqliteSimple.hs +++ b/src/Snap/Snaplet/SqliteSimple.hs @@ -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) diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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