Encrypted2.hs

DecodeFailure String

instance Error EncryptError where
  noMsg  = EncryptError
  strMsg = OtherEncryptError

-- | A monad transformer for building encryption pipelines and
-- methods. Within a single 'EncryptT' session, 'Nonce's are
-- guaranteed to be randomized and increasing.
newtype EncryptT m a =
  EncryptT (ErrorT EncryptError (StateT ([Key], Nonce) m) a)
  deriving (Functor, Applicative, Monad, MonadPlus, MonadIO)

-- | A synonym for when the transformer isn't stacked
type Encrypt a = EncryptT IO a

instance MonadTrans EncryptT where
  lift = EncryptT . lift . lift

-- | Attempts to inject an 'Encrypted a' into the 'Encrypt' monad,
-- using the first included key which can decrypt the value, but fails
-- otherwise.
fromEncrypted :: Encrypted a -> EncryptT m a
fromEncrypted = undefined

errd :: Monad m => EncryptError -> EncryptT m a
errd = EncryptT . throwError

-- | Gets the active keys inside of this 'EncryptT'
getKeys :: Monad m => EncryptT m [Key]
getKeys = EncryptT $ liftM fst $ lift get

addKey :: Monad m => Key -> EncryptT m ()
addKey k = EncryptT $ lift $ modify $ first (k:)

pickKey :: Monad m => Id -> EncryptT m Key
pickKey i = do keys <- getKeys
               case find (\k -> identity k == i) keys of
                 Nothing -> errd NotAuthorized
                 Just k  -> return k

removeKey :: Monad m => Key -> EncryptT m ()
removeKey k = EncryptT $ lift $ modify $ first f
  where f :: [Key] -> [Key]
        f = filter (/= k)

removeKeyById :: Monad m => Id -> EncryptT m ()
removeKeyById i = EncryptT $ lift $ modify $ first f
  where f :: [Key] -> [Key]
        f = filter (\k -> identity k /= i)

newKey :: MonadIO m => EncryptT m Key
newKey = do bs <- liftIO (randomBytes SK.keyLength)
            i  <- liftIO randomIO
            return Key { key = SecretKey bs, identity = Id i }

newNonce :: Monad m => EncryptT m Nonce
newNonce = do n <- EncryptT $ liftM snd $ lift get
              EncryptT $ lift $ modify $ second SaltI.incNonce
              return n

-- | Encrypts a payload using a fresh nonce and a given key
encrypt :: (Monad m, ToJSON a) => Key -> a -> EncryptT m (Encrypted a)
encrypt (Key {key = key, identity = i}) a =
  do n@(Nonce skn) <- newNonce
     return Encrypted { payload = B64.encode (SK.encrypt skn (encodeS a) key),
                        nonce   = n,
                        ownedBy = Single i }

-- | Encrypts a payload using all of the currently available keys
encryptMulti :: (MonadIO m, ToJSON a) => a -> EncryptT m (Encrypted a)
encryptMulti a = do keys <- getKeys
                    case keys of
                      []     -> errd NoKeys
                      (x:[]) -> encrypt x a
                      xs     -> do contentKey <- newKey
                                   enc        <- encrypt contentKey a
                                   certs      <- mapM (`encrypt` contentKey) xs
                                   return enc { ownedBy = Multi certs }

decrypt :: Encrypted a -> EncryptT m a
decrypt e@(Encrypted { ownedBy = o,
                       nonce = (Nonce skn),
                       payload = p }) =
  case o of
    Single id -> do k@(Key { key = sk }) <- pickKey id
                    case SK.decrypt skn p sk of
                      Nothing -> errd SignatureFailure
                      Just s  -> case decodeS s of
                        Nothing -> errd DecodeFailure (B8