snaplet-sqlite-simple 0.2.0 → 0.3.0

raw patch · 3 files changed

+116/−34 lines, 3 filesdep ~clientsessiondep ~snapPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: clientsession, snap

API changes (from Hackage documentation)

Files

• snaplet-sqlite-simple.cabal +15/−4
• src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs +100/−29
• src/Snap/Snaplet/SqliteSimple.hs +1/−1

@@ -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+                <https://github.com/nurpax/snaplet-sqlite-simple/tree/master/example>+                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

@@ -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)

@@ -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)   ------------------------------------------------------------------------------