diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/resources/auth/devel.cfg b/resources/auth/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/auth/devel.cfg @@ -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" diff --git a/resources/db/devel.cfg b/resources/db/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/db/devel.cfg @@ -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 diff --git a/snaplet-mysql-simple.cabal b/snaplet-mysql-simple.cabal new file mode 100644 --- /dev/null +++ b/snaplet-mysql-simple.cabal @@ -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 diff --git a/src/Snap/Snaplet/Auth/Backends/MysqlSimple.hs b/src/Snap/Snaplet/Auth/Backends/MysqlSimple.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/MysqlSimple.hs @@ -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] + diff --git a/src/Snap/Snaplet/MysqlSimple.hs b/src/Snap/Snaplet/MysqlSimple.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MysqlSimple.hs @@ -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 (). +It uses the excellent mysql-simple library +() 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)