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