134 lines
5.0 KiB
Haskell
134 lines
5.0 KiB
Haskell
{-# 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
|