Generalize encrypted error messages to encoded SecretBoxes
This commit is contained in:
Gregor Kleen
parent
431eb45a94
commit
3ad8505489
@ -491,11 +491,12 @@ ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere vers
|
||||
|
||||
ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
|
||||
ErrMsgCiphertext: Verschlüsselte Fehlermeldung
|
||||
ErrMsgCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
|
||||
ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
|
||||
ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
|
||||
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
|
||||
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
|
||||
EncodedSecretBoxCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
|
||||
EncodedSecretBoxInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
|
||||
EncodedSecretBoxInvalidPadding: Verschlüsselte Daten sind nicht korrekt padded
|
||||
EncodedSecretBoxCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
|
||||
EncodedSecretBoxCouldNotOpenSecretBox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
|
||||
EncodedSecretBoxCouldNotDecodePlaintext aesonErr@String: Konnte Klartext nicht JSON-dekodieren: #{aesonErr}
|
||||
ErrMsgHeading: Fehlermeldung entschlüsseln
|
||||
ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
|
||||
|
||||
|
||||
@ -110,6 +110,7 @@ dependencies:
|
||||
- monad-memo
|
||||
- xss-sanitize
|
||||
- text-metrics
|
||||
- pkcs7
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -137,7 +137,7 @@ makeFoundation appSettings@AppSettings{..} = do
|
||||
-- logging function. To get out of this loop, we initially create a
|
||||
-- temporary foundation without a real connection pool, get a log function
|
||||
-- from there, and then create the real foundation.
|
||||
let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appErrorMsgKey = UniWorX {..}
|
||||
let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey = UniWorX {..}
|
||||
-- The UniWorX {..} syntax is an example of record wild cards. For more
|
||||
-- information, see:
|
||||
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
||||
@ -146,7 +146,7 @@ makeFoundation appSettings@AppSettings{..} = do
|
||||
(error "smtpPool forced in tempFoundation")
|
||||
(error "cryptoIDKey forced in tempFoundation")
|
||||
(error "sessionKey forced in tempFoundation")
|
||||
(error "errorMsgKey forced in tempFoundation")
|
||||
(error "secretBoxKey forced in tempFoundation")
|
||||
logFunc loc src lvl str = do
|
||||
f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
|
||||
f loc src lvl str
|
||||
@ -166,9 +166,9 @@ makeFoundation appSettings@AppSettings{..} = do
|
||||
migrateAll `runSqlPool` sqlPool
|
||||
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
|
||||
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
|
||||
appErrorMsgKey <- clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
|
||||
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
|
||||
|
||||
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
|
||||
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey
|
||||
|
||||
handleJobs foundation
|
||||
|
||||
|
||||
@ -66,8 +66,6 @@ import Utils.Lens
|
||||
import Utils.Form
|
||||
import Utils.SystemMessage
|
||||
|
||||
import Data.Aeson hiding (Error, Success)
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
import Yesod.Form.I18n.German
|
||||
@ -76,7 +74,6 @@ import qualified Yesod.Auth.Message as Auth
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
|
||||
|
||||
instance DisplayAble b => DisplayAble (E.CryptoID a b) where
|
||||
@ -99,19 +96,19 @@ instance DisplayAble SchoolId where
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
-- access to the data present here.
|
||||
data UniWorX = UniWorX
|
||||
{ appSettings :: AppSettings
|
||||
, appStatic :: Static -- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: (ReleaseKey, TVar Logger)
|
||||
, appLogSettings :: TVar LogSettings
|
||||
, appCryptoIDKey :: CryptoIDKey
|
||||
, appInstanceID :: InstanceId
|
||||
, appJobCtl :: TVar (Map ThreadId (TMChan JobCtl))
|
||||
, appCronThread :: TMVar (ReleaseKey, ThreadId)
|
||||
, appErrorMsgKey :: SecretBox.Key
|
||||
, appSessionKey :: ClientSession.Key
|
||||
{ appSettings :: AppSettings
|
||||
, appStatic :: Static -- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: (ReleaseKey, TVar Logger)
|
||||
, appLogSettings :: TVar LogSettings
|
||||
, appCryptoIDKey :: CryptoIDKey
|
||||
, appInstanceID :: InstanceId
|
||||
, appJobCtl :: TVar (Map ThreadId (TMChan JobCtl))
|
||||
, appCronThread :: TMVar (ReleaseKey, ThreadId)
|
||||
, appSessionKey :: ClientSession.Key
|
||||
, appSecretBoxKey :: SecretBox.Key
|
||||
}
|
||||
|
||||
type SMTPPool = Pool SMTPConnection
|
||||
@ -201,6 +198,7 @@ embedRenderMessage ''UniWorX ''RatingException id
|
||||
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
|
||||
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
|
||||
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
|
||||
|
||||
newtype SheetTypeHeader = SheetTypeHeader SheetType
|
||||
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
|
||||
@ -681,15 +679,12 @@ instance Yesod UniWorX where
|
||||
if
|
||||
| shouldEncrypt
|
||||
, not canDecrypt -> do
|
||||
errKey <- getsYesod appErrorMsgKey
|
||||
nonce <- liftIO SecretBox.newNonce
|
||||
let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
|
||||
encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
|
||||
formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
|
||||
ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
|
||||
|
||||
[whamlet|
|
||||
<p>_{MsgErrorResponseEncrypted}
|
||||
<pre .errMsg>
|
||||
#{formatted}
|
||||
#{ciphertext}
|
||||
|]
|
||||
| otherwise -> plaintext
|
||||
|
||||
@ -1722,6 +1717,9 @@ instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto
|
||||
type MonadCryptoKey m = CryptoIDKey
|
||||
cryptoIDKey f = getsYesod appCryptoIDKey >>= f
|
||||
|
||||
instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
|
||||
secretBoxKey = getsYesod appSecretBoxKey
|
||||
|
||||
-- Note: Some functionality previously present in the scaffolding has been
|
||||
-- moved to documentation in the Wiki. Following are some hopefully helpful
|
||||
-- links:
|
||||
|
||||
@ -4,16 +4,7 @@ import Import
|
||||
import Handler.Utils
|
||||
import Jobs
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
import Crypto.Saltine.Core.SecretBox (secretboxOpen)
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import Data.Char (isSpace)
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
|
||||
@ -110,31 +101,17 @@ getAdminUserR uuid = do
|
||||
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
|
||||
getAdminErrMsgR = postAdminErrMsgR
|
||||
postAdminErrMsgR = do
|
||||
errKey <- getsYesod appErrorMsgKey
|
||||
|
||||
((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
|
||||
(unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
|
||||
<* submitButton
|
||||
|
||||
plaintext <- formResultMaybe ctResult $ \(encodeUtf8 . Text.filter (not . isSpace) -> inputBS) ->
|
||||
exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) $ do
|
||||
ciphertext <- either (throwE . MsgErrMsgInvalidBase64) return $ Base64.decode inputBS
|
||||
|
||||
unless (BS.length ciphertext >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
||||
throwE MsgErrMsgCiphertextTooShort
|
||||
let (nonceBS, secretbox) = BS.splitAt Saltine.secretBoxNonce ciphertext
|
||||
|
||||
nonce <- maybe (throwE MsgErrMsgCouldNotDecodeNonce) return $ Saltine.decode nonceBS
|
||||
|
||||
plainBS <- maybe (throwE MsgErrMsgCouldNotOpenSecretbox) return $ secretboxOpen errKey nonce secretbox
|
||||
|
||||
either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
|
||||
plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
|
||||
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
$maybe t <- plaintext
|
||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||
#{t}
|
||||
#{encodePrettyToTextBuilder t}
|
||||
|
||||
<form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
|
||||
^{ctView}
|
||||
|
||||
@ -69,4 +69,3 @@ warnTermDays tid times = do
|
||||
forM_ warnholidays $ warnI MsgDayIsAHoliday
|
||||
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
||||
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
||||
|
||||
|
||||
@ -240,7 +240,9 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
|
||||
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
-- | Format @DBTable@ when sort-circuiting
|
||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
|
||||
-- | Format @DBTable@ when not short-circuiting
|
||||
dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
|
||||
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
|
||||
|
||||
@ -368,16 +370,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
|
||||
FormFailure errs' -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
||||
_ -> runPSValidator dbtable Nothing
|
||||
psSorting' = map (first (dbtSorting !)) psSorting
|
||||
sqlQuery' = E.from $ \t -> dbtSQLQuery t
|
||||
<* E.orderBy (map (sqlSortDirection t) psSorting')
|
||||
<* E.limit psLimit
|
||||
<* E.offset (psPage * psLimit)
|
||||
<* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
|
||||
|
||||
mapM_ (addMessageI Warning) errs
|
||||
|
||||
runDB $ do
|
||||
rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
|
||||
rows' <- E.select . E.from $ \t -> do
|
||||
res <- dbtSQLQuery t
|
||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
||||
E.limit psLimit
|
||||
E.offset (psPage * psLimit)
|
||||
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
|
||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
|
||||
|
||||
let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
|
||||
|
||||
|
||||
@ -193,6 +193,12 @@ customMigrations = Map.fromListWith (>>)
|
||||
sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |]
|
||||
forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
|
||||
, whenM (tableExists "cluster_config") $
|
||||
[executeQQ|
|
||||
UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -36,7 +36,7 @@ import qualified Data.ByteString.Base64.URL as Base64
|
||||
data ClusterSettingsKey
|
||||
= ClusterCryptoIDKey
|
||||
| ClusterClientSessionKey
|
||||
| ClusterErrorMessageKey
|
||||
| ClusterSecretBoxKey
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
instance Universe ClusterSettingsKey
|
||||
@ -108,10 +108,10 @@ instance FromJSON ClientSession.Key where
|
||||
either fail return $ Serialize.decode bytes
|
||||
|
||||
|
||||
instance ClusterSetting 'ClusterErrorMessageKey where
|
||||
type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
|
||||
instance ClusterSetting 'ClusterSecretBoxKey where
|
||||
type ClusterSettingValue 'ClusterSecretBoxKey = SecretBox.Key
|
||||
initClusterSetting _ = liftIO SecretBox.newKey
|
||||
knownClusterSetting _ = ClusterErrorMessageKey
|
||||
knownClusterSetting _ = ClusterSecretBoxKey
|
||||
|
||||
instance ToJSON SecretBox.Key where
|
||||
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
|
||||
|
||||
103
src/Utils.hs
103
src/Utils.hs
@ -14,7 +14,9 @@ import Data.Monoid (Sum(..))
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Utils.DB as Utils
|
||||
import Utils.TH as Utils
|
||||
@ -27,7 +29,7 @@ import Control.Lens as Utils (none)
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
import Data.Char (isDigit)
|
||||
import Data.Char (isDigit, isSpace)
|
||||
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
|
||||
import Numeric (showFFloat)
|
||||
|
||||
@ -39,8 +41,9 @@ import qualified Data.Map as Map
|
||||
-- import qualified Data.List as List
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Catch hiding (throwM)
|
||||
|
||||
|
||||
import qualified Database.Esqueleto as E (Value, unValue)
|
||||
@ -54,6 +57,12 @@ import qualified Data.Aeson as Aeson
|
||||
|
||||
import Data.Universe
|
||||
|
||||
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Crypto.Data.PKCS7 as PKCS7
|
||||
|
||||
|
||||
|
||||
-----------
|
||||
@ -391,6 +400,10 @@ exceptT f g = either f g <=< runExceptT
|
||||
catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
|
||||
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
|
||||
|
||||
throwExceptT :: ( Exception e, MonadThrow m )
|
||||
=> ExceptT e m a -> m a
|
||||
throwExceptT = exceptT throwM return
|
||||
|
||||
|
||||
|
||||
------------
|
||||
@ -512,3 +525,89 @@ lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI
|
||||
|
||||
hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool
|
||||
hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)
|
||||
|
||||
------------------
|
||||
-- Cryptography --
|
||||
------------------
|
||||
|
||||
data SecretBoxEncoding = SecretBoxShort | SecretBoxPretty
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe SecretBoxEncoding
|
||||
instance Finite SecretBoxEncoding
|
||||
instance Default SecretBoxEncoding where
|
||||
def = SecretBoxShort
|
||||
|
||||
encodedSecretBoxBlocksize :: Word8
|
||||
-- | `encodedSecretBox'` tries to hide plaintext length by ensuring the message
|
||||
-- length (before addition of HMAC and nonce) is always a multiple of
|
||||
-- `encodedSecretBlocksize`.
|
||||
-- Bigger blocksizes hide exact message length better but lead to longer messages
|
||||
encodedSecretBoxBlocksize = maxBound
|
||||
|
||||
|
||||
encodedSecretBox' :: ( ToJSON a, MonadIO m )
|
||||
=> SecretBox.Key
|
||||
-> SecretBoxEncoding
|
||||
-> a -> m Text
|
||||
encodedSecretBox' sKey pretty val = liftIO $ do
|
||||
nonce <- SecretBox.newNonce
|
||||
let
|
||||
encrypt = SecretBox.secretbox sKey nonce
|
||||
base64 = decodeUtf8 . Base64.encode
|
||||
pad = PKCS7.padBytesN (fromIntegral encodedSecretBoxBlocksize)
|
||||
attachNonce = mappend $ Saltine.encode nonce
|
||||
chunk
|
||||
| SecretBoxPretty <- pretty = Text.intercalate "\n" . Text.chunksOf 76
|
||||
| otherwise = id
|
||||
|
||||
return . chunk . base64 . attachNonce . encrypt . pad . toStrict $ Aeson.encode val
|
||||
|
||||
data EncodedSecretBoxException
|
||||
= EncodedSecretBoxInvalidBase64 !String
|
||||
| EncodedSecretBoxInvalidPadding
|
||||
| EncodedSecretBoxCiphertextTooShort
|
||||
| EncodedSecretBoxCouldNotDecodeNonce
|
||||
| EncodedSecretBoxCouldNotOpenSecretBox
|
||||
| EncodedSecretBoxCouldNotDecodePlaintext !String
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Exception EncodedSecretBoxException
|
||||
|
||||
encodedSecretBoxOpen' :: (FromJSON a, MonadError EncodedSecretBoxException m)
|
||||
=> SecretBox.Key
|
||||
-> Text -> m a
|
||||
encodedSecretBoxOpen' sKey chunked = do
|
||||
let unchunked = Text.filter (not . isSpace) chunked
|
||||
decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked
|
||||
|
||||
unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
||||
throwError EncodedSecretBoxCiphertextTooShort
|
||||
let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce decoded
|
||||
nonce <- maybe (throwError EncodedSecretBoxCouldNotDecodeNonce) return $ Saltine.decode nonceBS
|
||||
padded <- maybe (throwError EncodedSecretBoxCouldNotOpenSecretBox) return $ SecretBox.secretboxOpen sKey nonce encrypted
|
||||
|
||||
unpadded <- maybe (throwError EncodedSecretBoxInvalidPadding) return $ PKCS7.unpadBytesN (fromIntegral encodedSecretBoxBlocksize) padded
|
||||
|
||||
either (throwError . EncodedSecretBoxCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' unpadded
|
||||
|
||||
class Monad m => MonadSecretBox m where
|
||||
secretBoxKey :: m SecretBox.Key
|
||||
|
||||
instance MonadSecretBox ((->) SecretBox.Key) where
|
||||
secretBoxKey = id
|
||||
|
||||
instance Monad m => MonadSecretBox (ReaderT SecretBox.Key m) where
|
||||
secretBoxKey = ask
|
||||
|
||||
encodedSecretBox :: ( ToJSON a, MonadSecretBox m, MonadIO m )
|
||||
=> SecretBoxEncoding
|
||||
-> a -> m Text
|
||||
encodedSecretBox pretty val = do
|
||||
sKey <- secretBoxKey
|
||||
encodedSecretBox' sKey pretty val
|
||||
|
||||
encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
|
||||
=> Text -> m a
|
||||
encodedSecretBoxOpen ciphertext = do
|
||||
sKey <- secretBoxKey
|
||||
encodedSecretBoxOpen' sKey ciphertext
|
||||
|
||||
@ -40,4 +40,6 @@ extra-deps:
|
||||
|
||||
- hlint-test-0.1.0.0
|
||||
|
||||
- pkcs7-1.0.0.1
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
39
test/UtilsSpec.hs
Normal file
39
test/UtilsSpec.hs
Normal file
@ -0,0 +1,39 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module UtilsSpec where
|
||||
|
||||
import TestImport
|
||||
import Utils
|
||||
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import Data.Aeson
|
||||
|
||||
instance Arbitrary Value where
|
||||
arbitrary = sized $ \size -> if
|
||||
| size <= 0 -> oneof [pure Null, bool', number, string]
|
||||
| otherwise -> resize (size `div` 2) $ oneof [pure Null, bool', number, string, array, object']
|
||||
where
|
||||
bool' = Bool <$> arbitrary
|
||||
number = Number <$> arbitrary
|
||||
string = String <$> arbitrary
|
||||
array = Array <$> arbitrary
|
||||
object' = Object <$> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SecretBoxEncoding where
|
||||
arbitrary = arbitraryBoundedEnum
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "encodedSecretBox" $ do
|
||||
it "has comptabile encryption/decryption" . property $
|
||||
\val pretty -> ioProperty $ do
|
||||
sKey <- SecretBox.newKey
|
||||
ciphertext <- encodedSecretBox' sKey pretty (val :: Value)
|
||||
plaintext <- throwExceptT $ encodedSecretBoxOpen' sKey ciphertext
|
||||
return $ plaintext == val
|
||||
it "produces pretty ciphertext" . property $
|
||||
\val -> ioProperty $ do
|
||||
sKey <- SecretBox.newKey
|
||||
ciphertext <- encodedSecretBox' sKey SecretBoxPretty (val :: Value)
|
||||
return . all ((<= 76) . length) $ lines ciphertext
|
||||
Loading…
Reference in New Issue
Block a user