{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2020, 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.Handler.Client
    ( getResendVerifyEmailR
    , getActorKey1R
    , getActorKey2R

    , getHomeR
    , getBrowseR
    , getNotificationsR
    , postNotificationsR
    , getPublishR
    , postPublishR
    , getInboxDebugR

    , getPublishOfferMergeR
    , postPublishOfferMergeR

    --, getPublishCommentR
    --, postPublishCommentR

    , getPublishMergeR
    , postPublishMergeR
    )
where

import Control.Applicative
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.Trans.Except
import Data.List
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Text.Blaze.Html (preEscapedToHtml)
import Yesod.Auth
import Yesod.Auth.Account
import Yesod.Auth.Account.Message
import Yesod.Core
import Yesod.Form
import Yesod.Persist.Core

import qualified Data.ByteString.Char8 as BC
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Database.Esqueleto as E

import Database.Persist.JSON
import Network.FedURI
import Web.Text
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Data.EventTime.Local
import Database.Persist.Local
import Yesod.Form.Local

import Vervis.API
import Vervis.Client
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Recipient
import Vervis.Settings
import Vervis.Web.Actor

-- | Account verification email resend form
getResendVerifyEmailR :: Handler Html
getResendVerifyEmailR = do
    person <- requireUnverifiedAuth
    defaultLayout $ do
        setTitleI MsgEmailUnverified
        [whamlet|
            <p>_{MsgEmailUnverified}
            ^{resendVerifyEmailWidget (username person) AuthR}
        |]

getActorKey1R :: Handler TypedContent
getActorKey1R = serveInstanceKey fst ActorKey1R

getActorKey2R :: Handler TypedContent
getActorKey2R = serveInstanceKey snd ActorKey2R

getHomeR :: Handler Html
getHomeR = do
    mp <- maybeAuth
    case mp of
        Just p  -> personalOverview p
        Nothing -> redirect BrowseR
    where
    personalOverview :: Entity Person -> Handler Html
    personalOverview (Entity pid _person) = do
        (repos, decks, looms) <- runDB $ (,,)
            <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
                    E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
                    E.on $ collab E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
                    E.on $ collab E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicRepoCollab
                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
                    E.orderBy [E.asc $ repo E.^. RepoId]
                    return (repo, actor)
                )
            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do
                    E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId
                    E.on $ collab E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId
                    E.on $ collab E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicDeckCollab
                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
                    E.orderBy [E.asc $ deck E.^. DeckId]
                    return (deck, actor)
                )
            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do
                    E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId
                    E.on $ collab E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId
                    E.on $ collab E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabTopicLoomCollab
                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
                    E.orderBy [E.asc $ loom E.^. LoomId]
                    return (loom, actor)
                )
        hashRepo <- getEncodeKeyHashid
        hashDeck <- getEncodeKeyHashid
        hashLoom <- getEncodeKeyHashid
        defaultLayout $(widgetFile "personal-overview")

getBrowseR :: Handler Html
getBrowseR = do
    (people, groups, repos, decks, looms) <- runDB $
        (,,,,)
            <$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do
                    E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
                    E.orderBy [E.asc $ person E.^. PersonId]
                    return (person, actor)
                )
            <*> (E.select $ E.from $ \ (group `E.InnerJoin` actor) -> do
                    E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
                    E.orderBy [E.asc $ group E.^. GroupId]
                    return (group, actor)
                )
            <*> (E.select $ E.from $ \ (repo `E.InnerJoin` actor) -> do
                    E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
                    E.orderBy [E.asc $ repo E.^. RepoId]
                    return (repo, actor)
                )
            <*> (E.select $ E.from $ \ (deck `E.InnerJoin` actor) -> do
                    E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId
                    E.orderBy [E.asc $ deck E.^. DeckId]
                    return (deck, actor)
                )
            <*> (E.select $ E.from $ \ (loom `E.InnerJoin` actor) -> do
                    E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId
                    E.orderBy [E.asc $ loom E.^. LoomId]
                    return (loom, actor)
                )
        {-
        now <- liftIO getCurrentTime
        repoRows <- forM repos $
            \ (E.Value sharer, E.Value mproj, E.Value repo, E.Value vcs) -> do
                path <- askRepoDir sharer repo
                mlast <- case vcs of
                    VCSDarcs -> liftIO $ D.lastChange path now
                    VCSGit -> do
                        mt <- liftIO $ G.lastCommitTime path
                        return $ Just $ case mt of
                            Nothing -> Never
                            Just t ->
                                intervalToEventTime $
                                FriendlyConvert $
                                now `diffUTCTime` t
                return (sharer, mproj, repo, vcs, mlast)
        -}
    hashPerson <- getEncodeKeyHashid
    hashGroup <- getEncodeKeyHashid
    hashRepo <- getEncodeKeyHashid
    hashDeck <- getEncodeKeyHashid
    hashLoom <- getEncodeKeyHashid
    defaultLayout $ do
        setTitle "Welcome to Vervis!"
        $(widgetFile "browse")

getShowTime = showTime <$> liftIO getCurrentTime
    where
    showTime now =
        showEventTime .
        intervalToEventTime .
        FriendlyConvert .
        diffUTCTime now

notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool))
notificationForm defs = renderDivs $ mk
    <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs)
    <*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs)
    where
    name t = FieldSettings "" Nothing Nothing (Just t) []
    mk Nothing     Nothing       = Nothing
    mk (Just ibid) (Just unread) = Just (ibid, unread)
    mk _           _             = error "Missing hidden field?"

objectSummary o =
    case M.lookup "summary" o of
        Just (String t) | not (T.null t) -> Just t
        _ -> Nothing

objectId o =
    case M.lookup "id" o <|> M.lookup "@id" o of
        Just (String t) | not (T.null t) -> t
        _ -> error "'id' field not found"

getNotificationsR :: Handler Html
getNotificationsR = do
    Entity _ viewer <- requireVerifiedAuth

    items <- runDB $ do
        inboxID <- actorInbox <$> getJust (personActor viewer)
        map adaptItem <$> getItems inboxID

    notifications <- for items $ \ (ibiid, activity) -> do
        ((_result, widget), enctype) <-
            runFormPost $ notificationForm $ Just $ Just (ibiid, False)
        return (activity, widget, enctype)

    ((_result, widgetAll), enctypeAll) <-
        runFormPost $ notificationForm $ Just Nothing

    showTime <- getShowTime
    defaultLayout $(widgetFile "person/notifications")
    where
    getItems ibid =
        E.select $ E.from $
            \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
                E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
                E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
                E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
                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
                E.orderBy [E.desc $ ib E.^. InboxItemId]
                return
                    ( ib E.^. InboxItemId
                    , ob E.?. OutboxItemActivity
                    , ob E.?. OutboxItemPublished
                    , ract E.?. RemoteActivityContent
                    , ract E.?. RemoteActivityReceived
                    )
    adaptItem
        (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) =
            case (mact, mpub, mobj, mrec) of
                (Nothing, Nothing, Nothing, Nothing) ->
                    error $ ibiidString ++ " neither local nor remote"
                (Just _, Just _, Just _, Just _) ->
                    error $ ibiidString ++ " both local and remote"
                (Just act, Just pub, Nothing, Nothing) ->
                    (ibid, (persistJSONObject act, (pub, False)))
                (Nothing, Nothing, Just obj, Just rec) ->
                    (ibid, (persistJSONObject obj, (rec, True)))
                _ -> error $ "Unexpected query result for " ++ ibiidString
        where
        ibiidString = "InboxItem #" ++ show (E.fromSqlKey ibid)

postNotificationsR :: Handler Html
postNotificationsR = do
    Entity _ poster <- requireVerifiedAuth

    ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing

    case result of
        FormMissing -> setMessage "Field(s) missing"
        FormFailure l ->
            setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
        FormSuccess mitem -> do
            (multi, markedUnread) <- runDB $ do
                inboxID <- actorInbox <$> getJust (personActor poster)
                case mitem of
                    Nothing -> do
                        ibiids <- map E.unValue <$> getItems inboxID
                        updateWhere
                            [InboxItemId <-. ibiids]
                            [InboxItemUnread =. False]
                        return (True, False)
                    Just (ibiid, unread) -> do
                        mib <-
                            requireEitherAlt
                                (getValBy $ UniqueInboxItemLocalItem ibiid)
                                (getValBy $ UniqueInboxItemRemoteItem ibiid)
                                "Unused InboxItem"
                                "InboxItem used more than once"
                        let samePid =
                                case mib of
                                    Left ibl ->
                                        inboxItemLocalInbox ibl == inboxID
                                    Right ibr ->
                                        inboxItemRemoteInbox ibr == inboxID
                        if samePid
                            then do
                                update ibiid [InboxItemUnread =. unread]
                                return (False, unread)
                            else
                                permissionDenied
                                    "Notification belongs to different user"
            setMessage $
                if multi
                    then "Items marked as read."
                    else if markedUnread
                        then "Item marked as unread."
                        else "Item marked as read."

    redirect NotificationsR
    where
    getItems 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 $ ib E.^. InboxItemId

getPublishR :: Handler Html
getPublishR = do
    error "Temporarily disabled"

postPublishR :: Handler Html
postPublishR = do
    error "Temporarily disabled"

getInboxDebugR :: Handler Html
getInboxDebugR = do
    acts <-
        liftIO . readTVarIO . snd =<< maybe notFound return =<< getsYesod appActivities
    defaultLayout
        [whamlet|
            <p>
              Welcome to the ActivityPub inbox test page! Activities received
              by this Vervis instance are listed here for testing and
              debugging. To test, go to another Vervis instance and publish
              something that supports federation, either through the regular UI
              or via the /publish page, and then come back here to see the
              result. Activities that aren't understood or their processing
              fails get listed here too, with a report of what exactly
              happened.
            <p>Last 10 activities posted:
            <ul>
              $forall ActivityReport time msg ctypes body <- acts
                <li>
                  <div>#{show time}
                  <div>#{msg}
                  <div><code>#{intercalate " | " $ map BC.unpack ctypes}
                  <div><pre>#{TLE.decodeUtf8 body}
        |]

{-

fedUriField
    :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
fedUriField = Field
    { fieldParse = parseHelper $ \ t ->
        case parseObjURI t of
            Left e  -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
            Right u -> Right u
    , fieldView = \theId name attrs val isReq ->
        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
    , fieldEnctype = UrlEncoded
    }

ticketField
    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, KeyHashid LocalTicket)
ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
    where
    toTicket uTicket = runExceptT $ do
        let ObjURI hTicket luTicket = uTicket
        route <-
            case decodeRouteLocal luTicket of
                Nothing -> throwE ("Not a valid route" :: Text)
                Just r -> return r
        case route of
            ProjectTicketR shr prj tkhid -> return (hTicket, shr, prj, tkhid)
            _ -> throwE "Not a ticket route"
    fromTicket (h, shr, prj, tkhid) =
        ObjURI h $ encodeRouteLocal $ ProjectTicketR shr prj tkhid

projectField
    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent)
projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
    where
    toProject u = runExceptT $ do
        let ObjURI h lu = u
        route <-
            case decodeRouteLocal lu of
                Nothing -> throwE ("Not a valid route" :: Text)
                Just r -> return r
        case route of
            ProjectR shr prj -> return (h, shr, prj)
            _ -> throwE "Not a project route"
    fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj

publishCommentForm
    :: Form ((Host, ShrIdent, PrjIdent, KeyHashid LocalTicket), Maybe FedURI, Text)
publishCommentForm html = do
    enc <- getEncodeRouteLocal
    defk <- encodeKeyHashid $ E.toSqlKey 1
    flip renderDivs html $ (,,)
        <$> areq (ticketField enc) "Ticket"      (Just $ deft defk)
        <*> aopt fedUriField       "Replying to" (Just $ Just defp)
        <*> areq textField         "Message"     (Just defmsg)
    where
    deft k = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", k)
    defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
    defmsg = "Hi! I'm testing federation. Can you see my message? :)"

createTicketForm :: Form (FedURI, FedURI, TextHtml, TextPandocMarkdown)
createTicketForm = renderDivs $ (,,,)
    <$> areq fedUriField "Tracker" (Just defaultProject)
    <*> areq fedUriField "Context" (Just defaultProject)
    <*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
    <*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
            areq textareaField "Description" Nothing
        )
    where
    defaultProject =
        ObjURI
            (Authority "forge.angeley.es" Nothing)
            (LocalURI "/s/fr33/p/sandbox")

offerTicketForm
    :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
offerTicketForm html = do
    enc <- getEncodeRouteLocal
    flip renderDivs html $ (,,)
        <$> areq (projectField enc) "Project"     (Just defj)
        <*> ( TextHtml . sanitizeBalance <$>
              areq textField        "Title"       (Just deft)
            )
        <*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
              areq textareaField    "Description" (Just defd)
            )
    where
    defj = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox")
    deft = "Time slows down when tasting coconut ice-cream"
    defd = "Is that slow-motion effect intentional? :)"

followForm :: Form (FedURI, FedURI)
followForm = renderDivs $ (,)
    <$> areq fedUriField "Target"    (Just deft)
    <*> areq fedUriField "Recipient" (Just deft)
    where
    deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33"

resolveForm :: Form FedURI
resolveForm = renderDivs $ areq fedUriField "Ticket" (Just deft)
    where
    deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/p/sandbox/t/20YNl"

unresolveForm :: Form FedURI
unresolveForm = renderDivs $ areq fedUriField "Ticket" (Just deft)
    where
    deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/p/sandbox/t/20YNl"

createMergeRequestForm :: Form (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo)
createMergeRequestForm = renderDivs $ (,,,,,)
    <$> areq fedUriField "Repo" (Just defaultRepo)
    <*> aopt fedUriField "Branch URI (for Git repos)" Nothing
    <*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
    <*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
            areq textareaField "Description" Nothing
        )
    <*> areq (selectFieldList pmtList) "Type" Nothing
    <*> areq fileField "Patch" Nothing
    where
    defaultRepo =
        ObjURI
            (Authority "forge.angeley.es" Nothing)
            (LocalURI "/s/fr33/r/one-more-darcs")
    pmtList :: [(Text, PatchMediaType)]
    pmtList =
        [ ("Darcs", PatchMediaTypeDarcs)
        ]

activityWidget
    :: Widget -> Enctype
    -> Widget -> Enctype
    -> Widget -> Enctype
    -> Widget -> Enctype
    -> Widget -> Enctype
    -> Widget -> Enctype
    -> Widget -> Enctype
    -> Widget -> Enctype
    -> Widget
activityWidget
    widget1 enctype1
    widget2 enctype2
    widget3 enctype3
    widget4 enctype4
    widget5 enctype5
    widget6 enctype6
    widget7 enctype7
    widget8 enctype8 =
        [whamlet|
            <h1>Publish a ticket comment
            <form method=POST action=@{PublishR} enctype=#{enctype1}>
              ^{widget1}
              <input type=submit>

            <h1>Open a new ticket (via Create)
            <form method=POST action=@{PublishR} enctype=#{enctype2}>
              ^{widget2}
              <input type=submit>

            <h1>Open a new ticket (via Offer)
            <form method=POST action=@{PublishR} enctype=#{enctype3}>
              ^{widget3}
              <input type=submit>

            <h1>Follow a person, a projet or a repo
            <form method=POST action=@{PublishR} enctype=#{enctype4}>
              ^{widget4}
              <input type=submit>

            <h1>Resolve a ticket / MR
            <form method=POST action=@{PublishR} enctype=#{enctype5}>
              ^{widget5}
              <input type=submit>

            <h1>Unresolve a ticket / MR
            <form method=POST action=@{PublishR} enctype=#{enctype6}>
              ^{widget6}
              <input type=submit>

            <h1>Submit a patch (via Create)
            <form method=POST action=@{PublishR} enctype=#{enctype7}>
              ^{widget7}
              <input type=submit>

            <h1>Submit a patch (via Offer)
            <form method=POST action=@{PublishR} enctype=#{enctype8}>
              ^{widget8}
              <input type=submit>
        |]

getUser :: Handler (ShrIdent, PersonId)
getUser = do
    Entity pid p <- requireVerifiedAuth
    s <- runDB $ getJust $ personIdent p
    return (sharerIdent s, pid)

getUser' :: Handler (Entity Person, Sharer)
getUser' = do
    ep@(Entity _ p) <- requireVerifiedAuth
    s <- runDB $ getJust $ personIdent p
    return (ep, s)

getUserShrIdent :: Handler ShrIdent
getUserShrIdent = fst <$> getUser

getPublishR :: Handler Html
getPublishR = do
    ((_result1, widget1), enctype1) <-
        runFormPost $ identifyForm "f1" publishCommentForm
    ((_result2, widget2), enctype2) <-
        runFormPost $ identifyForm "f2" createTicketForm
    ((_result3, widget3), enctype3) <-
        runFormPost $ identifyForm "f3" offerTicketForm
    ((_result4, widget4), enctype4) <-
        runFormPost $ identifyForm "f4" followForm
    ((_result5, widget5), enctype5) <-
        runFormPost $ identifyForm "f5" resolveForm
    ((_result6, widget6), enctype6) <-
        runFormPost $ identifyForm "f6" unresolveForm
    ((_result7, widget7), enctype7) <-
        runFormPost $ identifyForm "f7" createMergeRequestForm
    ((_result8, widget8), enctype8) <-
        runFormPost $ identifyForm "f8" createMergeRequestForm
    defaultLayout $
        activityWidget
            widget1 enctype1
            widget2 enctype2
            widget3 enctype3
            widget4 enctype4
            widget5 enctype5
            widget6 enctype6
            widget7 enctype7
            widget8 enctype8

data Result
    = ResultPublishComment ((Host, ShrIdent, PrjIdent, KeyHashid LocalTicket), Maybe FedURI, Text)
    | ResultCreateTicket (FedURI, FedURI, TextHtml, TextPandocMarkdown)
    | ResultOfferTicket ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
    | ResultFollow (FedURI, FedURI)
    | ResultResolve FedURI
    | ResultUnresolve FedURI
    | ResultCreateMR (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo)
    | ResultOfferMR (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo)

postPublishR :: Handler Html
postPublishR = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod

    ((result1, widget1), enctype1) <-
        runFormPost $ identifyForm "f1" publishCommentForm
    ((result2, widget2), enctype2) <-
        runFormPost $ identifyForm "f2" createTicketForm
    ((result3, widget3), enctype3) <-
        runFormPost $ identifyForm "f3" offerTicketForm
    ((result4, widget4), enctype4) <-
        runFormPost $ identifyForm "f4" followForm
    ((result5, widget5), enctype5) <-
        runFormPost $ identifyForm "f5" resolveForm
    ((result6, widget6), enctype6) <-
        runFormPost $ identifyForm "f6" unresolveForm
    ((result7, widget7), enctype7) <-
        runFormPost $ identifyForm "f7" createMergeRequestForm
    ((result8, widget8), enctype8) <-
        runFormPost $ identifyForm "f8" createMergeRequestForm
    let result
            =   ResultPublishComment <$> result1
            <|> ResultCreateTicket <$> result2
            <|> ResultOfferTicket <$> result3
            <|> ResultFollow <$> result4
            <|> ResultResolve <$> result5
            <|> ResultUnresolve <$> result6
            <|> ResultCreateMR <$> result7
            <|> ResultOfferMR <$> result8

    ep@(Entity _ p) <- requireVerifiedAuth
    s <- runDB $ getJust $ personIdent p
    let shrAuthor = sharerIdent s

    eid <- runExceptT $ do
        input <-
            case result of
                FormMissing -> throwE "Field(s) missing"
                FormFailure _l -> throwE "Invalid input, see below"
                FormSuccess r -> return r
        case input of
            ResultPublishComment v -> publishComment ep s v
            ResultCreateTicket v -> publishTicket ep s v
            ResultOfferTicket v -> openTicket ep s v
            ResultFollow v -> follow shrAuthor v
            ResultResolve u -> do
                (summary, audience, specific) <- ExceptT $ resolve shrAuthor u
                resolveC ep s summary audience specific
            ResultUnresolve u -> do
                (summary, audience, specific) <- ExceptT $ unresolve shrAuthor u
                undoC ep s summary audience specific
            ResultCreateMR (uCtx, muBranch, title, desc, typ, file) -> do
                diff <- TE.decodeUtf8 <$> fileSourceByteString file
                (summary, audience, ticket, muTarget) <-
                    ExceptT $ createMR shrAuthor title desc uCtx muBranch typ diff
                createTicketC ep s summary audience ticket muTarget
            ResultOfferMR (uCtx, muBranch, title, desc, typ, file) -> do
                diff <- TE.decodeUtf8 <$> fileSourceByteString file
                (summary, audience, ticket) <-
                    ExceptT $ offerMR shrAuthor title desc uCtx muBranch typ diff
                offerTicketC ep s summary audience ticket uCtx
    case eid of
        Left err -> setMessage $ toHtml err
        Right _obiid -> setMessage "Activity published"
    defaultLayout $
        activityWidget
            widget1 enctype1
            widget2 enctype2
            widget3 enctype3
            widget4 enctype4
            widget5 enctype5
            widget6 enctype6
            widget7 enctype7
            widget8 enctype8
    where
    publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do
        encodeRouteFed <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal
        let msg' = T.filter (/= '\r') msg
        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
        let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
            uTicket = encodeRecipRoute $ ProjectTicketR shrTicket prj num
            shrAuthor = sharerIdent sharer
            ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
            collections =
                [ ProjectFollowersR shrTicket prj
                , ProjectTicketParticipantsR shrTicket prj num
                --, ProjectTicketTeamR shrTicket prj num
                ]
            recips = ProjectR shrTicket prj : collections
            note = Note
                { noteId        = Nothing
                , noteAttrib    = luAuthor
                , noteAudience  = Audience
                    { audienceTo        = map encodeRecipRoute recips
                    , audienceBto       = []
                    , audienceCc        = []
                    , audienceBcc       = []
                    , audienceGeneral   = []
                    , audienceNonActors = map encodeRecipRoute collections
                    }
                , noteReplyTo   = Just $ fromMaybe uTicket muParent
                , noteContext   = Just uTicket
                , notePublished = Nothing
                , noteSource    = msg'
                , noteContent   = contentHtml
                }
        noteC eperson sharer note
    publishTicket eperson sharer (target, context, title, desc) = do
        (summary, audience, create) <-
            ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
        let ticket =
                case createObject create of
                    CreateTicket _ t -> t
                    _ -> error "Create object isn't a ticket"
            target = createTarget create
        createTicketC eperson sharer (Just summary) audience ticket target
    openTicket eperson sharer ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
        encodeRouteLocal <- getEncodeRouteLocal
        encodeRouteFed <- getEncodeRouteFed
        local <- hostIsLocal h
        descHtml <- ExceptT . pure $ renderPandocMarkdown desc
        let shrAuthor = sharerIdent sharer
        summary <-
            TextHtml . TL.toStrict . renderHtml <$>
                withUrlRenderer
                    [hamlet|
                        <p>
                          <a href=@{SharerR shrAuthor}>
                            #{shr2text shrAuthor}
                          \ offered a ticket to project #
                          $if local
                            <a href=@{ProjectR shr prj}>
                              ./s/#{shr2text shr}/p/#{prj2text prj}
                          $else
                            <a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
                              #{renderAuthority h}/s/#{shr2text shr}/p/#{prj2text prj}
                          : #{preEscapedToHtml title}.
                    |]
        let recipsA = [ProjectR shr prj]
            recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
            ticketAP = AP.Ticket
                { ticketLocal        = Nothing
                , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
                , ticketPublished    = Nothing
                , ticketUpdated      = Nothing
                , ticketContext      = Nothing
                -- , ticketName         = Nothing
                , ticketSummary      = TextHtml title
                , ticketContent      = TextHtml descHtml
                , ticketSource       = TextPandocMarkdown desc
                , ticketAssignedTo   = Nothing
                , ticketResolved     = Nothing
                , ticketAttachment   = Nothing
                }
            target = encodeRouteFed h $ ProjectR shr prj
            audience = Audience
                { audienceTo        =
                    map (encodeRouteFed h) $ recipsA ++ recipsC
                , audienceBto       = []
                , audienceCc        = []
                , audienceBcc       = []
                , audienceGeneral   = []
                , audienceNonActors = map (encodeRouteFed h) recipsC
                }
        offerTicketC eperson sharer (Just summary) audience ticketAP target
    follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do
        (summary, audience, followAP) <-
            C.follow shrAuthor uObject uRecip False
        followC shrAuthor (Just summary) audience followAP

setFollowMessage :: ShrIdent -> Either Text OutboxItemId -> Handler ()
setFollowMessage _   (Left err)    = setMessage $ toHtml err
setFollowMessage shr (Right obiid) = do
    obikhid <- encodeKeyHashid obiid
    setMessage =<<
        withUrlRenderer
            [hamlet|
                <a href=@{SharerOutboxItemR shr obikhid}>
                  Follow request published!
            |]

postSharerFollowR :: ShrIdent -> Handler ()
postSharerFollowR shrObject = do
    shrAuthor <- getUserShrIdent
    (summary, audience, follow) <- followSharer shrAuthor shrObject False
    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
    setFollowMessage shrAuthor eid
    redirect $ SharerR shrObject

postProjectFollowR :: ShrIdent -> PrjIdent -> Handler ()
postProjectFollowR shrObject prjObject = do
    shrAuthor <- getUserShrIdent
    (summary, audience, follow) <- followProject shrAuthor shrObject prjObject False
    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
    setFollowMessage shrAuthor eid
    redirect $ ProjectR shrObject prjObject

postProjectTicketFollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler ()
postProjectTicketFollowR shrObject prjObject tkhidObject = do
    shrAuthor <- getUserShrIdent
    (summary, audience, follow) <- followTicket shrAuthor shrObject prjObject tkhidObject False
    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
    setFollowMessage shrAuthor eid
    redirect $ ProjectTicketR shrObject prjObject tkhidObject

postRepoFollowR :: ShrIdent -> RpIdent -> Handler ()
postRepoFollowR shrObject rpObject = do
    shrAuthor <- getUserShrIdent
    (summary, audience, follow) <- followRepo shrAuthor shrObject rpObject False
    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
    setFollowMessage shrAuthor eid
    redirect $ RepoR shrObject rpObject

setUnfollowMessage :: ShrIdent -> Either Text OutboxItemId -> Handler ()
setUnfollowMessage _   (Left err)    = setMessage $ toHtml err
setUnfollowMessage shr (Right obiid) = do
    obikhid <- encodeKeyHashid obiid
    setMessage =<<
        withUrlRenderer
            [hamlet|
                <a href=@{SharerOutboxItemR shr obikhid}>
                  Unfollow request published!
            |]

postSharerUnfollowR :: ShrIdent -> Handler ()
postSharerUnfollowR shrFollowee = do
    (ep@(Entity pid _), s) <- getUser'
    let shrAuthor = sharerIdent s
    eid <- runExceptT $ do
        (summary, audience, undo) <-
            ExceptT $ undoFollowSharer shrAuthor pid shrFollowee
        undoC ep s (Just summary) audience undo
    setUnfollowMessage shrAuthor eid
    redirect $ SharerR shrFollowee

postProjectUnfollowR :: ShrIdent -> PrjIdent -> Handler ()
postProjectUnfollowR shrFollowee prjFollowee = do
    (ep@(Entity pid _), s) <- getUser'
    let shrAuthor = sharerIdent s
    eid <- runExceptT $ do
        (summary, audience, undo) <-
            ExceptT $ undoFollowProject shrAuthor pid shrFollowee prjFollowee
        undoC ep s (Just summary) audience undo
    setUnfollowMessage shrAuthor eid
    redirect $ ProjectR shrFollowee prjFollowee

postProjectTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler ()
postProjectTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do
    (ep@(Entity pid _), s) <- getUser'
    let shrAuthor = sharerIdent s
    eid <- runExceptT $ do
        (summary, audience, undo) <-
            ExceptT $ undoFollowTicket shrAuthor pid shrFollowee prjFollowee tkhidFollowee
        undoC ep s (Just summary) audience undo
    setUnfollowMessage shrAuthor eid
    redirect $ ProjectTicketR shrFollowee prjFollowee tkhidFollowee

postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler ()
postRepoUnfollowR shrFollowee rpFollowee = do
    (ep@(Entity pid _), s) <- getUser'
    let shrAuthor = sharerIdent s
    eid <- runExceptT $ do
        (summary, audience, undo) <-
            ExceptT $ undoFollowRepo shrAuthor pid shrFollowee rpFollowee
        undoC ep s (Just summary) audience undo
    setUnfollowMessage shrAuthor eid
    redirect $ RepoR shrFollowee rpFollowee

postProjectTicketCloseR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketCloseR shr prj ltkhid = do
    encodeRouteHome <- getEncodeRouteHome
    ep@(Entity _ p) <- requireVerifiedAuth
    s <- runDB $ getJust $ personIdent p
    let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid
    result <- runExceptT $ do
        (summary, audience, specific) <- ExceptT $ resolve (sharerIdent s) uTicket
        resolveC ep s summary audience specific
    case result of
        Left e -> setMessage $ toHtml $ "Error: " <> e
        Right _obiid -> setMessage "Ticket closed"
    redirect $ ProjectTicketR shr prj ltkhid

postProjectTicketOpenR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketOpenR shr prj ltkhid = do
    encodeRouteHome <- getEncodeRouteHome
    ep@(Entity _ p) <- requireVerifiedAuth
    s <- runDB $ getJust $ personIdent p
    let uTicket = encodeRouteHome $ ProjectTicketR shr prj ltkhid
    result <- runExceptT $ do
        (summary, audience, specific) <- ExceptT $ unresolve (sharerIdent s) uTicket
        undoC ep s summary audience specific
    case result of
        Left e -> setMessage $ toHtml $ "Error: " <> e
        Right _obiid -> setMessage "Ticket reopened"
    redirect $ ProjectTicketR shr prj ltkhid
-}

capField
    :: Field Handler
        ( FedURI
        , Either
            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
            FedURI
        )
capField = checkMMap toCap fst fedUriField
    where
    toCap u =
        runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u)

getSender :: Handler (Entity Person, Actor)
getSender = do
    ep@(Entity _ p) <- requireAuth
    a <- runDB $ getJust $ personActor p
    return (ep, a)

data OfferMergeGit = OfferMergeGit
    { omgTracker      :: FedURI
    , omgTargetRepo   :: FedURI
    , omgTargetBranch :: Text
    , omgOriginRepo   :: FedURI
    , omgOriginBranch :: Text
    , omgTitle        :: Text
    , omgDesc         :: PandocMarkdown
    }

offerMergeGitForm :: Form OfferMergeGit
offerMergeGitForm = renderDivs $ OfferMergeGit
    <$> areq fedUriField "Patch tracker URL"                Nothing
    <*> areq fedUriField "Target repo URL"                  Nothing
    <*> areq textField   "Target branch (e.g. main)"        Nothing
    <*> areq fedUriField "Origin repo URL"                  Nothing
    <*> areq textField   "Origin branch (e.g. fix-the-bug)" Nothing
    <*> areq textField   "Title"                            Nothing
    <*> (pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$>
            areq textareaField "Description" Nothing
        )

{-
data OfferMergeGit = OfferMergeGit
    { omgTracker :: FedURI
    , omgTarget  :: (FedURI, Text)
    , omgOrigin  :: (FedURI, Text)
    , omgTitle   :: Text
    , omgDesc    :: PandocMarkdown
    PatchMediaType
    FileInfo
-}

{-
offerMergeForm :: Form (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo)
offerMergeForm = renderDivs $ (,,,,,)
    <$> areq fedUriField "Repo" (Just defaultRepo)
    <*> aopt fedUriField "Branch URI (for Git repos)" Nothing
    <*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
    <*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
            areq textareaField "Description" Nothing
        )
    <*> areq (selectFieldList pmtList) "Type" Nothing
    <*> areq fileField "Patch" Nothing
    where
    defaultRepo =
        ObjURI
            (Authority "forge.angeley.es" Nothing)
            (LocalURI "/s/fr33/r/one-more-darcs")
    pmtList :: [(Text, PatchMediaType)]
    pmtList =
        [ ("Darcs", PatchMediaTypeDarcs)
        ]
-}

getPublishOfferMergeR :: Handler Html
getPublishOfferMergeR = do
    ((_, widget), enctype) <- runFormPost offerMergeGitForm
    defaultLayout
        [whamlet|
            <h1>Open a Merge Request on a Git repo
            <form method=POST action=@{PublishOfferMergeR} enctype=#{enctype}>
              ^{widget}
              <input type=submit>
        |]

postPublishOfferMergeR :: Handler ()
postPublishOfferMergeR = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod

    OfferMergeGit {..} <-
        runFormPostRedirect PublishOfferMergeR offerMergeGitForm

    (ep@(Entity pid _), a) <- getSender
    senderHash <- encodeKeyHashid pid

    trackerLocal <- hostIsLocalOld $ objUriAuthority omgTracker
    edest <- runExceptT $ do
        (summary, audience, ticket) <-
            offerMerge
                senderHash omgTitle omgDesc omgTracker
                omgTargetRepo (Just omgTargetBranch)
                omgOriginRepo (Just omgOriginBranch)
        (localRecips, remoteRecips, fwdHosts, action) <-
            makeServerInput Nothing summary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) omgTracker
        offerID <- offerTicketC ep a Nothing localRecips remoteRecips fwdHosts action ticket omgTracker
        if trackerLocal
            then nameExceptT "Offer published but" $ runDBExcept $ do
                ticketID <- do
                    mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
                    ticketAuthorLocalTicket <$>
                        fromMaybeE mtal "Can't find the ticket in DB"
                Entity clothID cloth <- do
                    mtl <- lift $ getBy $ UniqueTicketLoom ticketID
                    fromMaybeE mtl "Can't find ticket's patch tracker in DB"
                ClothR <$> encodeKeyHashid (ticketLoomLoom cloth) <*> encodeKeyHashid clothID
            else PersonOutboxItemR senderHash <$> encodeKeyHashid offerID
    case edest of
        Left err -> do
            setMessage $ toHtml err
            redirect PublishOfferMergeR
        Right dest -> do
            if trackerLocal
                then setMessage "Merge Request created"
                else setMessage "Offer published"
            redirect dest

{-
data Comment = Comment
    { commentTopic  :: FedURI
    , commentParent :: Maybe FedURI
    , commentText   :: PandocMarkdown
    }

commentForm :: Form Comment
commentForm = Comment
    <$> areq fedUriField "Topic"       Nothing
    <*> aopt fedUriField "Replying to" Nothing
    <*> (pandocMarkdownFromText <$>
            areq textField "Message"   Nothing
        )

getPublishCommentR :: Handler Html
getPublishCommentR = do
    ((_, widget), enctype) <- runFormPost commentForm
    defaultLayout
        [whamlet|
            <h1>Comment on a ticket or a merge request
            <form method=POST action=@{PublishCommentR} enctype=#{enctype}>
              ^{widget}
              <input type=submit>
        |]

postPublishCommentR :: Handler ()
postPublishCommentR = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod

    Comment uTopic uParent source <-
        runFormPostRedirect PublishCommentR commentForm

    (ep@(Entity pid _), a) <- getSender
    senderHash <- encodeKeyHashid pid

    result <- runExceptT $ do







        (maybeSummary, audience, apply) <- applyPatches senderHash uBundle
        (localRecips, remoteRecips, fwdHosts, action) <-
            makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply)
        applyC ep a (Just cap) localRecips remoteRecips fwdHosts action apply

    case result of
        Left err -> do
            setMessage $ toHtml err
            redirect PublishMergeR
        Right _ -> do
            setMessage "Apply activity sent"
            redirect HomeR
-}

mergeForm = renderDivs $ (,)
    <$> areq fedUriField "Patch bundle to apply"                   Nothing
    <*> areq capField    "Grant activity to use for authorization" Nothing

getPublishMergeR :: Handler Html
getPublishMergeR = do
    ((_, widget), enctype) <- runFormPost mergeForm
    defaultLayout
        [whamlet|
            <h1>Merge a merge request
            <form method=POST action=@{PublishMergeR} enctype=#{enctype}>
              ^{widget}
              <input type=submit>
        |]

postPublishMergeR :: Handler ()
postPublishMergeR = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod

    (uBundle, (uCap, cap)) <- runFormPostRedirect PublishMergeR mergeForm

    (ep@(Entity pid _), a) <- getSender
    senderHash <- encodeKeyHashid pid

    result <- runExceptT $ do
        (maybeSummary, audience, apply) <- applyPatches senderHash uBundle
        (localRecips, remoteRecips, fwdHosts, action) <-
            makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply)
        applyC ep a (Just cap) localRecips remoteRecips fwdHosts action apply

    case result of
        Left err -> do
            setMessage $ toHtml err
            redirect PublishMergeR
        Right _ -> do
            setMessage "Apply activity sent"
            redirect HomeR