{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Crypto.Verification (Signed(..)
                          , getSignable
                          , sign
                          , verify
                          , serialize
                          , deserialize
                          , deserializeSignable) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Crypto.Hash.Algorithms (SHA256)
import Crypto.MAC.HMAC (HMAC(..), hmac)
import Crypto.Hash (Digest, digestFromByteString)
import Data.ByteArray.Encoding (Base(..)
                              , convertToBase
                              , convertFromBase)
import Data.Tuple (swap)

import Crypto.Encryption (Encrypted(..), getIV, getSecret)
import Extension.Either
import qualified Extension.ByteString as EBS

data Signed signable =
  Signed signable (Digest SHA256) deriving (Int -> Signed signable -> ShowS
forall signable. Show signable => Int -> Signed signable -> ShowS
forall signable. Show signable => [Signed signable] -> ShowS
forall signable. Show signable => Signed signable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signed signable] -> ShowS
$cshowList :: forall signable. Show signable => [Signed signable] -> ShowS
show :: Signed signable -> String
$cshow :: forall signable. Show signable => Signed signable -> String
showsPrec :: Int -> Signed signable -> ShowS
$cshowsPrec :: forall signable. Show signable => Int -> Signed signable -> ShowS
Show, Signed signable -> Signed signable -> Bool
forall signable.
Eq signable =>
Signed signable -> Signed signable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signed signable -> Signed signable -> Bool
$c/= :: forall signable.
Eq signable =>
Signed signable -> Signed signable -> Bool
== :: Signed signable -> Signed signable -> Bool
$c== :: forall signable.
Eq signable =>
Signed signable -> Signed signable -> Bool
Eq)

class Eq signable => Signable signable where
  sign :: String -> signable -> Signed signable

  verify :: String -> Signed signable -> Bool
  verify String
key signed :: Signed signable
signed@(Signed signable
message Digest SHA256
_) = forall signable.
Signable signable =>
String -> signable -> Signed signable
sign String
key signable
message forall a. Eq a => a -> a -> Bool
== Signed signable
signed

  getSignable :: Signed signable -> signable
  getSignable (Signed signable
signable Digest SHA256
_) = signable
signable

  serializeSignable :: signable -> ByteString

  deserializeSignable :: ByteString -> Maybe signable

  serialize :: Signed signable -> ByteString
  serialize (Signed signable
signable Digest SHA256
digest) =
    forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded (forall signable. Signable signable => signable -> ByteString
serializeSignable signable
signable)
    ByteString -> ByteString -> ByteString
`BS.append` ByteString
"|signature." ByteString -> ByteString -> ByteString
`BS.append`
    String -> ByteString
BS.pack (forall a. Show a => a -> String
show Digest SHA256
digest)

  deserialize :: ByteString -> Maybe (Signed signable)
  deserialize ByteString
bs = forall signable. signable -> Digest SHA256 -> Signed signable
Signed
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e a. Either e a -> Maybe a
rightToMaybe Either String ByteString
message forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall signable. Signable signable => ByteString -> Maybe signable
deserializeSignable)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e a. Either e a -> Maybe a
rightToMaybe Either String ByteString
signature forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString)
      where
        (ByteString
encodedMessage, ByteString
base16Signature) =
          ByteString -> ByteString -> ByteString
EBS.stripPrefix ByteString
"|signature."
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span (forall a. Eq a => a -> a -> Bool
/= Char
'|') ByteString
bs
        signature :: Either String ByteString
        signature :: Either String ByteString
signature = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base16 ByteString
base16Signature
        message :: Either String ByteString
message = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded ByteString
encodedMessage

instance {-# OVERLAPPING #-} Signable String where
  sign :: String -> String -> Signed String
sign String
key String
message = forall signable. signable -> Digest SHA256 -> Signed signable
Signed String
message Digest SHA256
digest
    where
      digest :: Digest SHA256
digest = forall a. HMAC a -> Digest a
hmacGetDigest HMAC SHA256
hmac'ed
      hmac'ed :: HMAC SHA256
hmac'ed = forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac (String -> ByteString
BS.pack String
key) (String -> ByteString
BS.pack String
message) :: HMAC SHA256

  serializeSignable :: String -> ByteString
serializeSignable = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack

  deserializeSignable :: ByteString -> Maybe String
deserializeSignable ByteString
bs = ByteString -> String
BS.unpack
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Either e a -> Maybe a
rightToMaybe (forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded ByteString
bs)

instance Signable Encrypted where
  sign :: String -> Encrypted -> Signed Encrypted
sign String
key Encrypted
message = forall signable. signable -> Digest SHA256 -> Signed signable
Signed Encrypted
message Digest SHA256
digest
    where
      digest :: Digest SHA256
digest = forall a. HMAC a -> Digest a
hmacGetDigest HMAC SHA256
hmac'ed
      hmac'ed :: HMAC SHA256
hmac'ed =
        forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac (String -> ByteString
BS.pack String
key)
        (forall signable. Signable signable => signable -> ByteString
serializeSignable Encrypted
message) :: HMAC SHA256

  serializeSignable :: Encrypted -> ByteString
serializeSignable Encrypted
encrypted =
    ByteString
"iv," ByteString -> ByteString -> ByteString
`BS.append`
    forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded (String -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encrypted -> String
getIV forall a b. (a -> b) -> a -> b
$ Encrypted
encrypted)
    ByteString -> ByteString -> ByteString
`BS.append` ByteString
"|" ByteString -> ByteString -> ByteString
`BS.append`
    forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded (Encrypted -> ByteString
getSecret Encrypted
encrypted)

  deserializeSignable :: ByteString -> Maybe Encrypted
deserializeSignable ByteString
bs = String -> ByteString -> Encrypted
Encrypted
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> String
BS.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Either e a -> Maybe a
rightToMaybe Either String ByteString
iv)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e a. Either e a -> Maybe a
rightToMaybe Either String ByteString
secret)
      where
        (ByteString
base64Secret, ByteString
base64IV) =
          ByteString -> ByteString -> ByteString
EBS.stripPrefix ByteString
"iv," forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
EBS.stripSuffix ByteString
"|"
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> (b, a)
swap ((Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd (forall a. Eq a => a -> a -> Bool
/= Char
'|') ByteString
bs)
        iv :: Either String ByteString
iv = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded ByteString
base64IV
        secret :: Either String ByteString
secret = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded ByteString
base64Secret