otp-authenticator-0.1.2.0: src/Encrypted.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      : Encrypted
-- Description : Abstracting over an encrypted value with gpgme and gnupg
-- Copyright   : (c) Justin Le 2017
-- License     : MIT
-- Maintainer  : justin@jle.im
-- Stability   : unstable
-- Portability : portable
--
-- Basically provides @'Enc' a@, which abstracts over an encrypted @a@.
-- Can only be read by invoking GnuPG in 'IO', where the user needs to
-- provide their key to decrypt.
--
-- One main advantage is that an @'Enc' a@ can be seriealized and
-- deserialized using its 'Binary' instance, providing type-safe
-- deserialization into encrypted values.
--
-- Might be pulled out to an external package some day.
module Encrypted
  ( Enc (..),
    mkEnc,
    overEnc,
    getEnc,
    withEnc,
  )
where

import qualified Crypto.Gpgme as G
import qualified Data.Binary as B
import qualified Data.ByteString.Lazy as BSL
import GHC.Generics (Generic)

-- | An @'Enc' a@ abstracts over a encrypted @a@.
--
-- Has a useful 'Binary' instance, which allows type-safe deserialization
-- into encrypted values.
data Enc a = Enc {encBytes :: G.Encrypted}
  deriving (Generic)

instance B.Binary (Enc a)

-- | A variation of 'overEnc' that allows the user to also return a value
-- produced from the decrypted value.  Re-encrypts the changed value using
-- the given GnuPG key.
withEnc ::
  (B.Binary a) =>
  G.Ctx ->
  G.Key ->
  Enc a ->
  (a -> IO (b, a)) ->
  IO (b, Enc a)
withEnc c k e f = do
  x <- getEnc c e
  (o, y) <- f x
  e' <- mkEnc c k y
  return (o, e')

-- | Modify an encrypted value with a given @a -> IO a@ function,
-- re-encrypting it with the given GnuPG key.  The decrypted value never
-- leaves the closure.
overEnc ::
  (B.Binary a) =>
  G.Ctx ->
  G.Key ->
  Enc a ->
  (a -> IO a) ->
  IO (Enc a)
overEnc c k e f = fmap snd . withEnc c k e $ (fmap ((),) . f)

-- | Extract a value from an 'Enc', using a compatible key in the GnuPG
-- environment.
getEnc ::
  (B.Binary a) =>
  G.Ctx ->
  Enc a ->
  IO a
getEnc c (Enc e) = do
  Right x <- fmap (B.decode . BSL.fromStrict) <$> G.decrypt c e
  return x

-- | Wrap a value into an 'Enc', using a given GnuPG key.
mkEnc ::
  (B.Binary a) =>
  G.Ctx ->
  G.Key ->
  a ->
  IO (Enc a)
mkEnc c k x = do
  Right e' <- G.encrypt c [k] G.NoFlag . BSL.toStrict . B.encode $ x
  return (Enc e')