From 06df44eb87a2fb4e9a16d3aec5249fcacc2fd793 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sat, 28 Dec 2019 22:20:08 -0500 Subject: [PATCH] Split Foundation into 2 files Detailed reasoning in #197, and in the code comments of this PR Closes #197 --- src/Foundation.hs | 301 +----------------------------------- src/Foundation/Orphans.hs | 257 ++++++++++++++++++++++++++++++ src/Foundation/Primitive.hs | 71 +++++++++ src/Import.hs | 4 +- 4 files changed, 335 insertions(+), 298 deletions(-) create mode 100644 src/Foundation/Orphans.hs create mode 100644 src/Foundation/Primitive.hs diff --git a/src/Foundation.hs b/src/Foundation.hs index f4a7133..7ae5d1e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,297 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE InstanceSigs #-} +module Foundation + ( module X + ) where -module Foundation where - -import Import.NoFoundation -import Database.Persist.Sql (ConnectionPool, runSqlPool) -import Text.Hamlet (hamletFile) -import Text.Jasmine (minifym) -import Control.Monad.Logger (LogSource) - --- Used only when in "auth-dummy-login" setting is enabled. -import Yesod.Auth.Dummy - -import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed)) -import Yesod.Default.Util (addStaticContentExternal) -import Yesod.Core.Types (Logger) -import qualified Yesod.Core.Unsafe as Unsafe -import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as TE - --- | The foundation datatype for your application. This can be a good place to --- keep settings and values requiring initialization before your application --- starts running, such as database connections. Every handler will have --- access to the data present here. -data App = App - { appSettings :: AppSettings - , appStatic :: Static -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. - , appHttpManager :: Manager - , appLogger :: Logger - } - -data MenuItem = MenuItem - { menuItemLabel :: Text - , menuItemRoute :: Route App - , menuItemAccessCallback :: Bool - } - -data MenuTypes - = NavbarLeft MenuItem - | NavbarRight MenuItem - --- This is where we define all of the routes in our application. For a full --- explanation of the syntax, please see: --- http://www.yesodweb.com/book/routing-and-handlers --- --- Note that this is really half the story; in Application.hs, mkYesodDispatch --- generates the rest of the code. Please see the following documentation --- for an explanation for this split: --- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules --- --- This function also generates the following type synonyms: --- type Handler = HandlerT App IO --- type Widget = WidgetT App IO () -mkYesodData "App" $(parseRoutesFile "config/routes") - --- | A convenient synonym for creating forms. -type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) - --- | A convenient synonym for database access functions. -type DB a = forall (m :: * -> *). - (MonadUnliftIO m) => ReaderT SqlBackend m a - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod App where - -- Controls the base of generated URLs. For more information on modifying, - -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot - approot :: Approot App - approot = ApprootRequest $ \app req -> - case appRoot $ appSettings app of - Nothing -> getApprootText guessApproot app req - Just root -> root - - -- Store session data on the client in encrypted cookies, - -- default session idle timeout is 120 minutes - makeSessionBackend :: App -> IO (Maybe SessionBackend) - makeSessionBackend _ = Just <$> defaultClientSessionBackend - 120 -- timeout in minutes - "config/client_session_key.aes" - - -- Yesod Middleware allows you to run code before and after each handler function. - -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. - -- Some users may also want to add the defaultCsrfMiddleware, which: - -- a) Sets a cookie with a CSRF token in it. - -- b) Validates that incoming write requests include that token in either a header or POST parameter. - -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware - -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. - yesodMiddleware :: ToTypedContent res => Handler res -> Handler res - yesodMiddleware = defaultYesodMiddleware - - defaultLayout :: Widget -> Handler Html - defaultLayout widget = do - master <- getYesod - mmsg <- getMessage - - muser <- maybeAuthPair - mcurrentRoute <- getCurrentRoute - - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - (title, parents) <- breadcrumbs - - -- Define the menu items of the header. - let menuItems = - [ NavbarLeft $ MenuItem - { menuItemLabel = "Home" - , menuItemRoute = HomeR - , menuItemAccessCallback = True - } - , NavbarLeft $ MenuItem - { menuItemLabel = "Profile" - , menuItemRoute = ProfileR - , menuItemAccessCallback = isJust muser - } - , NavbarRight $ MenuItem - { menuItemLabel = "Login" - , menuItemRoute = AuthR LoginR - , menuItemAccessCallback = isNothing muser - } - , NavbarRight $ MenuItem - { menuItemLabel = "Logout" - , menuItemRoute = AuthR LogoutR - , menuItemAccessCallback = isJust muser - } - ] - - let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] - let navbarRightMenuItems = [x | NavbarRight x <- menuItems] - - let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] - let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] - - -- We break up the default layout into two components: - -- default-layout is the contents of the body tag, and - -- default-layout-wrapper is the entire page. Since the final - -- value passed to hamletToRepHtml cannot be a widget, this allows - -- you to use normal widget features in default-layout. - - pc <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_css - $(widgetFile "default-layout") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - - -- The page to be redirected to when authentication is required. - authRoute - :: App - -> Maybe (Route App) - authRoute _ = Just $ AuthR LoginR - - isAuthorized - :: Route App -- ^ The route the user is visiting. - -> Bool -- ^ Whether or not this is a "write" request. - -> Handler AuthResult - -- Routes not requiring authentication. - isAuthorized (AuthR _) _ = return Authorized - isAuthorized CommentR _ = return Authorized - isAuthorized HomeR _ = return Authorized - isAuthorized FaviconR _ = return Authorized - isAuthorized RobotsR _ = return Authorized - isAuthorized (StaticR _) _ = return Authorized - - -- the profile route requires that the user is authenticated, so we - -- delegate to that function - isAuthorized ProfileR _ = isAuthenticated - - -- This function creates static content files in the static folder - -- and names them based on a hash of their content. This allows - -- expiration dates to be set far in the future without worry of - -- users receiving stale content. - addStaticContent - :: Text -- ^ The file extension - -> Text -- ^ The MIME content type - -> LByteString -- ^ The contents of the file - -> Handler (Maybe (Either Text (Route App, [(Text, Text)]))) - addStaticContent ext mime content = do - master <- getYesod - let staticDir = appStaticDir $ appSettings master - addStaticContentExternal - minifym - genFileName - staticDir - (StaticR . flip StaticRoute []) - ext - mime - content - where - -- Generate a unique filename based on the content itself - genFileName lbs = "autogen-" ++ base64md5 lbs - - -- What messages should be logged. The following includes all messages when - -- in development, and warnings and errors in production. - shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool - shouldLogIO app _source level = - return $ - appShouldLogAll (appSettings app) - || level == LevelWarn - || level == LevelError - - makeLogger :: App -> IO Logger - makeLogger = return . appLogger - --- Define breadcrumbs. -instance YesodBreadcrumbs App where - -- Takes the route that the user is currently on, and returns a tuple - -- of the 'Text' that you want the label to display, and a previous - -- breadcrumb route. - breadcrumb - :: Route App -- ^ The route the user is visiting currently. - -> Handler (Text, Maybe (Route App)) - breadcrumb HomeR = return ("Home", Nothing) - breadcrumb (AuthR _) = return ("Login", Just HomeR) - breadcrumb ProfileR = return ("Profile", Just HomeR) - breadcrumb _ = return ("home", Nothing) - --- How to run database actions. -instance YesodPersist App where - type YesodPersistBackend App = SqlBackend - runDB :: SqlPersistT Handler a -> Handler a - runDB action = do - master <- getYesod - runSqlPool action $ appConnPool master - -instance YesodPersistRunner App where - getDBRunner :: Handler (DBRunner App, Handler ()) - getDBRunner = defaultGetDBRunner appConnPool - -instance YesodAuth App where - type AuthId App = UserId - - -- Where to send a user after successful login - loginDest :: App -> Route App - loginDest _ = HomeR - -- Where to send a user after logout - logoutDest :: App -> Route App - logoutDest _ = HomeR - -- Override the above two destinations when a Referer: header is present - redirectToReferer :: App -> Bool - redirectToReferer _ = True - - authenticate :: (MonadHandler m, HandlerSite m ~ App) - => Creds App -> m (AuthenticationResult App) - authenticate creds = liftHandler $ runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (Entity uid _) -> return $ Authenticated uid - Nothing -> Authenticated <$> insert User - { userIdent = credsIdent creds - , userPassword = Nothing - } - - -- You can add other plugins like Google Email, email or OAuth here - authPlugins :: App -> [AuthPlugin App] - authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins - -- Enable authDummy login if enabled. - where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] - --- | Access function to determine if a user is logged in. -isAuthenticated :: Handler AuthResult -isAuthenticated = do - muid <- maybeAuthId - return $ case muid of - Nothing -> Unauthorized "You must login to access this page" - Just _ -> Authorized - -instance YesodAuthPersist App - --- This instance is required to use forms. You can modify renderMessage to --- achieve customized and internationalized form validation messages. -instance RenderMessage App FormMessage where - renderMessage :: App -> [Lang] -> FormMessage -> Text - renderMessage _ _ = defaultFormMessage - --- Useful when writing code that is re-usable outside of the Handler context. --- An example is background jobs that send email. --- This can also be useful for writing code that works across multiple Yesod applications. -instance HasHttpManager App where - getHttpManager :: App -> Manager - getHttpManager = appHttpManager - -unsafeHandler :: App -> Handler a -> IO a -unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger - --- Note: Some functionality previously present in the scaffolding has been --- moved to documentation in the Wiki. Following are some hopefully helpful --- links: --- --- https://github.com/yesodweb/yesod/wiki/Sending-email --- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain --- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding +import Foundation.Primitive as X +import Foundation.Orphans as X diff --git a/src/Foundation/Orphans.hs b/src/Foundation/Orphans.hs new file mode 100644 index 0000000..6deac3a --- /dev/null +++ b/src/Foundation/Orphans.hs @@ -0,0 +1,257 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE InstanceSigs #-} +-- | This module defines orphan instances for 'App', building on the basic ones in 'Foundation.Primitive'. +-- +-- This separation is completely optional—if you wish to avoid orphan instances, +-- you can move the instances from this file into Primitive.hs. +-- +-- However, as your application grows, functions like 'defaultLayout', 'yesodMiddleware', and 'isAuthorized' +-- will grow. You may want to add additional modules that use 'App', 'Handler', 'DB', etc. and import them here. +-- Separating the definition of 'App' from its more complex typeclass instances, like 'Yesod', makes this possible. +module Foundation.Orphans where + +import Import.NoFoundation +import Foundation.Primitive +import Text.Hamlet (hamletFile) +import Text.Jasmine (minifym) +import Control.Monad.Logger (LogSource) + +-- Used only when in "auth-dummy-login" setting is enabled. +import Yesod.Auth.Dummy + +import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed)) +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Core.Types (Logger) +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Encoding as TE +import qualified Yesod.Core.Unsafe as Unsafe + +data MenuItem = MenuItem + { menuItemLabel :: Text + , menuItemRoute :: Route App + , menuItemAccessCallback :: Bool + } + +data MenuTypes + = NavbarLeft MenuItem + | NavbarRight MenuItem + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod App where + -- Controls the base of generated URLs. For more information on modifying, + -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot + approot :: Approot App + approot = ApprootRequest $ \app req -> + case appRoot $ appSettings app of + Nothing -> getApprootText guessApproot app req + Just root -> root + + -- Store session data on the client in encrypted cookies, + -- default session idle timeout is 120 minutes + makeSessionBackend :: App -> IO (Maybe SessionBackend) + makeSessionBackend _ = Just <$> defaultClientSessionBackend + 120 -- timeout in minutes + "config/client_session_key.aes" + + -- Yesod Middleware allows you to run code before and after each handler function. + -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. + -- Some users may also want to add the defaultCsrfMiddleware, which: + -- a) Sets a cookie with a CSRF token in it. + -- b) Validates that incoming write requests include that token in either a header or POST parameter. + -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. + yesodMiddleware :: ToTypedContent res => Handler res -> Handler res + yesodMiddleware = defaultYesodMiddleware + + defaultLayout :: Widget -> Handler Html + defaultLayout widget = do + master <- getYesod + mmsg <- getMessage + + muser <- maybeAuthPair + mcurrentRoute <- getCurrentRoute + + -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. + (title, parents) <- breadcrumbs + + -- Define the menu items of the header. + let menuItems = + [ NavbarLeft $ MenuItem + { menuItemLabel = "Home" + , menuItemRoute = HomeR + , menuItemAccessCallback = True + } + , NavbarLeft $ MenuItem + { menuItemLabel = "Profile" + , menuItemRoute = ProfileR + , menuItemAccessCallback = isJust muser + } + , NavbarRight $ MenuItem + { menuItemLabel = "Login" + , menuItemRoute = AuthR LoginR + , menuItemAccessCallback = isNothing muser + } + , NavbarRight $ MenuItem + { menuItemLabel = "Logout" + , menuItemRoute = AuthR LogoutR + , menuItemAccessCallback = isJust muser + } + ] + + let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] + let navbarRightMenuItems = [x | NavbarRight x <- menuItems] + + let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] + let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] + + -- We break up the default layout into two components: + -- default-layout is the contents of the body tag, and + -- default-layout-wrapper is the entire page. Since the final + -- value passed to hamletToRepHtml cannot be a widget, this allows + -- you to use normal widget features in default-layout. + + pc <- widgetToPageContent $ do + addStylesheet $ StaticR css_bootstrap_css + $(widgetFile "default-layout") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + -- The page to be redirected to when authentication is required. + authRoute + :: App + -> Maybe (Route App) + authRoute _ = Just $ AuthR LoginR + + isAuthorized + :: Route App -- ^ The route the user is visiting. + -> Bool -- ^ Whether or not this is a "write" request. + -> Handler AuthResult + -- Routes not requiring authentication. + isAuthorized (AuthR _) _ = return Authorized + isAuthorized CommentR _ = return Authorized + isAuthorized HomeR _ = return Authorized + isAuthorized FaviconR _ = return Authorized + isAuthorized RobotsR _ = return Authorized + isAuthorized (StaticR _) _ = return Authorized + + -- the profile route requires that the user is authenticated, so we + -- delegate to that function + isAuthorized ProfileR _ = isAuthenticated + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent + :: Text -- ^ The file extension + -> Text -- ^ The MIME content type + -> LByteString -- ^ The contents of the file + -> Handler (Maybe (Either Text (Route App, [(Text, Text)]))) + addStaticContent ext mime content = do + master <- getYesod + let staticDir = appStaticDir $ appSettings master + addStaticContentExternal + minifym + genFileName + staticDir + (StaticR . flip StaticRoute []) + ext + mime + content + where + -- Generate a unique filename based on the content itself + genFileName lbs = "autogen-" ++ base64md5 lbs + + -- What messages should be logged. The following includes all messages when + -- in development, and warnings and errors in production. + shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool + shouldLogIO app _source level = + return $ + appShouldLogAll (appSettings app) + || level == LevelWarn + || level == LevelError + + makeLogger :: App -> IO Logger + makeLogger = return . appLogger + +-- Define breadcrumbs. +instance YesodBreadcrumbs App where + -- Takes the route that the user is currently on, and returns a tuple + -- of the 'Text' that you want the label to display, and a previous + -- breadcrumb route. + breadcrumb + :: Route App -- ^ The route the user is visiting currently. + -> Handler (Text, Maybe (Route App)) + breadcrumb HomeR = return ("Home", Nothing) + breadcrumb (AuthR _) = return ("Login", Just HomeR) + breadcrumb ProfileR = return ("Profile", Just HomeR) + breadcrumb _ = return ("home", Nothing) + +instance YesodAuth App where + type AuthId App = UserId + + -- Where to send a user after successful login + loginDest :: App -> Route App + loginDest _ = HomeR + -- Where to send a user after logout + logoutDest :: App -> Route App + logoutDest _ = HomeR + -- Override the above two destinations when a Referer: header is present + redirectToReferer :: App -> Bool + redirectToReferer _ = True + + authenticate :: (MonadHandler m, HandlerSite m ~ App) + => Creds App -> m (AuthenticationResult App) + authenticate creds = liftHandler $ runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (Entity uid _) -> return $ Authenticated uid + Nothing -> Authenticated <$> insert User + { userIdent = credsIdent creds + , userPassword = Nothing + } + + -- You can add other plugins like Google Email, email or OAuth here + authPlugins :: App -> [AuthPlugin App] + authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins + -- Enable authDummy login if enabled. + where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] + +-- | Access function to determine if a user is logged in. +isAuthenticated :: Handler AuthResult +isAuthenticated = do + muid <- maybeAuthId + return $ case muid of + Nothing -> Unauthorized "You must login to access this page" + Just _ -> Authorized + +instance YesodAuthPersist App + +-- This instance is required to use forms. You can modify renderMessage to +-- achieve customized and internationalized form validation messages. +instance RenderMessage App FormMessage where + renderMessage :: App -> [Lang] -> FormMessage -> Text + renderMessage _ _ = defaultFormMessage + +--------------------------------------------- +-- Functions for use in development with GHCi +--------------------------------------------- + +unsafeHandler :: App -> Handler a -> IO a +unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger + +-- Note: Some functionality previously present in the scaffolding has been +-- moved to documentation in the Wiki. Following are some hopefully helpful +-- links: +-- +-- https://github.com/yesodweb/yesod/wiki/Sending-email +-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain +-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding diff --git a/src/Foundation/Primitive.hs b/src/Foundation/Primitive.hs new file mode 100644 index 0000000..58fef4f --- /dev/null +++ b/src/Foundation/Primitive.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE InstanceSigs #-} +-- | This module defines the core datatype 'App', as well as basic instances for it. +-- +-- The remaining instances are located in 'Foundation.Orphans'. +module Foundation.Primitive where + +import ClassyPrelude.Yesod +import Settings (AppSettings) +import Database.Persist.Sql (ConnectionPool, runSqlPool) +import Yesod.Core.Types (Logger) +import Yesod.Auth (Auth, getAuth) + +-- | The foundation datatype for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data App = App + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appHttpManager :: Manager + , appLogger :: Logger + } + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://www.yesodweb.com/book/routing-and-handlers +-- +-- Note that this is really half the story; in Application.hs, mkYesodDispatch +-- generates the rest of the code. Please see the following documentation +-- for an explanation for this split: +-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules +-- +-- This function also generates the following type synonyms: +-- type Handler = HandlerT App IO +-- type Widget = WidgetT App IO () +mkYesodData "App" $(parseRoutesFile "config/routes") + +-- | A convenient synonym for creating forms. +type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) + +-- | A convenient synonym for database access functions. +type DB a = forall (m :: * -> *). + (MonadUnliftIO m) => ReaderT SqlBackend m a + +-- Useful when writing code that is re-usable outside of the Handler context. +-- An example is background jobs that send email. +-- This can also be useful for writing code that works across multiple Yesod applications. +instance HasHttpManager App where + getHttpManager :: App -> Manager + getHttpManager = appHttpManager + +-- How to run database actions. +instance YesodPersist App where + type YesodPersistBackend App = SqlBackend + runDB :: SqlPersistT Handler a -> Handler a + runDB action = do + master <- getYesod + runSqlPool action $ appConnPool master + +instance YesodPersistRunner App where + getDBRunner :: Handler (DBRunner App, Handler ()) + getDBRunner = defaultGetDBRunner appConnPool diff --git a/src/Import.hs b/src/Import.hs index a102001..22bb058 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -2,5 +2,5 @@ module Import ( module Import ) where -import Foundation as Import -import Import.NoFoundation as Import +import Foundation as Import +import Import.NoFoundation as Import