eidolon/Foundation.hs

201 lines
6.9 KiB
Haskell
Raw Normal View History

2014-08-09 18:33:22 +00:00
module Foundation where
import Prelude
import Yesod
import Yesod.Static
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
2014-08-09 18:33:22 +00:00
import Settings.StaticFiles
import Settings
2014-08-12 16:14:59 +00:00
import Model
2014-08-09 18:33:22 +00:00
import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile)
import Yesod.Core.Types
2014-08-12 16:14:59 +00:00
-- costom imports
import Data.Text
2014-08-15 11:24:14 +00:00
import Helper
2014-08-09 18:33:22 +00:00
-- | 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
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appHttpManager :: Manager
, appLogger :: Logger
2014-08-09 18:33:22 +00:00
}
instance HasHttpManager App where
getHttpManager = appHttpManager
2014-08-09 18:33:22 +00:00
-- 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/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the linked documentation for an
-- explanation for this split.
mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
renderLayout :: Widget -> Handler Html
renderLayout widget = do
master <- getYesod
mmsg <- getMessage
msu <- lookupSession "userId"
username <- case msu of
Just a -> do
uId <- return $ getUserIdFromText a
user <- runDB $ getJust uId
return $ userName user
Nothing -> do
return ("" :: Text)
slug <- case msu of
Just a -> do
uId <- return $ getUserIdFromText a
user <- runDB $ getJust uId
return $ userSlug user
Nothing -> do
return ("" :: Text)
block <- return $ appSignupBlocked $ appSettings master
-- 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.
wc <- widgetToPageContent widget
pc <- widgetToPageContent $ do
-- add parallelism js files
$(combineScripts 'StaticR
[ js_jquery_min_js
, js_jquery_poptrox_min_js
, js_skel_min_js
, js_init_js
])
$(combineStylesheets 'StaticR
2015-01-12 14:15:52 +00:00
[
-- css_normalize_css
css_bootstrap_css
])
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
formLayout :: Widget -> Handler Html
formLayout widget = do
renderLayout $(widgetFile "form-widget")
2014-08-09 18:33:22 +00:00
-- 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 . appSettings
2014-08-09 18:33:22 +00:00
2014-09-03 22:19:07 +00:00
-- change maximum content length
2014-12-28 06:12:25 +00:00
maximumContentLength _ _ = Just $ 1024 ^ (5 :: Int)
2014-09-03 22:19:07 +00:00
2014-08-09 18:33:22 +00:00
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
defaultLayout widget = do
renderLayout $(widgetFile "default-widget")
2014-08-09 18:33:22 +00:00
-- 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
2014-08-09 18:33:22 +00:00
-- The page to be redirected to when authentication is required.
2014-08-12 12:37:31 +00:00
-- authRoute _ = Just $ AuthR LoginR
2014-08-09 18:33:22 +00:00
-- 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 ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
2014-08-09 18:33:22 +00:00
where
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
2014-08-09 18:33:22 +00:00
-- Place Javascript at bottom of the body tag so the rest of the page loads first
jsLoader _ = BottomOfBody
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLog app _source level =
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
2014-08-09 18:33:22 +00:00
makeLogger = return . appLogger
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlBackend
runDB action = do
master <- getYesod
runSqlPool action $ appConnPool master
2014-08-09 18:33:22 +00:00
instance YesodPersistRunner App where
getDBRunner = defaultGetDBRunner appConnPool
2014-08-09 18:33:22 +00:00
2014-08-12 12:37:31 +00:00
-- instance YesodAuth App where
-- type AuthId App = UserId
2014-08-09 18:33:22 +00:00
-- Where to send a user after successful login
2014-08-12 12:37:31 +00:00
-- loginDest _ = HomeR
2014-08-09 18:33:22 +00:00
-- Where to send a user after logout
2014-08-12 12:37:31 +00:00
-- logoutDest _ = HomeR
-- getAuthId creds = runDB $ do
-- x <- getBy $ UniqueUser $ credsIdent creds
-- case x of
-- Just (Entity uid _) -> return $ Just uid
-- Nothing -> do
-- fmap Just $ insert User
-- { userIdent = credsIdent creds
-- , userPassword = Nothing
-- }
2014-08-09 18:33:22 +00:00
-- You can add other plugins like BrowserID, email or OAuth here
2014-08-12 12:37:31 +00:00
-- authPlugins _ = [authBrowserId def]
2014-08-09 18:33:22 +00:00
2014-08-12 12:37:31 +00:00
-- authHttpManager = httpManager
2014-08-09 18:33:22 +00:00
-- 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
-- | Get the 'Extra' value, used to hold data from the settings.yml file.
-- getExtra :: Handler Extra
-- getExtra = fmap (appExtra . settings) getYesod
2014-08-09 18:33:22 +00:00
-- 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