diff --git a/snaplet-sqlite-simple.cabal b/snaplet-sqlite-simple.cabal --- a/snaplet-sqlite-simple.cabal +++ b/snaplet-sqlite-simple.cabal @@ -1,10 +1,21 @@ name: snaplet-sqlite-simple -version: 0.2.0 +version: 0.3.0 synopsis: sqlite-simple snaplet for the Snap Framework -description: This snaplet contains support for using the SQLite +description: This snaplet provides support for using the SQLite database with a Snap Framework application via the sqlite-simple package. It also includes an authentication backend. + . + See + + for an example project that demonstrates the use of + this snaplet. It implements a stand-alone application + with a login screen that persists user information in + a SQLite database and allows a logged in user to save + comments. Querying and listing comments demonstrates + how a user of snaplet-sqlite-simple might relate + Snaplet.Auth based AuthUsers to his own tables. + license: BSD3 license-file: LICENSE author: Janne Hellsten, Doug Beardsley @@ -37,14 +48,14 @@ build-depends: base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, - clientsession >= 0.7.2 && < 0.9, + 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.0 && < 2.3, resource-pool-catchio >= 0.2 && < 0.3, - snap >= 0.9 && < 0.10, + snap >= 0.10 && < 0.11, text >= 0.11 && < 0.12, transformers >= 0.2 && < 0.4, unordered-containers >= 0.2 && < 0.3 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 @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| @@ -67,7 +68,7 @@ -- | Initializer for the sqlite backend to the auth snaplet. -- initSqliteAuth - :: Lens b (Snaplet SessionManager) -- ^ Lens to the session snaplet + :: SnapletLens b SessionManager -- ^ Lens to the session snaplet -> Snaplet Sqlite -- ^ The sqlite snaplet -> SnapletInit b (AuthManager b) initSqliteAuth sess db = makeSnaplet "sqlite-auth" desc datadir $ do @@ -77,7 +78,7 @@ key <- liftIO $ getKey (asSiteKey authSettings) let tableDesc = defAuthTable { tblName = authTable } let manager = SqliteAuthManager tableDesc $ - sqlitePool $ getL snapletValue db + sqlitePool $ db ^# snapletValue liftIO $ createTableIfMissing manager rng <- liftIO mkRNG return $ AuthManager @@ -96,30 +97,81 @@ datadir = Just $ liftM (++"/resources/auth") getDataDir +tableExists :: S.Connection -> T.Text -> IO Bool +tableExists conn tblName = do + r <- S.query conn "SELECT name FROM sqlite_master WHERE type='table' AND name=?" (Only tblName) + case r of + [Only (_ :: String)] -> return True + _ -> return False + +createInitialSchema :: S.Connection -> AuthTable -> IO () +createInitialSchema conn pamTable = do + let q = Query $ T.concat + [ "CREATE TABLE ", tblName pamTable, " (uid INTEGER PRIMARY KEY," + , "login text UNIQUE NOT NULL," + , "password text," + , "activated_at timestamp,suspended_at timestamp,remember_token text," + , "login_count INTEGER NOT NULL,failed_login_count INTEGER NOT NULL," + , "locked_out_until timestamp,current_login_at timestamp," + , "last_login_at timestamp,current_login_ip text," + , "last_login_ip text,created_at timestamp,updated_at timestamp);" + ] + S.execute_ conn q + +versionTable :: AuthTable -> T.Text +versionTable pamTable = T.concat [tblName pamTable, "_version"] + +schemaVersion :: S.Connection -> AuthTable -> IO Int +schemaVersion conn pamTable = do + let verTbl = versionTable pamTable + versionExists <- tableExists conn verTbl + if not versionExists + then return 0 + else + do + let q = T.concat ["SELECT version FROM ", verTbl, " LIMIT 1"] + [Only v] <- S.query_ conn (Query q) :: IO [Only Int] + return v + +setSchemaVersion :: S.Connection -> AuthTable -> Int -> IO () +setSchemaVersion conn pamTable v = do + let q = Query $ T.concat ["UPDATE ", versionTable pamTable, " SET version = ?"] + S.execute conn q (Only v) + +upgradeSchema :: Connection -> AuthTable -> Int -> IO () +upgradeSchema conn pam fromVersion = do + ver <- schemaVersion conn pam + when (ver == fromVersion) (upgrade ver >> setSchemaVersion conn pam (fromVersion+1)) + where + upgrade 0 = do + S.execute_ conn (Query $ T.concat ["CREATE TABLE ", versionTable pam, " (version INTEGER)"]) + S.execute_ conn (Query $ T.concat ["INSERT INTO ", versionTable pam, " VALUES (1)"]) + + upgrade 1 = do + S.execute_ conn (addColumnQ (colEmail pam)) + S.execute_ conn (addColumnQ (colResetToken pam)) + S.execute_ conn (addColumnQ (colResetRequestedAt pam)) + + upgrade _ = error "unknown version" + + addColumnQ (c,t) = + Query $ T.concat [ "ALTER TABLE ", tblName pam, " ADD COLUMN ", c, " ", t] + + ------------------------------------------------------------------------------ -- | Create the user table if it doesn't exist. createTableIfMissing :: SqliteAuthManager -> IO () createTableIfMissing SqliteAuthManager{..} = do withResource pamConnPool $ \conn -> do - res <- S.query conn - (Query "SELECT name FROM sqlite_master WHERE type='table' AND name=?") - (Only (tblName pamTable)) - when (null (res :: [Only T.Text])) $ - S.execute_ conn (Query q) >> return () - return () - where - q = T.concat - [ "CREATE TABLE " - , tblName pamTable - , " (" - , T.intercalate "," (map (fDesc . ($pamTable) . (fst)) colDef) - , ")" - ] + authTblExists <- tableExists conn $ tblName pamTable + unless authTblExists $ createInitialSchema conn pamTable + upgradeSchema conn pamTable 0 + upgradeSchema conn pamTable 1 + buildUid :: Int -> UserId buildUid = UserId . T.pack . show - instance FromField UserId where fromField f = buildUid <$> fromField f @@ -131,6 +183,7 @@ AuthUser <$> _userId <*> _userLogin + <*> _userEmail <*> _userPassword <*> _userActivatedAt <*> _userSuspendedAt @@ -144,11 +197,14 @@ <*> _userLastLoginIp <*> _userCreatedAt <*> _userUpdatedAt + <*> _userResetToken + <*> _userResetRequestedAt <*> _userRoles <*> _userMeta where !_userId = field !_userLogin = field + !_userEmail = field !_userPassword = field !_userActivatedAt = field !_userSuspendedAt = field @@ -162,6 +218,8 @@ !_userLastLoginIp = field !_userCreatedAt = field !_userUpdatedAt = field + !_userResetToken = field + !_userResetRequestedAt = field !_userRoles = pure [] !_userMeta = pure HM.empty @@ -188,6 +246,7 @@ { tblName :: Text , colId :: (Text, Text) , colLogin :: (Text, Text) + , colEmail :: (Text, Text) , colPassword :: (Text, Text) , colActivatedAt :: (Text, Text) , colSuspendedAt :: (Text, Text) @@ -201,9 +260,11 @@ , colLastLoginIp :: (Text, Text) , colCreatedAt :: (Text, Text) , colUpdatedAt :: (Text, Text) - , rolesTable :: Text + , colResetToken :: (Text, Text) + , colResetRequestedAt :: (Text, Text) } + -- | Default authentication table layout defAuthTable :: AuthTable defAuthTable @@ -211,6 +272,7 @@ { tblName = "snap_auth_user" , colId = ("uid", "INTEGER PRIMARY KEY") , colLogin = ("login", "text UNIQUE NOT NULL") + , colEmail = ("email", "text") , colPassword = ("password", "text") , colActivatedAt = ("activated_at", "timestamp") , colSuspendedAt = ("suspended_at", "timestamp") @@ -224,18 +286,17 @@ , colLastLoginIp = ("last_login_ip", "text") , colCreatedAt = ("created_at", "timestamp") , colUpdatedAt = ("updated_at", "timestamp") - , rolesTable = "user_roles" + , colResetToken = ("reset_token", "text") + , colResetRequestedAt = ("reset_requested_at", "timestamp") } -fDesc :: (Text, Text) -> Text -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 -> SQLData)] colDef = [ (colId , S.toField . fmap unUid . userId) , (colLogin , S.toField . userLogin) + , (colEmail , S.toField . userEmail) , (colPassword , S.toField . userPassword) , (colActivatedAt , S.toField . userActivatedAt) , (colSuspendedAt , S.toField . userSuspendedAt) @@ -249,8 +310,14 @@ , (colLastLoginIp , S.toField . userLastLoginIp) , (colCreatedAt , S.toField . userCreatedAt) , (colUpdatedAt , S.toField . userUpdatedAt) + , (colResetToken , S.toField . userResetToken) + , (colResetRequestedAt, S.toField . userResetRequestedAt) ] +colNames :: AuthTable -> T.Text +colNames pam = + T.intercalate "," . map (\(f,_) -> fst (f pam)) $ colDef + saveQuery :: AuthTable -> AuthUser -> (Text, [SQLData]) saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId where @@ -284,22 +351,26 @@ instance IAuthBackend SqliteAuthManager where save SqliteAuthManager{..} u@AuthUser{..} = do let (qstr, params) = saveQuery pamTable u - let q = Query qstr withResource pamConnPool $ \conn -> do - S.execute conn q params + -- Note that the user INSERT here expects that duplicate + -- login error checking has been done already at the level + -- that calls here. + S.execute conn (Query qstr) params let q2 = Query $ T.concat - [ "select * from " + [ "select ", colNames pamTable, " from " , tblName pamTable , " where " , fst (colLogin pamTable) , " = ?" ] res <- S.query conn q2 [userLogin] - return $ fromMaybe u $ listToMaybe res + case res of + [savedUser] -> return $ Right savedUser + _ -> return . Left $ AuthError "snaplet-sqlite-simple: Failed user save" lookupByUserId SqliteAuthManager{..} uid = do let q = Query $ T.concat - [ "select * from " + [ "select ", colNames pamTable, " from " , tblName pamTable , " where " , fst (colId pamTable) @@ -309,7 +380,7 @@ lookupByLogin SqliteAuthManager{..} login = do let q = Query $ T.concat - [ "select * from " + [ "select ", colNames pamTable, " from " , tblName pamTable , " where " , fst (colLogin pamTable) @@ -319,7 +390,7 @@ lookupByRememberToken SqliteAuthManager{..} token = do let q = Query $ T.concat - [ "select * from " + [ "select ", colNames pamTable, " from " , tblName pamTable , " where " , fst (colRememberToken pamTable) 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 @@ -134,7 +134,7 @@ -- > d <- nestSnaplet "db" db pgsInit -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d instance (MonadCatchIO m) => HasSqlite (ReaderT (Snaplet Sqlite) m) where - getSqliteState = asks (getL snapletValue) + getSqliteState = asks (\sqlsnaplet -> sqlsnaplet ^# snapletValue) ------------------------------------------------------------------------------