2015-01-18 19:44:41 +00:00
|
|
|
-- eidolon -- A simple gallery in Haskell and Yesod
|
|
|
|
-- Copyright (C) 2015 Amedeo Molnár
|
|
|
|
--
|
|
|
|
-- This program is free software: you can redistribute it and/or modify
|
|
|
|
-- it under the terms of the GNU Affero General Public License as published
|
|
|
|
-- by the Free Software Foundation, either version 3 of the License, or
|
|
|
|
-- (at your option) any later version.
|
|
|
|
--
|
|
|
|
-- This program is distributed in the hope that it will be useful,
|
|
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
-- GNU Affero General Public License for more details.
|
|
|
|
--
|
|
|
|
-- You should have received a copy of the GNU Affero General Public License
|
2015-01-21 09:00:18 +00:00
|
|
|
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
2015-01-18 19:44:41 +00:00
|
|
|
|
2014-08-09 18:33:22 +00:00
|
|
|
module Foundation where
|
|
|
|
|
|
|
|
import Prelude
|
|
|
|
import Yesod
|
|
|
|
import Yesod.Static
|
|
|
|
import Yesod.Default.Util (addStaticContentExternal)
|
|
|
|
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
|
2014-12-23 04:01:53 +00:00
|
|
|
import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
|
2014-08-09 18:33:22 +00:00
|
|
|
import Settings.StaticFiles
|
2014-12-23 04:01:53 +00:00
|
|
|
import Settings
|
2014-08-12 16:14:59 +00:00
|
|
|
import Model
|
2014-08-09 18:33:22 +00:00
|
|
|
import Text.Jasmine (minifym)
|
|
|
|
import Text.Hamlet (hamletFile)
|
2014-12-23 04:01:53 +00:00
|
|
|
import Yesod.Core.Types
|
2014-08-12 16:14:59 +00:00
|
|
|
-- costom imports
|
2016-08-30 12:22:00 +00:00
|
|
|
import qualified Data.Text as T
|
2015-04-02 05:03:38 +00:00
|
|
|
import Data.Text.Encoding
|
|
|
|
import Network.Wai
|
2014-08-15 11:24:14 +00:00
|
|
|
import Helper
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- | The site argument 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
|
2014-12-23 04:01:53 +00:00
|
|
|
{ appSettings :: AppSettings
|
|
|
|
, appStatic :: Static -- ^ Settings for static file serving.
|
|
|
|
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
|
|
|
, appHttpManager :: Manager
|
|
|
|
, appLogger :: Logger
|
2014-08-09 18:33:22 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
instance HasHttpManager App where
|
2014-12-23 04:01:53 +00:00
|
|
|
getHttpManager = appHttpManager
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- Set up i18n messages. See the message folder.
|
|
|
|
mkMessage "App" "messages" "en"
|
|
|
|
|
|
|
|
-- 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 linked documentation for an
|
|
|
|
-- explanation for this split.
|
|
|
|
mkYesodData "App" $(parseRoutesFile "config/routes")
|
|
|
|
|
|
|
|
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
|
|
|
|
|
2015-01-11 07:06:48 +00:00
|
|
|
renderLayout :: Widget -> Handler Html
|
|
|
|
renderLayout widget = do
|
|
|
|
master <- getYesod
|
2015-08-18 21:57:50 +00:00
|
|
|
route <- getCurrentRoute
|
2015-01-11 07:06:48 +00:00
|
|
|
mmsg <- getMessage
|
|
|
|
msu <- lookupSession "userId"
|
2016-03-02 08:49:48 +00:00
|
|
|
username <- case msu of
|
|
|
|
Just a -> do
|
|
|
|
let uId = getUserIdFromText a
|
|
|
|
user <- runDB $ getJust uId
|
|
|
|
return $ userName user
|
|
|
|
Nothing ->
|
|
|
|
return ("" :: T.Text)
|
|
|
|
slug <- case msu of
|
|
|
|
Just a -> do
|
|
|
|
let uId = getUserIdFromText a
|
|
|
|
user <- runDB $ getJust uId
|
|
|
|
return $ userSlug user
|
|
|
|
Nothing ->
|
|
|
|
return ("" :: T.Text)
|
2016-07-12 20:07:44 +00:00
|
|
|
madmin <- case msu of
|
|
|
|
Just a -> do
|
|
|
|
let uId = getUserIdFromText a
|
|
|
|
user <- runDB $ getJust uId
|
|
|
|
return $ Just $ userAdmin user
|
|
|
|
Nothing ->
|
|
|
|
return Nothing
|
2015-09-14 16:54:46 +00:00
|
|
|
let block = appSignupBlocked $ appSettings master
|
2015-01-11 07:06:48 +00: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.
|
|
|
|
|
2016-09-04 17:56:36 +00:00
|
|
|
-- searchWidget <- widgetToPageContent $ [whamlet|
|
|
|
|
-- <form action=@{SearchR} method=GET>
|
|
|
|
-- <input type="hidden" name="_hasdata">
|
|
|
|
-- <div .input-group .required>
|
|
|
|
-- <input #hident2 .form-control type="text" autofocus="" required="" name="f1" placeholder="Search for ...">
|
|
|
|
-- <span .input-group-btn>
|
|
|
|
-- <button .btn .btn-default type="submit">Go!
|
|
|
|
-- <script>
|
|
|
|
-- if (!('autofocus' in document.createElement('input'))) {document.getElementById('hident2').focus();}
|
|
|
|
-- |]
|
2015-10-17 18:03:29 +00:00
|
|
|
|
2015-01-11 07:06:48 +00:00
|
|
|
wc <- widgetToPageContent widget
|
|
|
|
|
|
|
|
pc <- widgetToPageContent $ do
|
2016-09-05 14:01:49 +00:00
|
|
|
mapM_ addScript $ map StaticR
|
|
|
|
[ js_picturefill_js
|
|
|
|
]
|
2016-08-30 12:22:00 +00:00
|
|
|
mapM_ addStylesheet $ map StaticR
|
|
|
|
[ css_bootstrap_min_css
|
|
|
|
, css_dropdown_css
|
|
|
|
, css_main_css
|
|
|
|
]
|
2015-01-11 07:06:48 +00:00
|
|
|
$(widgetFile "default-layout")
|
2015-08-24 14:53:04 +00:00
|
|
|
|
2015-01-11 07:06:48 +00:00
|
|
|
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
|
|
|
|
2015-04-02 12:11:59 +00:00
|
|
|
approotRequest :: App -> Request -> T.Text
|
2015-04-02 05:03:38 +00:00
|
|
|
approotRequest master req =
|
|
|
|
case requestHeaderHost req of
|
2015-04-02 12:11:59 +00:00
|
|
|
Just a -> prefix `T.append` decodeUtf8 a
|
2015-04-02 05:03:38 +00:00
|
|
|
Nothing -> appRoot $ appSettings master
|
2015-04-02 12:11:59 +00:00
|
|
|
where
|
|
|
|
prefix =
|
2015-09-14 16:54:46 +00:00
|
|
|
if
|
2016-08-30 12:22:00 +00:00
|
|
|
"https://" `T.isPrefixOf` appRoot (appSettings master)
|
2015-09-14 16:54:46 +00:00
|
|
|
then
|
|
|
|
"https://"
|
|
|
|
else
|
|
|
|
"http://"
|
2015-04-02 05:03:38 +00:00
|
|
|
|
2014-08-09 18:33:22 +00:00
|
|
|
-- 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
|
2015-04-02 05:03:38 +00:00
|
|
|
--approot = ApprootMaster $ appRoot . appSettings
|
2015-04-02 12:11:59 +00:00
|
|
|
approot = ApprootRequest approotRequest
|
2014-08-09 18:33:22 +00:00
|
|
|
|
2014-09-03 22:19:07 +00:00
|
|
|
-- change maximum content length
|
2014-12-28 06:12:25 +00:00
|
|
|
maximumContentLength _ _ = Just $ 1024 ^ (5 :: Int)
|
2014-09-03 22:19:07 +00:00
|
|
|
|
2014-08-09 18:33:22 +00:00
|
|
|
-- Store session data on the client in encrypted cookies,
|
|
|
|
-- default session idle timeout is 120 minutes
|
2015-09-14 16:54:46 +00:00
|
|
|
makeSessionBackend _ = Just <$> defaultClientSessionBackend
|
2014-08-09 18:33:22 +00:00
|
|
|
120 -- timeout in minutes
|
|
|
|
"config/client_session_key.aes"
|
|
|
|
|
2016-08-30 12:22:00 +00:00
|
|
|
-- defaultLayout widget =
|
|
|
|
-- renderLayout $(widgetFile "default-widget")
|
|
|
|
defaultLayout = renderLayout
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- This is done to provide an optimization for serving static files from
|
|
|
|
-- a separate domain. Please see the staticRoot setting in Settings.hs
|
2014-12-23 04:01:53 +00:00
|
|
|
-- urlRenderOverride y (StaticR s) =
|
|
|
|
-- Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
|
|
|
|
-- urlRenderOverride _ _ = Nothing
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- The page to be redirected to when authentication is required.
|
2014-08-12 12:37:31 +00:00
|
|
|
-- authRoute _ = Just $ AuthR LoginR
|
2014-08-09 18:33:22 +00: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.
|
2014-12-23 04:01:53 +00:00
|
|
|
addStaticContent ext mime content = do
|
|
|
|
master <- getYesod
|
|
|
|
let staticDir = appStaticDir $ appSettings master
|
|
|
|
addStaticContentExternal
|
|
|
|
minifym
|
|
|
|
genFileName
|
|
|
|
staticDir
|
|
|
|
(StaticR . flip StaticRoute [])
|
|
|
|
ext
|
|
|
|
mime
|
|
|
|
content
|
2014-08-09 18:33:22 +00:00
|
|
|
where
|
|
|
|
-- Generate a unique filename based on the content itself
|
2014-12-23 04:01:53 +00:00
|
|
|
genFileName lbs = "autogen-" ++ base64md5 lbs
|
2014-08-09 18:33:22 +00:00
|
|
|
|
2015-05-19 01:43:55 +00:00
|
|
|
-- Place Javascript at head so scripts become loaded before content
|
|
|
|
jsLoader _ = BottomOfHeadBlocking
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- What messages should be logged. The following includes all messages when
|
|
|
|
-- in development, and warnings and errors in production.
|
2014-12-23 04:01:53 +00:00
|
|
|
shouldLog app _source level =
|
|
|
|
appShouldLogAll (appSettings app)
|
|
|
|
|| level == LevelWarn
|
|
|
|
|| level == LevelError
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
makeLogger = return . appLogger
|
|
|
|
|
|
|
|
-- How to run database actions.
|
|
|
|
instance YesodPersist App where
|
2014-12-23 04:01:53 +00:00
|
|
|
type YesodPersistBackend App = SqlBackend
|
|
|
|
runDB action = do
|
|
|
|
master <- getYesod
|
|
|
|
runSqlPool action $ appConnPool master
|
2014-08-09 18:33:22 +00:00
|
|
|
instance YesodPersistRunner App where
|
2014-12-23 04:01:53 +00:00
|
|
|
getDBRunner = defaultGetDBRunner appConnPool
|
2014-08-09 18:33:22 +00:00
|
|
|
|
2014-08-12 12:37:31 +00:00
|
|
|
-- instance YesodAuth App where
|
|
|
|
-- type AuthId App = UserId
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- Where to send a user after successful login
|
2014-08-12 12:37:31 +00:00
|
|
|
-- loginDest _ = HomeR
|
2014-08-09 18:33:22 +00:00
|
|
|
-- Where to send a user after logout
|
2014-08-12 12:37:31 +00:00
|
|
|
-- logoutDest _ = HomeR
|
|
|
|
|
|
|
|
-- getAuthId creds = runDB $ do
|
|
|
|
-- x <- getBy $ UniqueUser $ credsIdent creds
|
|
|
|
-- case x of
|
|
|
|
-- Just (Entity uid _) -> return $ Just uid
|
|
|
|
-- Nothing -> do
|
|
|
|
-- fmap Just $ insert User
|
|
|
|
-- { userIdent = credsIdent creds
|
|
|
|
-- , userPassword = Nothing
|
|
|
|
-- }
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- You can add other plugins like BrowserID, email or OAuth here
|
2014-08-12 12:37:31 +00:00
|
|
|
-- authPlugins _ = [authBrowserId def]
|
2014-08-09 18:33:22 +00:00
|
|
|
|
2014-08-12 12:37:31 +00:00
|
|
|
-- authHttpManager = httpManager
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
|
|
-- | Get the 'Extra' value, used to hold data from the settings.yml file.
|
2014-12-23 04:01:53 +00:00
|
|
|
-- getExtra :: Handler Extra
|
|
|
|
-- getExtra = fmap (appExtra . settings) getYesod
|
2014-08-09 18:33:22 +00:00
|
|
|
|
|
|
|
-- Note: previous versions of the scaffolding included a deliver function to
|
|
|
|
-- send emails. Unfortunately, there are too many different options for us to
|
|
|
|
-- give a reasonable default. Instead, the information is available on the
|
|
|
|
-- wiki:
|
|
|
|
--
|
|
|
|
-- https://github.com/yesodweb/yesod/wiki/Sending-email
|