diff options
Diffstat (limited to 'Foundation.hs')
| -rw-r--r-- | Foundation.hs | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/Foundation.hs b/Foundation.hs new file mode 100644 index 0000000..194fe14 --- /dev/null +++ b/Foundation.hs @@ -0,0 +1,181 @@ +module Foundation + ( App (..) + , Route (..) + , AppMessage (..) + , resourcesApp + , Handler + , Widget + , Form + , maybeAuth + , requireAuth + , module Settings + , module Model + ) where + +import Prelude +import Yesod +import Yesod.Static +import Yesod.Auth +import Auth.Proxied (authProxied) +import Yesod.Default.Config +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Form.Jquery (YesodJquery) +import Yesod.Logger (Logger, logMsg, formatLogText) +import Network.HTTP.Conduit (Manager) +import qualified Settings +import qualified Database.Persist.Store +import Settings.StaticFiles +import Database.Persist.GenericSql +import Settings (widgetFile, Extra (..)) +import Model +import Text.Jasmine (minifym) +import Web.ClientSession (getKey) +import Text.Hamlet (hamletFile) + +-- | The site argument 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 + { settings :: AppConfig DefaultEnv Extra + , getLogger :: Logger + , getStatic :: Static -- ^ Settings for static file serving. + , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool. + , httpManager :: Manager + , persistConfig :: Settings.PersistConfig + } + +-- Set up i18n messages. See the message folder. +mkMessage "App" "messages" "en" + +-- 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/handler +-- +-- This function does three things: +-- +-- * Creates the route datatype AppRoute. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route App = AppRoute +-- * Creates the value resourcesApp which contains information on the +-- resources declared below. This is used in Handler.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- App. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the AppRoute datatype. Therefore, we +-- split these actions into two functions and place them in separate files. +mkYesodData "App" $(parseRoutesFile "config/routes") + +type Form x = Html -> MForm App App (FormResult x, Widget) + +-- 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 + approot = ApprootMaster $ appRoot . settings + + -- Store session data on the client in encrypted cookies, + -- default session idle timeout is 120 minutes + makeSessionBackend _ = do + key <- getKey "config/client_session_key.aes" + return . Just $ clientSessionBackend key 120 + + defaultLayout widget = do + master <- getYesod + mmsg <- getMessage + + -- 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 + $(widgetFile "normalize") + addStylesheet $ StaticR css_bootstrap_css + $(widgetFile "default-layout") + hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") + + -- This is done to provide an optimization for serving static files from + -- a separate domain. Please see the staticRoot setting in Settings.hs + urlRenderOverride y (StaticR s) = + Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s + urlRenderOverride _ _ = Nothing + + -- The page to be redirected to when authentication is required. + authRoute _ = Just $ AuthR LoginR + + messageLogger y loc level msg = + formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y) + + -- 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 = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + + -- Place Javascript at bottom of the body tag so the rest of the page loads first + jsLoader _ = BottomOfBody + + isAuthorized (UserR u) True = isUser u + isAuthorized (UserR u) False = isUserOrAdmin u + isAuthorized _ _ = return Authorized + +isUser :: UserId -> GHandler s App AuthResult +isUser t = do + ma <- maybeAuth + return $ case ma of + Nothing -> AuthenticationRequired + Just (Entity u _) -> if t == u then Authorized else Unauthorized "That ain't your page." + +isUserOrAdmin :: UserId -> GHandler s App AuthResult +isUserOrAdmin t = do + ma <- maybeAuth + return $ case ma of + Nothing -> AuthenticationRequired + Just (Entity u v) -> if t == u || userIsAdmin v then Authorized else Unauthorized "You must be an admin" + +-- How to run database actions. +instance YesodPersist App where + type YesodPersistBackend App = SqlPersist + runDB f = do + master <- getYesod + Database.Persist.Store.runPool + (persistConfig master) + f + (connPool master) + +instance YesodAuth App where + type AuthId App = UserId + + -- Where to send a user after successful login + loginDest _ = HomeR + -- Where to send a user after logout + logoutDest _ = HomeR + + getAuthId creds = runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (Entity uid _) -> return $ Just uid + Nothing -> if credsIdent creds == "" then return Nothing + else fmap Just $ insert $ User (credsIdent creds) False + + authPlugins _ = [authProxied] + + authHttpManager = httpManager + +-- 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 _ _ = defaultFormMessage + +-- Note: previous versions of the scaffolding included a deliver function to +-- send emails. Unfortunately, there are too many different options for us to +-- give a reasonable default. Instead, the information is available on the +-- wiki: +-- +-- https://github.com/yesodweb/yesod/wiki/Sending-email + +instance YesodJquery App -- FIXME: go static |