Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
227 lines (204 sloc) 8.04 KB
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
module Foundation
( Yesodoro (..)
, YesodoroRoute (..)
, resourcesYesodoro
, Handler
, Widget
, maybeAuth
, requireAuth
, module Yesod
, module Settings
, module Model
, StaticRoute (..)
, AuthRoute (..)
) where
import Yesod
import Yesod.Static (Static, base64md5, StaticRoute(..))
import Settings.StaticFiles
import Yesod.Auth
import Yesod.Auth.OpenId
import Yesod.Auth.Email
import Yesod.Logger (Logger, logLazyText)
import qualified Settings
import System.Directory
import qualified Data.ByteString.Lazy as L
import Database.Persist.GenericSql
import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
import Model
import Data.Maybe (isJust)
import Control.Monad (join, unless)
import Network.Mail.Mime
import qualified Data.Text.Lazy.Encoding
import Text.Jasmine (minifym)
import qualified Data.Text as T
import Web.ClientSession (getKey)
import Text.Blaze.Renderer.Utf8 (renderHtml)
import Text.Hamlet (shamlet)
import Text.Shakespeare.Text (stext)
-- | 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 Yesodoro = Yesodoro
{ settings :: Settings.AppConfig
, getLogger :: Logger
, getStatic :: Static -- ^ Settings for static file serving.
, connPool :: Settings.ConnectionPool -- ^ Database connection pool.
}
-- 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 YesodoroRoute. Every valid URL in your
-- application can be represented as a value of this type.
-- * Creates the associated type:
-- type instance Route Yesodoro = YesodoroRoute
-- * Creates the value resourcesYesodoro 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
-- Yesodoro. 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 YesodoroRoute datatype. Therefore, we
-- split these actions into two functions and place them in separate files.
mkYesodData "Yesodoro" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod Yesodoro where
approot = Settings.appRoot . settings
-- Place the session key file in the config folder
encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
defaultLayout widget = do
mmsg <- getMessage
pc <- widgetToPageContent $ do
widget
addCassius $(Settings.cassiusFile "default-layout")
hamletToRepHtml $(Settings.hamletFile "default-layout")
-- 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 =
formatLogMessage loc level msg >>= logLazyText (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 ext' _ content = do
let fn = base64md5 content ++ '.' : T.unpack ext'
let content' =
if ext' == "js"
then case minifym content of
Left _ -> content
Right y -> y
else content
let statictmp = Settings.staticDir ++ "/tmp/"
liftIO $ createDirectoryIfMissing True statictmp
let fn' = statictmp ++ fn
exists <- liftIO $ doesFileExist fn'
unless exists $ liftIO $ L.writeFile fn' content'
return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
-- How to run database actions.
instance YesodPersist Yesodoro where
type YesodPersistBackend Yesodoro = SqlPersist
runDB f = liftIOHandler
$ fmap connPool getYesod >>= Settings.runConnectionPool f
instance YesodAuth Yesodoro where
type AuthId Yesodoro = UserId
-- Where to send a user after successful login
loginDest _ = RootR
-- Where to send a user after logout
logoutDest _ = RootR
getAuthId creds = runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds
case x of
Just (uid, _) -> return $ Just uid
Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing
authPlugins = [ authOpenId
, authEmail
]
-- Sends off your mail. Requires sendmail in production!
deliver :: Yesodoro -> L.ByteString -> IO ()
#ifdef PRODUCTION
deliver _ = sendmail
#else
deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8
#endif
instance YesodAuthEmail Yesodoro where
type AuthEmailId Yesodoro = EmailId
addUnverified email verkey =
runDB $ insert $ Email email Nothing $ Just verkey
sendVerifyEmail email _ verurl = do
y <- getYesod
liftIO $ deliver y =<< renderMail' Mail
{
mailHeaders =
[ ("From", "noreply")
, ("To", email)
, ("Subject", "Verify your email address")
]
, mailParts = [[textPart, htmlPart]]
}
where
textPart = Part
{ partType = "text/plain; charset=utf-8"
, partEncoding = None
, partFilename = Nothing
, partContent = Data.Text.Lazy.Encoding.encodeUtf8 [stext|
Please confirm your email address by clicking on the link below.
\#{verurl}
Thank you
|]
, partHeaders = []
}
htmlPart = Part
{ partType = "text/html; charset=utf-8"
, partEncoding = None
, partFilename = Nothing
, partContent = renderHtml [shamlet|
<p>Please confirm your email address by clicking on the link below.
<p>
<a href=#{verurl}>#{verurl}
<p>Thank you
|]
, partHeaders = []
}
getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
setVerifyKey eid key = runDB $ update eid [EmailVerkey =. Just key]
verifyAccount eid = runDB $ do
me <- get eid
case me of
Nothing -> return Nothing
Just e -> do
let email = emailEmail e
case emailUser e of
Just uid -> return $ Just uid
Nothing -> do
uid <- insert $ User email Nothing
update eid [EmailUser =. Just uid, EmailVerkey =. Nothing]
return $ Just uid
getPassword = runDB . fmap (join . fmap userPassword) . get
setPassword uid pass = runDB $ update uid [UserPassword =. Just pass]
getEmailCreds email = runDB $ do
me <- getBy $ UniqueEmail email
case me of
Nothing -> return Nothing
Just (eid, e) -> return $ Just EmailCreds
{ emailCredsId = eid
, emailCredsAuthId = emailUser e
, emailCredsStatus = isJust $ emailUser e
, emailCredsVerkey = emailVerkey e
}
getEmail = runDB . fmap (fmap emailEmail) . get
instance RenderMessage Yesodoro FormMessage where
renderMessage _ _ = defaultFormMessage
Jump to Line
Something went wrong with that request. Please try again.