]> Git — Sourcephile - comptalang.git/blob - web/Foundation.hs
Adapte hcompta-jcc.
[comptalang.git] / web / Foundation.hs
1 {-# LANGUAGE TemplateHaskell #-}
2 module Foundation where
3
4 import Import.NoFoundation
5 import Database.Persist.Sql (ConnectionPool, runSqlPool)
6 import Text.Hamlet (hamletFile)
7 import Text.Jasmine (minifym)
8 import Yesod.Auth.BrowserId (authBrowserId)
9 import Yesod.Default.Util (addStaticContentExternal)
10 import Yesod.Core.Types (Logger)
11 import qualified Yesod.Core.Unsafe as Unsafe
12
13 -- | The foundation datatype for your application. This can be a good place to
14 -- keep settings and values requiring initialization before your application
15 -- starts running, such as database connections. Every handler will have
16 -- access to the data present here.
17 data App = App
18 { appSettings :: AppSettings
19 , appStatic :: Static -- ^ Settings for static file serving.
20 , appConnPool :: ConnectionPool -- ^ Database connection pool.
21 , appHttpManager :: Manager
22 , appLogger :: Logger
23 }
24
25 instance HasHttpManager App where
26 getHttpManager = appHttpManager
27
28 -- This is where we define all of the routes in our application. For a full
29 -- explanation of the syntax, please see:
30 -- http://www.yesodweb.com/book/routing-and-handlers
31 --
32 -- Note that this is really half the story; in Application.hs, mkYesodDispatch
33 -- generates the rest of the code. Please see the linked documentation for an
34 -- explanation for this split.
35 mkYesodData "App" $(parseRoutesFile "config/routes")
36
37 -- | A convenient synonym for creating forms.
38 type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
39
40 -- Please see the documentation for the Yesod typeclass. There are a number
41 -- of settings which can be configured by overriding methods here.
42 instance Yesod App where
43 -- Controls the base of generated URLs. For more information on modifying,
44 -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
45 approot = ApprootMaster $ appRoot . appSettings
46
47 -- Store session data on the client in encrypted cookies,
48 -- default session idle timeout is 120 minutes
49 makeSessionBackend _ = Just <$> defaultClientSessionBackend
50 120 -- timeout in minutes
51 "config/client_session_key.aes"
52
53 defaultLayout widget = do
54 master <- getYesod
55 mmsg <- getMessage
56
57 -- We break up the default layout into two components:
58 -- default-layout is the contents of the body tag, and
59 -- default-layout-wrapper is the entire page. Since the final
60 -- value passed to hamletToRepHtml cannot be a widget, this allows
61 -- you to use normal widget features in default-layout.
62
63 pc <- widgetToPageContent $ do
64 addStylesheet $ StaticR css_bootstrap_css
65 $(widgetFile "default-layout")
66 withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
67
68 -- The page to be redirected to when authentication is required.
69 authRoute _ = Just $ AuthR LoginR
70
71 -- Routes not requiring authentication.
72 isAuthorized (AuthR _) _ = return Authorized
73 isAuthorized FaviconR _ = return Authorized
74 isAuthorized RobotsR _ = return Authorized
75 -- Default to Authorized for now.
76 isAuthorized _ _ = return Authorized
77
78 -- This function creates static content files in the static folder
79 -- and names them based on a hash of their content. This allows
80 -- expiration dates to be set far in the future without worry of
81 -- users receiving stale content.
82 addStaticContent ext mime content = do
83 master <- getYesod
84 let staticDir = appStaticDir $ appSettings master
85 addStaticContentExternal
86 minifym
87 genFileName
88 staticDir
89 (StaticR . flip StaticRoute [])
90 ext
91 mime
92 content
93 where
94 -- Generate a unique filename based on the content itself
95 genFileName lbs = "autogen-" ++ base64md5 lbs
96
97 -- What messages should be logged. The following includes all messages when
98 -- in development, and warnings and errors in production.
99 shouldLog app _source level =
100 appShouldLogAll (appSettings app)
101 || level == LevelWarn
102 || level == LevelError
103
104 makeLogger = return . appLogger
105
106 -- How to run database actions.
107 instance YesodPersist App where
108 type YesodPersistBackend App = SqlBackend
109 runDB action = do
110 master <- getYesod
111 runSqlPool action $ appConnPool master
112 instance YesodPersistRunner App where
113 getDBRunner = defaultGetDBRunner appConnPool
114
115 instance YesodAuth App where
116 type AuthId App = UserId
117
118 -- Where to send a user after successful login
119 loginDest _ = HomeR
120 -- Where to send a user after logout
121 logoutDest _ = HomeR
122 -- Override the above two destinations when a Referer: header is present
123 redirectToReferer _ = True
124
125 getAuthId creds = runDB $ do
126 x <- getBy $ UniqueUser $ credsIdent creds
127 case x of
128 Just (Entity uid _) -> return $ Just uid
129 Nothing -> Just <$> insert User
130 { userIdent = credsIdent creds
131 , userPassword = Nothing
132 }
133
134 -- You can add other plugins like BrowserID, email or OAuth here
135 authPlugins _ = [authBrowserId def]
136
137 authHttpManager = getHttpManager
138
139 instance YesodAuthPersist App
140
141 -- This instance is required to use forms. You can modify renderMessage to
142 -- achieve customized and internationalized form validation messages.
143 instance RenderMessage App FormMessage where
144 renderMessage _ _ = defaultFormMessage
145
146 unsafeHandler :: App -> Handler a -> IO a
147 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
148
149 -- Note: Some functionality previously present in the scaffolding has been
150 -- moved to documentation in the Wiki. Following are some hopefully helpful
151 -- links:
152 --
153 -- https://github.com/yesodweb/yesod/wiki/Sending-email
154 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
155 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding