Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 227 lines (204 sloc) 8.237 kb
a23ca2e @samstokes yesod init scaffold for yesodoro
authored
1 {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
2 {-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
3 {-# LANGUAGE CPP #-}
4 module Foundation
5 ( Yesodoro (..)
6 , YesodoroRoute (..)
7 , resourcesYesodoro
8 , Handler
9 , Widget
10 , maybeAuth
11 , requireAuth
12 , module Yesod
13 , module Settings
14 , module Model
15 , StaticRoute (..)
16 , AuthRoute (..)
17 ) where
18
19 import Yesod
20 import Yesod.Static (Static, base64md5, StaticRoute(..))
21 import Settings.StaticFiles
22 import Yesod.Auth
23 import Yesod.Auth.OpenId
24 import Yesod.Auth.Email
25 import Yesod.Logger (Logger, logLazyText)
26 import qualified Settings
27 import System.Directory
28 import qualified Data.ByteString.Lazy as L
29 import Database.Persist.GenericSql
30 import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
31 import Model
32 import Data.Maybe (isJust)
33 import Control.Monad (join, unless)
34 import Network.Mail.Mime
35 import qualified Data.Text.Lazy.Encoding
36 import Text.Jasmine (minifym)
37 import qualified Data.Text as T
38 import Web.ClientSession (getKey)
39 import Text.Blaze.Renderer.Utf8 (renderHtml)
40 import Text.Hamlet (shamlet)
41 import Text.Shakespeare.Text (stext)
42
43 -- | The site argument for your application. This can be a good place to
44 -- keep settings and values requiring initialization before your application
45 -- starts running, such as database connections. Every handler will have
46 -- access to the data present here.
47 data Yesodoro = Yesodoro
48 { settings :: Settings.AppConfig
49 , getLogger :: Logger
50 , getStatic :: Static -- ^ Settings for static file serving.
51 , connPool :: Settings.ConnectionPool -- ^ Database connection pool.
52 }
53
54 -- This is where we define all of the routes in our application. For a full
55 -- explanation of the syntax, please see:
56 -- http://www.yesodweb.com/book/handler
57 --
58 -- This function does three things:
59 --
60 -- * Creates the route datatype YesodoroRoute. Every valid URL in your
61 -- application can be represented as a value of this type.
62 -- * Creates the associated type:
63 -- type instance Route Yesodoro = YesodoroRoute
64 -- * Creates the value resourcesYesodoro which contains information on the
65 -- resources declared below. This is used in Handler.hs by the call to
66 -- mkYesodDispatch
67 --
68 -- What this function does *not* do is create a YesodSite instance for
69 -- Yesodoro. Creating that instance requires all of the handler functions
70 -- for our application to be in scope. However, the handler functions
71 -- usually require access to the YesodoroRoute datatype. Therefore, we
72 -- split these actions into two functions and place them in separate files.
73 mkYesodData "Yesodoro" $(parseRoutesFile "config/routes")
74
75 -- Please see the documentation for the Yesod typeclass. There are a number
76 -- of settings which can be configured by overriding methods here.
77 instance Yesod Yesodoro where
78 approot = Settings.appRoot . settings
79
80 -- Place the session key file in the config folder
81 encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
82
83 defaultLayout widget = do
84 mmsg <- getMessage
85 pc <- widgetToPageContent $ do
86 widget
87 addCassius $(Settings.cassiusFile "default-layout")
88 hamletToRepHtml $(Settings.hamletFile "default-layout")
89
90 -- This is done to provide an optimization for serving static files from
91 -- a separate domain. Please see the staticRoot setting in Settings.hs
92 urlRenderOverride y (StaticR s) =
93 Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
94 urlRenderOverride _ _ = Nothing
95
96 -- The page to be redirected to when authentication is required.
97 authRoute _ = Just $ AuthR LoginR
98
99 messageLogger y loc level msg =
100 formatLogMessage loc level msg >>= logLazyText (getLogger y)
101
102 -- This function creates static content files in the static folder
103 -- and names them based on a hash of their content. This allows
104 -- expiration dates to be set far in the future without worry of
105 -- users receiving stale content.
106 addStaticContent ext' _ content = do
107 let fn = base64md5 content ++ '.' : T.unpack ext'
108 let content' =
109 if ext' == "js"
110 then case minifym content of
111 Left _ -> content
112 Right y -> y
113 else content
114 let statictmp = Settings.staticDir ++ "/tmp/"
115 liftIO $ createDirectoryIfMissing True statictmp
116 let fn' = statictmp ++ fn
117 exists <- liftIO $ doesFileExist fn'
118 unless exists $ liftIO $ L.writeFile fn' content'
119 return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
120
121
122 -- How to run database actions.
123 instance YesodPersist Yesodoro where
124 type YesodPersistBackend Yesodoro = SqlPersist
125 runDB f = liftIOHandler
126 $ fmap connPool getYesod >>= Settings.runConnectionPool f
127
128 instance YesodAuth Yesodoro where
129 type AuthId Yesodoro = UserId
130
131 -- Where to send a user after successful login
132 loginDest _ = RootR
133 -- Where to send a user after logout
134 logoutDest _ = RootR
135
136 getAuthId creds = runDB $ do
137 x <- getBy $ UniqueUser $ credsIdent creds
138 case x of
139 Just (uid, _) -> return $ Just uid
140 Nothing -> do
141 fmap Just $ insert $ User (credsIdent creds) Nothing
142
143 authPlugins = [ authOpenId
144 , authEmail
145 ]
146
147 -- Sends off your mail. Requires sendmail in production!
148 deliver :: Yesodoro -> L.ByteString -> IO ()
149 #ifdef PRODUCTION
150 deliver _ = sendmail
151 #else
152 deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8
153 #endif
154
155 instance YesodAuthEmail Yesodoro where
156 type AuthEmailId Yesodoro = EmailId
157
158 addUnverified email verkey =
159 runDB $ insert $ Email email Nothing $ Just verkey
160
161 sendVerifyEmail email _ verurl = do
162 y <- getYesod
163 liftIO $ deliver y =<< renderMail' Mail
164 {
165 mailHeaders =
166 [ ("From", "noreply")
167 , ("To", email)
168 , ("Subject", "Verify your email address")
169 ]
170 , mailParts = [[textPart, htmlPart]]
171 }
172 where
173 textPart = Part
174 { partType = "text/plain; charset=utf-8"
175 , partEncoding = None
176 , partFilename = Nothing
177 , partContent = Data.Text.Lazy.Encoding.encodeUtf8 [stext|
178 Please confirm your email address by clicking on the link below.
179
180 \#{verurl}
181
182 Thank you
183 |]
184 , partHeaders = []
185 }
186 htmlPart = Part
187 { partType = "text/html; charset=utf-8"
188 , partEncoding = None
189 , partFilename = Nothing
190 , partContent = renderHtml [shamlet|
191 <p>Please confirm your email address by clicking on the link below.
192 <p>
193 <a href=#{verurl}>#{verurl}
194 <p>Thank you
195 |]
196 , partHeaders = []
197 }
198 getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
199 setVerifyKey eid key = runDB $ update eid [EmailVerkey =. Just key]
200 verifyAccount eid = runDB $ do
201 me <- get eid
202 case me of
203 Nothing -> return Nothing
204 Just e -> do
205 let email = emailEmail e
206 case emailUser e of
207 Just uid -> return $ Just uid
208 Nothing -> do
209 uid <- insert $ User email Nothing
210 update eid [EmailUser =. Just uid, EmailVerkey =. Nothing]
211 return $ Just uid
212 getPassword = runDB . fmap (join . fmap userPassword) . get
213 setPassword uid pass = runDB $ update uid [UserPassword =. Just pass]
214 getEmailCreds email = runDB $ do
215 me <- getBy $ UniqueEmail email
216 case me of
217 Nothing -> return Nothing
218 Just (eid, e) -> return $ Just EmailCreds
219 { emailCredsId = eid
220 , emailCredsAuthId = emailUser e
221 , emailCredsStatus = isJust $ emailUser e
222 , emailCredsVerkey = emailVerkey e
223 }
224 getEmail = runDB . fmap (fmap emailEmail) . get
225
226 instance RenderMessage Yesodoro FormMessage where
227 renderMessage _ _ = defaultFormMessage
Something went wrong with that request. Please try again.