Foundation.hs 9.46 KB
Newer Older
1
2
3
4
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
5
{-# LANGUAGE LambdaCase                 #-}
6
7
8
9
10
11
12
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}
13
14
15

module Foundation where

16
import qualified Calendar as Cal
17
18
import qualified Control.Monad.Catch  as MC
import           Control.Monad.Logger (LogSource)
19
import qualified Data.CaseInsensitive as CI
20
21
22
23
24
25
26
27
28
import qualified Data.Text.Encoding   as TE
import           Import.NoFoundation  as Pre
import qualified Network.Google       as Google
import qualified Network.Google.Auth  as Google
import           Text.Hamlet          (hamletFile)
import           Text.Jasmine         (minifym)
import           Yesod.Core.Types     (Logger)
import qualified Yesod.Core.Unsafe    as Unsafe
import           Yesod.Default.Util   (addStaticContentExternal)
29
30
31
32
33
34

-- | 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
35
36
37
38
  { appSettings    :: AppSettings
  , appStatic      :: Static -- ^ Settings for static file serving.
  , appHttpManager :: Manager
  , appLogger      :: Logger
39
  , appCalendarCxt :: Cal.Context
40
41
  }

42
data MenuItem = MenuItem
43
44
45
46
  { menuItemLabel          :: Text
  , menuItemRoute          :: Route App
  , menuItemAccessCallback :: Bool
  }
47
48

data MenuTypes
49
50
  = NavbarLeft MenuItem
  | NavbarRight MenuItem
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

-- 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)

69
70
71
instance MC.MonadCatch (HandlerFor App) where
  catch = Pre.catch

72
73
74
75
76
77
78
79
80
81
82
83
addStylesheetL :: Route App -> Text -> [(Text, Text)] -> Widget
addStylesheetL route cdn attrs =
  appLocalAssets . appSettings <$> getYesod >>= \case
  True -> addStylesheet route
  False -> addStylesheetRemoteAttrs cdn attrs

addScriptL :: Route App -> Text -> [(Text, Text)] -> Widget
addScriptL route cdn attrs =
  appLocalAssets . appSettings <$> getYesod >>= \case
  True -> addScript route
  False -> addScriptRemoteAttrs cdn attrs

84
85
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
86
instance Yesod App
87
88
    -- Controls the base of generated URLs. For more information on modifying,
    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
89
90
91
92
93
94
95
                                                                      where
  approot :: Approot App
  approot =
    ApprootRequest $ \app req ->
      case appRoot $ appSettings app of
        Nothing   -> getApprootText guessApproot app req
        Just root -> root
96
97
    -- Store session data on the client in encrypted cookies,
    -- default session idle timeout is 120 minutes
98
99
100
101
102
103
  makeSessionBackend :: App -> IO (Maybe SessionBackend)
  makeSessionBackend _ =
    Just <$>
    defaultClientSessionBackend
      120 -- timeout in minutes
      "config/client_session_key.aes"
104
105
106
107
108
109
110
    -- 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.
111
112
113
114
115
116
117
  yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
  yesodMiddleware = defaultYesodMiddleware
  defaultLayout :: Widget -> Handler Html
  defaultLayout widget = do
    master <- getYesod
    mmsg <- getMessage
    mcurrentRoute <- getCurrentRoute
118
        -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
119
    (title, parents) <- breadcrumbs
120
121
122
123
124
        -- 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.
125
126
    pc <-
      widgetToPageContent $ do
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
        let fontFamily =
              asText "'Play', 'Helvetica Neue', Helvetica, Arial, sans-serif"
        addScriptL (StaticR js_jquery_3_3_1_min_js)
          "https://code.jquery.com/jquery-3.3.1.min.js"
	  [("integrity", "sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=")
          ,("crossorigin", "anonymous")
          ]
        addScriptL (StaticR js_js_cookie_2_2_0_min_js)
          "https://cdn.jsdelivr.net/npm/js-cookie@2.2.0/src/js.cookie.min.js"
          []
        addStylesheetRemote "https://fonts.googleapis.com/css?family=Play:400,700"
        addStylesheetL (StaticR css_bootstrap_3_3_7_min_css)
          "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"
          [("integrity", "sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u")
          ,("crossorigin", "anonymous")
          ]
        --   $ StaticR css_bootstrap_css
144
145
146
147
148
149
        $(widgetFile "default-layout")
    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
  isAuthorized ::
       Route App -- ^ The route the user is visiting.
    -> Bool -- ^ Whether or not this is a "write" request.
    -> Handler AuthResult
150
    -- Routes not requiring authenitcation.
151
152
  isAuthorized FaviconR _ = return Authorized
  isAuthorized RobotsR _  = return Authorized
153
    -- Default to Authorized for now.
154
  isAuthorized _ _        = return Authorized
155
156
157
158
    -- 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.
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
  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
175
        -- Generate a unique filename based on the content itself
176
177
    where
      genFileName lbs = "autogen-" ++ base64md5 lbs
178
179
    -- What messages should be logged. The following includes all messages when
    -- in development, and warnings and errors in production.
180
181
182
183
184
185
186
  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
187
188

-- Define breadcrumbs.
189
instance YesodBreadcrumbs App
190
191
192
    -- 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.
193
194
195
196
197
198
                         where
  breadcrumb ::
       Route App -- ^ The route the user is visiting currently.
    -> Handler (Text, Maybe (Route App))
  breadcrumb HomeR = return ("Home", Nothing)
  breadcrumb _     = return ("home", Nothing)
199
200
201
202

-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
203
204
  renderMessage :: App -> [Lang] -> FormMessage -> Text
  renderMessage _ _ = defaultFormMessage
205
206
207
208
209

-- 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
210
211
  getHttpManager :: App -> Manager
  getHttpManager = appHttpManager
212
213
214
215
216
217
218
219
220
221

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