Foundation.hs 8.37 KB
Newer Older
1
{-# OPTIONS_GHC -fno-warn-orphans #-}
Bryan Richter's avatar
Bryan Richter committed
2 3 4
module Foundation where

import Import.NoFoundation
5 6

import Control.Monad.Logger (logDebugSH)
7
import Database.Persist.Sql (runSqlPool)
Bryan Richter's avatar
Bryan Richter committed
8 9 10
import Text.Hamlet          (hamletFile)
import Text.Jasmine         (minifym)
import Yesod.Default.Util   (addStaticContentExternal)
Bryan Richter's avatar
Bryan Richter committed
11 12
import qualified Data.List as List
import qualified Data.Text as T
Bryan Richter's avatar
Bryan Richter committed
13 14
import qualified Yesod.Core.Unsafe as Unsafe

15
import AppDataTypes
16 17
import Email
import Network.Mail.Mime
18
import qualified TestHooks
Bryan Richter's avatar
Bryan Richter committed
19

Bryan Richter's avatar
Bryan Richter committed
20 21 22 23 24 25 26 27 28
-- | A convenient synonym for creating forms.
type Form x = Html -> MForm (HandlerT App IO) (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
    -- Controls the base of generated URLs. For more information on modifying,
    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
    approot = ApprootRequest $ \app req ->
Bryan Richter's avatar
Bryan Richter committed
29 30
        fromMaybe (getApprootText guessApproot app req)
                  (appRoot (appSettings app))
Bryan Richter's avatar
Bryan Richter committed
31 32 33 34 35 36 37

    -- Store session data on the client in encrypted cookies,
    -- default session idle timeout is 120 minutes
    makeSessionBackend _ = Just <$> defaultClientSessionBackend
        120    -- timeout in minutes
        "config/client_session_key.aes"

38 39 40 41 42
    -- 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:
Bryan Richter's avatar
Bryan Richter committed
43
    --   a) Sets a cookie with a CSRF token in it.
44 45 46 47 48 49 50
    --   b) Validates that incoming write requests include that token in
    --      either a header or POST parameter.
    -- For details, see the CSRF documentation in the Yesod.Core.Handler
    -- module of the yesod-core package.
    --
    -- yesodMiddleware :: ToTypedContent res
    --    => HandlerT site IO res -> HandlerT site IO res
Bryan Richter's avatar
Bryan Richter committed
51
    yesodMiddleware = TestHooks.middleware
Bryan Richter's avatar
Bryan Richter committed
52

53
    defaultLayout = navbarLayout ""
Bryan Richter's avatar
Bryan Richter committed
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83

    -- The page to be redirected to when authentication is required.
    authRoute _ = Just $ AuthR LoginR

    -- Routes not requiring authentication.
    isAuthorized (AuthR _) _ = return Authorized
    isAuthorized FaviconR _ = return Authorized
    isAuthorized RobotsR _ = return Authorized
    -- Default to Authorized for now.
    isAuthorized _ _ = return Authorized

    -- 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
      where
        -- Generate a unique filename based on the content itself
        genFileName lbs = "autogen-" ++ base64md5 lbs

84 85
    -- What messages should be logged. The following includes all messages
    -- when in development, and warnings and errors in production.
Bryan Richter's avatar
Bryan Richter committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
    shouldLog app _source level =
        appShouldLogAll (appSettings app)
            || level == LevelWarn
            || level == LevelError

    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
instance YesodPersistRunner App where
    getDBRunner = defaultGetDBRunner appConnPool

102 103 104 105 106 107 108 109 110 111 112 113 114 115
-- | A form for 'Credentials', to be used when a new passphrase is chosen
createCredentialsForm :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
                => AForm m Credentials
createCredentialsForm = Credentials
    <$> (AuthEmail <$>
            areq textField "Email"{fsAttrs=emailAttrs}  Nothing)
    <*> (ClearPassphrase <$>
            areq
                passwordField
                "New Passphrase"{fsAttrs=ppAttrs}
                Nothing)
  where
    emailAttrs = [("autofocus",""), ("autocomplete","email")]
    ppAttrs = [("minlength","9")]
Bryan Richter's avatar
Bryan Richter committed
116

117 118
-- Create the pages for auth
instance AuthMaster App where
119

120
    postLoginRoute _ = DashboardR
121 122
    postLogoutRoute = postLoginRoute

123
    loginHandler = do
124
        (loginFields, enctype) <- generateFormPost (renderDivs credentialsForm)
125
        navbarLayout "page/auth/login" $ do
126 127 128 129
            setTitle "Login — Snowdrift.coop"
            $(widgetFile "page/auth/login")

    createAccountHandler = do
130
        (loginFields, enctype) <- generateFormPost (renderDivs createCredentialsForm)
131
        navbarLayout "page/auth/create-account" $ do
132 133 134
            setTitle "Create Account — Snowdrift.coop"
            $(widgetFile "page/auth/create-account")

135 136
    verifyAccountHandler = do
        ((_, tokenField), enctype) <-
Bryan Richter's avatar
Bryan Richter committed
137 138
            runFormPost
                (renderDivs (areq textField "Token"{fsAttrs=af} Nothing))
139
        navbarLayout "page/auth/verify-account" $ do
140 141
            setTitle "Verify Account — Snowdrift.coop"
            $(widgetFile "page/auth/verify-account")
Bryan Richter's avatar
Bryan Richter committed
142
      where af = [("autofocus","true")]
143

144 145 146 147 148
    resetPassphraseHandler = do
        (loginFields, enctype) <- generateFormPost (renderDivs credentialsForm)
        navbarLayout "page/auth/reset-passphrase" $ do
            setTitle "Passphrase Reset — Snowdrift.coop"
            $(widgetFile "page/auth/reset-passphrase")
149

150
    sendAuthEmail to msg = do
151
        $logDebugSH msg
152 153 154 155 156
        s <- appSettings <$> getYesod
        if appSendMail s
            then do r <- getUrlRenderParams
                    liftIO (renderSendMail (snowdriftAuthEmail r to msg))
            else pure ()
Bryan Richter's avatar
Bryan Richter committed
157

Bryan Richter's avatar
Bryan Richter committed
158 159 160 161 162
-- 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

163 164 165
-- 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.
Bryan Richter's avatar
Bryan Richter committed
166 167 168 169 170 171 172 173 174 175 176 177 178
instance HasHttpManager App where
    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
Bryan Richter's avatar
Bryan Richter committed
179

180 181
navbarLayout :: Text -> Widget -> Handler Html
navbarLayout pageName widget = do
182
    msgs <- getMessages
Bryan Richter's avatar
Bryan Richter committed
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
    maybeUser  <- maybeAuth

    active <- maybe (const False) (==) <$> getCurrentRoute
    howItWorksActive <- do
        r <- getCurrentRoute
        return $ case r of
            Just HowItWorksR -> True
            _                -> False
    authActive <- do
        r <- getCurrentRoute
        return $ case r of
            Just (AuthR _)        -> True
            _                     -> False

    let navbar, footer :: Widget
198 199
        navbar = $(widgetFile "default/navbar")
        footer = $(widgetFile "default/footer")
200 201

    pc <- widgetToPageContent $ do
202 203 204 205 206
        $(widgetFile "default/reset")
        $(widgetFile "default/breaks")
        $(widgetFile "default/fonts")
        $(widgetFile "default/grid")
        $(widgetFile "default-layout")
Bryan Richter's avatar
Bryan Richter committed
207 208 209 210
    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
  where
    pageClasses :: (Text, Text)
    pageClasses = ("class", classes pageName)
Bryan Richter's avatar
Bryan Richter committed
211
    classes = T.unwords
Bryan Richter's avatar
Bryan Richter committed
212 213
            . List.tail
            . T.splitOn "/"
214 215 216 217 218 219 220 221 222 223 224 225 226 227

defaultLayoutNew :: Widget -> Handler Html
defaultLayoutNew widget = do
    maybeUser <- maybeAuth
    let navbar :: Widget
        navbar = $(widgetFile "main/navbar")

    -- This should catch only main.hamlet, because _main.sass is already
    -- @import-ed in page SASS and we don't need to load it here
    pc <- widgetToPageContent $(widgetFile "main/main")
    withUrlRenderer $(hamletFile "templates/main/main-wrapper.hamlet")
  where
    footer :: Widget
    footer = $(widgetFile "main/footer")