1012 lines
33 KiB
Haskell
1012 lines
33 KiB
Haskell
module Utils
|
|
( module Utils
|
|
, List.nub, List.nubBy
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch)
|
|
|
|
-- 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 (First, 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 Text.Blaze (Markup, ToMarkup)
|
|
|
|
import Data.Char (isDigit, isSpace, isAscii)
|
|
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
|
|
|
|
import qualified Data.Set as Set
|
|
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 Data.Set.Lens
|
|
|
|
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.Trans.Writer.Lazy (execWriterT, tell)
|
|
import Control.Monad.Catch
|
|
import Control.Monad.Morph (hoist)
|
|
|
|
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(..))
|
|
|
|
import Control.Monad.Random.Class (MonadRandom)
|
|
import qualified System.Random.Shuffle as Rand (shuffleM)
|
|
|
|
{-# 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
|
|
=> a -> WidgetFor site ()
|
|
toWgt = toWidget . toHtml
|
|
|
|
-- Convenience Functions to avoid type signatures:
|
|
text2widget :: Text -> WidgetFor site ()
|
|
text2widget t = [whamlet|#{t}|]
|
|
|
|
citext2widget :: CI Text -> WidgetFor site ()
|
|
citext2widget t = [whamlet|#{CI.original t}|]
|
|
|
|
str2widget :: String -> WidgetFor site ()
|
|
str2widget s = [whamlet|#{s}|]
|
|
|
|
withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (a, WidgetFor site ())
|
|
withFragment form html = flip fmap form $ over _2 (toWidget html >>)
|
|
|
|
rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a
|
|
rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (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 :: forall a. 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 :: Double
|
|
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)"]
|
|
|
|
fromText :: (IsString a, Textual t) => t -> a
|
|
fromText = fromString . unpack
|
|
|
|
----------
|
|
-- 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
|
|
|
|
guardMonoid :: Monoid m => Bool -> m -> m
|
|
guardMonoid False _ = mempty
|
|
guardMonoid True x = x
|
|
|
|
------------
|
|
-- 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
|
|
|
|
|
|
-- | 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 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 :: Set a -> Set b -> Set (a, b)
|
|
-- ^ Depends on the valid internal structure of the given sets
|
|
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
|
|
|
|
setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
|
|
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
|
|
|
|
----------
|
|
-- 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
|
|
|
|
mapSymmDiff :: (Ord k, Ord v) => Map k v -> Map k v -> Map k (Set v)
|
|
mapSymmDiff a b = Map.fromListWith Set.union . map (over _2 Set.singleton) . Set.toList $ (setSymmDiff `on` assocsSet) a b
|
|
|
|
assocsSet :: Ord (k, v) => Map k v -> Set (k, v)
|
|
assocsSet = setOf folded . imap (,)
|
|
|
|
mapF :: (Ord k, Finite k) => (k -> v) -> Map k v
|
|
mapF = flip Map.fromSet $ Set.fromList universeF
|
|
|
|
---------------
|
|
-- 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
|
|
|
|
mapMaybeM :: ( Monad m
|
|
, MonoFoldable (f a)
|
|
, MonoPointed (f b)
|
|
, Monoid (f b)
|
|
) => (Element (f a) -> MaybeT m (Element (f b))) -> f a -> m (f b)
|
|
mapMaybeM f = execWriterT . mapM_ (void . runMaybeT . (lift . tell . opoint <=< hoist lift . f))
|
|
|
|
forMaybeM :: ( Monad m
|
|
, MonoFoldable (f a)
|
|
, MonoPointed (f b)
|
|
, Monoid (f b)
|
|
) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
|
|
forMaybeM = flip mapMaybeM
|
|
|
|
------------
|
|
-- 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
|
|
|
|
guardOnM :: Alternative m => Bool -> m a -> m a
|
|
guardOnM b x = guard b *> x
|
|
|
|
guardMOn :: MonadPlus m => m Bool -> a -> m a
|
|
guardMOn b x = x <$ guardM b
|
|
|
|
guardMOnM :: MonadPlus m => m Bool -> m a -> m a
|
|
guardMOnM b x = guardM b *> 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)@ 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"
|
|
|
|
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
|
|
foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty
|
|
|
|
ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b
|
|
ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty
|
|
|
|
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
|
|
, MonadUnliftIO 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 :: MonadUnliftIO 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 :: forall a o m n. (Integral n, Monad m) => n -> ConduitT a o m [a]
|
|
peekN n = do
|
|
peeked <- catMaybes <$> replicateM (fromIntegral n) await
|
|
mapM_ leftover peeked
|
|
return peeked
|
|
|
|
anyMC, allMC :: forall a o m. Monad m => (a -> m Bool) -> ConduitT a o 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 | SessionConflictingStudyTerms
|
|
| 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 = Text.dropWhileEnd (== '=') . decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash
|
|
|
|
setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m ()
|
|
setEtagHashable = setEtag . hashToText
|
|
setWeakEtagHashable = setWeakEtag . hashToText
|
|
|
|
setLastModified :: MonadHandler 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)
|
|
|
|
-------------
|
|
-- Ord --
|
|
-------------
|
|
|
|
clamp :: Ord a
|
|
=> a -- ^ Minimum
|
|
-> a -- ^ Maximum
|
|
-> a -- ^ Value
|
|
-> a -- ^ Clamped Value
|
|
clamp minVal maxVal = clampMin minVal . clampMax maxVal
|
|
|
|
clampMin, clampMax :: Ord a
|
|
=> a -- ^ Boundary
|
|
-> a -- ^ Value
|
|
-> a -- ^ Clamped Value
|
|
clampMin = max
|
|
clampMax = min
|
|
|
|
------------
|
|
-- Random --
|
|
------------
|
|
|
|
unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
|
|
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
|
|
|
|
unstableSortOn :: (MonadRandom m, Ord b) => (a -> b) -> [a] -> m [a]
|
|
unstableSortOn = unstableSortBy . comparing
|
|
|
|
unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a]
|
|
unstableSort = unstableSortBy compare
|
|
|
|
----------
|
|
-- Lens --
|
|
----------
|
|
|
|
mpreview :: (MonadPlus m, MonadReader s m) => Getting (First a) s a -> m a
|
|
mpreview = hoistMaybe <=< preview
|
|
|
|
mpreviews :: (MonadPlus m, MonadReader s m) => Getting (First b) s a -> (a -> b) -> m b
|
|
mpreviews a f = hoistMaybe =<< previews a f
|