{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

module Model.Tokens.Upload
  ( UploadNonce, newUploadNonce
  , UploadToken(..)
  , _uploadTokenIdentifier, _uploadTokenNonce, _uploadTokenIssuedBy, _uploadTokenIssuedAt, _uploadTokenExpiresAt, _uploadTokenStartsAt, _uploadTokenConfig
  , UploadTokenState(..)
  , _uploadTokenStateHashState, _uploadTokenStateManifest
  , UploadTokenStateHashState(..)
  , _utsHashStateNonce, _utsHashStateState
  ) where

import ClassyPrelude.Yesod

import Model.Tokens.Lens
import Model
import Utils.Lens

import Jose.Jwt (IntDate(..))
import qualified Jose.Jwt as Jose

import Data.Time.Clock.POSIX

import Control.Monad.Fail

import qualified Data.Aeson as JSON
import Data.Aeson.TH
import Utils.PathPiece

import qualified Data.HashMap.Strict as HashMap

import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Data.ByteString.Base64.URL as Base64
import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Saltine.Internal.SecretBox as Saltine

import qualified Data.ByteString as BS


data UploadToken = UploadToken
  { uploadTokenIdentifier :: TokenId
  , uploadTokenNonce      :: UploadNonce
  , uploadTokenIssuedAt   :: UTCTime
  , uploadTokenIssuedBy   :: InstanceId
  , uploadTokenIssuedFor  :: ClusterId
  , uploadTokenExpiresAt
  , uploadTokenStartsAt   :: Maybe UTCTime
  , uploadTokenConfig     :: FileField FileReference
  , uploadTokenState      :: Maybe UploadTokenState
  } deriving (Eq, Ord, Show, Generic, Typeable)

data UploadTokenState = UploadTokenState
  { uploadTokenStateHashState :: UploadTokenStateHashState
  , uploadTokenStateManifest  :: Seq FileContentChunkReference
  } deriving (Eq, Ord, Show, Generic, Typeable)

data UploadTokenStateHashState = UploadTokenStateHashState
  { utsHashStateNonce :: SecretBox.Nonce
  , utsHashStateState :: ByteString
  } deriving (Eq, Ord, Show, Generic, Typeable)


makeLenses_ ''UploadToken
instance HasTokenIdentifier UploadToken TokenId where
  _tokenIdentifier = _uploadTokenIdentifier
instance HasTokenIssuedBy UploadToken InstanceId where
  _tokenIssuedBy = _uploadTokenIssuedBy
instance HasTokenIssuedFor UploadToken ClusterId where
  _tokenIssuedFor = _uploadTokenIssuedFor
instance HasTokenIssuedAt UploadToken UTCTime where
  _tokenIssuedAt = _uploadTokenIssuedAt
instance HasTokenExpiresAt UploadToken (Maybe UTCTime) where
  _tokenExpiresAt = _uploadTokenExpiresAt
instance HasTokenStartsAt UploadToken (Maybe UTCTime) where
  _tokenStartsAt = _uploadTokenStartsAt
makeLenses_ ''UploadTokenState
makeLenses_ ''UploadTokenStateHashState


deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 3
  } ''UploadTokenState

instance ToJSON UploadTokenStateHashState where
  toJSON UploadTokenStateHashState{..} = JSON.String . decodeUtf8 . Base64.encode $ Saltine.encode utsHashStateNonce <> utsHashStateState

instance FromJSON UploadTokenStateHashState where
  parseJSON = JSON.withText "UploadTokenStateHashState" $ \t -> do
    decoded <- either (const $ fail "Invalid base64") return . Base64.decode $ encodeUtf8 t
    unless (BS.length decoded >= Saltine.secretbox_noncebytes + Saltine.secretbox_macbytes) $
      fail "Too short"
    let (nonceBS, utsHashStateState) = BS.splitAt Saltine.secretbox_noncebytes decoded
    utsHashStateNonce <- maybe (fail "Invalid nonce") return $ Saltine.decode nonceBS
    return UploadTokenStateHashState{..}

instance ToJSON UploadToken where
  toJSON UploadToken{..} = JSON.object . catMaybes $
      [ pure $ "config" JSON..= uploadTokenConfig
      , fmap ("state" JSON..=) uploadTokenState
      ] ++ let JSON.Object hm = toJSON Jose.JwtClaims{..} in (pure <$> HashMap.toList hm)
    where jwtIss = Just $ toPathPiece uploadTokenIssuedBy
          jwtSub = Just $ toPathPiece uploadTokenNonce
          jwtAud = Just . pure $ toPathPiece uploadTokenIssuedFor
          jwtExp = IntDate . utcTimeToPOSIXSeconds <$> uploadTokenExpiresAt
          jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> uploadTokenStartsAt
          jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds uploadTokenIssuedAt
          jwtJti = Just $ toPathPiece uploadTokenIdentifier

instance FromJSON UploadToken where
  parseJSON val = flip (JSON.withObject "UploadToken") val $ \o -> do
    Jose.JwtClaims{..} <- parseJSON val

    uploadTokenIdentifier <- parseMaybe "uploadTokenIdentfier" $
      fromPathPiece =<< jwtJti
    uploadTokenNonce <- parseMaybe "uploadTokenNonce" $
      fromPathPiece =<< jwtSub
    uploadTokenIssuedAt <- parseMaybe "uploadTokenIssuedAt" $
      unIntDate <$> jwtIat
    uploadTokenIssuedBy <- parseMaybe "uploadTokenIssuedBy" $
      fromPathPiece =<< jwtIss
    uploadTokenIssuedFor <- parseMaybe "uploadTokenIssuedFor" $ do
      [aud] <- jwtAud
      fromPathPiece aud
    let uploadTokenExpiresAt = unIntDate <$> jwtExp
        uploadTokenStartsAt = unIntDate <$> jwtNbf

    uploadTokenConfig <- o JSON..: "config"
    uploadTokenState <- o JSON..:? "state"

    return UploadToken{..}
    where
      parseMaybe errId = maybe (fail $ "Could not parse " <> errId) return
      unIntDate (IntDate posix) = posixSecondsToUTCTime posix