{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2022 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.Key
    ( getKeysR
    , postKeysR
    , postKeyDeleteR
    )
where

import Control.Monad
import Data.ByteString.Base64 (encode)
import Data.Monoid ((<>))
import Data.Text (Text, intercalate)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Traversable
import Database.Persist
import Network.HTTP.Types.Method
import Text.Blaze.Html (Html, toHtml)
import Yesod.Auth (requireAuthId)
import Yesod.Core
import Yesod.Core.Handler
import Yesod.Core.Widget (setTitle)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core

import Web.ActivityPub
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids

import Yesod.Form.Local
import Yesod.Persist.Local

import Vervis.Form.Key
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Widget (buttonW)

getKeysR :: Handler Html
getKeysR = do
    pid <- requireAuthId
    newW <- do
        ((_, widget), enctype) <- runFormPost $ newKeyForm pid
        return $(widgetFile "key/new")
    keysW <- mconcat <$> do
        keys <- runDB $ selectList [SshKeyPerson ==. pid] [Asc SshKeyIdent]
        for keys $ \ (Entity keyID key) -> do
            keyHash <- encodeKeyHashid keyID
            return $ keyW keyHash key
    defaultLayout $(widgetFile "key/list")
    where
    keyW tag key =
        let toText = decodeUtf8With lenientDecode
            content = toText $ encode $ sshKeyContent key
        in  $(widgetFile "key/one")

postKeysR :: Handler Html
postKeysR = do
    pid <- requireAuthId
    key <- runFormPostRedirect KeysR $ newKeyForm pid
    runDB $ insert_ key
    setMessage "Key added."
    redirect KeysR

postKeyDeleteR :: KeyHashid SshKey -> Handler Html
postKeyDeleteR keyHash = do
    pid <- requireAuthId
    keyID <- decodeKeyHashid404 keyHash
    runDB $ do
        key <- get404 keyID
        unless (sshKeyPerson key == pid) notFound
        delete keyID
    setMessage "Key deleted."
    redirect KeysR