diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 86c1d0cd5..44209ffb9 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 diff --git a/package.yaml b/package.yaml index 0853fdd38..4e09e10e4 100644 --- a/package.yaml +++ b/package.yaml @@ -110,6 +110,7 @@ dependencies: - monad-memo - xss-sanitize - text-metrics + - pkcs7 other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index b1f17147b..90792b4f5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 9b899765f..ea504444d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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|

_{MsgErrorResponseEncrypted} 

-                    #{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:
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index da8a8aed8..feea45783 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -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
         
-          #{t}
+          #{encodePrettyToTextBuilder t}
 
       

         ^{ctView}
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 67beeabd1..7ccf0a731 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -69,4 +69,3 @@ warnTermDays tid times = do
   forM_ warnholidays  $ warnI MsgDayIsAHoliday
   forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
   forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
-
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 82f177cde..df84f44fc 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -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)
   
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index e84be6b9c..1aa9fe36a 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -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';
+        |]
+    )
   ]
 
 
diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs
index 65219f347..a6fb11799 100644
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@@ -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
diff --git a/src/Utils.hs b/src/Utils.hs
index a451eb70b..e7776ec5b 100644
--- a/src/Utils.hs
+++ b/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
diff --git a/stack.yaml b/stack.yaml
index 1e74d2310..083c073db 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -40,4 +40,6 @@ extra-deps:
 
   - hlint-test-0.1.0.0
 
+  - pkcs7-1.0.0.1
+
 resolver: lts-10.5
diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs
new file mode 100644
index 000000000..dd50cf61e
--- /dev/null
+++ b/test/UtilsSpec.hs
@@ -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