2017-10-02 03:07:09 -04:00
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
|
|
|
|
module Foundation where
|
|
|
|
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
|
|
|
import Text.Hamlet (hamletFile)
|
|
|
|
import Text.Jasmine (minifym)
|
2017-10-08 17:51:42 -04:00
|
|
|
import Web.Slug (Slug)
|
2017-10-02 03:07:09 -04:00
|
|
|
|
2017-10-05 21:32:27 -04:00
|
|
|
import Yesod.Auth.HashDB (authHashDBWithForm)
|
2017-10-05 19:38:10 -04:00
|
|
|
import qualified Yesod.Auth.Message as AuthMsg
|
2017-10-02 03:07:09 -04:00
|
|
|
|
|
|
|
import Yesod.Default.Util (addStaticContentExternal)
|
|
|
|
import Yesod.Core.Types (Logger)
|
|
|
|
import qualified Yesod.Core.Unsafe as Unsafe
|
|
|
|
|
2017-10-05 01:19:15 -04:00
|
|
|
import Package
|
2017-10-08 01:51:48 -04:00
|
|
|
import Entry.Kind ( EntryKind )
|
2017-10-04 18:58:32 -04:00
|
|
|
|
2017-10-02 03:07:09 -04:00
|
|
|
-- | 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
|
|
|
|
{ appSettings :: AppSettings
|
|
|
|
, appStatic :: Static -- ^ Settings for static file serving.
|
|
|
|
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
|
|
|
, appHttpManager :: Manager
|
|
|
|
, appLogger :: Logger
|
|
|
|
}
|
|
|
|
|
|
|
|
data MenuItem = MenuItem
|
|
|
|
{ menuItemLabel :: Text
|
|
|
|
, menuItemRoute :: Route App
|
|
|
|
}
|
|
|
|
|
|
|
|
-- 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 (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
|
2017-10-04 18:01:35 -04:00
|
|
|
approot = ApprootMaster $ fromMaybe "localhost" . appRoot . appSettings
|
2017-10-02 03:07:09 -04:00
|
|
|
|
|
|
|
-- Store session data on the client in encrypted cookies,
|
|
|
|
-- default session idle timeout is 120 minutes
|
2017-10-02 05:17:49 -04:00
|
|
|
makeSessionBackend _ = sslOnlySessions . strictSameSiteSessions $ Just <$> defaultClientSessionBackend
|
2017-10-02 03:07:09 -04:00
|
|
|
120 -- timeout in minutes
|
|
|
|
"config/client_session_key.aes"
|
|
|
|
|
2017-10-02 05:31:49 -04:00
|
|
|
-- Redirect static requests to a subdomain - this is recommended for best
|
|
|
|
-- performance, since serving static files does not need your session
|
|
|
|
-- cookies and they can be served from the frontend HTTP server without
|
|
|
|
-- hitting the app server at all.
|
|
|
|
-- https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Serve-static-files-from-a-separate-domain.md
|
|
|
|
urlParamRenderOverride app (StaticR s) _ = do
|
|
|
|
staticRoot <- appStaticRoot . appSettings $ app
|
|
|
|
return . uncurry (joinPath app staticRoot) . renderRoute $ s
|
|
|
|
urlParamRenderOverride _ _ _ = Nothing
|
|
|
|
|
2017-10-02 03:07:09 -04:00
|
|
|
-- 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.
|
2017-10-02 05:17:49 -04:00
|
|
|
yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
2017-10-02 03:07:09 -04:00
|
|
|
|
|
|
|
defaultLayout widget = do
|
|
|
|
master <- getYesod
|
|
|
|
mmsg <- getMessage
|
|
|
|
|
2017-10-05 23:23:42 -04:00
|
|
|
muser <- maybeAuthPair
|
2017-10-02 03:07:09 -04:00
|
|
|
mcurrentRoute <- getCurrentRoute
|
|
|
|
|
|
|
|
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
|
|
|
|
(title, parents) <- breadcrumbs
|
|
|
|
|
2017-10-05 23:43:00 -04:00
|
|
|
let navbars = [leftMenuItems, rightMenuItems] <*> [muser]
|
2017-10-02 03:07:09 -04:00
|
|
|
|
|
|
|
-- 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.
|
|
|
|
|
2017-10-02 07:33:32 -04:00
|
|
|
pc <- widgetToPageContent $(widgetFile "default-layout")
|
2017-10-02 03:07:09 -04:00
|
|
|
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
|
|
|
|
|
|
|
-- The page to be redirected to when authentication is required.
|
|
|
|
authRoute _ = Just $ AuthR LoginR
|
|
|
|
|
|
|
|
-- Routes not requiring authentication.
|
2017-10-05 19:38:10 -04:00
|
|
|
isAuthorized _ _ = return Authorized
|
2017-10-02 03:07:09 -04:00
|
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
|
|
-- What messages should be logged. The following includes all messages when
|
|
|
|
-- in development, and warnings and errors in production.
|
|
|
|
shouldLog app _source level =
|
|
|
|
appShouldLogAll (appSettings app)
|
|
|
|
|| level == LevelWarn
|
|
|
|
|| level == LevelError
|
|
|
|
|
|
|
|
makeLogger = return . appLogger
|
|
|
|
|
2017-10-05 23:23:42 -04:00
|
|
|
leftMenuItems, rightMenuItems :: Maybe (UserId, User) -> [MenuItem]
|
|
|
|
leftMenuItems _ = []
|
|
|
|
rightMenuItems = loggedOutItems `maybe` loggedInItems
|
|
|
|
where loggedOutItems =
|
|
|
|
[ "log in" `MenuItem` AuthR LoginR
|
|
|
|
]
|
|
|
|
loggedInItems (_id, user) =
|
|
|
|
[ userUsername user `MenuItem` HomeR
|
|
|
|
, "log out" `MenuItem` AuthR LogoutR
|
|
|
|
]
|
|
|
|
|
2017-10-02 03:07:09 -04:00
|
|
|
-- Define breadcrumbs.
|
|
|
|
instance YesodBreadcrumbs App where
|
2017-10-05 19:38:10 -04:00
|
|
|
breadcrumb (AuthR _) = return ("login", Just HomeR)
|
|
|
|
breadcrumb _ = return ("home", Nothing)
|
2017-10-02 03:07:09 -04:00
|
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
|
|
instance YesodAuth App where
|
|
|
|
type AuthId App = UserId
|
|
|
|
|
|
|
|
-- Where to send a user after successful login
|
|
|
|
loginDest _ = HomeR
|
|
|
|
-- Where to send a user after logout
|
|
|
|
logoutDest _ = HomeR
|
|
|
|
|
2017-10-05 19:38:10 -04:00
|
|
|
authenticate = fmap toResult . lookupCreds
|
|
|
|
where
|
|
|
|
lookupCreds = runDB . getBy . UniqueUser . credsIdent
|
|
|
|
toResult = UserError AuthMsg.InvalidLogin `maybe` (Authenticated . entityKey)
|
2017-10-02 03:07:09 -04:00
|
|
|
|
2017-10-05 19:38:10 -04:00
|
|
|
-- You can add other plugins like Google Email, email or OAuth here
|
2017-10-05 21:32:27 -04:00
|
|
|
authPlugins _ = [authHashDBWithForm loginForm (Just . UniqueUser)]
|
|
|
|
where loginForm :: Route App -> Widget
|
|
|
|
loginForm action = do
|
|
|
|
mtok <- reqToken <$> getRequest
|
|
|
|
$(widgetFile "auth/login")
|
2017-10-02 03:07:09 -04:00
|
|
|
authHttpManager = getHttpManager
|
|
|
|
|
|
|
|
-- | Access function to determine if a user is logged in.
|
|
|
|
isAuthenticated :: Handler AuthResult
|
|
|
|
isAuthenticated = do
|
|
|
|
muid <- maybeAuthId
|
|
|
|
return $ case muid of
|
|
|
|
Nothing -> Unauthorized "You must login to access this page"
|
|
|
|
Just _ -> Authorized
|
|
|
|
|
|
|
|
instance YesodAuthPersist App
|
|
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
|
|
-- 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
|
|
|
|
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
|