mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-09 14:46:46 +09:00
1042 lines
46 KiB
Haskell
1042 lines
46 KiB
Haskell
{- This file is part of Vervis.
|
||
-
|
||
- Written in 2016, 2018, 2019 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.CallStack (logWarn)
|
||
import Control.Monad.Trans.Except
|
||
import Control.Monad.Trans.Maybe
|
||
import Crypto.Error (CryptoFailable (..))
|
||
import Crypto.PubKey.Ed25519 (PublicKey, publicKey, signature, verify)
|
||
import Data.Either (isRight)
|
||
import Data.Maybe (fromJust)
|
||
import Data.PEM (pemContent)
|
||
import Data.Text.Encoding (decodeUtf8')
|
||
import Data.Time.Interval (TimeInterval, fromTimeUnit, toTimeUnit)
|
||
import Data.Time.Units (Second, Minute, Day)
|
||
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||
import Graphics.SVGFonts.ReadFont (PreparedFont)
|
||
import Network.HTTP.Client (Manager, HttpException, requestFromURI, responseBody)
|
||
import Network.HTTP.Simple (httpJSONEither, setRequestManager, addRequestHeader)
|
||
import Network.HTTP.Types.Header (hHost)
|
||
import Network.URI (URI, uriAuthority, uriFragment, uriRegName, parseURI)
|
||
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 qualified Data.ByteString.Char8 as BC (unpack)
|
||
import qualified Data.ByteString.Lazy as BL (ByteString)
|
||
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 Network.HTTP.Signature hiding (Algorithm (..))
|
||
import Yesod.Auth.Unverified
|
||
import Yesod.Auth.Unverified.Creds
|
||
import Yesod.HttpSignature (YesodHttpSig (..))
|
||
import Yesod.Mail.Send
|
||
|
||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||
|
||
import Network.FedURI
|
||
import Web.ActivityPub hiding (PublicKey)
|
||
|
||
import Text.Email.Local
|
||
import Text.Jasmine.Local (discardm)
|
||
|
||
import Vervis.Access
|
||
import Vervis.ActorKey (ActorKey)
|
||
import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn)
|
||
import Vervis.Model.Group
|
||
import Vervis.Model.Ident
|
||
import Vervis.Model.Role
|
||
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
|
||
, appActorKeys :: TVar (ActorKey, ActorKey, Bool)
|
||
, appCapSignKey :: ActorKey
|
||
, appHashidEncode :: Int64 -> Text
|
||
, appHashidDecode :: Text -> Maybe Int64
|
||
|
||
, appActivities :: TVar (Vector (UTCTime, Either String (ByteString, BL.ByteString)))
|
||
}
|
||
|
||
-- 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 <- maybeAuthAllowUnverified
|
||
(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
|
||
|
||
(OutboxR , True) -> personAny
|
||
|
||
(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
|
||
|
||
(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
|
||
(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 = do
|
||
mpid <- maybeAuthId
|
||
oas <- runDB $ checkProjectAccess mpid op shr prj
|
||
return $
|
||
case oas of
|
||
ObjectAccessAllowed -> Authorized
|
||
_ ->
|
||
Unauthorized
|
||
"You need a project role with that operation enabled"
|
||
|
||
-- 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
|
||
{ personIdent = sid
|
||
, personLogin = name
|
||
, personPassphraseHash = pwd
|
||
, personEmail = email
|
||
, personVerified = False
|
||
, personVerifiedKey = key
|
||
, personVerifiedKeyCreated = now
|
||
, personResetPassKey = ""
|
||
, personResetPassKeyCreated = defTime
|
||
, personAbout = ""
|
||
}
|
||
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
|
||
|
||
sumUpTo :: Int -> AppDB Int -> AppDB Int -> AppDB Bool
|
||
sumUpTo limit action1 action2 = do
|
||
n <- action1
|
||
if n <= limit
|
||
then do
|
||
m <- action2
|
||
return $ n + m <= limit
|
||
else return False
|
||
|
||
-- | Grab instance and remote sharer IDs from the DB, inserting new ones if
|
||
-- they can't be found in the DB. The @Maybe Bool@ indicates whether the IDs
|
||
-- are newly inserted record: 'Nothing' means they're both new. @Just True@
|
||
-- means the instance record existed but the remote sharer is new. @Just False@
|
||
-- means both the instance and remote sharer existed in the DB.
|
||
instanceAndActor
|
||
:: Text
|
||
-> LocalURI
|
||
-> LocalURI
|
||
-> AppDB (InstanceId, RemoteSharerId, Maybe Bool)
|
||
instanceAndActor host luActor luInbox = do
|
||
(iid, inew) <- idAndNew <$> insertBy (Instance host)
|
||
let rs = RemoteSharer luActor iid luInbox
|
||
if inew
|
||
then do
|
||
rsid <- insert rs
|
||
return (iid, rsid, Nothing)
|
||
else do
|
||
(rsid, rsnew) <- idAndNew <$> insertBy rs
|
||
return (iid, rsid, Just rsnew)
|
||
where
|
||
idAndNew (Left (Entity iid _)) = (iid, False)
|
||
idAndNew (Right iid) = (iid, True)
|
||
|
||
actorRoom :: RemoteSharerId -> AppDB Bool
|
||
actorRoom rsid =
|
||
sumUpTo 2
|
||
(count [VerifKeySharedUsageUser ==. rsid])
|
||
(count [VerifKeySharer ==. Just rsid])
|
||
|
||
keyListedByActor'
|
||
:: Manager
|
||
-> InstanceId
|
||
-> VerifKeyId
|
||
-> Text
|
||
-> LocalURI
|
||
-> LocalURI
|
||
-> Handler (Either String ())
|
||
keyListedByActor' manager iid vkid host luKey luActor = do
|
||
mresult <- do
|
||
ments <- runDB $ do
|
||
mrs <- getBy $ UniqueRemoteSharer iid luActor
|
||
for mrs $ \ (Entity rsid _) ->
|
||
(rsid,) . isJust <$>
|
||
getBy (UniqueVerifKeySharedUsage vkid rsid)
|
||
return $
|
||
case ments of
|
||
Nothing -> Just Nothing
|
||
Just (rsid, used) ->
|
||
if used
|
||
then Nothing
|
||
else Just $ Just rsid
|
||
runExceptT $ for_ mresult $ \ mrsid -> do
|
||
luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
|
||
ExceptT $ runDB $ case mrsid of
|
||
Nothing -> do
|
||
rsid <- insert $ RemoteSharer luActor iid luInbox
|
||
insert_ $ VerifKeySharedUsage vkid rsid
|
||
return $ Right ()
|
||
Just rsid -> do
|
||
room <- actorRoom rsid
|
||
if room
|
||
then do
|
||
insert_ $ VerifKeySharedUsage vkid rsid
|
||
return $ Right ()
|
||
else return $ Left "Actor already has at least 2 keys"
|
||
|
||
data AddVerifKey = AddVerifKey
|
||
{ addvkHost :: Text
|
||
, addvkKeyId :: LocalURI
|
||
, addvkExpires :: Maybe UTCTime
|
||
, addvkKey :: PublicKey
|
||
, addvkActorId :: LocalURI
|
||
, addvkActorInbox :: LocalURI
|
||
}
|
||
|
||
addSharedKey :: AddVerifKey -> AppDB (Maybe String)
|
||
addSharedKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
|
||
(iid, rsid, inew) <- instanceAndActor host luActor luInbox
|
||
room <-
|
||
case inew of
|
||
Nothing -> pure True
|
||
Just rsnew -> do
|
||
iRoom <- instanceRoom iid
|
||
if iRoom
|
||
then if rsnew
|
||
then pure True
|
||
else actorRoom rsid
|
||
else return False
|
||
if room
|
||
then do
|
||
vkid <- insert $ VerifKey luKey iid mexpires key Nothing
|
||
insert_ $ VerifKeySharedUsage vkid rsid
|
||
return Nothing
|
||
else return $ Just "We already store 2 keys"
|
||
where
|
||
instanceRoom iid =
|
||
(< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
|
||
|
||
addPersonalKey :: AddVerifKey -> AppDB (Maybe String)
|
||
addPersonalKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
|
||
(iid, rsid, inew) <- instanceAndActor host luActor luInbox
|
||
room <-
|
||
if inew == Just False
|
||
then actorRoom rsid
|
||
else pure True
|
||
if room
|
||
then do
|
||
insert_ $ VerifKey luKey iid mexpires key (Just rsid)
|
||
return Nothing
|
||
else return $ Just "We already store 2 keys"
|
||
|
||
data UpdateVerifKey = UpdateVerifKey
|
||
{ updvkId :: VerifKeyId
|
||
, updvkExpires :: Maybe UTCTime
|
||
, updvkKey :: PublicKey
|
||
}
|
||
|
||
updateVerifKey :: UpdateVerifKey -> AppDB (Maybe String)
|
||
updateVerifKey (UpdateVerifKey vkid mexpires key) = do
|
||
update vkid [VerifKeyExpires =. mexpires, VerifKeyPublic =. key]
|
||
return Nothing
|
||
|
||
data VerifKeyUpdate
|
||
= VKUAddSharedKey AddVerifKey
|
||
| VKUAddPersonalKey AddVerifKey
|
||
| VKUUpdateKey UpdateVerifKey
|
||
|
||
updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String)
|
||
updateVerifKeyInDB (VKUAddSharedKey avk) = addSharedKey avk
|
||
updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk
|
||
updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk
|
||
|
||
data VerifKeyDetail = VerifKeyDetail
|
||
{ vkdKeyId :: LocalURI
|
||
, vkdInboxOrId :: Either LocalURI VerifKeyId
|
||
, vkdKey :: PublicKey
|
||
, vkdExpires :: Maybe UTCTime
|
||
, vkdActorId :: LocalURI
|
||
, vkdShared :: Bool
|
||
}
|
||
|
||
makeVerifKeyUpdate :: Text -> VerifKeyDetail -> VerifKeyUpdate
|
||
makeVerifKeyUpdate
|
||
host (VerifKeyDetail luKey iori key mexpires luActor shared) =
|
||
case iori of
|
||
Left luInbox ->
|
||
let avk = AddVerifKey host luKey mexpires key luActor luInbox
|
||
in if shared
|
||
then VKUAddSharedKey avk
|
||
else VKUAddPersonalKey avk
|
||
Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
|
||
|
||
instance YesodHttpSig App where
|
||
data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
|
||
httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor]
|
||
httpSigVerSeconds =
|
||
fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
|
||
where
|
||
toSeconds :: TimeInterval -> Second
|
||
toSeconds = toTimeUnit
|
||
httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do
|
||
ExceptT . pure $ case malgo of
|
||
Nothing -> Right ()
|
||
Just algo ->
|
||
case algo of
|
||
S.AlgorithmEd25519 -> Right ()
|
||
S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
|
||
(host, luKey) <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of
|
||
Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e
|
||
Right uri -> Right $ f2l uri
|
||
signature <- ExceptT . pure $ do
|
||
case signature sig of
|
||
CryptoPassed s -> Right s
|
||
CryptoFailed e -> Left "Parsing Ed25519 signature failed"
|
||
mluActorHeader <- do
|
||
bs <- lookupHeaders hActivityPubActor
|
||
case bs of
|
||
[] -> return Nothing
|
||
[b] -> fmap Just . ExceptT . pure $ do
|
||
t <- first displayException $ decodeUtf8' b
|
||
(h, lu) <- f2l <$> parseFedURI t
|
||
if h == host
|
||
then Right ()
|
||
else Left "Key and actor have different hosts"
|
||
Right lu
|
||
_ -> throwE "Multiple ActivityPub-Actor headers"
|
||
vkd <- do
|
||
ments <- lift $ runDB $ do
|
||
mvk <- runMaybeT $ do
|
||
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
|
||
MaybeT $ getBy $ UniqueVerifKey iid luKey
|
||
for mvk $ \ vk@(Entity _ verifkey) -> do
|
||
mremote <- traverse getJust $ verifKeySharer verifkey
|
||
return (vk, mremote)
|
||
case ments of
|
||
Just (Entity vkid vk, mremote) -> do
|
||
(ua, s) <-
|
||
case mremote of
|
||
Just remote -> do
|
||
let sharer = remoteSharerIdent remote
|
||
for_ mluActorHeader $ \ u ->
|
||
if sharer == u
|
||
then return ()
|
||
else throwE "Key's owner doesn't match actor header"
|
||
return (sharer, False)
|
||
Nothing -> do
|
||
ua <- case mluActorHeader of
|
||
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
|
||
Just u -> return u
|
||
manager <- getsYesod appHttpManager
|
||
let iid = verifKeyInstance vk
|
||
ExceptT $
|
||
keyListedByActor' manager iid vkid host luKey ua
|
||
return (ua, True)
|
||
return VerifKeyDetail
|
||
{ vkdKeyId = luKey
|
||
, vkdInboxOrId = Right vkid
|
||
, vkdKey = verifKeyPublic vk
|
||
, vkdExpires = verifKeyExpires vk
|
||
, vkdActorId = ua
|
||
, vkdShared = s
|
||
}
|
||
Nothing -> fetched2vkd luKey <$> fetchKey' host mluActorHeader luKey
|
||
let verify' k = verify k input signature
|
||
errSig = throwE "Ed25519 sig verification says not valid"
|
||
errTime = throwE "Key expired"
|
||
existsInDB = isRight $ vkdInboxOrId vkd
|
||
now <- liftIO getCurrentTime
|
||
let stillValid Nothing = True
|
||
stillValid (Just expires) = expires > now
|
||
|
||
mvkd <-
|
||
if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
|
||
then return $ if existsInDB
|
||
then Nothing
|
||
else Just vkd
|
||
else if existsInDB
|
||
then do
|
||
Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey
|
||
if vkdShared vkd == s
|
||
then return ()
|
||
else throwE "Key scope changed, we reject that"
|
||
unless (vkdShared vkd) $
|
||
if newActor == vkdActorId vkd
|
||
then return ()
|
||
else throwE "Key owner changed, we reject that"
|
||
if stillValid newExp
|
||
then return ()
|
||
else errTime
|
||
if verify' newKey
|
||
then return $ Just vkd
|
||
{ vkdKey = newKey
|
||
, vkdExpires = newExp
|
||
}
|
||
else errSig
|
||
else if stillValid $ vkdExpires vkd
|
||
then errSig
|
||
else errTime
|
||
|
||
for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB . updateVerifKeyInDB . makeVerifKeyUpdate host
|
||
return $ l2f host $ vkdActorId vkd
|
||
where
|
||
fetchKey' h mua uk = do
|
||
manager <- getsYesod appHttpManager
|
||
ExceptT $ fetchKey manager (isJust malgo) h mua uk
|
||
fetched2vkd uk (Fetched k mexp ua uinb s) = VerifKeyDetail
|
||
{ vkdKeyId = uk
|
||
, vkdInboxOrId = Left uinb
|
||
, vkdKey = k
|
||
, vkdExpires = mexp
|
||
, vkdActorId = ua
|
||
, vkdShared = s
|
||
}
|
||
|
||
instance YesodBreadcrumbs App where
|
||
breadcrumb route = return $ case route of
|
||
StaticR _ -> ("", Nothing)
|
||
FaviconR -> ("", Nothing)
|
||
RobotsR -> ("", Nothing)
|
||
|
||
InboxR -> ("Inbox", Nothing)
|
||
OutboxR -> ("Outbox", Nothing)
|
||
ActorKey1R -> ("Actor Key 1", Nothing)
|
||
ActorKey2R -> ("Actor Key 2", 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)
|
||
|
||
GroupsR -> ("Groups", Just HomeR)
|
||
GroupNewR -> ("New", Just GroupsR)
|
||
GroupMembersR shar -> ("Members", Just $ SharerR 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
|
||
)
|
||
|
||
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 $ SharerR 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)
|
||
GitUploadRequestR _ _ -> ("", Nothing)
|
||
|
||
ProjectsR shar -> ("Projects", Just $ SharerR 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)
|