vervis/src/Vervis/Handler/Person.hs

{- 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.Handler.Person
    ( getResendVerifyEmailR
    , getPeopleR
    , postPeopleR
    , getPersonNewR
    , getPersonR
    , postPersonR
    , getPersonActivitiesR
    )
where

import Vervis.Import hiding ((==.))
--import Prelude

import Data.PEM (PEM (..))
import Database.Esqueleto hiding (isNothing, count)
import Network.URI (uriFragment, parseAbsoluteURI)
import Vervis.Form.Person
--import Model
import Text.Blaze.Html (toHtml)
import Yesod.Auth.Account (newAccountR, resendVerifyEmailWidget, username)
import Yesod.Auth.Account.Message (AccountMsg (MsgEmailUnverified))

import qualified Data.Text as T (unpack)

import Yesod.Auth.Unverified (requireUnverifiedAuth)

import Text.Email.Local

--import Vervis.ActivityStreams
import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.Model.Ident
import Vervis.Secure
import Vervis.Widget (avatarW)

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

-- | Get list of users
getPeopleR :: Handler Html
getPeopleR = do
    people <- runDB $ select $ from $ \ (sharer, person) -> do
        where_ $ sharer ^. SharerId ==. person ^. PersonIdent
        orderBy [asc $ sharer ^. SharerIdent]
        return $ sharer ^. SharerIdent
    defaultLayout $(widgetFile "people")

-- | Create new user
postPeopleR :: Handler Html
postPeopleR = redirect $ AuthR newAccountR
{-
    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
            if room
                then do
                    ((result, widget), enctype) <- runFormPost newPersonForm
                    case result of
                        FormSuccess np -> do
                            now <- liftIO getCurrentTime
                            runDB $ do
                                let sharer = Sharer
                                        { sharerIdent   = npLogin np
                                        , sharerName    = npName np
                                        , sharerCreated = now
                                        }
                                sid <- insert sharer
                                let person = Person
                                        { personIdent = sid
                                        , personLogin = shr2text $ npLogin np
                                        , personHash  = Nothing
                                        , personEmail = npEmail np
                                        }
                                person' <- setPassword (npPass np) person
                                insert_ person'
                            redirectUltDest HomeR
                        FormMissing -> do
                            setMessage "Field(s) missing"
                            defaultLayout $(widgetFile "person-new")
                        FormFailure _l -> do
                            setMessage
                                "User registration failed, see errors below"
                            defaultLayout $(widgetFile "person-new")
                else do
                    setMessage "Maximal number of registered users reached"
                    redirect PeopleR
        else do
            setMessage "User registration disabled"
            redirect PeopleR
-}

getPersonNewR :: Handler Html
getPersonNewR = redirect $ AuthR newAccountR
{-
    regEnabled <- getsYesod $ appRegister . appSettings
    if regEnabled
        then do
            ((_result, widget), enctype) <- runFormPost newPersonForm
            defaultLayout $(widgetFile "person-new")
        else notFound
-}

getPersonR :: ShrIdent -> Handler TypedContent
getPersonR shr = do
    person <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharer shr
        Entity _pid p <- getBy404 $ UniquePersonIdent sid
        return p
    renderUrl <- getUrlRender
    let route2uri route =
            case parseAbsoluteURI $ T.unpack $ renderUrl route of
                Nothing -> error "getRenderUrl produced invalid URI!!!"
                Just u  -> u
        me = route2uri $ PersonR shr
    actorKey <-
        liftIO . fmap actorKeyPublicBin . readTVarIO =<< getsYesod appActorKey
    selectRep $ do
        provideRep $ do
            secure <- getSecure
            defaultLayout $(widgetFile "person")
        provideAP Actor
            { actorId        = me
            , actorType      = ActorTypePerson
            , actorUsername  = shr2text shr
            , actorInbox     = route2uri InboxR
            , actorPublicKey = PublicKey
                { publicKeyId    = me { uriFragment = "#key" }
                , publicKeyOwner = me
                , publicKeyPem   = PEM "PUBLIC KEY" [] actorKey
                , publicKeyAlgo  = Just AlgorithmEd25519
                }
            }

postPersonR :: ShrIdent -> Handler TypedContent
postPersonR _ = notFound

getPersonActivitiesR :: ShrIdent -> Handler TypedContent
getPersonActivitiesR _ = notFound