85 lines
2.3 KiB
Haskell
85 lines
2.3 KiB
Haskell
module Handler.StorageKey
|
|
( postStorageKeyR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Crypto.Hash
|
|
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient)
|
|
import qualified Data.Binary as Binary (encode)
|
|
import qualified Crypto.KDF.HKDF as HKDF
|
|
|
|
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
|
|
|
|
|
data StorageKeyType
|
|
= SKTExamCorrect
|
|
{ _sktExam :: CryptoUUIDExam
|
|
}
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
, constructorTagModifier = camelToPathPiece' 1
|
|
, tagSingleConstructors = True
|
|
} ''StorageKeyType
|
|
|
|
data StorageKeyRequest
|
|
= StorageKeyRequest
|
|
{ skReqType :: StorageKeyType
|
|
, skReqTimestamp :: Maybe UTCTime
|
|
, skReqSalt :: Maybe Text
|
|
, skReqLength :: Int
|
|
}
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 2
|
|
, omitNothingFields = True
|
|
} ''StorageKeyRequest
|
|
|
|
data StorageKeyResponse
|
|
= StorageKeyResponse
|
|
{ skResKey :: Text
|
|
, skResTimestamp :: UTCTime
|
|
, skResSalt :: Text
|
|
}
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 2
|
|
, constructorTagModifier = camelToPathPiece' 2
|
|
} ''StorageKeyResponse
|
|
|
|
|
|
postStorageKeyR :: Handler Value
|
|
postStorageKeyR = do
|
|
uid <- requireAuthId
|
|
sbKey <- secretBoxKey
|
|
|
|
StorageKeyRequest{..} <- requireCheckJsonBody
|
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
let
|
|
(lBound,rBound) = case skReqType of
|
|
SKTExamCorrect _ -> (-30*nominalDay, nominalDay)
|
|
|
|
timestampInBounds = maybe False (\ts -> addUTCTime lBound now < ts && addUTCTime rBound now > ts) skReqTimestamp
|
|
|
|
timestamp = if
|
|
| Just ts <- skReqTimestamp, timestampInBounds -> ts
|
|
| otherwise -> now
|
|
|
|
salt <- let sltSize = hashDigestSize SHA3_256 in if
|
|
| Just slt <- Base64.decodeLenient . encodeUtf8 <$> skReqSalt
|
|
, timestampInBounds
|
|
, length slt == sltSize -> return slt
|
|
| otherwise -> pack . take sltSize <$> liftIO getRandoms
|
|
|
|
let
|
|
ikm = (toStrict . Aeson.encode) (skReqType, uid, sbKey)
|
|
key = HKDF.expand (HKDF.extract salt ikm :: HKDF.PRK SHA3_256) (toStrict $ Binary.encode (timestamp,skReqLength)) skReqLength
|
|
|
|
return $ toJSON StorageKeyResponse
|
|
{ skResKey = (decodeUtf8 . Base64.encode) key
|
|
, skResTimestamp = timestamp
|
|
, skResSalt = (decodeUtf8 . Base64.encode) salt
|
|
}
|