
module Zero.Identification.Internal
  (
    -- * Data Structures
    IdentityAssertion(..)
  , Certificate(..)
  , BackedAssertion(..)

  , parseAssertion
  , decodeAssertion
  , encodeAssertion

  , parseCertificate
  , encodeCertificate

    -- * Constructors
  , buildIdentityAssertion
  , buildIdentityAssertionHex
  , buildCertificate

    -- * Verifiers
  , verifyIdentityAssertion
  , verifyCertificate
  ) where

------------------------------------------------------------------------------

import           Prelude hiding (exp)
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteArray as BA
import           Data.Either (Either(..), lefts)
import           Data.Ratio (numerator)
import           Data.Text (Text)
import           Data.Time.Clock.POSIX
import           Data.Aeson
import           Data.Hex (hex)
import           Crypto.PubKey.Ed25519 (SecretKey, sign, toPublic)
import           Zero.Swagger
import qualified Zero.Settings as Settings

------------------------------------------------------------------------------

parseAssertion :: Text -> (Text, Text, Text)
parseAssertion assertionHex =
  let
    pubkeyHex = T.take 64 assertionHex
    signatureHex = T.take 128 (T.drop 64 assertionHex)
    payloadHex = T.drop 192 assertionHex
  in (pubkeyHex, signatureHex, payloadHex)

decodeAssertion :: Text -> Maybe IdentityAssertion
decodeAssertion assertionHex =
  let (pubkeyHex, signatureHex, payloadHex) = parseAssertion assertionHex in
    decode $ L8.pack $ T.unpack payloadHex

encodeAssertion :: SecretKey -> IdentityAssertion -> Text
encodeAssertion key assertion =
  let
    pubkey = toPublic key
    payload = L8.toStrict $ encode assertion
    signature = sign key pubkey payload
  in T.pack $ B8.unpack $ hex (BA.convert pubkey)
        `B8.append` hex (BA.convert signature)
        `B8.append` hex payload

parseCertificate :: Text -> (Text, Text, Text)
parseCertificate assertionHex =
  let
    pubkeyHex = T.take 64 assertionHex
    signatureHex = T.take 128 (T.drop 64 assertionHex)
    payloadHex = T.drop 196 assertionHex
  in (pubkeyHex, signatureHex, payloadHex)

encodeCertificate :: SecretKey -> Certificate -> Text
encodeCertificate key certificate =
  let
    pubkey = toPublic key
    payload = L8.toStrict $ encode certificate
    signature = sign key pubkey payload
  in T.pack $ B8.unpack $ hex (BA.convert pubkey)
        `B8.append` hex (BA.convert signature)
        `B8.append` hex payload

------------------------------------------------------------------------------
-- Certificate
------------------------------------------------------------------------------

data Certificate = Certificate {
    c_iss :: Text       -- ^ The issuer
  , c_sub :: Text       -- ^ The subject (user)
  , c_iat :: Integer    -- ^ Issued at
  , c_exp :: Integer    -- ^ Expiry
  , c_pub :: Text       -- ^ The clients public key
  } deriving (Show, Generic)

instance ToJSON Certificate where
  toJSON (Certificate iss sub iat exp pub) =
    object [
      "iss" .= iss
    , "sub" .= sub
    , "iat" .= iat
    , "exp" .= exp
    , "pub" .= pub
    ]

instance FromJSON Certificate where
  parseJSON = withObject "Certificate" $ \v -> Certificate
    <$> v .: "iss"
    <*> v .: "sub"
    <*> v .: "iat"
    <*> v .: "exp"
    <*> v .: "pub"

instance ToSchema Certificate where
  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
    & mapped.schema.description ?~ "A signed certificate."
    & mapped.schema.example ?~ toJSON defaultCertificate

-----------------------------------------------------------------------------
-- Assertion
------------------------------------------------------------------------------

data IdentityAssertion = IdentityAssertion
  { ia_kid :: Text     -- ^ The public key used to sign
  , ia_aud :: Text     -- ^ The audience (e.g zero.example.com)
  , ia_exp :: Integer  -- ^ When the assertion expires
  } deriving (Show, Generic)

instance ToJSON IdentityAssertion where
  toJSON (IdentityAssertion kid aud exp) =
    object [
      "kid" .= kid
    , "aud" .= aud
    , "exp" .= exp
    ]

instance FromJSON IdentityAssertion where
  parseJSON = withObject "IdentityAssertion" $ \v -> IdentityAssertion
    <$> v .: "kid"
    <*> v .: "aud"
    <*> v .: "exp"

data BackedAssertion = BackedAssertion IdentityAssertion Certificate
  deriving (Show, Generic)

------------------------------------------------------------------------------
-- Constructors
------------------------------------------------------------------------------

defaultIdentityAssertion = IdentityAssertion
  { ia_kid = "<some-public-id>"
  , ia_aud = "example.com"
  , ia_exp = 0
  }

buildIdentityAssertion aud delta kid = do
  t <- timeInSeconds
  l <- posixLater delta
  return $ IdentityAssertion {
      ia_kid = kid
    , ia_aud = aud
    , ia_exp = l
    }

buildIdentityAssertionHex aud delta kid = do
  t <- timeInSeconds
  l <- posixLater delta
  return $ T.pack $ hex $ L8.unpack $ encode $ IdentityAssertion {
      ia_kid = kid
    , ia_aud = aud
    , ia_exp = l
    }

defaultCertificate = Certificate
  { c_iss = "example.com"
  , c_sub = "someone@example.com"
  , c_iat = 0
  , c_exp = 0
  , c_pub = "<some-public-key>"
  }

buildCertificate user pubkey delta = do
  t <- timeInSeconds
  l <- posixLater delta
  return $ Certificate {
      c_iss = Settings.domain
    , c_sub = user
    , c_iat = t
    , c_exp = l
    , c_pub = pubkey
    }

------------------------------------------------------------------------------
-- Functions
------------------------------------------------------------------------------

-- | Verify an idp provided certificate
verifyCertificate :: Text -> Text -> Certificate -> IO (Either [String] Certificate)
verifyCertificate user pubkey cert@Certificate{..} = do
  expired <- hasExpired c_exp
  let errors = lefts $ checkConditions expired c_iat c_pub pubkey c_sub user c_iss
  if length errors > 0 then
    return $ Left (errors)
    else
    return $ Right cert

-- | Verify an identity assertion
verifyIdentityAssertion :: IdentityAssertion -> IO (Either String IdentityAssertion)
verifyIdentityAssertion assertion@IdentityAssertion{..} = do
  exp <- hasExpired ia_exp
  if not exp then
    if ia_aud == Settings.audience then do
      return $ Right assertion
    else
      return $ Left "The audience does not match this service."
  else
    return $ Left "The claims have expired."

------------------------------------------------------------------------------
-- Utility
------------------------------------------------------------------------------

hasExpired :: Integer -> IO Bool
hasExpired t = do
  -- TODO: skew
  now <- timeInSeconds
  if now > t then
    return True
  else
    return False

-- withinTime iat tf = undefined

checkExpired exp =
  if not exp then
    Right True
  else
    Left "The certificate has expired."

pubkeyEq pubkeyA pubkeyB =
  if pubkeyA == pubkeyB then
    Right True
  else
    Left "Public key mismatch."

userEq userA userB =
  if userA == userB then
    Right True
  else
    Left "User mismatch."

domainEq iss =
  if Settings.domain == iss then
    Right True
  else
    Left "Issuer mismatch."

checkConditions exp iat pubA pubB userA userB iss =
  [ checkExpired exp
  , pubkeyEq pubA pubB
  , userEq userA userB
  , domainEq iss
  ]

------------------------------------------------------------------------------
-- Time
------------------------------------------------------------------------------

timeInMicros :: IO Integer
timeInMicros = numerator . toRational . (* 1000000) <$> getPOSIXTime

timeInMillis :: IO Integer
timeInMillis = (`div` 1000) <$> timeInMicros

timeInSeconds :: IO Integer
timeInSeconds = (`div` 1000) <$> timeInMillis

timeInSeconds' :: IO Double
timeInSeconds' = (/ 1000000) . fromIntegral <$> timeInMicros

posixLater :: Integer -> IO Integer
posixLater seconds = do
  now <- timeInSeconds
  return (now + seconds)
