gonito/Foundation.hs

307 lines
12 KiB
Haskell
Raw Normal View History

2018-05-20 16:58:48 +02:00
{-# LANGUAGE InstanceSigs #-}
2015-08-20 22:33:38 +02:00
module Foundation where
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Import.NoFoundation
import Text.Hamlet (hamletFile)
import Yesod.Auth.HashDB (HashDBUser(..), authHashDBWithForm)
2015-08-20 22:33:38 +02:00
import qualified Yesod.Core.Unsafe as Unsafe
import Yesod.Core.Types (Logger)
import Yesod.Default.Util (addStaticContentExternal)
2019-10-05 14:04:24 +02:00
import Text.Blaze.Internal (MarkupM)
2016-12-03 14:14:39 +01:00
instance HashDBUser User where
userPasswordHash = userPassword
setPasswordHash h u = u { userPassword = Just h }
2015-08-20 22:33:38 +02: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
2015-08-29 18:24:01 +02:00
, jobs :: TVar (IntMap (TChan (Maybe Text)))
, nextJob :: TVar Int
2015-08-20 22:33:38 +02:00
}
instance HasHttpManager App where
getHttpManager = appHttpManager
-- 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.
--
-- This function also generates the following type synonyms:
-- type Handler = HandlerT App IO
-- type Widget = WidgetT App IO ()
mkYesodData "App" $(parseRoutesFile "config/routes")
2015-08-29 07:23:34 +02:00
mkMessage "App" "messages" "en"
2015-08-20 22:33:38 +02:00
-- | A convenient synonym for creating forms.
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
2015-08-20 22:33:38 +02:00
2018-09-20 13:02:07 +02:00
-- | A convenient synonym for database access functions.
type DB a = forall (m :: * -> *).
(MonadIO m) => ReaderT SqlBackend m a
isTrustedAuthorized :: (AuthEntity (HandlerSite m) ~ User, AuthId (HandlerSite m) ~ Key User, MonadHandler m, YesodAuthPersist (HandlerSite m)) => m AuthResult
2015-08-27 22:44:17 +02:00
isTrustedAuthorized = do
mauth <- maybeAuth
case mauth of
Nothing -> return AuthenticationRequired
Just (Entity _ user)
| isTrusted user -> return Authorized
| otherwise -> return $ Unauthorized "???"
isAdmin :: (AuthEntity (HandlerSite m) ~ User, AuthId (HandlerSite m) ~ Key User, MonadHandler m, YesodAuthPersist (HandlerSite m)) => m AuthResult
2017-02-18 10:26:02 +01:00
isAdmin = do
mauth <- maybeAuth
case mauth of
Nothing -> return AuthenticationRequired
Just (Entity _ user)
| userIsAdmin user -> return Authorized
| otherwise -> return $ Unauthorized "only permitted for the admin"
2015-08-27 22:44:17 +02:00
isTrusted :: User -> Bool
isTrusted user =
case userIdent user of
"ptlen@ceti.pl" -> True
2015-10-06 22:56:57 +02:00
_ -> True
2015-08-27 22:44:17 +02:00
2019-10-05 14:04:24 +02:00
data LayoutCustomization = LayoutCustomization {
layoutCustomizationBanner :: Maybe Text,
layoutCustomizationRightPanel :: Maybe (WidgetFor App ())
}
instance Default LayoutCustomization where
def = LayoutCustomization {
layoutCustomizationBanner = Nothing,
layoutCustomizationRightPanel = Nothing }
ourBanner :: Text -> LayoutCustomization
ourBanner banner = def {
layoutCustomizationBanner = Just ("/static/images/" <> banner <> ".jpg")
}
defaultCustomizableLayout :: ToWidget App a => LayoutCustomization -> a -> HandlerFor App (MarkupM ())
defaultCustomizableLayout customization widget = do
let mBanner = layoutCustomizationBanner customization
let mRightPanel = layoutCustomizationRightPanel customization
master <- getYesod
mmsg <- getMessage
-- 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.
maybeUser <- maybeAuth
pc <- widgetToPageContent $ do
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
2015-08-27 22:44:17 +02:00
2015-08-20 22:33:38 +02: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
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
approot = ApprootMaster $ appRoot . appSettings
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
2016-01-08 21:57:29 +01:00
makeSessionBackend app = Just <$> defaultClientSessionBackend
2015-08-20 22:33:38 +02:00
120 -- timeout in minutes
2016-01-08 21:57:29 +01:00
((appVarDir $ appSettings app) </> "config/client_session_key.aes")
2015-08-20 22:33:38 +02:00
2018-09-20 13:02:07 +02: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.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
2019-10-05 14:04:24 +02:00
defaultLayout widget = defaultCustomizableLayout def widget
2015-08-20 22:33:38 +02:00
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authentication.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
2020-03-17 20:45:10 +01:00
isAuthorized HomeR _ = regularAuthorization
isAuthorized (StaticR _) _ = return Authorized
2020-03-17 20:45:10 +01:00
isAuthorized QueryFormR _ = regularAuthorization
isAuthorized (QueryResultsR _) _ = regularAuthorization
isAuthorized ListChallengesR _ = regularAuthorization
isAuthorized (ViewVariantR _) _ = regularAuthorization
2016-03-14 21:24:33 +01:00
2020-03-17 20:45:10 +01:00
isAuthorized TagsR _ = regularAuthorization
isAuthorized AchievementsR _ = regularAuthorization
2017-10-20 09:24:36 +02:00
isAuthorized (EditAchievementR _) _ = isAdmin
2018-01-02 18:55:35 +01:00
isAuthorized ExtraPointsR _ = isAdmin
2017-02-19 14:05:56 +01:00
2020-03-17 20:45:10 +01:00
isAuthorized DashboardR _ = regularAuthorization
2020-03-17 20:45:10 +01:00
isAuthorized (ShowChallengeR _) _ = regularAuthorization
isAuthorized (ChallengeHowToR _) _ = regularAuthorization
isAuthorized (ChallengeReadmeR _) _ = regularAuthorization
isAuthorized (ChallengeAllSubmissionsR _) _ = regularAuthorization
isAuthorized (ChallengeGraphDataR _) _ = regularAuthorization
isAuthorized (ChallengeDiscussionR _) _ = regularAuthorization
isAuthorized (ChallengeDiscussionFeedR _) _ = regularAuthorization
2016-03-14 21:24:33 +01:00
2020-03-17 20:45:10 +01:00
isAuthorized Presentation4RealR _ = regularAuthorization
isAuthorized PresentationPSNC2019R _ = regularAuthorization
isAuthorized GonitoInClassR _ = regularAuthorization
isAuthorized WritingPapersWithGonitoR _ = regularAuthorization
2016-05-16 23:44:28 +02:00
2020-03-17 20:45:10 +01:00
isAuthorized (AvatarR _) _ = regularAuthorization
2016-05-03 12:29:56 +02:00
2017-09-28 11:29:48 +02:00
isAuthorized TriggerRemotelyR _ = return Authorized
2020-02-21 22:56:39 +01:00
isAuthorized (TriggerRemotelySimpleR _ _ _ _) _ = return Authorized
2017-09-28 16:11:22 +02:00
isAuthorized TriggerLocallyR _ = return Authorized
2017-09-28 11:29:48 +02:00
isAuthorized (OpenViewProgressR _) _ = return Authorized
2017-02-18 10:26:02 +01:00
isAuthorized CreateResetLinkR _ = isAdmin
2017-05-15 13:55:56 +02:00
isAuthorized (ScoreR _) _ = isAdmin
2019-03-20 16:31:08 +01:00
isAuthorized ListArchivedChallengesR _ = isAdmin
isAuthorized (ArchiveR _) _ = isAdmin
isAuthorized (UnarchiveR _) _ = isAdmin
2019-08-28 08:49:43 +02:00
isAuthorized (ChallengeUpdateR _) _ = isAdmin
2019-03-20 16:31:08 +01:00
2020-03-17 20:45:10 +01:00
isAuthorized MyScoreR _ = regularAuthorization
2017-05-15 13:55:56 +02:00
2017-02-18 10:26:02 +01:00
isAuthorized (ResetPasswordR _) _ = return Authorized
2020-03-17 20:45:10 +01:00
isAuthorized (ToggleSubmissionTagR _) _ = regularAuthorization
2017-05-28 10:06:50 +02:00
2020-03-17 20:45:10 +01:00
isAuthorized (ChallengeImageR _) _ = regularAuthorization
2017-02-18 10:26:02 +01:00
2019-11-30 20:47:19 +01:00
isAuthorized (ApiTxtScoreR _) _ = return Authorized
2018-01-25 16:34:05 +01:00
2020-03-17 20:45:10 +01:00
isAuthorized (ChallengeParamGraphDataR _ _ _) _ = regularAuthorization
isAuthorized (IndicatorGraphDataR _) _ = regularAuthorization
2018-07-26 22:01:21 +02:00
2015-08-20 22:33:38 +02:00
-- Default to Authorized for now.
2015-08-27 22:44:17 +02:00
isAuthorized _ _ = isTrustedAuthorized
2015-08-20 22:33:38 +02: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
Right
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
makeLogger = return . appLogger
2020-03-17 20:45:10 +01:00
regularAuthorization = do
app <- getYesod
mauth <- maybeAuth
return $ defaultStatus mauth $ appIsPublic (appSettings app)
where defaultStatus _ True = Authorized
defaultStatus mauth False = case mauth of
Just _ -> Authorized
Nothing -> AuthenticationRequired
2015-08-20 22:33:38 +02: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
-- Override the above two destinations when a Referer: header is present
redirectToReferer _ = True
2018-05-20 16:58:48 +02:00
authenticate :: (MonadHandler m, HandlerSite m ~ App)
=> Creds App -> m (AuthenticationResult App)
authenticate creds = liftHandler $ runDB $ do
2015-08-20 22:33:38 +02:00
x <- getBy $ UniqueUser $ credsIdent creds
2015-08-27 22:44:17 +02:00
Authenticated <$> case x of
Just (Entity uid _) -> return $ uid
Nothing ->
insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
2015-09-30 20:15:33 +02:00
, userName = Nothing
2015-10-06 22:56:57 +02:00
, userIsAdmin = False
, userLocalId = Nothing
2016-02-14 08:59:12 +01:00
, userIsAnonymous = False
2016-05-03 10:21:40 +02:00
, userAvatar = Nothing
2017-02-18 10:26:02 +01:00
, userVerificationKey = Nothing
, userKeyExpirationDate = Nothing
2017-09-28 11:29:48 +02:00
, userTriggerToken = Nothing
, userAltRepoScheme = Nothing
2015-08-27 22:44:17 +02:00
}
2015-08-20 22:33:38 +02:00
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins master = [authHashDBWithForm (myLoginForm master) (Just . UniqueUser)]
2015-08-20 22:33:38 +02:00
contactEmailLabel :: App -> Text
contactEmailLabel site =
case maybeContactMail of
Just contactMail -> " (" ++ contactMail ++ ")"
Nothing -> ""
where maybeContactMail = appContactEmail $ appSettings site
myLoginForm :: App -> Route site -> WidgetFor site ()
myLoginForm site action = $(whamletFile "templates/auth.hamlet")
2015-08-20 22:33:38 +02:00
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
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