vervis/src/Vervis/ActorKey.hs

{- This file is part of Vervis.
 -
 - Written in 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.ActorKey
    ( ActorKey ()
    , generateActorKey
    , actorKeyRotator
    , actorPublicKey
    )
where

import Prelude

import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TVar, writeTVar)
import Control.Monad (forever)
import Control.Monad.STM (atomically)
import Crypto.PubKey.Ed25519
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import Data.Time.Interval (TimeInterval, microseconds)
import Data.PEM

-- | Ed25519 signing key.
data ActorKey = ActorKey
    { actorKeySecret    :: SecretKey
    , actorKeyPublic    :: PublicKey
    , actorKeyPublicPem :: ByteString
    }

-- | Generate a new random key.
generateActorKey :: IO ActorKey
generateActorKey = mk <$> generateSecretKey
    where
    mk secret =
        let public = toPublic secret
        in  ActorKey
                { actorKeySecret    = secret
                , actorKeyPublic    = public
                , actorKeyPublicPem =
                    pemWriteBS $ PEM "PUBLIC KEY" [] $ convert public
                }

-- | A loop that runs forever and periodically generates a new actor key,
-- storing it in a 'TVar'.
actorKeyRotator :: TimeInterval -> TVar ActorKey -> IO ()
actorKeyRotator interval key =
    let micros = microseconds interval
    in  if 0 < micros && micros <= toInteger (maxBound :: Int)
            then
                let micros' = fromInteger micros
                in  forever $ do
                        threadDelay micros'
                        generateActorKey >>= atomically . writeTVar key
            else
                error $
                    "actorKeyRotator: interval out of range: " ++ show micros

-- | The public key in PEM format, can be directly placed in responses.
actorPublicKey :: ActorKey -> ByteString
actorPublicKey = actorKeyPublicPem