{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult module Utils ( module Utils ) where import ClassyPrelude.Yesod hiding (foldlM) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold import Data.Foldable as Utils (foldlM, foldrM) 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 import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Message as Utils import Utils.Lang as Utils import Control.Lens as Utils (none) import Text.Blaze (Markup, ToMarkup) import Data.Char (isDigit, isSpace) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Numeric (showFFloat) import Control.Lens import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) 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 hiding (throwM) import qualified Database.Esqueleto as E (Value, unValue) import Language.Haskell.TH import Instances.TH.Lift () import Text.Shakespeare.Text (st) 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 import Data.Fixed (Centi) import Data.Ratio ((%)) ----------- -- Yesod -- ----------- newtype MsgRendererS site = MsgRenderer { render :: forall msg. RenderMessage site msg => msg -> Text } getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site) getMsgRenderer = do mr <- getMessageRender return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text) instance Monad FormResult where FormMissing >>= _ = FormMissing (FormFailure errs) >>= _ = FormFailure errs (FormSuccess a) >>= f = f a guardAuthResult :: MonadHandler m => AuthResult -> m () guardAuthResult AuthenticationRequired = notAuthenticated guardAuthResult (Unauthorized t) = permissionDenied t guardAuthResult Authorized = return () data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route deriving (Eq, Ord, Typeable, Show) instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route) unsupportedAuthPredicate :: ExpQ unsupportedAuthPredicate = do logFunc <- logErrorS [e| \tag route -> do $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|] unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] class RedirectUrl site url => HasRoute site url where urlRoute :: url -> Route site instance HasRoute site (Route site) where urlRoute = id instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where urlRoute = view _1 instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where urlRoute = view _1 instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where urlRoute (a :#: _) = urlRoute a data SomeRoute site = forall url. HasRoute site url => SomeRoute url instance RedirectUrl site (SomeRoute site) where toTextUrl (SomeRoute url) = toTextUrl url instance HasRoute site (SomeRoute site) where urlRoute (SomeRoute url) = urlRoute url -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) => WidgetT site m () ----------- -- Icons -- ----------- isVisible :: Bool -> Markup -- ^ Display an icon that denotes that something™ is visible or invisible isVisible True = [shamlet||] isVisible False = [shamlet||] -- -- For documentation on how to avoid these unneccessary functions -- we implement them here just once for the first icon: -- isVisibleWidget :: Bool -> WidgetSiteless -- ^ Widget having an icon that denotes that something™ is visible or invisible isVisibleWidget = toWidget . isVisible maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless -- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible maybeIsVisibleWidget = toWidget . foldMap isVisible -- Other _frequently_ used icons: hasComment :: Bool -> Markup -- ^ Display an icon that denotes that something™ has a comment or not hasComment True = [shamlet||] hasComment False = [shamlet||] -- comment-alt-slash is not available for free hasTickmark :: Bool -> Markup -- ^ Display an icon that denotes that something™ is okay hasTickmark True = [shamlet||] hasTickmark False = mempty --------------------- -- Text and String -- --------------------- -- DEPRECATED: use hasTickmark instead; -- maybe reinstate if needed for @bewertung.txt@ files -- tickmark :: IsString a => a -- tickmark = fromString "✔" text2Html :: Text -> Html text2Html = toHtml -- prevents ambiguous types toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) => a -> WidgetT site m () toWgt = toWidget . toHtml -- Convenience Functions to avoid type signatures: text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => Text -> WidgetT site m () text2widget t = [whamlet|#{t}|] citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => CI Text -> WidgetT site m () citext2widget t = [whamlet|#{CI.original t}|] str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => String -> WidgetT site m () str2widget s = [whamlet|#{s}|] display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) => a -> WidgetT site m () display2widget = text2widget . display withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = flip fmap form $ over _2 (toWidget html >>) -- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production) {- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -} class DisplayAble a where display :: a -> Text -- Default definitions for types belonging to Show (allows empty instance declarations) default display :: Show a => a -> Text display = pack . show instance DisplayAble Text where display = id instance DisplayAble String where display = pack instance DisplayAble Int instance DisplayAble Int64 instance DisplayAble Integer instance DisplayAble Rational where display r = showFFloat (Just 2) (rat2float r) "" & pack & dropWhileEnd ('0'==) & dropWhileEnd ('.'==) where rat2float :: Rational -> Double rat2float = fromRational instance DisplayAble a => DisplayAble (Maybe a) where display Nothing = "" display (Just x) = display x instance DisplayAble a => DisplayAble (E.Value a) where display = display . E.unValue instance DisplayAble a => DisplayAble (CI a) where display = display . CI.original {- We do not want DisplayAble for every Show-Class: We want to explicitly verify that the resulting text can be displayed to the User! For example: UTCTime values were shown without proper format rendering! instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) display = pack . show -} textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercent x = lz <> pack (show rx) <> "%" where rx :: Centi rx = realToFrac (x * 100) lz = if rx < 10.0 then "0" else "" textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounter text | (Just i) <- readMay number = let iplus1 = tshow (succ i :: Int) zeroip = justifyRight (length number) '0' iplus1 in prefix <> zeroip <> suffix | otherwise = text where -- no splitWhile nor findEnd in Data.Text suffix = takeWhileEnd (not . isDigit) text number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text -- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)" -- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"] ------------ -- Tuples -- ------------ fst3 :: (a,b,c) -> a fst3 (x,_,_) = x snd3 :: (a,b,c) -> b snd3 (_,y,_) = y trd3 :: (a,b,c) -> c trd3 (_,_,z) = z -- Further projections are available via TemplateHaskell, defined in Utils.Common: -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n) -- snd3 = $(projNI 3 2) ----------- -- Lists -- ----------- -- notNull = not . null lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing lastMaybe [h] = Just h lastMaybe (_:t) = lastMaybe t lastMaybe' :: [a] -> Maybe a lastMaybe' l = fmap snd $ l ^? _Snoc mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] mergeAttrs = mergeAttrs' `on` sort where special = [ ("class", \v1 v2 -> v1 <> " " <> v2) ] mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2) | Just merge <- lookup n1 special , n2 == n1 = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2 | Just _ <- lookup n1 special , n1 < n2 = x2 : mergeAttrs' (x1:xs1) xs2 | otherwise = x1 : mergeAttrs' xs1 (x2:xs2) mergeAttrs' [] xs2 = xs2 mergeAttrs' xs1 [] = xs1 ---------- -- Maps -- ---------- infixl 5 !!! (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v (!!!) m k = fromMaybe mempty $ Map.lookup k m groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v) groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l] partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v partMap = Map.fromListWith mappend invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList ----------- -- Maybe -- ----------- toMaybe :: Bool -> a -> Maybe a toMaybe True = Just toMaybe False = const Nothing toNothing :: a -> Maybe b toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y maybeAdd x Nothing = x -- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a) deepAlt Nothing altSnd = altSnd deepAlt altFst Nothing = altFst deepAlt (Just Nothing) altSnd = altSnd deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM ifMaybeM Nothing dft _ = return dft ifMaybeM (Just x) _ act = act x maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if maybePositive a | a > 0 = Just a | otherwise = Nothing positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act maybeT :: Monad m => m a -> MaybeT m a -> m a maybeT x m = runMaybeT m >>= maybe x return maybeT_ :: Monad m => MaybeT m () -> m () maybeT_ = void . runMaybeT hoistMaybe :: MonadPlus m => Maybe a -> m a -- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@ hoistMaybe = maybe mzero return catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a catchIfMaybeT p act = catchIf p (lift act) (const mzero) mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom instance Eq a => Eq (NTop (Maybe a)) where (NTop x) == (NTop y) = x == y instance Ord a => Ord (NTop (Maybe a)) where compare (NTop Nothing) (NTop Nothing) = EQ compare (NTop Nothing) _ = GT compare _ (NTop Nothing) = LT compare (NTop (Just x)) (NTop (Just y)) = compare x y exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT ------------ -- Either -- ------------ maybeLeft :: Either a b -> Maybe a maybeLeft (Left a) = Just a maybeLeft _ = Nothing maybeRight :: Either a b -> Maybe b maybeRight (Right b) = Just b maybeRight _ = Nothing whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m () whenIsLeft (Left x) f = f x whenIsLeft (Right _) _ = return () whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m () whenIsRight (Right x) f = f x whenIsRight (Left _) _ = return () --------------- -- Exception -- --------------- maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b maybeExceptT err act = lift act >>= maybe (throwE err) return maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return whenExceptT :: Monad m => Bool -> e -> ExceptT e m () whenExceptT b err = when b $ throwE err whenMExceptT :: Monad m => Bool -> m e -> ExceptT e m () whenMExceptT b err = when b $ lift err >>= throwE guardExceptT :: Monad m => Bool -> e -> ExceptT e m () guardExceptT b err = unless b $ throwE err guardMExceptT :: Monad m => Bool -> m e -> ExceptT e m () guardMExceptT b err = unless b $ lift err >>= throwE exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b 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 ------------ -- Monads -- ------------ shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a shortCircuitM sc binOp mx my = do x <- mx if | sc x -> return x | otherwise -> binOp <$> pure x <*> my guardM :: MonadPlus m => m Bool -> m () guardM f = guard =<< f assertM :: MonadPlus m => (a -> Bool) -> m a -> m a assertM f x = x >>= assertM' f assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m () assertM_ f x = guard . f =<< x assertM' :: MonadPlus m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a ifM c m m' = do b <- c if b then m else m' -- | @ifNotM mc = ifM (not <$> mc)@ ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM c = flip $ ifM c and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool and2M ma mb = ifM ma mb (return False) or2M ma = ifM ma (return True) andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool andM = Fold.foldr and2M (return True) orM = Fold.foldr or2M (return False) allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool allM xs f = andM $ fmap f xs anyM xs f = orM $ fmap f xs ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono) ofoldr1M f (otoList -> x:xs) = foldrM f x xs ofoldr1M _ _ = error "otoList of NonNull is empty" ofoldl1M f (otoList -> x:xs) = foldlM f x xs ofoldl1M _ _ = error "otoList of NonNull is empty" partitionM :: forall mono m . ( MonoFoldable mono , Monoid mono , MonoPointed mono , Monad m) => (Element mono -> m Bool) -> mono -> m (mono, mono) partitionM crit = ofoldlM dist mempty where dist :: (mono,mono) -> Element mono -> m (mono,mono) dist acc x = do okay <- crit x return $ if | okay -> acc `mappend` (opoint x, mempty) | otherwise -> acc `mappend` (mempty, opoint x) mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b mconcatForM = flip mconcatMapM -------------- -- Sessions -- -------------- setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m () setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m () modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m () tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) -- ^ `lookupSessionJson` followed by `deleteSession` getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key) -------------------- -- GET Parameters -- -------------------- data GlobalGetParam = GetReferer deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalGetParam instance Finite GlobalGetParam nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1) lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result) lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident) hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident) data GlobalPostParam = PostDeleteTarget deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalPostParam instance Finite GlobalPostParam nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1) lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result) lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident) hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) --------------------------------- -- Custom HTTP Request-Headers -- --------------------------------- data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe CustomHeader instance Finite CustomHeader nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel) lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result) lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) 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