snaplet-mysql-simple (empty) → 0.1.0
raw patch · 7 files changed
+887/−0 lines, 7 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed
Dependencies added: MonadCatchIO-transformers, base, bytestring, clientsession, configurator, containers, errors, lens, mtl, mysql, mysql-simple, resource-pool-catchio, snap, text, transformers, unordered-containers
Files
- LICENSE +27/−0
- Setup.hs +3/−0
- resources/auth/devel.cfg +21/−0
- resources/db/devel.cfg +17/−0
- snaplet-mysql-simple.cabal +57/−0
- src/Snap/Snaplet/Auth/Backends/MysqlSimple.hs +361/−0
- src/Snap/Snaplet/MysqlSimple.hs +401/−0
+ LICENSE view
@@ -0,0 +1,27 @@+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.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ resources/auth/devel.cfg view
@@ -0,0 +1,21 @@+# Currently this option is not enforced. See current auth documentation for+# more information.+minPasswordLen = 8++# Name of the cookie to use for remembering the logged in user.+rememberCookie = "_remember"++# Number of seconds of inactivity before the user is logged out. If ommitted,+# the user will remain logged in until the end of the session.+rememberPeriod = 1209600 # 2 weeks++# Lockout strategy. The first value is the max number of invalid login+# attempts before lockout. The second value is how long the locked lasts. If+# ommitted, then incorrect passwords will never result in lockout.+# lockout = [5, 86400]++# File where the auth encryption key is stored.+siteKey = "site_key.txt"++# Name of the table where the user data is stored.+authTable = "snap_auth_user"
+ resources/db/devel.cfg view
@@ -0,0 +1,17 @@+host = "localhost"+port = 3306+user = "mysql"+pass = ""+db = "testdb"++# Nmuber of distinct connection pools to maintain. The smallest acceptable+# value is 1.+numStripes = 1++# Number of seconds an unused resource is kept open. The smallest acceptable+# value is 0.5 seconds.+idleTime = 5++# Maximum number of resources to keep open per stripe. The smallest+# acceptable value is 1.+maxResourcesPerStripe = 20
+ snaplet-mysql-simple.cabal view
@@ -0,0 +1,57 @@+name: snaplet-mysql-simple+version: 0.1.0+synopsis: mysql-simple snaplet for the Snap Framework+description: This snaplet contains support for using the MariaDB and MySQL+ database with a Snap Framework application via the mysql-simple+ package. It also includes an untested authentication backend.+ Heavily based on snaplet-postgresql-simple by Doug Beardsley.+license: BSD3+license-file: LICENSE+author: Tobias Florek+maintainer: me@ibotty.net+build-type: Simple+cabal-version: >= 1.6+homepage: https://github.com/ibotty/snaplet-mysql-simple+category: Web, Snap++extra-source-files: LICENSE++data-files:+ resources/db/devel.cfg+ resources/auth/devel.cfg++source-repository head+ type: git+ location: https://github.com/ibotty/snaplet-mysql-simple.git++Library+ hs-source-dirs: src++ exposed-modules:+ Snap.Snaplet.MysqlSimple+ Snap.Snaplet.Auth.Backends.MysqlSimple++ other-modules:+ Paths_snaplet_mysql_simple++ build-depends:+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.11,+ clientsession >= 0.7.2 && < 0.10,+ containers >= 0.4 && < 0.5,+ configurator >= 0.2 && < 0.3,+ errors >= 1.4 && < 1.5,+ lens >= 3.0 && < 4.0,+ MonadCatchIO-transformers >= 0.3 && < 0.4,+ mtl >= 2 && < 3,+ mysql-simple >= 0.2 && < 0.3,+ mysql >= 0.1 && < 0.2,+ resource-pool-catchio >= 0.2 && < 0.3,+ snap >= 0.10 && < 0.14,+ text >= 0.11.2 && < 0.12,+ transformers >= 0.2 && < 0.4,+ unordered-containers >= 0.2 && < 0.3+++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-orphans -fno-warn-unused-do-bind
+ src/Snap/Snaplet/Auth/Backends/MysqlSimple.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-|++This module allows you to use the auth snaplet with your user database stored+in a MySQL database. When you run your application with this snaplet, a+config file will be copied into the the @snaplets/mysql-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, mysql, and auth+snaplets as follows:++> data App = App+> { ... -- your own application state here+> , _sess :: Snaplet SessionManager+> , _db :: Snaplet Mysql+> , _auth :: Snaplet (AuthManager App)+> }++Then in your initializer you'll have something like this:++> d <- nestSnaplet "db" db mysqlInit+> a <- nestSnaplet "auth" auth $ initMysqlAuth 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.++-}++module Snap.Snaplet.Auth.Backends.MysqlSimple+ ( initMysqlAuth+ ) where++------------------------------------------------------------------------------+import Prelude+import Control.Error+import qualified Control.Exception as E+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.Pool+import qualified Database.MySQL.Simple as M+import Database.MySQL.Simple.Param+import Database.MySQL.Simple.Result+import Database.MySQL.Simple.Types+import Database.MySQL.Simple.QueryResults+import Snap+import Snap.Snaplet.Auth+import Snap.Snaplet.MysqlSimple+import Snap.Snaplet.Session+import Web.ClientSession+import Paths_snaplet_mysql_simple+++data MysqlAuthManager = MysqlAuthManager+ { pamTable :: AuthTable+ , pamConnPool :: Pool M.Connection+ }+++------------------------------------------------------------------------------+-- | Initializer for the mysql backend to the auth snaplet.+--+initMysqlAuth+ :: SnapletLens b SessionManager -- ^ Lens to the session snaplet+ -> Snaplet Mysql -- ^ The mysql snaplet+ -> SnapletInit b (AuthManager b)+initMysqlAuth sess db = makeSnaplet "mysql-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 = MysqlAuthManager tableDesc $+ pgPool $ db ^# snapletValue+ -- ^ XXX+ liftIO $ createTableIfMissing manager+ rng <- liftIO mkRNG+ return $ AuthManager+ { backend = manager+ , session = sess+ , activeUser = Nothing+ , minPasswdLen = asMinPasswdLen authSettings+ , rememberCookieName = asRememberCookieName authSettings+ , rememberPeriod = asRememberPeriod authSettings+ , siteKey = key+ , lockout = asLockout authSettings+ , randomNumberGenerator = rng+ }+ where+ desc = "A MySQL backend for user authentication"+ datadir = Just $ liftM (++"/resources/auth") getDataDir+++------------------------------------------------------------------------------+-- | Create the user table if it doesn't exist.+-- XXX: Check sql+createTableIfMissing :: MysqlAuthManager -> IO ()+createTableIfMissing MysqlAuthManager{..} = do+ withResource pamConnPool $ \conn -> do+ res <- M.query_ conn $ Query $ T.encodeUtf8 $+ "select relname from pg_class where relname='"+ `T.append` schemaless (tblName pamTable) `T.append` "'"+ when (null (res :: [Only T.Text])) $+ M.execute_ conn (Query $ T.encodeUtf8 q) >> return ()+ return ()+ where+ schemaless = T.reverse . T.takeWhile (/='.') . T.reverse+ q = T.concat+ [ "CREATE TABLE \""+ , tblName pamTable+ , "\" ("+ , T.intercalate "," (map (fDesc . ($pamTable) . (fst)) colDef)+ , ")"+ ]++buildUid :: Int -> UserId+buildUid = UserId . T.pack . show+++instance Result UserId where+ convert f v = buildUid $ convert f v++instance Result Password where+ convert f v = Encrypted $ convert f v++instance QueryResults AuthUser where+ convertResults [f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12,f13,f14,f15,f16,f17,f18]+ [b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,b16,b17,b18] =+ AuthUser+ _userId+ _userLogin+ _userEmail+ _userPassword+ _userActivatedAt+ _userSuspendedAt+ _userRememberToken+ _userLoginCount+ _userFailedLoginCount+ _userLockedOutUntil+ _userCurrentLoginAt+ _userLastLoginAt+ _userCurrentLoginIp+ _userLastLoginIp+ _userCreatedAt+ _userUpdatedAt+ _userResetToken+ _userResetRequestedAt+ _userRoles+ _userMeta+ where+ !_userId = convert f1 b1+ !_userLogin = convert f2 b2+ !_userEmail = convert f3 b3+ !_userPassword = convert f4 b4+ !_userActivatedAt = convert f5 b5+ !_userSuspendedAt = convert f6 b6+ !_userRememberToken = convert f7 b7+ !_userLoginCount = convert f8 b8+ !_userFailedLoginCount = convert f9 b9+ !_userLockedOutUntil = convert f10 b10+ !_userCurrentLoginAt = convert f11 b11+ !_userLastLoginAt = convert f12 b12+ !_userCurrentLoginIp = convert f13 b13+ !_userLastLoginIp = convert f14 b14+ !_userCreatedAt = convert f15 b15+ !_userUpdatedAt = convert f16 b16+ !_userResetToken = convert f17 b17+ !_userResetRequestedAt = convert f18 b18+ !_userRoles = []+ !_userMeta = HM.empty+ convertResults fs vs = convertError fs vs 18+++querySingle :: (QueryParams q, QueryResults a)+ => Pool M.Connection -> Query -> q -> IO (Maybe a)+querySingle pool q ps = withResource pool $ \conn -> return . listToMaybe =<<+ M.query conn q ps++authExecute :: QueryParams q+ => Pool M.Connection -> Query -> q -> IO ()+authExecute pool q ps = do+ _ <- withResource pool $ \conn -> M.execute conn q ps+ return ()++instance Param Password where+ render (ClearText bs) = render bs+ render (Encrypted bs) = render bs+++-- | Datatype containing the names of the columns for the authentication table.+data AuthTable+ = AuthTable+ { tblName :: Text+ , colId :: (Text, Text)+ , colLogin :: (Text, Text)+ , colEmail :: (Text, Text)+ , colPassword :: (Text, Text)+ , colActivatedAt :: (Text, Text)+ , colSuspendedAt :: (Text, Text)+ , colRememberToken :: (Text, Text)+ , colLoginCount :: (Text, Text)+ , colFailedLoginCount :: (Text, Text)+ , colLockedOutUntil :: (Text, Text)+ , colCurrentLoginAt :: (Text, Text)+ , colLastLoginAt :: (Text, Text)+ , colCurrentLoginIp :: (Text, Text)+ , colLastLoginIp :: (Text, Text)+ , colCreatedAt :: (Text, Text)+ , colUpdatedAt :: (Text, Text)+ , colResetToken :: (Text, Text)+ , colResetRequestedAt :: (Text, Text)+ , rolesTable :: Text+ }++-- | Default authentication table layout+defAuthTable :: AuthTable+defAuthTable+ = AuthTable+ { tblName = "snap_auth_user"+ , colId = ("uid", "SERIAL PRIMARY KEY")+ , colLogin = ("login", "VARCHAR UNIQUE NOT NULL")+ , colEmail = ("email", "VARCHAR")+ , colPassword = ("password", "VARCHAR")+ , colActivatedAt = ("activated_at", "TIMESTAMP")+ , colSuspendedAt = ("suspended_at", "TIMESTAMP")+ , colRememberToken = ("remember_token", "VARCHAR")+ , colLoginCount = ("login_count", "INTEGER NOT NULL")+ , colFailedLoginCount = ("failed_login_count", "INTEGER NOT NULL")+ , colLockedOutUntil = ("locked_out_until", "TIMESTAMP")+ , colCurrentLoginAt = ("current_login_at", "TIMESTAMP")+ , colLastLoginAt = ("last_login_at", "TIMESTAMP")+ , colCurrentLoginIp = ("current_login_ip", "VARCHAR")+ , colLastLoginIp = ("last_login_ip", "VARCHAR")+ , colCreatedAt = ("created_at", "TIMESTAMP")+ , colUpdatedAt = ("updated_at", "TIMESTAMP")+ , colResetToken = ("reset_token", "VARCHAR")+ , colResetRequestedAt = ("reset_requested_at", "TIMESTAMP")+ , rolesTable = "user_roles"+ }++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 -> Action)]+colDef =+ [ (colId , render . fmap unUid . userId)+ , (colLogin , render . userLogin)+ , (colEmail , render . userEmail)+ , (colPassword , render . userPassword)+ , (colActivatedAt , render . userActivatedAt)+ , (colSuspendedAt , render . userSuspendedAt)+ , (colRememberToken , render . userRememberToken)+ , (colLoginCount , render . userLoginCount)+ , (colFailedLoginCount, render . userFailedLoginCount)+ , (colLockedOutUntil , render . userLockedOutUntil)+ , (colCurrentLoginAt , render . userCurrentLoginAt)+ , (colLastLoginAt , render . userLastLoginAt)+ , (colCurrentLoginIp , render . userCurrentLoginIp)+ , (colLastLoginIp , render . userLastLoginIp)+ , (colCreatedAt , render . userCreatedAt)+ , (colUpdatedAt , render . userUpdatedAt)+ , (colResetToken , render . userResetToken)+ , (colResetRequestedAt, render . userResetRequestedAt)+ ]++saveQuery :: AuthTable -> AuthUser -> (Text, [Action])+saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId+ where+ insertQuery = (T.concat [ "INSERT INTO "+ , tblName at+ , " ("+ , T.intercalate "," cols+ , ") VALUES ("+ , T.intercalate "," vals+ , ");"+ ]+ , params)+ qval f = fst (f at) `T.append` " = ?"+ updateQuery uid =+ (T.concat [ "UPDATE "+ , tblName at+ , " SET "+ , T.intercalate "," (map (qval . fst) $ tail colDef)+ , " WHERE "+ , fst (colId at)+ , " = ? ;"+ ]+ , params ++ [render $ unUid uid])+ cols = map (fst . ($at) . fst) $ tail colDef+ vals = map (const "?") cols+ params = map (($u) . snd) $ tail colDef+++onFailure :: Monad m => E.SomeException -> m (Either AuthFailure a)+onFailure e = return $ Left $ AuthError $ show e++------------------------------------------------------------------------------+-- |+instance IAuthBackend MysqlAuthManager where+ save MysqlAuthManager{..} u@AuthUser{..} = do+ let (qstr, params) = saveQuery pamTable u+ let q = Query $ T.encodeUtf8 qstr+ let action = withResource pamConnPool $ \conn -> do+ _ <- M.execute conn q params+ newUid <- M.insertID conn+ return . Right $+ u{ userId = Just $ buildUid $ fromIntegral newUid}+ E.catch action onFailure+++ lookupByUserId MysqlAuthManager{..} uid = do+ let q = Query $ T.encodeUtf8 $ T.concat+ [ "select ", T.intercalate "," cols, " from "+ , tblName pamTable+ , " where "+ , fst (colId pamTable)+ , " = ?"+ ]+ querySingle pamConnPool q [unUid uid]+ where cols = map (fst . ($pamTable) . fst) colDef++ lookupByLogin MysqlAuthManager{..} login = do+ let q = Query $ T.encodeUtf8 $ T.concat+ [ "select ", T.intercalate "," cols, " from "+ , tblName pamTable+ , " where "+ , fst (colLogin pamTable)+ , " = ?"+ ]+ querySingle pamConnPool q [login]+ where cols = map (fst . ($pamTable) . fst) colDef++ lookupByRememberToken MysqlAuthManager{..} token = do+ let q = Query $ T.encodeUtf8 $ T.concat+ [ "select ", T.intercalate "," cols, " from "+ , tblName pamTable+ , " where "+ , fst (colRememberToken pamTable)+ , " = ?"+ ]+ querySingle pamConnPool q [token]+ where cols = map (fst . ($pamTable) . fst) colDef++ destroy MysqlAuthManager{..} AuthUser{..} = do+ let q = Query $ T.encodeUtf8 $ T.concat+ [ "delete from "+ , tblName pamTable+ , " where "+ , fst (colLogin pamTable)+ , " = ?"+ ]+ authExecute pamConnPool q [userLogin]+
+ src/Snap/Snaplet/MysqlSimple.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++{-|++This snaplet makes it simple to use a MariaDB or MySQL database from your Snap+application and is a literal translation of snaplet-postgresql-simple by+Doug Beardsley (<https://github.com/mightybyte/snaplet-postgresql-simple>).+It uses the excellent mysql-simple library+(<http://hackage.haskell.org/package/mysql-simple>) by Bryan O\'Sullivan.+Now, adding a database to your web app takes just two simple steps.++First, include this snaplet in your application's state.++> data App = App+> { ... -- Other state needed in your app+> , _db :: Snaplet Mysql+> }++Next, call the mysqlInit from your application's initializer.++> appInit = makeSnaplet ... $ do+> ...+> d <- nestSnaplet "db" db mysqlInit+> return $ App ... d++Now you can use any of the postgresql-simple wrapper functions defined in this+module anywhere in your application handlers. For instance:++> postHandler :: Handler App App ()+> postHandler = do+> posts <- with db $ query_ "select * from blog_post"+> ...++Optionally, if you find yourself doing many database queries, you can eliminate some of the boilerplate by defining a HasMysql instance for your application.++> instance HasMysql (Handler b App) where+> getMysqlState = with db get++With this code, our postHandler example no longer requires the 'with' function:++> postHandler :: Handler App App ()+> postHandler = do+> posts <- query_ "select * from blog_post"+> ...++The first time you run an application with the postgresql-simple snaplet,+a configuration file @devel.cfg@ is created in the+@snaplets/postgresql-simple@ directory underneath your project root. It+specifies how to connect to your MySQL or MariaDB server and what user,+password, and database to use. Edit this file and modify the values+appropriately and you'll be off and running.++If you want to have out-of-the-box authentication, look at the documentation+for the "Snap.Snaplet.Auth.Backends.MysqlSimple" module.++-}++module Snap.Snaplet.MysqlSimple (+ -- * The Snaplet+ Mysql(..)+ , HasMysql(..)+ , mysqlInit+ , mysqlInit'+ , getConnectionInfo++ -- * Wrappers and re-exports+ , query+ , query_+ , fold+ , fold_+ , forEach+ , forEach_+ , execute+ , execute_+ , executeMany+ , rollback+ , commit+ , withTransaction+ , formatMany+ , formatQuery++ -- Re-exported from postgresql-simple+ , M.Query+ , M.In(..)+ , M.Binary(..)+ , M.Only(..)+ , M.FormatError(..)+ , M.QueryError(..)+ , M.ResultError(..)+ , QueryResults(..)+ , QueryParams(..)++ , M.defaultConnectInfo+ ) where++import Prelude hiding ((++))+import Control.Lens -- (ASetter(), camelCaseFields, makeLensesWith, set)+import Control.Monad.CatchIO (MonadCatchIO)+import qualified Control.Monad.CatchIO as CIO+import Control.Monad.IO.Class+import Control.Monad.State+import Control.Monad.Trans.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import Data.Char+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C+import Data.Int+import Data.Maybe+import Data.Monoid(Monoid(..))+import Data.Pool+import qualified Data.Set as S+import Data.Text (Text)+import qualified Database.MySQL.Simple as M+import qualified Database.MySQL.Base as MB+import Database.MySQL.Simple.QueryParams+import Database.MySQL.Simple.QueryResults+import Snap+import Paths_snaplet_mysql_simple+++-- This is actually more portable than using <>+(++) :: Monoid a => a -> a -> a+(++) = mappend+infixr 5 ++++------------------------------------------------------------------------------+-- | The state for the postgresql-simple snaplet. To use it in your app+-- include this in your application state and use pgsInit to initialize it.+data Mysql = Mysql+ { pgPool :: Pool M.Connection+ -- ^ Function for retrieving the connection pool+ }+++------------------------------------------------------------------------------+-- | Instantiate this typeclass on 'Handler b YourAppState' so this snaplet+-- can find the connection source. If you need to have multiple instances of+-- the postgres snaplet in your application, then don't provide this instance+-- and leverage the default instance by using \"@with dbLens@\" in front of calls+-- to snaplet-postgresql-simple functions.+class (MonadCatchIO m) => HasMysql m where+ getMysqlState :: m Mysql+++------------------------------------------------------------------------------+-- | Default instance+instance HasMysql (Handler b Mysql) where+ getMysqlState = get+++------------------------------------------------------------------------------+-- | A convenience instance to make it easier to use this snaplet in the+-- Initializer monad like this:+--+-- > d <- nestSnaplet "db" db pgsInit+-- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d+instance (MonadCatchIO m) => HasMysql (ReaderT (Snaplet Mysql) m) where+ getMysqlState = asks (^# snapletValue)+++------------------------------------------------------------------------------+-- | A convenience instance to make it easier to use functions written for+-- this snaplet in non-snaplet contexts.+instance (MonadCatchIO m) => HasMysql (ReaderT Mysql m) where+ getMysqlState = ask+++------------------------------------------------------------------------------+-- | Orphan Lenses for ConnectInfo+-- Not exported, only used for 'getConnectionInfo'.+$(makeLensesWith (LensRules Just Just (const Nothing)+ (S.fromList [SimpleLenses, GenerateSignatures]))+ ''M.ConnectInfo)+$(makeLensesWith (LensRules Just Just (const Nothing)+ (S.fromList [SimpleLenses, GenerateSignatures]))+ ''MB.SSLInfo)++------------------------------------------------------------------------------+-- | Produce a connection info from a config+getConnectionInfo :: MonadIO m => C.Config -> m M.ConnectInfo+getConnectionInfo config = do+ sslOpts <- foldl modRecord (return MB.defaultSSLInfo) sslParams+ connOpts <- liftM catMaybes $ mapM handleOpts optParams++ connInfo <- foldl modRecord (return M.defaultConnectInfo) params++ return $ set connectSSL (Just sslOpts) $ set connectOptions connOpts connInfo+ where params =+ [ ("host", set connectHost)+ , ("port", set connectPort . read)+ , ("dbname", set connectDatabase)+ , ("user", set connectUser)+ , ("password", set connectPassword)+ , ("path", set connectPath)+ ]+ optParams =+ [ ("connection_timeout", MB.ConnectTimeout . read)+ , ("compress", const MB.Compress)+ , ("named_pipe", const MB.NamedPipe)+ , ("init_commmand", MB.InitCommand . B8.pack)+ , ("read_default_file", MB.ReadDefaultFile)+ , ("read_default_group", MB.ReadDefaultGroup . B8.pack)+ , ("charset_dir", MB.CharsetDir)+ , ("charset_name", MB.CharsetName)+ , ("local_in_file", MB.LocalInFile . readBool)+ , ("protocol", \s -> MB.Protocol $ case map toLower s of+ "tcp" -> MB.TCP+ "socket" -> MB.Socket+ "pipe" -> MB.Pipe+ "memory" -> MB.Memory+ _ -> error "no valid protocol.")+ , ("shared_memory_base_name", MB.SharedMemoryBaseName . B8.pack)+ , ("read_timeout", MB.ReadTimeout . read)+ , ("write_timeout", MB.WriteTimeout . read)+ , ("use_remote_connection", const MB.UseRemoteConnection)+ , ("use_embedded_connection", const MB.UseEmbeddedConnection)+ , ("guess_connection", const MB.GuessConnection)+ , ("client_ip", MB.ClientIP . B8.pack)+ , ("secure_auth", MB.SecureAuth . readBool)+ , ("report_data_truncation", MB.ReportDataTruncation . readBool)+ , ("reconnect", MB.Reconnect . readBool)+ , ("ssl_verify_server_cert", MB.SSLVerifyServerCert . readBool)+ , ("found_rows", const MB.FoundRows)+ , ("ignore_sigpipe", const MB.IgnoreSIGPIPE)+ , ("ignore_space", const MB.IgnoreSpace)+ , ("interactive", const MB.Interactive)+ , ("local_files", const MB.LocalFiles)+ , ("multi_results", const MB.MultiResults)+ , ("multi_statements", const MB.MultiStatements)+ , ("no_schema", const MB.NoSchema)+ ]+ sslParams =+ [ ("ssl_key", set sslKey)+ , ("ssl_cert", set sslCert)+ , ("ssl_ca", set sslCA)+ , ("ssl_ca_path", set sslCAPath)+ , ("ssl_ciphers", set sslCiphers)+ ]+ modRecord :: MonadIO m => m a -> (C.Name, String -> a -> a) -> m a+ modRecord conf (name, setter) = do+ x <- liftIO $ C.lookup config name+ case x of+ Just val -> liftM (setter val) conf+ Nothing -> conf+ handleOpts :: MonadIO m => (C.Name, String -> a) -> m (Maybe a)+ handleOpts (name, f) = liftIO $ liftM (fmap f) $ C.lookup config name++ readBool :: String -> Bool+ readBool s = case map toLower s of+ "yes" -> True+ "y" -> True+ "true" -> True+ "no" -> False+ "n" -> False+ "false" -> False+ _ -> error "expected 'yes' or 'no'."++description :: Text+description = "MySQL abstraction"++datadir :: Maybe (IO FilePath)+datadir = Just $ liftM (++"/resources/db") getDataDir+++------------------------------------------------------------------------------+-- | Initialize the snaplet+mysqlInit :: SnapletInit b Mysql+mysqlInit = makeSnaplet "mysql-simple" description datadir $ do+ config <- getSnapletUserConfig+ initHelper config+++------------------------------------------------------------------------------+-- | Initialize the snaplet+mysqlInit' :: C.Config -> SnapletInit b Mysql+mysqlInit' config = makeSnaplet "mysql-simple" description datadir $+ initHelper config+++initHelper :: MonadIO m => C.Config -> m Mysql+initHelper config = do+ conninfo <- liftIO $ getConnectionInfo config+ stripes <- liftIO $ C.lookupDefault 1 config "numStripes"+ idle <- liftIO $ C.lookupDefault 5 config "idleTime"+ resources <- liftIO $ C.lookupDefault 20 config "maxResourcesPerStripe"+ pool <- liftIO $ createPool (M.connect conninfo) M.close stripes+ (realToFrac (idle :: Double)) resources+ return $ Mysql pool+++------------------------------------------------------------------------------+-- | Convenience function for executing a function that needs a database+-- connection.+withMysql :: (HasMysql m)+ => (M.Connection -> IO b) -> m b+withMysql f = do+ s <- getMysqlState+ let pool = pgPool s+ liftIO $ withResource pool f+++------------------------------------------------------------------------------+-- | See 'M.query'+query :: (HasMysql m, QueryParams q, QueryResults r)+ => M.Query -> q -> m [r]+query q params = withMysql (\c -> M.query c q params)+++------------------------------------------------------------------------------+-- | See 'M.query_'+query_ :: (HasMysql m, QueryResults r) => M.Query -> m [r]+query_ q = withMysql (\c -> M.query_ c q)++------------------------------------------------------------------------------+-- |+fold :: (HasMysql m,+ QueryResults row,+ QueryParams params,+ MonadCatchIO m)+ => M.Query -> params -> b -> (b -> row -> IO b) -> m b+fold template qs a f = withMysql (\c -> M.fold c template qs a f)+++------------------------------------------------------------------------------+-- |+fold_ :: (HasMysql m,+ QueryResults row,+ MonadCatchIO m)+ => M.Query -> b -> (b -> row -> IO b) -> m b+fold_ template a f = withMysql (\c -> M.fold_ c template a f)+++------------------------------------------------------------------------------+-- |+forEach :: (HasMysql m,+ QueryResults r,+ QueryParams q,+ MonadCatchIO m)+ => M.Query -> q -> (r -> IO ()) -> m ()+forEach template qs f = withMysql (\c -> M.forEach c template qs f)+++------------------------------------------------------------------------------+-- |+forEach_ :: (HasMysql m,+ QueryResults r,+ MonadCatchIO m)+ => M.Query -> (r -> IO ()) -> m ()+forEach_ template f = withMysql (\c -> M.forEach_ c template f)+++------------------------------------------------------------------------------+-- |+execute :: (HasMysql m, QueryParams q, MonadCatchIO m)+ => M.Query -> q -> m Int64+execute template qs = withMysql (\c -> M.execute c template qs)+++------------------------------------------------------------------------------+-- |+execute_ :: (HasMysql m, MonadCatchIO m)+ => M.Query -> m Int64+execute_ template = withMysql (\c -> M.execute_ c template)+++------------------------------------------------------------------------------+-- |+executeMany :: (HasMysql m, QueryParams q, MonadCatchIO m)+ => M.Query -> [q] -> m Int64+executeMany template qs = withMysql (\c -> M.executeMany c template qs)+++rollback :: (HasMysql m, MonadCatchIO m) => m ()+rollback = withMysql M.rollback+++commit :: (HasMysql m, MonadCatchIO m) => m ()+commit = withMysql M.commit+++withTransaction :: (HasMysql m, MonadCatchIO m) => m a -> m a+withTransaction action = do+ r <- action `CIO.onException` rollback+ commit+ return r+++formatMany :: (QueryParams q, HasMysql m, MonadCatchIO m)+ => M.Query -> [q] -> m ByteString+formatMany q qs = withMysql (\c -> M.formatMany c q qs)+++formatQuery :: (QueryParams q, HasMysql m, MonadCatchIO m)+ => M.Query -> q -> m ByteString+formatQuery q qs = withMysql (\c -> M.formatQuery c q qs)