Encrypted.hs

  fromEncrypted,
  newKey, getKeys,
  addKey, removeKey, removeKeyById,
  encrypt, encryptMulti, decrypt
  ) where

import Data.Encrypted.Internal

import Data.UUID
import Data.Aeson
import Data.Tagged
import Data.Maybe
import Data.Monoid
import Data.List
import qualified Data.Text as T
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Base64 as B64

import GHC.Generics
import Data.Data

import Crypto.NaCl.Key
import Crypto.NaCl.Random
import qualified Crypto.NaCl.Internal as SaltI
import qualified Crypto.NaCl.Encrypt.SecretKey as SK

import Control.Error
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Error

import System.Random
import Test.QuickCheck
import Test.QuickCheck.Gen

-- | 'Id's are encryption identities, wrappers around random
-- "Data.UUID.UUID" which helps for Serialization purposes.
newtype Id = Id { unId :: UUID } deriving (Eq, Ord, Data, Typeable, Generic)

instance Show Id where
  show (Id {unId = uuid}) = "Id " ++ show uuid

-- | 'UUID's are serialized directly, but since we known the UUID
-- character set is valid ASCII, it's safe to just directly encode it
instance ToJSON Id where
  toJSON = String . T.pack . toString . unId

-- | 'UUID's are deserialized directly. Similar to the 'ToJSON'
-- instance, we assume the character set is fine and encode directly.
instance FromJSON Id where
  parseJSON (String t) =
    justZ . fmap Id . fromString . T.unpack $ t
  parseJSON _ = mzero

-- | Lifts the 'Random UUID' instance
instance Arbitrary Id where
  arbitrary = fmap Id $ MkGen $ \g _ -> fst (random g)



data Key = Key { key :: SecretKey, identity :: Id }
           deriving (Eq, Typeable, Generic)

instance Show Key where
  showsPrec p (Key { identity = i }) =
    showParen (p>0) $
    showString $ "Key {key = <<elided>>, identity = " ++ show i ++ "}"


instance ToJSON Key where
  toJSON (Key { key = SecretKey kbs, identity = i }) =
    object ["key"      .= String (b64text kbs),
            "identity" .= toJSON i]
            
instance FromJSON Key where
  parseJSON (Object o) =
    do i            <- o .: "identity"
       (String ktx) <- o .: "key"
       kbs          <- justZ $ unb64text ktx
       return Key { key = SecretKey kbs, identity = i }
  parseJSON _ = mzero

-- | WARNING For testing only! This does not produce cryptographically
-- random keys!
instance Arbitrary Key where
  arbitrary = do k <- fmap (SecretKey . B.pack) $ vector SK.keyLength
                 i <- arbitrary
                 return Key { key = k, identity = i }

-- | A newtype wrapper around 'SK.SKNonce' for serialization
newtype Nonce = Nonce SK.SKNonce deriving (Eq, Typeable, Generic)

instance Show Nonce where
  showsPrec p (Nonce sk) =
    showParen (p>0) $
    showString (B8.unpack $ "Nonce " <> B64.encode (SaltI.toBS sk))

-- | Lift the internal 'Nonce' API up to 'Nonce'
instance SaltI.Nonce Nonce where
  size = retag (SaltI.size :: Tagged SK.SKNonce Int)
  toBS (Nonce n) = SaltI.toBS n
  fromBS bs = fmap Nonce $ SaltI.fromBS bs
  createZeroNonce = Nonce SaltI.createZeroNonce
  createRandomNonce = fmap Nonce SaltI.createRandomNonce
  incNonce (Nonce n) = Nonce (SaltI.incNonce n)

instance ToJSON Nonce where
  toJSON (Nonce n) = String . b64text $ SaltI.toBS n

instance FromJSON Nonce where
  parseJSON (String t) = justZ $ SaltI.fromBS <=< unb64text $ t
  parseJSON _ = mzero

instance Arbitrary Nonce where
  arbitrary =
    do let size = SaltI.size
       n <- fmap (fromJust . SaltI.fromBS . B.pack) (vector $ untag size)
       return (n `asTaggedTypeOf` size)

data Ownership = Single Id | Multi [Encrypted Key]
               deriving (Show, Eq, Typeable, Generic)

instance ToJSON Ownership where
  toJSON (Single i)  = object ["one"  .= toJSON i]
  toJSON (Multi  is) = object ["many" .= toJSON is]

instance FromJSON Ownership where
  parseJSON (Object o) = singleParse <|> multiParse
    where singleParse = fmap Single $ o .: "one"
          multiParse  = fmap Multi  $ o .: "many"
  parseJSON _ = mzero

data Encrypted a =
  Encrypted { payload :: ByteString,
              nonce   :: Nonce,
              ownedBy :: Ownership }
  deriving (Eq, Show, Typeable, Generic)

instance ToJSON   (Encrypted a)
instance FromJSON (Encrypted a)

instance (Arbitrary a, ToJSON a) => Arbitrary (Encrypted a) where
  arbitrary =
    do a                              <- arbitrary
       n@(Nonce skn)                  <- arbitrary
       (Key { key = k, identity = i}) <- arbitrary
       return $ encryptedAsTypeOf a 
         Encrypted { payload = B64.encode $ SK.encrypt skn (encodeS a) k,
                     nonce   = n,
                     own