mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-07 21:16:45 +09:00
5862b03019
I suppose there's no performance difference in using one, but it requires `http-conduit` as a build dependency, so potentially we may be reducing build time by removing unnecessary deps.
742 lines
34 KiB
Haskell
742 lines
34 KiB
Haskell
{- This file is part of Vervis.
|
||
-
|
||
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
|
||
-
|
||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||
-
|
||
- The author(s) have dedicated all copyright and related and neighboring
|
||
- rights to this software to the public domain worldwide. This software is
|
||
- distributed without any warranty.
|
||
-
|
||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||
- with this software. If not, see
|
||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||
-}
|
||
|
||
module Vervis.Foundation where
|
||
|
||
import Prelude (init, last)
|
||
|
||
import Control.Monad.Logger (logWarn)
|
||
import Control.Monad.Trans.Maybe
|
||
import Data.Time.Interval (fromTimeUnit, toTimeUnit)
|
||
import Data.Time.Units (Minute, Day)
|
||
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||
import Graphics.SVGFonts.ReadFont (PreparedFont)
|
||
import Text.Shakespeare.Text (textFile)
|
||
import Text.Hamlet (hamletFile)
|
||
--import Text.Jasmine (minifym)
|
||
import Yesod.Auth.Account
|
||
import Yesod.Auth.Account.Message (AccountMsg (MsgUsernameExists))
|
||
import Yesod.Auth.Message (AuthMessage (IdentifierNotFound))
|
||
import Yesod.Core.Types (Logger)
|
||
import Yesod.Default.Util (addStaticContentExternal)
|
||
|
||
import Text.Email.Local
|
||
|
||
import Yesod.Auth.Unverified
|
||
import Yesod.Auth.Unverified.Creds
|
||
import Yesod.Mail.Send
|
||
|
||
import qualified Yesod.Core.Unsafe as Unsafe
|
||
--import qualified Data.CaseInsensitive as CI
|
||
import Data.Text as T (pack, intercalate, concat)
|
||
--import qualified Data.Text.Encoding as TE
|
||
|
||
import Text.Jasmine.Local (discardm)
|
||
import Vervis.Import.NoFoundation hiding (Handler, Day, last, init)
|
||
import Vervis.Model.Group
|
||
import Vervis.Model.Ident
|
||
import Vervis.Model.Role
|
||
import Vervis.Query (getProjectRoleAncestorWithOpQ)
|
||
import Vervis.Widget (breadcrumbsW, revisionW)
|
||
|
||
-- | 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
|
||
, appMailQueue :: Maybe (Chan (MailRecipe App))
|
||
, appSvgFont :: PreparedFont Double
|
||
}
|
||
|
||
-- 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 a = Html -> MForm (HandlerT App IO) (FormResult a, Widget)
|
||
|
||
type AppDB = YesodDB App
|
||
|
||
-- 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 = ApprootRequest $ \app req ->
|
||
case appRoot $ appSettings app of
|
||
Nothing -> getApprootText guessApproot app req
|
||
Just root -> root
|
||
|
||
-- Store session data on the client in encrypted cookies,
|
||
-- default session idle timeout is 120 minutes
|
||
makeSessionBackend app =
|
||
-- sslOnlySessions $
|
||
let s = appSettings app
|
||
t = fromIntegral (toTimeUnit $ appClientSessionTimeout s :: Minute)
|
||
k = appClientSessionKeyFile s
|
||
in Just <$> defaultClientSessionBackend t k
|
||
|
||
-- 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.
|
||
-- The defaultCsrfMiddleware:
|
||
-- 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.
|
||
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
|
||
yesodMiddleware
|
||
-- sslOnlyMiddleware 120 .
|
||
= defaultCsrfSetCookieMiddleware
|
||
. (\ handler ->
|
||
csrfCheckMiddleware
|
||
handler
|
||
(getCurrentRoute >>= \ mr -> case mr of
|
||
Nothing -> return False
|
||
Just (GitUploadRequestR _ _) -> return False
|
||
Just r -> isWriteRequest r
|
||
)
|
||
defaultCsrfHeaderName
|
||
defaultCsrfParamName
|
||
)
|
||
. defaultYesodMiddleware
|
||
|
||
defaultLayout widget = do
|
||
master <- getYesod
|
||
mmsg <- getMessage
|
||
mperson <- maybeAuth
|
||
(title, bcs) <- breadcrumbs
|
||
|
||
-- 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.
|
||
|
||
pc <- widgetToPageContent $ do
|
||
setTitle $ toHtml $
|
||
T.intercalate " → " (map snd bcs) <> " → " <> title
|
||
$(widgetFile "default-layout")
|
||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||
|
||
-- The page to be redirected to when authentication is required.
|
||
authRoute _ = Just $ AuthR LoginR
|
||
|
||
-- Who can access which pages.
|
||
isAuthorized r w = case (r, w) of
|
||
(AuthR a , True)
|
||
| a == resendVerifyR -> personFromResendForm
|
||
(AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
|
||
|
||
(GroupsR , True) -> personAny
|
||
(GroupNewR , _ ) -> personAny
|
||
(GroupMembersR grp , True) -> groupAdmin grp
|
||
(GroupMemberNewR grp , _ ) -> groupAdmin grp
|
||
(GroupMemberR grp _memb , True) -> groupAdmin grp
|
||
|
||
(KeysR , _ ) -> personAny
|
||
(KeyR _key , _ ) -> personAny
|
||
(KeyNewR , _ ) -> personAny
|
||
|
||
(ClaimRequestsPersonR , _ ) -> personAny
|
||
|
||
(RepoRolesR shr , _ ) -> personOrGroupAdmin shr
|
||
(RepoRoleNewR shr , _ ) -> personOrGroupAdmin shr
|
||
(RepoRoleR shr _rl , _ ) -> personOrGroupAdmin shr
|
||
(RepoRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
|
||
(RepoRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
|
||
|
||
(ProjectRolesR shr , _ ) -> personOrGroupAdmin shr
|
||
(ProjectRoleNewR shr , _ ) -> personOrGroupAdmin shr
|
||
(ProjectRoleR shr _rl , _ ) -> personOrGroupAdmin shr
|
||
(ProjectRoleOpsR shr _rl , _ ) -> personOrGroupAdmin shr
|
||
(ProjectRoleOpNewR shr _rl , _ ) -> personOrGroupAdmin shr
|
||
|
||
(ReposR shr , True) -> personOrGroupAdmin shr
|
||
(RepoNewR shr , _ ) -> personOrGroupAdmin shr
|
||
(RepoR shar _ , True) -> person shar
|
||
(RepoEditR shr _rp , _ ) -> person shr
|
||
(RepoDevsR shr _rp , _ ) -> person shr
|
||
(RepoDevNewR shr _rp , _ ) -> person shr
|
||
(RepoDevR shr _rp _dev , _ ) -> person shr
|
||
|
||
(ProjectsR shr , True) -> personOrGroupAdmin shr
|
||
(ProjectNewR shr , _ ) -> personOrGroupAdmin shr
|
||
(ProjectR shr _prj , True) -> person shr
|
||
(ProjectEditR shr _prj , _ ) -> person shr
|
||
(ProjectDevsR shr _prj , _ ) -> person shr
|
||
(ProjectDevNewR shr _prj , _ ) -> person shr
|
||
(ProjectDevR shr _prj _dev , _ ) -> person shr
|
||
|
||
-- (GlobalWorkflowsR , _ ) -> serverAdmin
|
||
-- (GlobalWorkflowNewR , _ ) -> serverAdmin
|
||
-- (GlobalWorkflowR _wfl , _ ) -> serverAdmin
|
||
|
||
(WorkflowsR shr , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowNewR shr , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowR shr _wfl , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowFieldsR shr _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowFieldNewR shr _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowFieldR shr _ _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowEnumsR shr _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowEnumNewR shr _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowEnumR shr _ _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowEnumCtorsR shr _ _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowEnumCtorNewR shr _ _ , _ ) -> personOrGroupAdmin shr
|
||
(WorkflowEnumCtorR shr _ _ _ , _ ) -> personOrGroupAdmin shr
|
||
|
||
(TicketsR s j , True) -> projOp ProjOpOpenTicket s j
|
||
(TicketNewR s j , _ ) -> projOp ProjOpOpenTicket s j
|
||
(TicketR user _ _ , True) -> person user
|
||
(TicketEditR user _ _ , _ ) -> person user
|
||
(TicketAcceptR s j _ , _ ) -> projOp ProjOpAcceptTicket s j
|
||
(TicketCloseR s j _ , _ ) -> projOp ProjOpCloseTicket s j
|
||
(TicketOpenR s j _ , _ ) -> projOp ProjOpReopenTicket s j
|
||
(TicketClaimR s j _ , _ ) -> projOp ProjOpClaimTicket s j
|
||
(TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j
|
||
(TicketAssignR s j _ , _ ) -> projOp ProjOpAssignTicket s j
|
||
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
|
||
(ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
|
||
(ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j
|
||
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
|
||
(TicketDiscussionR _ _ _ , True) -> personAny
|
||
(TicketMessageR _ _ _ _ , True) -> personAny
|
||
(TicketTopReplyR _ _ _ , _ ) -> personAny
|
||
(TicketReplyR _ _ _ _ , _ ) -> personAny
|
||
(TicketDepsR s j _ , True) -> projOp ProjOpAddTicketDep s j
|
||
(TicketDepNewR s j _ , _ ) -> projOp ProjOpAddTicketDep s j
|
||
(TicketDepR s j _ _ , True) -> projOp ProjOpRemoveTicketDep s j
|
||
_ -> return Authorized
|
||
where
|
||
nobody :: Handler AuthResult
|
||
nobody = return $ Unauthorized "This operation is currently disabled"
|
||
|
||
serverAdmin :: Handler AuthResult
|
||
serverAdmin = nobody
|
||
|
||
personAnd
|
||
:: (Entity Person -> Handler AuthResult) -> Handler AuthResult
|
||
personAnd f = do
|
||
mp <- maybeAuth
|
||
case mp of
|
||
Nothing -> return AuthenticationRequired
|
||
Just p -> f p
|
||
|
||
personUnverifiedAnd
|
||
:: (Entity Person -> Handler AuthResult) -> Handler AuthResult
|
||
personUnverifiedAnd f = do
|
||
mp <- maybeUnverifiedAuth
|
||
case mp of
|
||
Nothing -> return AuthenticationRequired
|
||
Just p -> f p
|
||
|
||
personAny :: Handler AuthResult
|
||
personAny = personAnd $ \ _p -> return Authorized
|
||
|
||
person :: ShrIdent -> Handler AuthResult
|
||
person ident = personAnd $ \ (Entity _ p) -> do
|
||
let sid = personIdent p
|
||
sharer <- runDB $ getJust sid
|
||
return $ if ident == sharerIdent sharer
|
||
then Authorized
|
||
else Unauthorized "No access to this operation"
|
||
|
||
personUnver :: Text -> Handler AuthResult
|
||
personUnver uname = personUnverifiedAnd $ \ p ->
|
||
if username p == uname
|
||
then return Authorized
|
||
else do
|
||
$logWarn $ T.concat
|
||
[ "User ", username p, " tried to verify user ", uname
|
||
]
|
||
return $ Unauthorized "You can't verify other users"
|
||
|
||
personFromResendForm :: Handler AuthResult
|
||
personFromResendForm = personUnverifiedAnd $ \ p -> do
|
||
((result, _), _) <-
|
||
runFormPost $ renderDivs $ resendVerifyEmailForm ""
|
||
case result of
|
||
FormSuccess uname ->
|
||
if username p == uname
|
||
then return Authorized
|
||
else do
|
||
$logWarn $ T.concat
|
||
[ "User ", username p, " tried to POST to \
|
||
\verification email resend for user ", uname
|
||
]
|
||
return $
|
||
Unauthorized
|
||
"You can't do that for other users"
|
||
_ -> do
|
||
$logWarn $ T.concat
|
||
[ "User ", username p, " tried to POST to \
|
||
\verification email resend for invalid username"
|
||
]
|
||
return $
|
||
Unauthorized "Requesting resend for invalid username"
|
||
|
||
groupRole :: (GroupRole -> Bool) -> ShrIdent -> Handler AuthResult
|
||
groupRole role grp = personAnd $ \ (Entity pid _p) -> runDB $ do
|
||
Entity sid _s <- getBy404 $ UniqueSharer grp
|
||
Entity gid _g <- getBy404 $ UniqueGroup sid
|
||
mem <- getBy $ UniqueGroupMember pid gid
|
||
let mrole = groupMemberRole . entityVal <$> mem
|
||
return $ case mrole of
|
||
Nothing -> Unauthorized "Not a member of the group"
|
||
Just r ->
|
||
if role r
|
||
then Authorized
|
||
else Unauthorized "Not the expected group role"
|
||
|
||
groupAdmin :: ShrIdent -> Handler AuthResult
|
||
groupAdmin = groupRole (== GRAdmin)
|
||
|
||
personOrGroupAdmin :: ShrIdent -> Handler AuthResult
|
||
personOrGroupAdmin shr = personAnd $ \ (Entity vpid _vp) -> runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
mep <- getBy $ UniquePersonIdent sid
|
||
case mep of
|
||
Just (Entity pid _p) ->
|
||
return $ if pid == vpid
|
||
then Authorized
|
||
else Unauthorized "Can’t access other people’s roles"
|
||
Nothing -> do
|
||
meg <- getBy $ UniqueGroup sid
|
||
case meg of
|
||
Nothing -> do
|
||
$logWarn $
|
||
"Found non-person non-group sharer: " <>
|
||
shr2text shr
|
||
return $ error "Zombie sharer"
|
||
Just (Entity gid _g) -> do
|
||
mem <- getBy $ UniqueGroupMember vpid gid
|
||
return $ case mem of
|
||
Nothing -> Unauthorized "Not a group member"
|
||
Just (Entity _mid m) ->
|
||
if groupMemberRole m == GRAdmin
|
||
then Authorized
|
||
else Unauthorized "Not a group admin"
|
||
|
||
projOp
|
||
:: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult
|
||
projOp op shr prj = personAnd $ \ (Entity pid _p) -> do
|
||
ma <- runDB $ runMaybeT $ do
|
||
Entity sid _s <- MaybeT $ getBy $ UniqueSharer shr
|
||
Entity jid _j <- MaybeT $ getBy $ UniqueProject prj sid
|
||
let asCollab = do
|
||
Entity _cid c <-
|
||
MaybeT $ getBy $ UniqueProjectCollab jid pid
|
||
return $ projectCollabRole c
|
||
asUser = do
|
||
Entity _cuid cu <-
|
||
MaybeT $ getBy $ UniqueProjectCollabUser jid
|
||
return $ projectCollabUserRole cu
|
||
role <- asCollab <|> asUser
|
||
let roleHas = getBy $ UniqueProjectAccess role op
|
||
ancestorHas = getProjectRoleAncestorWithOpQ op role
|
||
MaybeT roleHas <|> MaybeT ancestorHas
|
||
return $ case ma of
|
||
Nothing ->
|
||
Unauthorized
|
||
"You need a project role with that operation enabled"
|
||
Just _ -> Authorized
|
||
|
||
-- 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
|
||
discardm
|
||
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.
|
||
shouldLogIO app _source level = pure $
|
||
appShouldLogAll (appSettings app)
|
||
|| level == LevelWarn
|
||
|| level == LevelError
|
||
|
||
makeLogger = return . appLogger
|
||
|
||
-- 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 YesodMailSend App where
|
||
data MailMessage App
|
||
= MailVerifyAccount (Route App)
|
||
| MailResetPassphrase (Route App)
|
||
formatMailMessage _reply _mname msg =
|
||
case msg of
|
||
MailVerifyAccount url ->
|
||
( "Verify your Vervis account"
|
||
, $(textFile "templates/person/email/verify-account.md")
|
||
)
|
||
MailResetPassphrase url ->
|
||
( "Reset your Vervis passphrase"
|
||
, $(textFile "templates/person/email/reset-passphrase.md")
|
||
)
|
||
getMailSettings = getsYesod $ appMail . appSettings
|
||
getSubmitMail = do
|
||
mchan <- getsYesod appMailQueue
|
||
case mchan of
|
||
Nothing -> return Nothing
|
||
Just chan -> return $ Just $ liftIO . writeChan chan
|
||
|
||
instance YesodAuth App where
|
||
type AuthId App = PersonId
|
||
|
||
-- 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
|
||
|
||
authenticate creds = liftHandler $ do
|
||
let ident = credsIdent creds
|
||
mpid <- runDB $ getBy $ UniquePersonLogin $ credsIdent creds
|
||
return $ case mpid of
|
||
Nothing -> UserError $ IdentifierNotFound ident
|
||
Just (Entity pid _) -> Authenticated pid
|
||
|
||
-- You can add other plugins like BrowserID, email or OAuth here
|
||
authPlugins _ = [accountPlugin]
|
||
|
||
authHttpManager = error "authHttpManager"
|
||
|
||
onLogout = clearUnverifiedCreds False
|
||
|
||
instance YesodAuthPersist App
|
||
|
||
newtype AccountPersistDB' a = AccountPersistDB'
|
||
{ unAccountPersistDB' :: Handler a
|
||
}
|
||
deriving (Functor, Applicative, Monad, MonadIO)
|
||
|
||
morphAPDB :: AccountPersistDB App Person a -> AccountPersistDB' a
|
||
morphAPDB = AccountPersistDB' . runAccountPersistDB
|
||
|
||
instance AccountDB AccountPersistDB' where
|
||
type UserAccount AccountPersistDB' = Entity Person
|
||
|
||
loadUser = morphAPDB . loadUser
|
||
loadUserByEmailAddress = morphAPDB . loadUserByEmailAddress
|
||
|
||
addNewUser name email key pwd = AccountPersistDB' $ runDB $ do
|
||
now <- liftIO getCurrentTime
|
||
let sharer = Sharer
|
||
{ sharerIdent = text2shr name
|
||
, sharerName = Nothing
|
||
, sharerCreated = now
|
||
}
|
||
msid <- insertBy sharer
|
||
case msid of
|
||
Left _ -> do
|
||
mr <- getMessageRender
|
||
return $ Left $ mr $ MsgUsernameExists name
|
||
Right sid -> do
|
||
let defTime = UTCTime (ModifiedJulianDay 0) 0
|
||
person = Person sid name pwd email False key now "" defTime
|
||
pid <- insert person
|
||
return $ Right $ Entity pid person
|
||
|
||
verifyAccount = morphAPDB . verifyAccount
|
||
setVerifyKey = (morphAPDB .) . setVerifyKey
|
||
setNewPasswordKey = (morphAPDB .) . setNewPasswordKey
|
||
setNewPassword = (morphAPDB .) . setNewPassword
|
||
|
||
instance AccountSendEmail App where
|
||
sendVerifyEmail uname email url = do
|
||
sent <- sendMail (Address (Just uname) email) (MailVerifyAccount url)
|
||
unless sent $ do
|
||
setMessage "Mail sending disabled, please contact admin"
|
||
ur <- getUrlRender
|
||
$logWarn $ T.concat
|
||
[ "Verification email NOT SENT for user "
|
||
, uname, " <", emailText email, ">: "
|
||
, ur url
|
||
]
|
||
sendNewPasswordEmail uname email url = do
|
||
sent <- sendMail (Address (Just uname) email) (MailResetPassphrase url)
|
||
unless sent $ do
|
||
setMessage "Mail sending disabled, please contact admin"
|
||
ur <- getUrlRender
|
||
$logWarn $ T.concat
|
||
["Password reset email NOT SENT for user "
|
||
, uname, " <", emailText email, ">: "
|
||
, ur url
|
||
]
|
||
|
||
instance YesodAuthVerify App where
|
||
verificationRoute _ = ResendVerifyEmailR
|
||
|
||
instance YesodAuthAccount AccountPersistDB' App where
|
||
emailVerifyKeyDuration _ = Just $ fromTimeUnit (1 :: Day)
|
||
passphraseResetKeyDuration _ = Just $ fromTimeUnit (1 :: Day)
|
||
allowLoginByEmailAddress _ = True
|
||
runAccountDB = unAccountPersistDB'
|
||
unregisteredLogin u = do
|
||
setUnverifiedCreds True $ Creds "account" (username u) []
|
||
return mempty
|
||
|
||
-- 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
|
||
|
||
instance YesodBreadcrumbs App where
|
||
breadcrumb route = return $ case route of
|
||
StaticR _ -> ("", Nothing)
|
||
FaviconR -> ("", Nothing)
|
||
RobotsR -> ("", Nothing)
|
||
|
||
HomeR -> ("Home", Nothing)
|
||
ResendVerifyEmailR -> ( "Resend verification email"
|
||
, Nothing
|
||
)
|
||
AuthR _ -> ("Auth", Nothing)
|
||
|
||
SharersR -> ("Sharers", Just HomeR)
|
||
SharerR shar -> (shr2text shar, Just SharersR)
|
||
|
||
PeopleR -> ("People", Just HomeR)
|
||
PersonNewR -> ("New", Just PeopleR)
|
||
PersonR shar -> (shr2text shar, Just PeopleR)
|
||
|
||
GroupsR -> ("Groups", Just HomeR)
|
||
GroupNewR -> ("New", Just GroupsR)
|
||
GroupR shar -> (shr2text shar, Just GroupsR)
|
||
GroupMembersR shar -> ("Members", Just $ GroupR shar)
|
||
GroupMemberNewR shar -> ("New", Just $ GroupMembersR shar)
|
||
GroupMemberR grp memb -> ( shr2text memb
|
||
, Just $ GroupMembersR grp
|
||
)
|
||
|
||
KeysR -> ("Keys", Just HomeR)
|
||
KeyNewR -> ("New", Just KeysR)
|
||
KeyR key -> (ky2text key, Just KeysR)
|
||
|
||
ClaimRequestsPersonR -> ( "Ticket Claim Requests"
|
||
, Just HomeR
|
||
)
|
||
|
||
RepoRolesR shr -> ("Repo Roles", Just $ SharerR shr)
|
||
RepoRoleNewR shr -> ("New", Just $ RepoRolesR shr)
|
||
RepoRoleR shr rl -> (rl2text rl, Just $ RepoRolesR shr)
|
||
RepoRoleOpsR shr rl -> ( "Operations"
|
||
, Just $ RepoRoleR shr rl
|
||
)
|
||
RepoRoleOpNewR shr rl -> ("New", Just $ RepoRoleOpsR shr rl)
|
||
|
||
ProjectRolesR shr -> ( "Project Roles"
|
||
, Just $ SharerR shr
|
||
)
|
||
ProjectRoleNewR shr -> ("New", Just $ ProjectRolesR shr)
|
||
ProjectRoleR shr rl -> ( rl2text rl
|
||
, Just $ ProjectRolesR shr
|
||
)
|
||
ProjectRoleOpsR shr rl -> ( "Operations"
|
||
, Just $ ProjectRoleR shr rl
|
||
)
|
||
ProjectRoleOpNewR shr rl -> ( "New"
|
||
, Just $ ProjectRoleOpsR shr rl
|
||
)
|
||
|
||
ReposR shar -> ("Repos", Just $ PersonR shar)
|
||
RepoNewR shar -> ("New", Just $ ReposR shar)
|
||
RepoR shar repo -> (rp2text repo, Just $ ReposR shar)
|
||
RepoEditR shr rp -> ("Edit", Just $ RepoR shr rp)
|
||
RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo)
|
||
RepoSourceR shar repo refdir -> ( last refdir
|
||
, Just $
|
||
RepoSourceR shar repo $
|
||
init refdir
|
||
)
|
||
RepoHeadChangesR shar repo -> ("Changes", Just $ RepoR shar repo)
|
||
RepoChangesR shar repo ref -> ( ref
|
||
, Just $ RepoHeadChangesR shar repo
|
||
)
|
||
RepoPatchR shr rp hash -> ( "Patch " <> hash
|
||
, Just $ RepoR shr rp
|
||
)
|
||
RepoDevsR shr rp -> ( "Collaboratots"
|
||
, Just $ RepoR shr rp
|
||
)
|
||
RepoDevNewR shr rp -> ("New", Just $ RepoDevsR shr rp)
|
||
RepoDevR shr rp dev -> ( shr2text dev
|
||
, Just $ RepoDevsR shr rp
|
||
)
|
||
|
||
DarcsDownloadR _ _ _ -> ("", Nothing)
|
||
|
||
GitRefDiscoverR _ _ -> ("", Nothing)
|
||
|
||
ProjectsR shar -> ("Projects", Just $ PersonR shar)
|
||
ProjectNewR shar -> ("New", Just $ ProjectsR shar)
|
||
ProjectR shar proj -> ( prj2text proj
|
||
, Just $ ProjectsR shar
|
||
)
|
||
ProjectEditR shr prj -> ("Edit", Just $ ProjectR shr prj)
|
||
ProjectDevsR shr prj -> ( "Collaborators"
|
||
, Just $ ProjectR shr prj
|
||
)
|
||
ProjectDevNewR shr prj -> ( "New"
|
||
, Just $ ProjectDevsR shr prj
|
||
)
|
||
ProjectDevR shr prj dev -> ( shr2text dev
|
||
, Just $ ProjectDevsR shr prj
|
||
)
|
||
|
||
WorkflowsR shr -> ("Workflows", Just $ SharerR shr)
|
||
WorkflowNewR shr -> ("New", Just $ WorkflowsR shr)
|
||
WorkflowR shr wfl -> ( wfl2text wfl
|
||
, Just $ WorkflowsR shr
|
||
)
|
||
WorkflowFieldsR shr wfl -> ( "Fields"
|
||
, Just $ WorkflowR shr wfl
|
||
)
|
||
WorkflowFieldNewR shr wfl -> ( "New"
|
||
, Just $ WorkflowFieldsR shr wfl
|
||
)
|
||
WorkflowFieldR shr wfl fld -> ( fld2text fld
|
||
, Just $ WorkflowFieldsR shr wfl
|
||
)
|
||
WorkflowEnumsR shr wfl -> ( "Enums"
|
||
, Just $ WorkflowR shr wfl
|
||
)
|
||
WorkflowEnumNewR shr wfl -> ( "New"
|
||
, Just $ WorkflowEnumsR shr wfl
|
||
)
|
||
WorkflowEnumR shr wfl enm -> ( enm2text enm
|
||
, Just $ WorkflowEnumsR shr wfl
|
||
)
|
||
WorkflowEnumCtorsR shr wfl enm -> ( "Ctors"
|
||
, Just $ WorkflowEnumR shr wfl enm
|
||
)
|
||
WorkflowEnumCtorNewR shr wfl enm -> ( "New"
|
||
, Just $
|
||
WorkflowEnumCtorsR shr wfl enm
|
||
)
|
||
WorkflowEnumCtorR shr wfl enm c -> ( c
|
||
, Just $
|
||
WorkflowEnumCtorsR shr wfl enm
|
||
)
|
||
|
||
TicketsR shar proj -> ( "Tickets"
|
||
, Just $ ProjectR shar proj
|
||
)
|
||
TicketTreeR shr prj -> ( "Tree", Just $ TicketsR shr prj)
|
||
TicketNewR shar proj -> ("New", Just $ TicketsR shar proj)
|
||
TicketR shar proj num -> ( T.pack $ '#' : show num
|
||
, Just $ TicketsR shar proj
|
||
)
|
||
TicketEditR shar proj num -> ( "Edit"
|
||
, Just $ TicketR shar proj num
|
||
)
|
||
TicketAcceptR _shr _prj _num -> ("", Nothing)
|
||
TicketCloseR _shar _proj _num -> ("", Nothing)
|
||
TicketOpenR _shar _proj _num -> ("", Nothing)
|
||
TicketClaimR _shar _proj _num -> ("", Nothing)
|
||
TicketUnclaimR _shar _proj _num -> ("", Nothing)
|
||
TicketAssignR shr prj num -> ( "Assign"
|
||
, Just $ TicketR shr prj num
|
||
)
|
||
TicketUnassignR _shr _prj _num -> ("", Nothing)
|
||
ClaimRequestsProjectR shr prj -> ( "Ticket Claim Requests"
|
||
, Just $ ProjectR shr prj
|
||
)
|
||
ClaimRequestsTicketR shr prj num -> ( "Ticket Claim Requests"
|
||
, Just $ TicketR shr prj num
|
||
)
|
||
ClaimRequestNewR shr prj num -> ( "New"
|
||
, Just $
|
||
ClaimRequestsTicketR shr prj num
|
||
)
|
||
TicketDiscussionR shar proj num -> ( "Discussion"
|
||
, Just $ TicketR shar proj num
|
||
)
|
||
TicketMessageR shar proj t c -> ( T.pack $ '#' : show c
|
||
, Just $
|
||
TicketDiscussionR shar proj t
|
||
)
|
||
TicketTopReplyR shar proj num -> ( "New topic"
|
||
, Just $
|
||
TicketDiscussionR shar proj num
|
||
)
|
||
TicketReplyR shar proj num cnum -> ( "Reply"
|
||
, Just $
|
||
TicketMessageR shar proj num cnum
|
||
)
|
||
TicketDepsR shr prj num -> ( "Dependencies"
|
||
, Just $ TicketR shr prj num
|
||
)
|
||
TicketDepNewR shr prj num -> ( "New dependency"
|
||
, Just $ TicketDepsR shr prj num
|
||
)
|
||
TicketDepR shr prj pnum cnum -> ( T.pack $ '#' : show cnum
|
||
, Just $ TicketDepsR shr prj pnum
|
||
)
|
||
TicketReverseDepsR shr prj num -> ( "Dependants"
|
||
, Just $ TicketR shr prj num
|
||
)
|
||
|
||
WikiPageR shr prj _page -> ("Wiki", Just $ ProjectR shr prj)
|