module Utils ( module Utils , List.nub, List.nubBy ) where import ClassyPrelude.Yesod hiding (foldlM, Proxy) -- 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.Proxy 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 qualified Data.Text.Encoding as Text -- import Utils.DB as Utils import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Route as Utils import Utils.Icon as Utils import Utils.Message as Utils import Utils.Lang as Utils import Utils.Parameters as Utils import Utils.Csv as Utils import Control.Concurrent.Async.Lifted.Safe.Utils as Utils import Text.Blaze (Markup, ToMarkup) import Data.Char (isDigit, isSpace, isAscii) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) 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 qualified Data.Conduit.List as C import Control.Lens import Control.Lens as Utils (none) import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans.Maybe as Utils (MaybeT(..)) import Control.Monad.Catch (catchIf) import System.Timeout.Lifted (timeout) import Language.Haskell.TH import Language.Haskell.TH.Instances () 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 -- import Data.Ratio ((%)) import Data.Binary (Binary) import qualified Data.Binary as Binary import Network.Wai (requestMethod) import Data.Time.Clock import Data.List.NonEmpty (NonEmpty, nonEmpty) import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice) import Data.Constraint (Dict(..)) {-# ANN module ("HLint: ignore Use asum" :: String) #-} $(iconShortcuts) -- declares constants for all known icons ----------- -- 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) guardAuthResult :: MonadHandler m => AuthResult -> m () guardAuthResult AuthenticationRequired = notAuthenticated guardAuthResult (Unauthorized t) = permissionDenied t guardAuthResult Authorized = return () data UnsupportedAuthPredicate tag route = UnsupportedAuthPredicate tag route deriving (Eq, Ord, Typeable, Show) instance (Show tag, Typeable tag, Show route, Typeable route) => Exception (UnsupportedAuthPredicate tag route) unsupportedAuthPredicate :: ExpQ unsupportedAuthPredicate = do logFunc <- logErrorS [e| \tag route -> do tRoute <- toTextUrl route $(return logFunc) "AccessControl" $ "!" <> toPathPiece tag <> " used on route that doesn't support it: " <> tRoute unauthorizedI (UnsupportedAuthPredicate tag route) |] -- | allows conditional attributes in hamlet via *{..} syntax maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)] maybeAttribute _ _ Nothing = [] maybeAttribute a c (Just v) = [(a,c v)] --------------------- -- Text and String -- --------------------- -- DEPRECATED: use hasTickmark instead; -- maybe reinstate if needed for @bewertung.txt@ files -- tickmark :: IsString a => a -- tickmark = fromString "✔" -- | remove all Whitespace from Text stripAll :: Text -> Text stripAll = Text.filter (not . isSpace) -- | Convert text as it is to Html, may prevent ambiguous types -- This function definition is mainly for documentation purposes text2Html :: Text -> Html text2Html = toHtml -- | Convert text as it is to Message, may prevent ambiguous types -- This function definition is mainly for documentation purposes text2message :: Text -> SomeMessage site text2message = SomeMessage 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}|] 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 >>) rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy :: HasResolution a => Proxy a))) rationalToFixed3 :: Rational -> Fixed E3 rationalToFixed3 = rationalToFixed rationalToFixed2 :: Rational -> Fixed E2 rationalToFixed2 = rationalToFixed -- | Convert `part` and `whole` into percentage including symbol -- showing trailing zeroes and to decimal digits textPercent :: Real a => a -> a -> Text textPercent = textPercent' False 2 -- | Convert `part` and `whole` into percentage including symbol -- `trailZero` shows trailing Zeros, `precision` is number of decimal digits textPercent' :: Real a => Bool -> Int -> a -> a -> Text textPercent' trailZero precision part whole | precision == 0 = showPercent (frac :: Uni) | precision == 1 = showPercent (frac :: Deci) | precision == 2 = showPercent (frac :: Centi) | precision == 3 = showPercent (frac :: Milli) | precision == 4 = showPercent (frac :: Micro) | otherwise = showPercent (frac :: Pico) where frac :: forall a. HasResolution a => Fixed a frac = rationalToFixed $ (100*) $ toRational part / toRational whole showPercent :: HasResolution a => Fixed a -> Text showPercent f = pack $ showFixed trailZero f <> "%" -- | Convert number of bytes to human readable format textBytes :: Integral a => a -> Text textBytes x | v < kb = rshow v <> "B" | v < mb = rshow (v/kb) <> "KB" | v < gb = rshow (v/mb) <> "MB" | otherwise = rshow (v/gb) <> "GB" where v = fromIntegral x kb = 1024 mb = 1024 * kb gb = 1024 * mb rshow :: Double -> Text rshow = tshow . floorToDigits 1 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)"] -- | Ignore warnings for unused variables with a more specific type notUsedT :: a -> Text notUsedT = notUsed ---------- -- Bool -- ---------- -- | Logical implication, readable synonym for (<=) which appears the wrong way around implies :: Bool -> Bool -> Bool implies True x = x implies _ _ = True ------------- -- Numeric -- ------------- -- | round n to nearest multiple of m roundToNearestMultiple :: Int -> Int -> Int roundToNearestMultiple m n = (n `div` m + 1) * m roundToDigits :: (RealFrac a, Integral b) => b -> a -> a roundToDigits d x = fromInteger (round $ x * prec) / prec where prec = 10^d floorToDigits :: (RealFrac a, Integral b) => b -> a -> a floorToDigits d x = fromInteger (floor $ x * prec) / prec where prec = 10^d -- | Integral division, but rounded upwards. ceilingDiv :: Integral a => a -> a -> a ceilingDiv d n = (d+n-1) `div` n -- | Integral division, rounded to custom digit; convenience function for hamlets roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c roundDiv digits numerator denominator = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator -- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all -- `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved) -- Useful for heat maps, with offset giving a visual step between completed and not yet completed cutOffPercent :: Double -> Double -> Double -> Double cutOffPercent offset full achieved | full <= achieved = 0 | full <= 0 = 0   | otherwise = offset + (1-offset) * (1 - percent) where percent = achieved / full ------------ -- Monoid -- ------------ -- | Ignore warnings for unused variables notUsed :: Monoid m => a -> m notUsed = const mempty ------------ -- 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 -- | Merge/Add any attribute-value pair to an existing list of such pairs. -- If the attribute exists, the new valu will be prepended, separated by a single empty space -- Also see `Utils.mergeAttrs` insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] insertAttr attr valu = aux where aux :: [(Text,Text)] -> [(Text,Text)] aux [] = [(attr,valu)] aux (p@(a,v) : t) | attr==a = (a, Text.append valu $ Text.cons ' ' v) : t | otherwise = p : aux t -- | Add another class attribute; special function for a frequent case to avoid mistyping "class". -- Also see `Utils.insertAttrs` insertClass :: Text -> [(Text,Text)] -> [(Text,Text)] insertClass = insertAttr "class" -- | Append two lists of attributes, merging the class attribute only. -- Also see `Utils.insertAttr` to merge any attribute 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 -- | Copied form Util from package ghc partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -- ^ Uses a function to determine which of two output lists an input element should join partitionWith _ [] = ([],[]) partitionWith f (x:xs) = case f x of Left b -> (b:bs, cs) Right c -> (bs, c:cs) where (bs,cs) = partitionWith f xs nonEmpty' :: Alternative f => [a] -> f (NonEmpty a) nonEmpty' = maybe empty pure . nonEmpty nubOn :: Eq b => (a -> b) -> [a] -> [a] nubOn = List.nubBy . ((==) `on`) ---------- -- Sets -- ---------- -- | Intersection of multiple sets. Returns empty set for empty input list setIntersections :: Ord a => [Set a] -> Set a setIntersections [] = Set.empty setIntersections (h:t) = foldl' Set.intersection h t setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b setMapMaybe f = Set.fromList . mapMaybe f . Set.toList -- | Symmetric difference of two sets. setSymmDiff :: Ord a => Set a -> Set a -> Set a setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x) setProduct :: (Ord a, Ord b) => Set a -> Set b -> Set (a, b) setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs ---------- -- 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 -- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons) countMapElems :: (Ord v) => Map k v -> Map v Int countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList --------------- -- Functions -- --------------- -- curryN, uncurryN see Utils.TH -- | Just @flip (.)@ for convenient formatting in some cases, -- Deprecated in favor of Control.Arrow.(>>>) compose :: (a -> b) -> (b -> c) -> (a -> c) compose = flip (.) ----------- -- 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 -- | Swap 'Nothing' for 'Just' and vice versa -- This belongs into Module 'Utils' but we have a weird cyclic -- dependency flipMaybe :: b -> Maybe a -> Maybe b flipMaybe x Nothing = Just x flipMaybe _ (Just _) = Nothing -- | 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) catchMaybeT :: forall p m e a. (MonadCatch m, Exception e) => p e -> m a -> MaybeT m a catchMaybeT _ act = catch (lift act) (const mzero :: e -> MaybeT m a) catchMPlus :: forall p m e a. (MonadPlus m, MonadCatch m, Exception e) => p e -> m a -> m a catchMPlus _ = handle (const mzero :: e -> m a) mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs -- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a ignoreNothing _ Nothing y = y ignoreNothing _ x Nothing = x ignoreNothing f (Just x) (Just y) = Just $ f x y 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 formResultToMaybe :: Alternative m => FormResult a -> m a formResultToMaybe (FormSuccess x) = pure x formResultToMaybe _ = empty maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a maybeThrow exc = maybe (throwM exc) return maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a maybeThrowM excM = maybe (throwM =<< excM) return ------------ -- 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 maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b maybeTExceptT err act = maybeExceptT err $ runMaybeT act maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act 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' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) guardOn :: Alternative m => Bool -> a -> m a guardOn b x = x <$ guard b -- 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)@ from Agda.Utils.Monad ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM c = flip $ ifM c -- | Short-circuiting monadic boolean function, copied from Andreas Abel's utility function 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) -- | Short-circuiting monady any 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 findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero yesodTimeout :: ( MonadHandler m , MonadBaseControl IO m ) => (HandlerSite m -> NominalDiffTime) -- ^ Calculate timeout -> a -- ^ Default value -> m a -- ^ Computation -> m a -- ^ Result of computation or default value, if timeout is reached yesodTimeout getTimeout timeoutRes act = do timeoutLength <- getsYesod getTimeout diffTimeout timeoutLength timeoutRes act diffTimeout :: MonadBaseControl IO m => NominalDiffTime -> a -> m a -> m a diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout timeoutMicro act where timeoutMicro = let (MkFixed micro :: Micro) = realToFrac timeoutLength in fromInteger micro ------------- -- Conduit -- ------------- peekN :: (Integral n, Monad m) => n -> Consumer a m [a] peekN n = do peeked <- catMaybes <$> replicateM (fromIntegral n) await mapM_ leftover peeked return peeked anyMC, allMC :: Monad m => (a -> m Bool) -> Consumer a m Bool anyMC f = C.mapM f .| orC allMC f = C.mapM f .| andC ----------------- -- Alternative -- ----------------- choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a choice = foldr (<|>) empty -------------- -- Sessions -- -------------- data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags | SessionNewStudyTerms | SessionBearer deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe SessionKey instance Finite SessionKey nullaryPathPiece ''SessionKey $ camelToPathPiece' 1 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 takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) -- ^ `lookupSessionJson` followed by `deleteSession` takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key) -------------------- -- GET Parameters -- -------------------- -- Moved to Utils.Parameters --------------------------------- -- Custom HTTP Headers -- --------------------------------- data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit | HeaderAlerts 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 <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) => CustomHeader -> payload -> m () addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload) replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload) ------------------ -- HTTP Headers -- ------------------ data ContentDisposition = ContentInline | ContentAttachment deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ContentDisposition instance Finite ContentDisposition nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1 setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m () -- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader` -- -- Takes care of correct formatting and encoding of non-ascii filenames setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal where headerVal | Just fName <- mFName , Text.all isAscii fName , Text.all (not . flip elem ['"', '\\']) fName = [st|#{toPathPiece cd}; filename="#{fName}"|] | Just fName <- mFName = let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|] | otherwise = toPathPiece cd ------------------ -- 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 = stripAll 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 ------------- -- Caching -- ------------- cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b cachedByBinary k = cachedBy (toStrict $ Binary.encode k) cachedHere :: Q Exp cachedHere = do loc <- location [e| cachedByBinary loc |] cachedHereBinary :: Q Exp cachedHereBinary = do loc <- location [e| \k -> cachedByBinary (loc, k) |] hashToText :: Hashable a => a -> Text hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m () setEtagHashable = setEtag . hashToText setWeakEtagHashable = setEtag . hashToText setLastModified :: (MonadHandler m, MonadLogger m) => UTCTime -> m () setLastModified lastModified = do rMethod <- requestMethod <$> waiRequest when (rMethod `elem` safeMethods) $ do ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since" $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince) when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince) notModified addHeader "Last-Modified" $ formatRFC1123 lastModified where precision :: NominalDiffTime precision = 1 safeMethods = [ methodGet, methodHead, methodOptions ] -------------- -- Lattices -- -------------- foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono foldJoin = foldr (\/) bottom foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono foldMeet = foldr (/\) top ----------------- -- Constraints -- ----------------- type DictMaybe constr a = Maybe (Dict constr, a) pattern DictJust :: constr => a -> DictMaybe constr a pattern DictJust a = Just (Dict, a)