{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2022, 2023
 - 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 Control.Applicative
import Control.Concurrent.Chan
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.Logger.CallStack (logWarn)
import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Interval (fromTimeUnit, toTimeUnit)
import Data.Traversable
import Data.Vector (Vector)
import Database.Persist.Postgresql
import Database.Persist.Sql (ConnectionPool)
import Graphics.SVGFonts.ReadFont (PreparedFont)
import Network.HTTP.Client (Manager, HasHttpManager (..))
import Network.HTTP.Types.Header
import Text.Shakespeare.Text (textFile)
import Text.Hamlet          (hamletFile)
--import Text.Jasmine         (minifym)
import Text.Read hiding (lift)
import Web.Hashids
import Yesod.Auth
import Yesod.Auth.Account
import Yesod.Auth.Account.Message (AccountMsg (MsgUsernameExists))
import Yesod.Auth.Message   (AuthMessage (IdentifierNotFound))
import Yesod.Core hiding (logWarn)
import Yesod.Core.Types
import Yesod.Default.Util   (addStaticContentExternal)
import Yesod.Form.Fields
import Yesod.Form.Functions
import Yesod.Form.Types hiding (Env)
import Yesod.Persist.Core
import Yesod.Static

import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Time.Units as U
import qualified Database.Esqueleto as E
import qualified Yesod.Core.Unsafe as Unsafe
--import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
--import qualified Data.Text.Encoding as TE

import Dvara
import Network.HTTP.Digest
import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders)
import Yesod.Auth.Unverified
import Yesod.Auth.Unverified.Creds
import Yesod.Mail.Send

import qualified Network.HTTP.Signature as S (Algorithm (..))

import Control.Concurrent.Actor hiding (Message)
import Crypto.ActorKey
import Crypto.PublicVerifKey
import Network.FedURI
import Web.ActivityAccess
import Web.Actor.Persist
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
import Yesod.MonadSite

import qualified Web.ActivityPub as AP
import qualified Yesod.Hashids as YH

import Text.Email.Local
import Text.Jasmine.Local (discardm)
import Yesod.Paginate.Local

import Vervis.Actor
import Vervis.FedURI
import Vervis.Hook
import Vervis.Model
import Vervis.Model.Group
import Vervis.Model.Ident
import Vervis.Model.Role
import Vervis.RemoteActorStore
import Vervis.Settings
import Vervis.Style
import Vervis.Widget (breadcrumbsW, revisionW)

data ActivityAuthentication
    = ActivityAuthLocal (LocalActorBy Key)
    | ActivityAuthRemote RemoteAuthor

data ActivityReport = ActivityReport
    { _arTime         :: UTCTime
    , _arMessage      :: Text
    , _arContentTypes :: [ContentType]
    , _arBody         :: BL.ByteString
    }

-- | 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    :: Maybe (TVar (ActorKey, ActorKey, Bool))
    , appInstanceMutex :: InstanceMutex
    , appCapSignKey   :: AccessTokenSecretKey
    , appHashidsContext :: HashidsContext
    , appHookSecret      :: HookSecret
    , appActorFetchShare :: ActorFetchShare App
    , appTheater :: Theater

    , appActivities  :: Maybe (Int, TVar (Vector ActivityReport))
    }

-- Aliases for the routes file, because it doesn't like spaces in path piece
-- type names.
type PersonKeyHashid            = KeyHashid Person
type GroupKeyHashid             = KeyHashid Group
type RepoKeyHashid              = KeyHashid Repo
type OutboxItemKeyHashid        = KeyHashid OutboxItem
type SshKeyKeyHashid            = KeyHashid SshKey
type MessageKeyHashid           = KeyHashid Message
type LocalMessageKeyHashid      = KeyHashid LocalMessage
type TicketDepKeyHashid         = KeyHashid LocalTicketDependency
type BundleKeyHashid            = KeyHashid Bundle
type PatchKeyHashid             = KeyHashid Patch
type DeckKeyHashid              = KeyHashid Deck
type LoomKeyHashid              = KeyHashid Loom
type TicketDeckKeyHashid        = KeyHashid TicketDeck
type TicketLoomKeyHashid        = KeyHashid TicketLoom
type SigKeyKeyHashid            = KeyHashid SigKey

-- 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 = HandlerFor App
-- type Widget = WidgetFor App ()
getDvara :: App -> Dvara
getDvara = const dvara

mkYesodData "App" $(parseRoutesFile "th/routes")

-- | A convenient synonym for creating forms.
type Form a = Html -> MForm (HandlerFor App) (FormResult a, Widget)

type AppDB = YesodDB App

type Worker = WorkerFor App

type WorkerDB = PersistConfigBackend (SitePersistConfig App) Worker

instance Site App where
    type SitePersistConfig App = PostgresConf
    siteApproot       =
        renderObjURI . flip ObjURI topLocalURI . appInstanceHost . appSettings
    sitePersistConfig = appDatabaseConf . appSettings
    sitePersistPool   = appConnPool
    siteLogger        = appLogger

instance SiteFedURI App where
    type SiteFedURIMode App = URIMode

-- 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 siteApproot

    -- 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 :: U.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 PostReceiveR          -> return False
                    Just (PersonOutboxR _)     -> return False
                    Just (PersonInboxR _)      -> return False
                    Just (GroupInboxR _)       -> return False
                    Just (RepoInboxR _)        -> return False
                    Just (DeckInboxR _)        -> return False
                    Just (LoomInboxR _)        -> return False
                    Just (GitUploadRequestR _) -> return False
                    Just (DvaraR _)              -> return False
                    Just r                       -> isWriteRequest r
                )
                defaultCsrfHeaderName
                defaultCsrfParamName
          )
        . ( \ handler -> do
                host <- getsYesod $ renderAuthority . siteInstanceHost
                port <- getsYesod $ appPort . appSettings
                mroute <- getCurrentRoute
                let localhost = "localhost:" <> T.pack (show port)
                    expectedHost =
                        case mroute of
                            Just PostReceiveR -> localhost
                            _ -> host
                bs <- lookupHeaders hHost
                case bs of
                    [b] | b == encodeUtf8 expectedHost -> handler
                    _ -> invalidArgs [hostMismatch expectedHost bs]
          )
        . defaultYesodMiddleware
        where
        hostMismatch h l = T.concat
            [ "Request host mismatch: Expected "
            , h
            , " but instead got "
            , T.pack (show l)
            ]

    defaultLayout widget = do
        master <- getYesod
        msgs <- getMessages
        mperson <- do
            mperson' <- maybeAuthAllowUnverified
            for mperson' $ \ (p@(Entity pid person), verified) -> runDB $ do
                inboxID <- actorInbox <$> getJust (personActor person)
                unread <- do
                    vs <- countUnread inboxID
                    case vs :: [E.Value Int] of
                        [E.Value i] -> return i
                        _ -> error $ "countUnread returned " ++ show vs
                hash <- YH.encodeKeyHashid pid
                return (p, hash, verified, unread)
        (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
            let settings = appSettings master
                instanceHost = appInstanceHost settings
                federationDisabled = not $ appFederation settings
                federatedServers = appInstances settings
                main =
                    case appMainColor settings `mod` 6 of
                        0 -> blue
                        1 -> green
                        2 -> red
                        3 -> yellow
                        4 -> magenta
                        5 -> cyan
                        _ -> error "Impossible mod 6"
            $(widgetFile "default-layout")
        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
        where
        countUnread ibid =
            E.select $ E.from $ \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do
                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
                E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
                E.where_ $
                    ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
                      ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
                    )
                    E.&&.
                    ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
                      ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
                    )
                    E.&&.
                    ib E.^. InboxItemUnread E.==. E.val True
                return $ E.count $ ib E.^. InboxItemId

    -- 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

        -- Authentication

        (AuthR a                   , True)
            | a == resendVerifyR           -> personFromResendForm

        -- Client

        (NotificationsR,     _   ) -> personAny
        (PublishOfferMergeR, True) -> personAny

        -- Person

        (PersonInboxR p   , False) -> person p
        (PersonOutboxR p  , True)  -> person p

        -- Group

        {-
        (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
        -}

        -- Repo

        (RepoInboxR _   , False) -> personAny

        -- Deck

        (DeckInboxR _   , False) -> personAny
        (DeckNewR       , _    ) -> personAny

        -- Loom

        (LoomInboxR _   , False) -> personAny









--      (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
        -}

        {-
        (ProjectTicketsR s j              , True) -> projOp ProjOpOpenTicket s j
        (ProjectTicketNewR s j            , _   ) -> projOp ProjOpOpenTicket s j
        (ProjectTicketR user _ _          , True) -> person user
        (ProjectTicketEditR user _ _      , _   ) -> person user
        (ProjectTicketAcceptR s j _       , _   ) -> projOp ProjOpAcceptTicket s j
        (ProjectTicketCloseR s j _        , _   ) -> projOp ProjOpCloseTicket s j
        (ProjectTicketOpenR s j _         , _   ) -> projOp ProjOpReopenTicket s j
        (ProjectTicketClaimR s j _        , _   ) -> projOp ProjOpClaimTicket s j
        (ProjectTicketUnclaimR s j _      , _   ) -> projOp ProjOpUnclaimTicket s j
        (ProjectTicketAssignR s j _       , _   ) -> projOp ProjOpAssignTicket s j
        (ProjectTicketUnassignR s j _     , _   ) -> projOp ProjOpUnassignTicket s j
        (ProjectTicketFollowR _ _ _       , True) -> personAny
        (ProjectTicketUnfollowR _ _ _     , True) -> personAny
        (ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
        (ClaimRequestNewR s j _    , _   ) -> projOp ProjOpRequestTicket s j
        (ProjectTicketDiscussionR _ _ _   , True) -> personAny
        (ProjectTicketMessageR _ _ _ _    , True) -> personAny
        (ProjectTicketTopReplyR _ _ _     , _   ) -> personAny
        (ProjectTicketReplyR _ _ _ _      , _   ) -> personAny
        (ProjectTicketDepsR s j _         , True) -> projOp ProjOpAddTicketDep s j
        (ProjectTicketDepNewR s j _       , _   ) -> projOp ProjOpAddTicketDep s j
        (TicketDepOldR 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 <- runMaybeT $ MaybeT maybeAuth <|> maybeAuthDvara
            case mp of
                Nothing -> return AuthenticationRequired
                Just p  -> f p
            where
            maybeAuthDvara = do
                (_app, mpid, _scopes) <- MaybeT getDvaraAuth
                pid <- MaybeT $ pure mpid
                lift $ runDB $ getJustEntity pid

        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 :: KeyHashid Person -> Handler AuthResult
        person hash = personAnd $ \ (Entity pid _) -> do
            hash' <- YH.encodeKeyHashid pid
            return $ if hash == hash'
                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
        addStaticContentExternal
            discardm
            genFileName
            appStaticDir
            (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 = runSiteDB
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 _ = False

    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
        ibid <- insert Inbox
        obid <- insert Outbox
        fsid <- insert FollowerSet
        let actor = Actor
                { actorName      = name
                , actorDesc      = ""
                , actorCreatedAt = now
                , actorInbox     = ibid
                , actorOutbox    = obid
                , actorFollowers = fsid
                }
        aid <- insert actor
        let defTime = UTCTime (ModifiedJulianDay 0) 0
            person = Person
                { personUsername            = text2username $ name
                , personLogin               = name
                , personPassphraseHash      = pwd
                , personEmail               = email
                , personVerified            = False
                , personVerifiedKey         = key
                , personVerifiedKeyCreated  = now
                , personResetPassKey        = ""
                , personResetPassKeyCreated = defTime
                , personActor               = aid
                -- , personReviewFollow        = True
                }
        mpid <- insertBy person
        case mpid of
            Left _ -> do
                delete aid
                delete ibid
                delete obid
                delete fsid
                mr <- getMessageRender
                return $ Left $ mr $ MsgUsernameExists name
            Right pid -> 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
    requireEmailVerification     = appEmailVerification . appSettings
    emailVerifyKeyDuration _     = Just $ fromTimeUnit (1 :: U.Day)
    passphraseResetKeyDuration _ = Just $ fromTimeUnit (1 :: U.Day)
    allowLoginByEmailAddress _   = True
    runAccountDB                 = unAccountPersistDB'

    unregisteredLogin u = do
        setUnverifiedCreds True $ Creds "account" (username u) []
        return mempty
    registrationAllowed = do
        settings <- getsYesod appSettings
        if appRegister settings
            then do
                room <- case appAccounts settings of
                    Nothing -> return True
                    Just cap -> do
                        current <- runDB $ count ([] :: [Filter Person])
                        return $ current < cap
                return $
                    if room
                        then Nothing
                        else Just $ setMessage "Maximal number of registered users reached"
            else return $ Just $ setMessage "User registration disabled"

instance YesodAuthDvara App where
    data YesodAuthDvaraScope App = ScopeRead deriving Eq
    renderAuthId _ pid = T.pack $ show $ fromSqlKey pid
    parseAuthId _ t =
        maybe (Left err) (Right . toSqlKey) $ readMaybe $ T.unpack t
        where
        err = "Failed to parse an Int64 for AuthId a.k.a PersonId"

instance DvaraScope (YesodAuthDvaraScope App) where
    renderScope ScopeRead = "read"
    parseScope "read" = Right ScopeRead
    parseScope _      = Left "Unrecognized scope"
    defaultScopes = pure ScopeRead
    selfScopes = pure ScopeRead

-- 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 YH.YesodHashids App where
    siteHashidsContext = appHashidsContext

instance YesodRemoteActorStore App where
    siteInstanceMutex    = appInstanceMutex
    siteInstanceRoomMode = appMaxInstanceKeys . appSettings
    siteActorRoomMode    = appMaxActorKeys . appSettings
    siteRejectOnMaxKeys  = appRejectOnMaxKeys . appSettings
    siteActorFetchShare  = appActorFetchShare

instance YesodActivityPub App where
    siteInstanceHost = appInstanceHost . appSettings
    sitePostSignedHeaders _ =
        hRequestTarget :| [hHost, hDate, hDigest, AP.hActivityPubActor]
    {-
    siteGetHttpSign = do
        (akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys
        renderUrl <- askUrlRender
        let (keyID, akey) =
                if new1
                    then (renderUrl ActorKey1R, akey1)
                    else (renderUrl ActorKey2R, akey2)
        return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
    -}

instance YesodPaginate App where
    sitePageParamName _ = "page"

instance YesodBreadcrumbs App where
    breadcrumb route = return $ case route of

        HighlightStyleR _ -> ("", Nothing)
        StaticR _         -> ("", Nothing)
        FaviconSvgR       -> ("", Nothing)
        FaviconPngR       -> ("", Nothing)
        RobotsR           -> ("", Nothing)

        ResendVerifyEmailR -> ("Resend verification email", Nothing)
        AuthR _            -> ("Auth", Just HomeR)
        DvaraR _           -> ("OAuth", Just HomeR)
        ActorKey1R         -> ("Actor Key 1", Just HomeR)
        ActorKey2R         -> ("Actor Key 2", Just HomeR)

        HomeR          -> ("Home", Nothing)
        BrowseR        -> ("Browse", Just HomeR)
        NotificationsR -> ("Notifications", Just HomeR)
        InboxDebugR    -> ("Inbox Debug", Just HomeR)

        KeysR        -> ("SSH Keys", Just HomeR)
        KeyDeleteR _ -> ("", Nothing)

        PublishOfferMergeR -> ("Open MR", Just HomeR)
        PublishMergeR      -> ("Apply MR", Just HomeR)

        PersonR p             -> ("Person ~" <> keyHashidText p, Just HomeR)
        PersonInboxR p        -> ("Inbox", Just $ PersonR p)
        PersonOutboxR p       -> ("Outbox", Just $ PersonR p)
        PersonOutboxItemR p i -> (keyHashidText i, Just $ PersonOutboxR p)
        PersonFollowersR p    -> ("Followers", Just $ PersonR p)
        PersonFollowingR p    -> ("Following", Just $ PersonR p)

        SshKeyR p k -> ("SSH Key #" <> keyHashidText k, Just $ PersonR p)

        PersonMessageR p m -> ("Message #" <> keyHashidText m, Just $ PersonR p)

        PersonFollowR _   -> ("", Nothing)
        PersonUnfollowR _ -> ("", Nothing)

        PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)

        GroupR g             -> ("Team &" <> keyHashidText g, Just HomeR)
        GroupInboxR g        -> ("Inbox", Just $ GroupR g)
        GroupOutboxR g       -> ("Outbox", Just $ GroupR g)
        GroupOutboxItemR g i -> (keyHashidText i, Just $ GroupOutboxR g)
        GroupFollowersR g    -> ("Followers", Just $ GroupR g)

        GroupMessageR g m -> ("Message #" <> keyHashidText m, Just $ GroupR g)

        GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)

        RepoR r             -> ("Repo ^" <> keyHashidText r, Just HomeR)
        RepoInboxR r        -> ("Inbox", Just $ RepoR r)
        RepoOutboxR r       -> ("Outbox", Just $ RepoR r)
        RepoOutboxItemR r i -> (keyHashidText i, Just $ RepoOutboxR r)
        RepoFollowersR r    -> ("Followers", Just $ RepoR r)

        DarcsDownloadR _ _  -> ("", Nothing)
        GitRefDiscoverR _   -> ("", Nothing)
        GitUploadRequestR _ -> ("", Nothing)

        RepoSourceR r []          -> ("Files", Just $ RepoR r)
        RepoSourceR r dir         -> (last dir, Just $ RepoSourceR r $ init dir)
        RepoBranchSourceR r b []  -> ("Branch " <> b <> " Files", Just $ RepoR r)
        RepoBranchSourceR r b dir -> (last dir, Just $ RepoBranchSourceR r b $ init dir)
        RepoCommitsR r            -> ("Commits", Just $ RepoR r)
        RepoBranchCommitsR r b    -> ("Branch " <> b <> " Commits", Just $ RepoR r)
        RepoCommitR r c           -> (c, Just $ RepoCommitsR r)

        RepoMessageR r m -> ("Message #" <> keyHashidText m, Just $ RepoR r)

        RepoNewR        -> ("New Repo", Just HomeR)
        RepoDeleteR r   -> ("", Nothing)
        RepoEditR r     -> ("Edit", Just $ RepoR r)
        RepoFollowR r   -> ("", Nothing)
        RepoUnfollowR r -> ("", Nothing)

        PostReceiveR -> ("", Nothing)

        RepoLinkR _ _ -> ("", Nothing)

        RepoStampR r k -> ("Stamp #" <> keyHashidText k, Just $ RepoR r)

        DeckR d             -> ("Ticket Tracker =" <> keyHashidText d, Just HomeR)
        DeckInboxR d        -> ("Inbox", Just $ DeckR d)
        DeckOutboxR d       -> ("Outbox", Just $ DeckR d)
        DeckOutboxItemR d i -> (keyHashidText i, Just $ DeckOutboxR d)
        DeckFollowersR d    -> ("Followers", Just $ DeckR d)
        DeckTicketsR d      -> ("Tickets", Just $ DeckR d)

        DeckTreeR d -> ("Tree", Just $ DeckTicketsR d)

        DeckMessageR d m -> ("Message #" <> keyHashidText m, Just $ DeckR d)

        DeckNewR        -> ("New Ticket Tracker", Just HomeR)
        DeckDeleteR _   -> ("", Nothing)
        DeckEditR d     -> ("Edit", Just $ DeckR d)
        DeckFollowR _   -> ("", Nothing)
        DeckUnfollowR _ -> ("", Nothing)

        DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d)

        DeckCollabsR d -> ("Collaborators", Just $ DeckR d)

        TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
        TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)
        TicketEventsR d t      -> ("Events", Just $ TicketR d t)
        TicketFollowersR d t   -> ("Followers", Just $ TicketR d t)
        TicketDepsR d t        -> ("Dependencies", Just $ TicketR d t)
        TicketReverseDepsR d t -> ("Dependants", Just $ TicketR d t)

        TicketNewR d         -> ("New Ticket", Just $ DeckR d)
        TicketFollowR _ _    -> ("", Nothing)
        TicketUnfollowR _ _  -> ("", Nothing)
        TicketReplyR d t     -> ("Reply", Just $ TicketR d t)
        TicketReplyOnR d t _ -> ("Reply", Just $ TicketR d t)

        TicketDepR d t p -> (keyHashidText p, Just $ TicketDepsR d t)

        LoomR l             -> ("Merge Request Tracker +" <> keyHashidText l, Just HomeR)
        LoomInboxR l        -> ("Inbox", Just $ LoomR l)
        LoomOutboxR l       -> ("Outbox", Just $ LoomR l)
        LoomOutboxItemR l i -> (keyHashidText i, Just $ LoomOutboxR l)
        LoomFollowersR l    -> ("Followers", Just $ LoomR l)
        LoomClothsR l       -> ("Merge Requests", Just $ LoomR l)

        LoomMessageR l m -> ("Message #" <> keyHashidText m, Just $ LoomR l)

        LoomNewR        -> ("New Patch Tracker", Just HomeR)
        LoomFollowR _   -> ("", Nothing)
        LoomUnfollowR _ -> ("", Nothing)

        LoomStampR l k -> ("Stamp #" <> keyHashidText k, Just $ LoomR l)

        ClothR l c            -> ("#" <> keyHashidText c, Just $ LoomClothsR l)
        ClothDiscussionR l c  -> ("Discussion", Just $ ClothR l c)
        ClothEventsR l c      -> ("Events", Just $ ClothR l c)
        ClothFollowersR l c   -> ("Followers", Just $ ClothR l c)
        ClothDepsR l c        -> ("Dependencies", Just $ ClothR l c)
        ClothReverseDepsR l c -> ("Dependants", Just $ ClothR l c)

        BundleR l c b  -> ("Bundle " <> keyHashidText b, Just $ ClothR l c)
        PatchR l c b p -> ("Patch " <> keyHashidText p, Just $ BundleR l c b)

        ClothNewR l         -> ("New Merge Request", Just $ LoomR l)
        ClothApplyR _ _     -> ("", Nothing)
        ClothFollowR _ _    -> ("", Nothing)
        ClothUnfollowR _ _  -> ("", Nothing)
        ClothReplyR l c     -> ("Reply", Just $ ClothR l c)
        ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c)

        ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c)