eidolon/Foundation.hs

402 lines
14 KiB
Haskell
Raw Permalink Normal View History

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
2017-12-24 06:57:23 +00:00
{-# LANGUAGE FlexibleInstances, PackageImports #-}
2017-04-24 05:46:34 +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))
import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
2014-08-09 18:33:22 +00:00
import Settings.StaticFiles
import Settings
2014-08-12 16:14:59 +00:00
import Model
2017-08-06 02:42:31 +00:00
import Licence
2014-08-09 18:33:22 +00:00
import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile)
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
2017-04-24 05:46:34 +00:00
import Data.Maybe (fromJust)
2015-04-02 05:03:38 +00:00
import Network.Wai
2017-04-24 05:46:34 +00:00
import Helper hiding (hmacKeccak)
import Yesod.Auth
import Yesod.Auth.HmacKeccak
2017-12-24 06:57:23 +00:00
import "yesod-auth-hmac-keccak" Yesod.Auth.Types (gimmeFile)
import "yesod-auth-hmac-keccak" Yesod.Auth.Message as Auth
import Yesod.Form.Bootstrap3
2017-04-24 05:46:34 +00:00
import System.IO.Unsafe (unsafePerformIO)
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
{ 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
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")
2018-03-20 08:45:39 +00:00
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
2014-08-09 18:33:22 +00:00
renderLayout :: Widget -> Handler Html
renderLayout widget = do
master <- getYesod
2015-08-18 21:57:50 +00:00
route <- getCurrentRoute
mmsg <- getMessage
2017-04-24 05:46:34 +00:00
-- msu <- lookupSession "userId"
musername <- maybeAuthId
slug <- case musername of
Just name -> do
user <- runDB $ getBy $ UniqueUser name
return $ userSlug $ entityVal $ fromJust user
2016-03-02 08:49:48 +00:00
Nothing ->
return ("" :: T.Text)
2017-04-24 05:46:34 +00:00
admin <- case musername of
Just name -> do
user <- runDB $ getBy $ UniqueUser name
return $ userAdmin $ entityVal $ fromJust user
2016-07-12 20:07:44 +00:00
Nothing ->
2017-04-24 05:46:34 +00:00
return False
2015-09-14 16:54:46 +00:00
let block = appSignupBlocked $ appSettings master
-- 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-20 16:49:37 +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();}
|]
wc <- widgetToPageContent widget
pc <- widgetToPageContent $ do
2016-09-05 14:01:49 +00:00
mapM_ addScript $ map StaticR
[ js_picturefill_js
2017-04-24 05:46:34 +00:00
, js_jquery_min_js
2016-09-05 14:01:49 +00:00
]
2016-08-30 12:22:00 +00:00
mapM_ addStylesheet $ map StaticR
[ css_bootstrap_min_css
, css_main_css
]
$(widgetFile "default-layout")
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 =
2017-04-24 05:46:34 +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
-- 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.
2017-04-26 19:43:22 +00:00
authRoute _ = Just $ AuthR LoginR
isAuthorized AdminR _ = getAdminAuth
2017-08-13 21:03:48 +00:00
isAuthorized AdminRepopThumbsR _ = getAdminAuth
2017-04-26 19:43:22 +00:00
isAuthorized AdminProfilesR _ = getAdminAuth
isAuthorized (AdminProfileSettingsR _) _ = getAdminAuth
isAuthorized (AdminUserAlbumsR _) _ = getAdminAuth
isAuthorized (AdminUserMediaR _) _ = getAdminAuth
isAuthorized (AdminProfileDeleteR _) _ = getAdminAuth
isAuthorized AdminAlbumsR _ = getAdminAuth
isAuthorized (AdminAlbumSettingsR _) _ = getAdminAuth
isAuthorized (AdminAlbumMediaR _) _ = getAdminAuth
isAuthorized (AdminAlbumDeleteR _) _ = getAdminAuth
isAuthorized AdminMediaR _ = getAdminAuth
isAuthorized (AdminMediumSettingsR _) _ = getAdminAuth
isAuthorized (AdminMediumDeleteR _) _ = getAdminAuth
isAuthorized AdminCommentR _ = getAdminAuth
isAuthorized (AdminCommentDeleteR _) _ = getAdminAuth
isAuthorized _ _ = return Authorized
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.
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
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.
2018-03-19 20:57:42 +00:00
-- shouldLog app _source level =
-- appShouldLogAll (appSettings app)
-- || level == LevelWarn
-- || level == LevelError
2014-08-09 18:33:22 +00:00
makeLogger = return . appLogger
2017-04-26 19:43:22 +00:00
getAdminAuth = do
musername <- maybeAuthId
case musername of
Nothing -> return AuthenticationRequired
Just un -> do
muser <- runDB $ getBy $ UniqueUser un
return $ case muser of
Just (Entity _ u)
| isAdmin u -> Authorized
| otherwise -> Unauthorized "You are not authorized"
Nothing -> AuthenticationRequired
isAdmin = userAdmin
2014-08-09 18:33:22 +00:00
-- How to run database actions.
instance YesodPersist App where
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
getDBRunner = defaultGetDBRunner appConnPool
2014-08-09 18:33:22 +00:00
2017-04-24 05:46:34 +00:00
instance YesodAuth App where
type AuthId App = Username
2014-08-09 18:33:22 +00:00
2017-04-24 05:46:34 +00:00
-- Where to send a user after successful login
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest _ = HomeR
2014-08-12 12:37:31 +00:00
2017-04-24 05:46:34 +00:00
getAuthId = return . Just . credsIdent
2014-08-09 18:33:22 +00:00
2017-04-24 05:46:34 +00:00
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [hmacPlugin]
2014-08-09 18:33:22 +00:00
2017-04-24 05:46:34 +00:00
authHttpManager = error "no HttpManager needed"
maybeAuthId = lookupSession credsKey
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.
-- 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
2017-04-24 05:46:34 +00:00
instance YesodHmacKeccak (HmacPersistDB App User Token) App where
2018-03-20 08:45:39 +00:00
runHmacDB = liftHandler . runHmacPersistDB
2017-04-26 19:43:22 +00:00
rawLoginRoute = Just LoginRawR
2017-12-24 06:57:23 +00:00
getNewAccountR = do
2018-03-20 08:45:39 +00:00
master <- getYesod
tm <- getRouteToParent
2017-12-24 06:57:23 +00:00
if not (appSignupBlocked $ appSettings master)
then do
tm <- getRouteToParent
2018-03-20 08:45:39 +00:00
authLayout $ do
((_, widget), enctype) <- runFormPost $
2017-12-24 06:57:23 +00:00
renderBootstrap3 BootstrapBasicForm $ eidolonAccountForm
(appTos1 $ appSettings master)
(appTos2 $ appSettings master)
render <- getUrlRenderParams
toWidgetHead $ gimmeFile render
setTitleI MsgRegisterLong
[whamlet|
<div .newaccount>
<form method="post" enctype=#{enctype} action=@{tm newAccountR}>
^{widget}
|]
else do
setMessage "User signup has been disabled"
2018-03-20 08:45:39 +00:00
redirect (tm LoginR)
2017-12-24 06:57:23 +00:00
postNewAccountR = do
2018-03-20 08:45:39 +00:00
tm <- getRouteToParent
master <- getYesod
2017-12-24 06:57:23 +00:00
if not (appSignupBlocked $ appSettings master)
then do
tm <- getRouteToParent
2018-03-20 08:45:39 +00:00
((result, _), _) <- runFormPost $
2017-12-24 06:57:23 +00:00
renderBootstrap3 BootstrapBasicForm $ eidolonAccountForm
(appTos1 $ appSettings master)
(appTos2 $ appSettings master)
case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure m -> do
2018-03-20 08:45:39 +00:00
setMessage $ toHtml $ T.concat m
redirect (tm newAccountR)
2017-12-24 06:57:23 +00:00
FormSuccess d -> do
case (eadTos1 d, eadTos2 d) of
(Just True, Just True) -> do
2018-03-20 08:45:39 +00:00
setMessageI MsgActivationSent
createNewAccount
2017-12-24 06:57:23 +00:00
(NewAccountData (eadUsername d) (eadEmail d))
2018-03-20 08:45:39 +00:00
redirect (tm LoginR)
2017-12-24 06:57:23 +00:00
_ -> do
2018-03-20 08:45:39 +00:00
setMessage "Please Accept the Terms of Service"
redirect (tm newAccountR)
2017-12-24 06:57:23 +00:00
else do
2018-03-20 08:45:39 +00:00
setMessage "User signup has been disabled"
redirect (tm LoginR)
2017-12-24 06:57:23 +00:00
data EidolonAccountData = EidolonAccountData
{ eadUsername :: T.Text
, eadEmail :: T.Text
, eadTos1 :: Maybe Bool
, eadTos2 :: Maybe Bool
}
eidolonAccountForm tos1 tos2= EidolonAccountData
<$> areq (checkM checkValidUsername textField) userSettings Nothing
<*> areq emailField emailSettings Nothing
<*> aopt checkBoxField (tosSettings tos1) Nothing
<*> aopt checkBoxField (tosSettings tos2) Nothing
<* bootstrapSubmit ("Sign up" :: BootstrapSubmit T.Text)
where
userSettings = bfs (SomeMessage MsgUsername)
emailSettings = bfs (SomeMessage MsgEmail)
tosSettings t = bfs (SomeMessage t)
2017-04-24 05:46:34 +00:00
instance UserCredentials (Entity User) where
userUserName = userName . entityVal
userUserSalt = userSalt . entityVal
userUserSalted = userSalted . entityVal
userUserEmail = userEmail . entityVal
userUserActive = userActive . entityVal
instance TokenData (Entity Token) where
tokenTokenKind = tokenKind . entityVal
tokenTokenUsername = tokenUsername . entityVal
tokenTokenToken = tokenToken . entityVal
instance PersistUserCredentials User where
userUsernameF = UserName
userUserSaltF = UserSalt
userUserSaltedF = UserSalted
userUserEmailF = UserEmail
userUserActiveF = UserActive
uniqueUsername = UniqueUser
2017-08-06 02:42:31 +00:00
userCreate name email salt = User name name email salt "" [] False AllRightsReserved False
2017-04-24 05:46:34 +00:00
instance PersistToken Token where
tokenTokenTokenF = TokenToken
tokenTokenKindF = TokenKind
tokenTokenUsernameF = TokenUsername
uniqueToken = UniqueToken
tokenCreate t u k = Token t k u
instance HmacSendMail App where
sendVerifyEmail username email url =
sendMail email "Please activate your account!" $
[shamlet|
<h1>Hello #{username} and welcome to Eidolon!
To complete your signup process, please activate your account by visiting the
following link:
<a href=#{url}>#{url}
See you soon!
|]
sendReactivateEmail username email url = do
2018-03-20 08:45:39 +00:00
muser <- runHmacDB $ loadUser username
2017-04-24 05:46:34 +00:00
let user = entityVal $ fromJust muser
sendMail email "Reset your password" $
[shamlet|
<h1>Welcome again to Eidolon #{userSlug user}
To reset your password visit the following link:
<a href=#{url}>#{url}
See you soon!
|]