vervis/src/Vervis/Handler/Key.hs

{- This file is part of Vervis.
 -
 - Written in 2016 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
    , getKeyNewR
    , getKeyR
    )
where

import Prelude

import Data.ByteString.Base64 (encode)
import Data.Text (Text, intercalate)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Database.Persist
import Text.Blaze.Html (Html, toHtml)
import Yesod.Core (defaultLayout)
import Yesod.Core.Widget (setTitle)
import Yesod.Persist.Core (runDB, getBy404)

import Vervis.Foundation
import Vervis.Model
import Vervis.Settings

getKeysR :: Text -> Handler Html
getKeysR user = do
    keys <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharerIdent user
        Entity pid _person <- getBy404 $ UniquePersonIdent sid
        ks <- selectList [SshKeyPerson ==. pid] [Asc SshKeyName]
        return $ map (\ (Entity _ k) -> sshKeyName k) ks
    defaultLayout $ do
        setTitle $ toHtml $
            intercalate " > " ["Vervis", "People", user, "Keys"]
        $(widgetFile "keys")

postKeysR :: Text -> Handler Html
postKeysR _ = error "not impl"

getKeyNewR :: Text -> Handler Html
getKeyNewR _ = error "not impl"

getKeyR :: Text -> Text -> Handler Html
getKeyR user tag = do
    Entity _kid key <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharerIdent user
        Entity pid _person <- getBy404 $ UniquePersonIdent sid
        getBy404 $ UniqueSshKey pid tag
    let toText = decodeUtf8With lenientDecode
        content = toText $ encode $ sshKeyContent key
    defaultLayout $ do
        setTitle $ toHtml $
            intercalate " > " ["Vervis", "People", user, "Keys", tag]
        $(widgetFile "key")