1898 lines
64 KiB
Haskell
1898 lines
64 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Utils
|
|
( module Utils
|
|
, module Data.Containers.ListUtils
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)
|
|
|
|
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
|
|
import qualified Data.Foldable as Fold
|
|
import qualified Data.Traversable as Trav
|
|
import Data.Foldable as Utils (foldlM, foldrM)
|
|
import Data.Monoid (First, Sum(..), Endo)
|
|
import Data.Proxy
|
|
import Control.Arrow (Kleisli(..))
|
|
import Control.Arrow.Instances ()
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as CBS
|
|
import qualified Data.Char as Char
|
|
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.Cookies as Utils
|
|
import Utils.Cookies.Registered as Utils
|
|
import Utils.Session as Utils
|
|
import Utils.Csv as Utils
|
|
import Utils.I18n as Utils
|
|
import Utils.NTop as Utils
|
|
import Utils.HttpConditional as Utils
|
|
import Utils.Persist as Utils
|
|
import Utils.ARC as Utils
|
|
import Utils.LRU as Utils
|
|
import Utils.Set 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.HashMap.Strict as HashMap
|
|
import qualified Data.Vector as V
|
|
|
|
import qualified Data.Conduit.List as C (mapMaybe)
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import Control.Lens hiding (uncons)
|
|
import Control.Lens as Utils (none)
|
|
import Control.Lens.Extras (is)
|
|
import Data.Set.Lens
|
|
|
|
import Control.Monad (zipWithM)
|
|
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.Strict (execWriterT)
|
|
import qualified Control.Monad.Trans.Writer.Strict as Strict
|
|
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
|
|
import Control.Monad.Writer.Class (MonadWriter(..))
|
|
import Control.Monad.Catch
|
|
import Control.Monad.Morph (hoist)
|
|
import Control.Monad.Fail
|
|
import Control.Monad.Trans.Cont (ContT, evalContT, callCC)
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Instances ()
|
|
import Instances.TH.Lift ()
|
|
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
|
|
|
|
import Text.Shakespeare.Text (st)
|
|
|
|
import Data.Aeson (FromJSONKey)
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.Aeson.Types as Aeson
|
|
import qualified Data.Aeson.Encode.Pretty as Aeson
|
|
import qualified Data.Yaml as Yaml
|
|
|
|
import Data.Universe
|
|
|
|
import qualified Crypto.Saltine.Internal.SecretBox as Saltine
|
|
import qualified Data.ByteString.Base64.URL as Base64
|
|
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
|
import qualified Crypto.Saltine.Core.Auth as Auth
|
|
import qualified Crypto.Saltine.Class as Saltine
|
|
import qualified Crypto.Data.PKCS7 as PKCS7
|
|
import Crypto.MAC.KMAC (KMAC, HashSHAKE)
|
|
import qualified Crypto.MAC.KMAC as KMAC
|
|
import qualified Crypto.Hash as Crypto
|
|
import Crypto.Hash (HashAlgorithm, Digest)
|
|
import Crypto.Hash.Instances ()
|
|
import qualified Crypto.Random as Crypto
|
|
|
|
import Data.ByteArray (ByteArrayAccess)
|
|
|
|
import Data.Fixed
|
|
-- import Data.Ratio ((%))
|
|
|
|
import Data.Binary (Binary)
|
|
import qualified Data.Binary as Binary
|
|
|
|
import Network.Wai (requestMethod)
|
|
import Network.HTTP.Types.Header as Wai
|
|
|
|
import Web.HttpApiData
|
|
|
|
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 (MonadSplit(getSplit), MonadRandom, MonadInterleave(interleave), uniform)
|
|
import Control.Monad.Random (RandomGen)
|
|
import qualified System.Random.Shuffle as Rand (shuffleM)
|
|
import qualified Control.Monad.Random.Lazy as LazyRand
|
|
|
|
import Data.Data (Data)
|
|
import qualified Data.Text.Lazy.Builder as Builder
|
|
|
|
import Data.Coerce
|
|
|
|
import System.FilePath as Utils (addExtension, isExtensionOf)
|
|
import System.FilePath (dropDrive)
|
|
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Types.Instances.Catch ()
|
|
import Control.Monad.Trans.Resource
|
|
import Control.Monad.Reader.Class (MonadReader(local))
|
|
|
|
import Text.Hamlet (Translate)
|
|
|
|
import Data.Ratio ((%))
|
|
|
|
import Data.UUID (UUID)
|
|
import qualified Data.UUID as UUID
|
|
|
|
import Data.Containers.ListUtils
|
|
|
|
{-# 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)
|
|
|
|
getTranslate :: forall m site msg. (MonadHandler m, HandlerSite m ~ site, RenderMessage site msg) => m (Translate msg)
|
|
getTranslate = (toMarkup .) <$> getMessageRender
|
|
|
|
|
|
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)]
|
|
|
|
|
|
newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
|
|
deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
|
|
deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
|
|
|
|
instance ToContent PrettyValue where
|
|
toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
|
|
instance ToTypedContent PrettyValue where
|
|
toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
|
|
instance HasContentType PrettyValue where
|
|
getContentType _ = typeJson
|
|
|
|
toPrettyJSON :: ToJSON a => a -> PrettyValue
|
|
toPrettyJSON = PrettyValue . toJSON
|
|
|
|
|
|
newtype YamlValue = YamlValue { unYamlValue :: Value }
|
|
deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
|
|
deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
|
|
|
|
instance ToContent YamlValue where
|
|
toContent = toContent . Yaml.encode
|
|
instance ToTypedContent YamlValue where
|
|
toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
|
|
instance HasContentType YamlValue where
|
|
getContentType _ = "text/vnd.yaml"
|
|
|
|
instance ToMarkup YamlValue where
|
|
toMarkup = toMarkup . decodeUtf8 . Yaml.encode
|
|
|
|
toYAML :: ToJSON a => a -> YamlValue
|
|
toYAML = YamlValue . toJSON
|
|
|
|
delimitInternalState :: forall site a. HandlerFor site a -> HandlerFor site a
|
|
-- | Switches the `InternalState` contained within the environment of `HandlerFor` to new one created with `bracket`
|
|
--
|
|
-- Therefor all `ResourceT`-Resources allocated within the inner `HandlerFor`-Action are collected at the end of it.
|
|
delimitInternalState act = bracket createInternalState closeInternalState $ \newInternalState -> local (renewEnviron newInternalState) act
|
|
where
|
|
renewEnviron newInternalState HandlerData{..}
|
|
= HandlerData { handlerResource = newInternalState
|
|
, ..
|
|
}
|
|
|
|
selectRep' :: [(ContentType, a)] -> ContentType -> Maybe a
|
|
selectRep' cMap _ | null cMap = Nothing
|
|
selectRep' cMap' needle = asum
|
|
[ guardOnM (needleMain == "*" && needleSub == "*") $ preview (folded . _2) cMap'
|
|
, guardOnM (needleSub == "*") $ preview (folded . filtered (views _1 $ views _1 (== needleMain) . contentTypeTypes) . _2) cMap'
|
|
, Map.lookup needle cMap
|
|
, Map.lookup (noSpaces needle) cMap
|
|
, Map.lookup (simpleContentType needle) cMap
|
|
]
|
|
where
|
|
cMap = Map.fromListWith const $ over _1 <$> [id, noSpaces, simpleContentType] <*> cMap'
|
|
|
|
(needleMain, needleSub) = contentTypeTypes needle
|
|
|
|
noSpaces = CBS.filter (/= ' ')
|
|
|
|
addAttrsClass :: Text -> [(Text, Text)] -> [(Text, Text)]
|
|
addAttrsClass cl attrs = ("class", cl') : noClAttrs
|
|
where
|
|
(clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs
|
|
cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs)
|
|
|
|
---------------------
|
|
-- Text and String --
|
|
---------------------
|
|
|
|
-- DEPRECATED: use hasTickmark instead;
|
|
-- maybe reinstate if needed for @bewertung.txt@ files
|
|
-- tickmark :: IsString a => a
|
|
-- tickmark = fromString "✔"
|
|
|
|
-- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available
|
|
textElem :: Char -> Text -> Bool
|
|
textElem c = Text.any (c ==)
|
|
|
|
-- | remove all whitespace from Text
|
|
-- whereas Text.strip only removes leading and trailing whitespace
|
|
stripAll :: Text -> Text
|
|
stripAll = Text.filter (not . isSpace)
|
|
|
|
-- | take first line, only
|
|
cropText :: Text -> Text
|
|
cropText (Text.take 255 -> t) = headDef t $ Text.lines t
|
|
|
|
tshowCrop :: Show a => a -> Text
|
|
tshowCrop = cropText . tshow
|
|
|
|
-- | strip leading and trailing whitespace and make case insensitive
|
|
-- also helps to avoid the need to import just for CI.mk
|
|
stripCI :: Text -> CI Text
|
|
stripCI = CI.mk . Text.strip
|
|
|
|
citext2lower :: CI Text -> Text
|
|
citext2lower = Text.toLower . CI.original
|
|
|
|
-- avoids unnecessary imports
|
|
citext2string :: CI Text -> String
|
|
citext2string = Text.unpack . CI.original
|
|
|
|
-- | Convert or remove all non-ascii characters, e.g. for filenames
|
|
text2asciiAlphaNum :: Text -> Text
|
|
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
|
|
. Text.replace "ä" "ae"
|
|
. Text.replace "Ä" "Ae"
|
|
. Text.replace "Æ" "ae"
|
|
. Text.replace "æ" "ae"
|
|
. Text.replace "Å" "Aa"
|
|
. Text.replace "å" "aa"
|
|
. Text.replace "â" "a"
|
|
. Text.replace "à" "a"
|
|
. Text.replace "á" "a"
|
|
. Text.replace "Ö" "Oe"
|
|
. Text.replace "ö" "oe"
|
|
. Text.replace "œ" "oe"
|
|
. Text.replace "Ø" "Oe"
|
|
. Text.replace "ø" "oe"
|
|
. Text.replace "ò" "o"
|
|
. Text.replace "ò" "o"
|
|
. Text.replace "ò" "o"
|
|
. Text.replace "ó" "o"
|
|
. Text.replace "Ü" "Ue"
|
|
. Text.replace "ü" "ue"
|
|
. Text.replace "ù" "u"
|
|
. Text.replace "ú" "u"
|
|
. Text.replace "û" "u"
|
|
. Text.replace "ë" "e"
|
|
. Text.replace "ê" "e"
|
|
. Text.replace "è" "e"
|
|
. Text.replace "é" "e"
|
|
. Text.replace "ï" "i"
|
|
. Text.replace "î" "i"
|
|
. Text.replace "ì" "i"
|
|
. Text.replace "í" "i"
|
|
. Text.replace "ß" "ss"
|
|
. Text.replace "ç" "c"
|
|
. Text.replace "ş" "s"
|
|
. Text.replace "ğ" "g"
|
|
. Text.replace "ñ" "n"
|
|
|
|
-- | Convert text as it is to Html, may prevent ambiguous types
|
|
-- This function definition is mainly for documentation purposes
|
|
text2Html :: Text -> Html
|
|
text2Html = toHtml
|
|
|
|
char2Text :: Char -> Text
|
|
char2Text c
|
|
| isSpace c = "<Space>"
|
|
| otherwise = Text.singleton c
|
|
|
|
-- | 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:
|
|
text2markup :: Text -> Markup
|
|
text2markup t = [shamlet|#{t}|]
|
|
|
|
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}|]
|
|
|
|
int2widget :: Int64 -> WidgetFor site ()
|
|
int2widget i = [whamlet|#{tshow i}|]
|
|
|
|
word2widget :: Word64 -> WidgetFor site ()
|
|
word2widget i = [whamlet|#{tshow i}|]
|
|
|
|
msg2widget :: RenderMessage site a => a -> WidgetFor site ()
|
|
msg2widget msg = [whamlet|_{msg}|]
|
|
|
|
withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (a, WidgetFor site ())
|
|
withFragment form html = flip fmap form $ over _2 (toWidget html >>)
|
|
|
|
-- | Burst Text into an unordered set of letters
|
|
charSet :: Text -> Set Char
|
|
charSet = Text.foldl (flip Set.insert) mempty
|
|
|
|
-- | Returns Nothing iff both texts are identical,
|
|
-- otherwise a differing character is returned, preferable from the first argument
|
|
textDiff :: Text -> Text -> Maybe Char
|
|
textDiff (Text.uncons -> xs) (Text.uncons -> ys)
|
|
| Just (x,xt) <- xs
|
|
, Just (y,yt) <- ys
|
|
= if x == y
|
|
then textDiff xt yt
|
|
else Just x
|
|
| otherwise
|
|
= fst <$> (xs <|> ys)
|
|
|
|
-- | 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) <> "KiB"
|
|
| v < gb = rshow (v/mb) <> "MiB"
|
|
| otherwise = rshow (v/gb) <> "GiB"
|
|
where
|
|
v = fromIntegral x
|
|
kb :: Double
|
|
kb = 1024
|
|
mb = 1024 * kb
|
|
gb = 1024 * mb
|
|
rshow :: Double -> Text
|
|
rshow = tshow . floorToDigits 1
|
|
|
|
textDuration :: forall a. Integral a => a -> Text
|
|
textDuration n' = view _2 $ foldr acc (toInteger n', "") units
|
|
where units = sortOn (view _1)
|
|
[ (86400, "d")
|
|
, (3600, "h")
|
|
, (60, "m")
|
|
, (1, "s")
|
|
]
|
|
acc (mult, unit) (n, t)
|
|
| unitCount > 0 = (unitRem, t <> tshow unitCount <> unit)
|
|
| otherwise = (n, t)
|
|
where (unitCount, unitRem) = n `divMod` mult
|
|
|
|
|
|
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
|
|
|
|
{-
|
|
-- | Captialize the first character and leave all others as they were
|
|
textToCapital :: Text -> Text
|
|
textToCapital s
|
|
| Just (h,t) <- Text.uncons s
|
|
= Text.Cons (Char.toUpper h) t
|
|
| otherwise = s
|
|
|
|
snakecase2camelcase :: Text -> Text
|
|
snakecase2camelcase t = Text.concat $ map textToCapital words
|
|
where
|
|
words = Text.splitOn '_' t
|
|
-}
|
|
|
|
|
|
-----------
|
|
-- Fixed --
|
|
-----------
|
|
|
|
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
|
|
|
|
realToFixed :: forall a n. (Real n, HasResolution a) => n -> Fixed a
|
|
realToFixed = rationalToFixed . toRational
|
|
|
|
roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
|
|
roundToPoints ((* toRational (resolution $ Proxy @a)) -> raw) = MkFixed $
|
|
let (whole, frac) = properFraction raw
|
|
in if | abs frac < abs (1 % 2)
|
|
-> whole
|
|
| otherwise
|
|
-> succ whole
|
|
|
|
----------
|
|
-- 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
|
|
|
|
-- | @cutOffCoPercent offset full achieved@ returns 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 @full@ is equal to @achieved@
|
|
--
|
|
-- Useful for heat maps, with offset giving a visual step between completed and not yet completed
|
|
cutOffCoPercent :: Rational -> Rational -> Rational -> Rational
|
|
cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved)
|
|
| 0 <= achieved, achieved < full
|
|
, full /= 0
|
|
= offset + (1-offset) * (1 - percent)
|
|
| full <= achieved = 0
|
|
| otherwise = 1
|
|
where
|
|
percent = achieved / full
|
|
|
|
-- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all
|
|
--
|
|
-- @offset@ specifies minimum result value, unless @achieved@ is zero
|
|
--
|
|
-- Useful for heat maps, with offset giving a visual step between zero and nonzero
|
|
cutOffPercent :: Rational -> Rational -> Rational -> Rational
|
|
cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved)
|
|
| 0 < achieved, achieved <= full
|
|
, full /= 0
|
|
= offset + (1-offset) * percent
|
|
| achieved <= 0 = 0
|
|
| otherwise = 1
|
|
where
|
|
percent = achieved / full
|
|
|
|
_Integer :: (RealFrac a, Integral b) => Prism' a b
|
|
_Integer = prism' fromIntegral $ fmap (view _1) . assertM' (has $ _2 . only 0) . properFraction
|
|
|
|
------------
|
|
-- 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
|
|
|
|
assertMonoid :: Monoid m => (m -> Bool) -> m -> m
|
|
assertMonoid f x = guardMonoid (f x) x
|
|
|
|
maybeMonoid :: Monoid m => Maybe m -> m
|
|
-- ^ Identify `Nothing` with `mempty`
|
|
maybeMonoid = fromMaybe 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)
|
|
|
|
mTuple :: Applicative f => f a -> f b -> f (a, b)
|
|
mTuple = liftA2 (,)
|
|
|
|
-- From Data.Tuple.Extra
|
|
mapBoth :: (a -> b) -> (a,a) -> (b,b)
|
|
mapBoth f ~(a,b) = (f a, f b)
|
|
|
|
-----------
|
|
-- Lists --
|
|
-----------
|
|
|
|
-- avoids some parenthesis within guards
|
|
notNull :: MonoFoldable mono => mono -> Bool
|
|
notNull = not . null
|
|
|
|
headDef :: a -> [a] -> a
|
|
headDef _ (h:_) = h
|
|
headDef d _ = d
|
|
|
|
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
|
|
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
|
|
-- Could be implemented using updateAssoc like so, but would add superfluous space at the end:
|
|
-- insertAttr attr valu = adjustAssoc (Text.append valu . Text.cons ' ') attr
|
|
|
|
-- | Insert key-value pair into association list.
|
|
-- If the new value is null/mempty, the first occurrence of the key is removed. (Unlike Data.Map.insert)
|
|
-- If the key is already present, then the first associated value is replaced by the new one.
|
|
-- Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
|
|
-- Some of our libraries use association lists for very few keys.
|
|
insertAssoc :: (Eq k, MonoFoldable v) => k -> v -> [(k,v)] -> [(k,v)]
|
|
insertAssoc key val = aux
|
|
where
|
|
aux [] = mbcons []
|
|
aux (p@(k,_) : t)
|
|
| key == k = mbcons t
|
|
| otherwise = p : aux t
|
|
mbcons t
|
|
| onull val = t
|
|
| otherwise = (key,val) : t
|
|
|
|
insertAssoc' :: (Eq k, Eq v, Monoid v) => k -> v -> [(k,v)] -> [(k,v)]
|
|
insertAssoc' key val = adjustAssoc (const val) key
|
|
|
|
-- | Update first matching key/value pair within an association list with a function.
|
|
-- If the key is not present, the update function is applied to mempty. (Unlike Data.Map.adjust)
|
|
-- If the result is mempty, the first occurrence of the key is removed.
|
|
-- Note: Avoid association lists, if possible. See GHC.Data.List.SetOps
|
|
adjustAssoc :: (Eq k, Eq v, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)]
|
|
adjustAssoc upd key = aux
|
|
where
|
|
aux [] = mbcons key mempty []
|
|
aux (p@(k,v) : t)
|
|
| key == k = mbcons k v t
|
|
| otherwise = p : aux t
|
|
mbcons k v t
|
|
| v' == mempty = t
|
|
| otherwise = (k,v') : t
|
|
where
|
|
v' = upd v
|
|
|
|
-- | 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
|
|
|
|
dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq
|
|
dropWhileM p xs'
|
|
| Just (x, xs) <- uncons xs'
|
|
= bool (return xs') (dropWhileM p xs) =<< p x
|
|
| otherwise = return xs'
|
|
|
|
|
|
isSubsequenceOfBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
|
|
isSubsequenceOfBy _ [] _ = True
|
|
isSubsequenceOfBy _ _ [] = False
|
|
isSubsequenceOfBy cmp a@(x:a') (y:b)
|
|
| x `cmp` y = isSubsequenceOfBy cmp a' b
|
|
| otherwise = isSubsequenceOfBy cmp a b
|
|
|
|
withoutSubsequenceBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe [b]
|
|
withoutSubsequenceBy cmp = go []
|
|
where go acc [] b = Just $ reverse acc ++ b
|
|
go _ _ [] = Nothing
|
|
go acc a@(x:a') (y:b)
|
|
| x `cmp` y = go acc a' b
|
|
| otherwise = go (y:acc) a b
|
|
|
|
pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
|
|
pattern NonEmpty x xs = x :| xs
|
|
{-# COMPLETE NonEmpty #-}
|
|
|
|
----------
|
|
-- Sets --
|
|
----------
|
|
-- all functions that used to be here are now in Utils.Set
|
|
|
|
----------
|
|
-- Maps --
|
|
----------
|
|
|
|
infixl 5 !!!
|
|
|
|
|
|
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
|
|
(!!!) m k = fromMaybe mempty $ Map.lookup k m
|
|
|
|
lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
|
|
-- lookupSome :: Ord k => Map k [v] -> [k] -> [v]
|
|
-- lookupSome m ks = ks >>= (m !!!)
|
|
lookupSome = (=<<) . (!!!)
|
|
|
|
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
|
|
|
|
maybeMap :: IsMap p => ContainerKey p -> Maybe (MapValue p) -> p
|
|
maybeMap k = foldMap (singletonMap k)
|
|
|
|
maybeMapWith :: IsMap p => (t -> MapValue p) -> ContainerKey p -> Maybe t -> p
|
|
maybeMapWith f k = foldMap $ singletonMap k . f
|
|
|
|
-- | 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
|
|
|
|
partitionKeysEither :: Map (Either k1 k2) v -> (Map k1 v, Map k2 v)
|
|
partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . over _1 (Map.mapKeysMonotonic . view $ singular _Left) . Map.partitionWithKey (\k _ -> is _Left k)
|
|
|
|
mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v)
|
|
mapFromSetM = (sequenceA .) . Map.fromSet
|
|
|
|
mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v)
|
|
mapFM = sequenceA . mapF
|
|
|
|
mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v)
|
|
mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m)
|
|
|
|
_MapUnit :: Iso' (Map k ()) (Set k)
|
|
_MapUnit = iso Map.keysSet $ Map.fromSet (const ())
|
|
|
|
---------------
|
|
-- 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
|
|
|
|
-- replaced by a more general formulation, see canonical
|
|
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
|
|
-- null2nothing (Just x) | null x = Nothing
|
|
-- null2nothing other = other
|
|
|
|
-- | 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
|
|
|
|
hoistMaybeM :: MonadPlus m => m (Maybe a) -> m a
|
|
hoistMaybeM = (=<<) hoistMaybe
|
|
|
|
maybeVoid :: Monad m => Maybe (m a) -> m ()
|
|
maybeVoid = maybe (return ()) void
|
|
|
|
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)
|
|
|
|
catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> Bool) -> m a -> m a
|
|
catchIfMPlus p act = catchIf p act (const mzero)
|
|
|
|
-- | Monadic version of 'fromMaybe'
|
|
fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a
|
|
fromMaybeM act = maybeM act pure
|
|
|
|
fromMaybeT :: MaybeT Identity a -> Maybe a
|
|
fromMaybeT = runIdentity . runMaybeT
|
|
|
|
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
|
|
|
|
-- `NTop` moved to `Utils.NTop`
|
|
|
|
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
|
|
|
|
-- | Monadic version of 'fromMaybe'
|
|
maybeThrowM :: (Exception e, MonadThrow m) => e -> m (Maybe a) -> m a
|
|
maybeThrowM = fromMaybeM . throwM
|
|
|
|
|
|
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
|
|
|
|
{-
|
|
-- Takes computations returnings @Maybes@; tries each one in order.
|
|
-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations
|
|
-- return @Nothing@.
|
|
-- Copied from GHC.Data.Maybe, which could not be imported somehow.
|
|
firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
|
|
firstJustsM = foldlM go Nothing
|
|
where
|
|
go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
|
|
go Nothing action = action
|
|
go result@(Just _) _action = return result
|
|
-}
|
|
|
|
-- | Run the maybe computation repeatedly until the first Just is returned
|
|
-- or the number of maximum retries is exhausted.
|
|
-- So like Control.Monad.Loops.untilJust, but with a maximum number of attempts.
|
|
untilJustMaxM :: Monad m => Int -> m (Maybe a) -> m (Maybe a)
|
|
untilJustMaxM nmax act = go 0
|
|
where
|
|
go n | n >= nmax = return Nothing
|
|
| otherwise = do
|
|
x <- act
|
|
case x of
|
|
Nothing -> go $ succ n
|
|
res@(Just _) -> return res
|
|
|
|
|
|
------------
|
|
-- 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 :: Applicative f => Either a b -> (a -> f ()) -> f ()
|
|
whenIsLeft (Left x) f = f x
|
|
whenIsLeft (Right _) _ = pure ()
|
|
|
|
whenIsRight :: Applicative f => Either a b -> (b -> f ()) -> f ()
|
|
whenIsRight (Right x) f = f x
|
|
whenIsRight (Left _) _ = pure ()
|
|
|
|
{- Just a reminder for Steffen:
|
|
mapLeft :: (a -> c) -> Either a b -> Either c b
|
|
mapLeft = over _Left
|
|
-}
|
|
|
|
throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
|
|
throwLeft = either throwM return
|
|
|
|
throwLeftM :: (MonadThrow m, Exception exc) => m (Either exc a) -> m a
|
|
throwLeftM = (throwLeft =<<)
|
|
|
|
actLeft :: Applicative f => Either a b -> (a -> f (Either c b)) -> f (Either c b)
|
|
actLeft (Left x) f = f x
|
|
actLeft (Right y) _ = pure $ Right y
|
|
|
|
-- | like monadic bind for 'Either', but wrapped in another monad
|
|
-- ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead
|
|
actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c)
|
|
actRight (Left x) _ = pure $ Left x
|
|
actRight (Right y) f = f y
|
|
|
|
---------------
|
|
-- Exception --
|
|
---------------
|
|
|
|
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
|
|
maybeExceptT err act = lift act >>= maybe (throwE err) return
|
|
|
|
maybeExceptT' :: Monad m => e -> Maybe b -> ExceptT e m b
|
|
maybeExceptT' err = 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
|
|
|
|
catchIfExceptT :: (MonadCatch m, Exception e) => (e -> e') -> (e -> Bool) -> m a -> ExceptT e' m a
|
|
catchIfExceptT err p act = catchIf p (lift act) (throwE . err)
|
|
|
|
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
|
|
|
|
generalFinally :: MonadMask m => m a -> (ExitCase a -> m b) -> m a
|
|
generalFinally action finalizer = view _1 <$> generalBracket (return ()) (const finalizer) (const action)
|
|
|
|
------------
|
|
-- 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 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
|
|
|
|
assertMM :: MonadPlus m => (a -> m Bool) -> m a -> m a
|
|
assertMM f x = do
|
|
x' <- x
|
|
guardM $ f x'
|
|
return x'
|
|
|
|
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)
|
|
|
|
assertMM' :: MonadPlus m => (a -> m Bool) -> a -> m a
|
|
assertMM' f x = x <$ guardM (f x)
|
|
|
|
guardOn :: forall m a. 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 :: (MonoFoldable mono, Element mono ~ m Bool, Monad m) => mono -> m Bool
|
|
andM = ofoldl' and2M (return True)
|
|
orM = ofoldl' or2M (return False)
|
|
|
|
-- | Short-circuiting monady any
|
|
allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) -> m Bool
|
|
allM xs f = andM . fmap f $ otoList xs
|
|
anyM xs f = orM . fmap f $ otoList xs
|
|
|
|
allMOf, anyMOf :: Monad m => Getting (Endo [a]) s a -> s -> (a -> m Bool) -> m Bool
|
|
allMOf l x = allM $ x ^.. l
|
|
anyMOf l x = anyM $ x ^.. l
|
|
|
|
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
|
|
|
|
forever' :: Monad m
|
|
=> a
|
|
-> (a -> m a)
|
|
-> m b
|
|
forever' start cont = cont start >>= flip forever' cont
|
|
|
|
foreverBreak :: Monad m
|
|
=> ((r -> ContT r m b) -> ContT r m a)
|
|
-> m r
|
|
foreverBreak cont = evalContT . callCC $ forever . cont
|
|
|
|
|
|
sortOnM :: (Ord b, Monad m)
|
|
=> (a -> m b)
|
|
-> [a]
|
|
-> m [a]
|
|
sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x)
|
|
|
|
-- Stolen from Agda...
|
|
|
|
mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b)
|
|
mapMM f mxs = Trav.mapM f =<< mxs
|
|
|
|
forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b)
|
|
forMM = flip mapMM
|
|
|
|
mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m ()
|
|
mapMM_ f mxs = Fold.mapM_ f =<< mxs
|
|
|
|
forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m ()
|
|
forMM_ = flip mapMM_
|
|
|
|
-- | Monadic bind that also returns the intermediate value. This common pattern avoids the duplicated local identifiers required in the equivalent do-notation.
|
|
bind2 :: Monad m => m a -> (a -> m b) -> m (a, b)
|
|
bind2 ma ma2b = do
|
|
a <- ma
|
|
b <- ma2b a
|
|
return (a,b)
|
|
|
|
bind3 :: Monad m => m a -> (a -> m b) -> (a -> b -> m c) -> m (a, b, c)
|
|
bind3 ma ma2b mab2c = do
|
|
a <- ma
|
|
b <- ma2b a
|
|
c <- mab2c a b
|
|
return (a,b,c)
|
|
|
|
|
|
--------------
|
|
-- Foldable --
|
|
--------------
|
|
|
|
minLength :: ( Integral n
|
|
, MonoFoldable mono
|
|
)
|
|
=> n -> mono -> Bool
|
|
-- ^ @minLegth n xs = length xs >= n@
|
|
minLength l = go l . otoList
|
|
where
|
|
go l' _ | l' <= 0 = True
|
|
go l' xs = case xs of
|
|
_ : xs' -> go (pred l') xs'
|
|
[] -> False
|
|
|
|
maxLength :: ( Integral n
|
|
, MonoFoldable mono
|
|
)
|
|
=> n -> mono -> Bool
|
|
-- ^ @maxLegth n xs = length xs <= n@
|
|
maxLength l = not . minLength (succ l)
|
|
|
|
------------
|
|
-- Writer --
|
|
------------
|
|
|
|
tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m ()
|
|
tellM = tell <=< lift
|
|
|
|
tellPoint :: forall mono m. (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
|
|
tellPoint = tell . opoint
|
|
|
|
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
|
|
tellMPoint = tellM . fmap opoint
|
|
|
|
class IsWriterT t where
|
|
runWriterT' :: (Monad m, Monoid w) => t w m a -> m (a, w)
|
|
mapWriterT' :: (m (a, w) -> n (b, w')) -> t w m a -> t w' n b
|
|
instance IsWriterT Strict.WriterT where
|
|
runWriterT' = Strict.runWriterT
|
|
mapWriterT' = Strict.mapWriterT
|
|
instance IsWriterT Lazy.WriterT where
|
|
runWriterT' = Lazy.runWriterT
|
|
mapWriterT' = Lazy.mapWriterT
|
|
|
|
evalWriterT :: (IsWriterT t, Monoid w, Monad m) => t w m a -> m a
|
|
evalWriterT = fmap fst . runWriterT'
|
|
|
|
censorM :: (IsWriterT t, Monad m)
|
|
=> (w -> m w)
|
|
-> t w m a -> t w m a
|
|
censorM f = mapWriterT' (>>= \(x, w) -> (x, ) <$> f w)
|
|
|
|
-------------
|
|
-- 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
|
|
|
|
peekWhile :: forall a o m. Monad m => (a -> Bool) -> ConduitT a o m [a]
|
|
peekWhile p = do
|
|
let go acc = do
|
|
next <- await
|
|
case next of
|
|
Nothing -> return (reverse acc, Nothing)
|
|
Just x
|
|
| p x -> go $ x : acc
|
|
| otherwise -> return (reverse acc, Just x)
|
|
(peeked, failed) <- go []
|
|
mapM_ leftover $ peeked ++ hoistMaybe failed
|
|
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
|
|
|
|
yieldMMany :: forall mono m a. (Monad m, MonoFoldable mono) => m mono -> ConduitT a (Element mono) m ()
|
|
yieldMMany = C.yieldMany <=< lift
|
|
|
|
eitherC :: Monad m => ConduitT l o m () -> ConduitT r o m () -> ConduitT (Either l r) o m ()
|
|
eitherC lC rC = void $ sequenceConduits [C.mapMaybe (preview _Left) .| lC, C.mapMaybe (preview _Right) .| rC]
|
|
|
|
takeWhileMC :: forall a m. Monad m => (a -> m Bool) -> ConduitT a a m ()
|
|
takeWhileMC f = loop
|
|
where loop = do
|
|
x <- await
|
|
whenIsJust x $ \x' ->
|
|
whenM (lift $ f x') $ yield x' *> loop
|
|
|
|
takeWhileTime :: forall a m. MonadIO m => NominalDiffTime -> ConduitT a a m ()
|
|
takeWhileTime maxT = do
|
|
sTime <- liftIO getCurrentTime
|
|
takeWhileMC . const $ do
|
|
now <- liftIO getCurrentTime
|
|
let tDelta = now `diffUTCTime` sTime
|
|
return $ tDelta < maxT
|
|
|
|
runPeekN :: forall o m n. (Integral n, Monad m) => n -> ConduitT () o m () -> m (ConduitT () o m (), [o])
|
|
runPeekN n src = over (mapped . _1) unsealConduitT $ src $$+ peekN n
|
|
|
|
runPeekWhile :: forall o m. Monad m => (o -> Bool) -> ConduitT () o m () -> m (ConduitT () o m (), [o])
|
|
runPeekWhile f src = over (mapped . _1) unsealConduitT $ src $$+ peekWhile f
|
|
|
|
-----------------
|
|
-- Alternative --
|
|
-----------------
|
|
|
|
choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a
|
|
choice = foldr (<|>) empty
|
|
|
|
--------------
|
|
-- Sessions --
|
|
--------------
|
|
|
|
-- Moved to Utils.Session
|
|
|
|
-------------
|
|
-- Cookies --
|
|
-------------
|
|
|
|
-- Moved to Utils.Cookies.Registered
|
|
|
|
--------------------
|
|
-- GET Parameters --
|
|
--------------------
|
|
|
|
-- Moved to Utils.Parameters
|
|
|
|
---------------------------------
|
|
-- Custom HTTP Headers --
|
|
---------------------------------
|
|
|
|
data CustomHeader
|
|
= HeaderIsModal
|
|
| HeaderDBTableShortcircuit
|
|
| HeaderMassInputShortcircuit
|
|
| HeaderAlerts
|
|
| HeaderDBTableCanonicalURL
|
|
| HeaderDryRun
|
|
| HeaderUploadToken
|
|
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)
|
|
|
|
waiCustomHeader :: ToHttpApiData payload => CustomHeader -> payload -> Wai.Header
|
|
waiCustomHeader ident payload = (CI.mk . encodeUtf8 $ toPathPiece ident, toHeader 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 (decodeUtf8 $ CI.original hContentDisposition) 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
|
|
|
|
setCSPSandbox :: MonadHandler m => m ()
|
|
setCSPSandbox = replaceOrAddHeader "Content-Security-Policy" "sandbox;"
|
|
|
|
------------------
|
|
-- 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.secretbox_noncebytes + Saltine.secretbox_macbytes) $
|
|
throwError EncodedSecretBoxCiphertextTooShort
|
|
let (nonceBS, encrypted) = BS.splitAt Saltine.secretbox_noncebytes 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 :: forall a m.
|
|
( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
|
|
=> Text -> m a
|
|
encodedSecretBoxOpen ciphertext = do
|
|
sKey <- secretBoxKey
|
|
encodedSecretBoxOpen' sKey ciphertext
|
|
|
|
encodedAuthSep :: Text
|
|
encodedAuthSep = "."
|
|
|
|
encodedAuth' :: ToJSON a
|
|
=> Auth.Key
|
|
-> a -> Text
|
|
encodedAuth' aKey val = base64 msg <> encodedAuthSep <> base64 (Saltine.encode auth)
|
|
where msg = toStrict $ Aeson.encode val
|
|
auth = Auth.auth aKey msg
|
|
base64 = decodeUtf8 . Base64.encodeUnpadded
|
|
|
|
data EncodedAuthException
|
|
= EncodedAuthInvalidSeparation
|
|
| EncodedAuthInvalidBase64 !String
|
|
| EncodedAuthCouldNotDecodeAuthenticator
|
|
| EncodedAuthInvalidAuthenticator
|
|
| EncodedAuthCouldNotDecodePlaintext !String
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
encodedAuthVerify' :: (FromJSON a, MonadError EncodedAuthException m)
|
|
=> Auth.Key
|
|
-> Text -> m a
|
|
encodedAuthVerify' aKey bothEncoded = do
|
|
(msgEncoded, authEncoded) <- case Text.splitOn encodedAuthSep bothEncoded of
|
|
[msgEncoded, authEncoded] -> return (msgEncoded, authEncoded)
|
|
_other -> throwError EncodedAuthInvalidSeparation
|
|
authBS <- either (throwError . EncodedAuthInvalidBase64) return . Base64.decode $ encodeUtf8 authEncoded
|
|
auth <- maybe (throwError EncodedAuthCouldNotDecodeAuthenticator) return $ Saltine.decode authBS
|
|
msgDecoded <- either (throwError . EncodedAuthInvalidBase64) return . Base64.decode $ encodeUtf8 msgEncoded
|
|
unless (Auth.verify aKey auth msgDecoded) $
|
|
throwError EncodedAuthInvalidAuthenticator
|
|
either (throwError . EncodedAuthCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' msgDecoded
|
|
|
|
class Monad m => MonadAuth m where
|
|
authKey :: m Auth.Key
|
|
|
|
instance MonadAuth ((->) Auth.Key) where
|
|
authKey = id
|
|
|
|
instance Monad m => MonadAuth (ReaderT Auth.Key m) where
|
|
authKey = ask
|
|
|
|
encodedAuth :: ( ToJSON a, MonadAuth m )
|
|
=> a -> m Text
|
|
encodedAuth val = do
|
|
aKey <- authKey
|
|
return $ encodedAuth' aKey val
|
|
|
|
encodedAuthVerify :: ( FromJSON a, MonadError EncodedAuthException m, MonadAuth m )
|
|
=> Text -> m a
|
|
encodedAuthVerify bothEncoded = do
|
|
aKey <- authKey
|
|
encodedAuthVerify' aKey bothEncoded
|
|
|
|
|
|
|
|
kmaclazy :: forall a string key ba chunk.
|
|
( HashSHAKE a
|
|
, ByteArrayAccess string
|
|
, ByteArrayAccess key
|
|
, ByteArrayAccess chunk
|
|
, LazySequence ba chunk
|
|
)
|
|
=> string
|
|
-> key
|
|
-> ba
|
|
-> KMAC a
|
|
kmaclazy str k = KMAC.finalize . KMAC.updates (KMAC.initialize @a str k) . toChunks
|
|
|
|
emptyHash :: forall a. HashAlgorithm a => Q (TExp (Digest a))
|
|
-- ^ Hash of `mempty`
|
|
--
|
|
-- Computationally preferrable to computing the hash at runtime
|
|
emptyHash = TH.liftTyped $ Crypto.hashFinalize Crypto.hashInit
|
|
|
|
-------------
|
|
-- Caching --
|
|
-------------
|
|
|
|
cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
|
|
cachedByBinary k = cachedBy (toStrict $ Binary.encode k)
|
|
|
|
cacheIdentHere :: Q Exp
|
|
cacheIdentHere = TH.lift =<< location
|
|
|
|
cachedHere :: Q Exp
|
|
cachedHere = do
|
|
loc <- location
|
|
[e| cachedByBinary loc |]
|
|
|
|
cachedHereBinary :: Q Exp
|
|
cachedHereBinary = do
|
|
loc <- location
|
|
[e| \k -> cachedByBinary (loc, k) |]
|
|
|
|
-- TODO: replace with Utils.HttpConditional
|
|
|
|
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 hIfModifiedSince
|
|
$logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince)
|
|
when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince)
|
|
notModified
|
|
|
|
addHeader (decodeUtf8 $ CI.original hLastModified) $ formatRFC1123 lastModified
|
|
where
|
|
precision :: NominalDiffTime
|
|
precision = 1
|
|
|
|
safeMethods = [ methodGet, methodHead, methodOptions ]
|
|
|
|
-- | Adapter for memoization of five-argument function
|
|
for5 :: (((k1, k2, k3, k4, k5) -> mv) -> (k1, k2, k3, k4, k5) -> mv) -> (k1 -> k2 -> k3 -> k4 -> k5 -> mv) -> k1 -> k2 -> k3 -> k4 -> k5 -> mv
|
|
for5 m f a b c d e = m (\(a',b',c',d',e') -> f a' b' c' d' e') (a,b,c,d,e)
|
|
|
|
--------------
|
|
-- 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
|
|
|
|
minBy,maxBy :: (a -> a -> Ordering) -> a -> a -> a
|
|
minBy cmp a b = case a `cmp` b of
|
|
GT -> b
|
|
_ -> a
|
|
maxBy cmp a b = case a `cmp` b of
|
|
LT -> b
|
|
_ -> a
|
|
|
|
minOn,maxOn :: Ord b => (a -> b) -> a -> a -> a
|
|
minOn = minBy . comparing
|
|
maxOn = maxBy . comparing
|
|
|
|
inBetween:: Ord a => a -> (a,a) -> Bool
|
|
inBetween x (lower,upper) = lower <= x && x <= upper
|
|
|
|
-- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists
|
|
pickBetter :: a -> a -> (a -> Bool) -> Maybe a
|
|
pickBetter x y crit
|
|
| cx == cy = Nothing
|
|
| cx = Just x
|
|
| otherwise = Just y
|
|
where
|
|
cx = crit x
|
|
cy = crit y
|
|
|
|
------------
|
|
-- 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
|
|
|
|
uniforms :: (RandomGen g, MonadSplit g m, Foldable t) => t a -> m [a]
|
|
uniforms xs = LazyRand.evalRand (randomInfiniteList $ uniform xs) <$> getSplit
|
|
|
|
randomInfiniteList :: MonadInterleave m => m a -> m [a]
|
|
randomInfiniteList gen = interleave $ (:) <$> gen <*> randomInfiniteList gen
|
|
|
|
randUUIDC :: MonadIO m
|
|
=> (forall m'. Monad m' => m' UUID -> (forall a. m a -> m' a) -> ConduitT i o m' r)
|
|
-> ConduitT i o m r
|
|
randUUIDC cont = do
|
|
drg <- liftIO Crypto.drgNew
|
|
let
|
|
mkUUID = do
|
|
uuidBS <- State.state $ Crypto.randomBytesGenerate 16
|
|
return . fromMaybe (error $ "Could not convert bytestring to uuid: " <> show uuidBS) . UUID.fromByteString $ fromStrict uuidBS
|
|
evalStateC drg $ cont mkUUID lift
|
|
|
|
----------
|
|
-- 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
|
|
|
|
-------------
|
|
-- HashMap --
|
|
-------------
|
|
|
|
newtype MergeHashMap k v = MergeHashMap { unMergeHashMap :: HashMap k v }
|
|
deriving (Show, Generic, Typeable, Data)
|
|
deriving newtype ( Eq, Ord, Hashable
|
|
, Functor, Foldable, NFData
|
|
, ToJSON
|
|
)
|
|
|
|
makePrisms ''MergeHashMap
|
|
makeWrapped ''MergeHashMap
|
|
|
|
type instance Element (MergeHashMap k v) = v
|
|
|
|
instance MonoFoldable (MergeHashMap k v)
|
|
instance MonoFunctor (MergeHashMap k v)
|
|
instance MonoTraversable (MergeHashMap k v)
|
|
|
|
instance Traversable (MergeHashMap k) where
|
|
traverse = _MergeHashMap . traverse
|
|
|
|
instance FunctorWithIndex k (MergeHashMap k)
|
|
instance TraversableWithIndex k (MergeHashMap k) where
|
|
itraverse = _MergeHashMap .> itraverse
|
|
instance FoldableWithIndex k (MergeHashMap k)
|
|
|
|
instance (Eq k, Hashable k, Semigroup v) => Semigroup (MergeHashMap k v) where
|
|
(MergeHashMap a) <> (MergeHashMap b) = MergeHashMap $ HashMap.unionWith (<>) a b
|
|
instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where
|
|
mempty = MergeHashMap HashMap.empty
|
|
instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where
|
|
parseJSON = case Aeson.fromJSONKey of
|
|
Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $
|
|
coerce @(Aeson.Parser (HashMap k v)) @(Aeson.Parser (MergeHashMap k v)) . fmap HashMap.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
|
|
Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $
|
|
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
|
|
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
|
|
fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
|
|
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
|
|
fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
|
where
|
|
parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
|
|
parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
|
|
where
|
|
p = Aeson.withArray "(k, v)" $ \ab ->
|
|
let n = V.length ab
|
|
in if n == 2
|
|
then (,) <$> parseJSONElemAtIndex keyParser 0 ab
|
|
<*> parseJSONElemAtIndex valParser 1 ab
|
|
else fail $ "cannot unpack array of length " ++
|
|
show n ++ " into a pair"
|
|
|
|
parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
|
|
parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
|
|
|
|
|
|
newtype MergeMap k v = MergeMap { unMergeMap :: Map k v }
|
|
deriving (Show, Generic, Typeable, Data)
|
|
deriving newtype ( Eq, Ord
|
|
, Functor, Foldable, NFData
|
|
, ToJSON
|
|
)
|
|
|
|
makePrisms ''MergeMap
|
|
makeWrapped ''MergeMap
|
|
|
|
type instance Element (MergeMap k v) = v
|
|
|
|
instance MonoFoldable (MergeMap k v)
|
|
instance MonoFunctor (MergeMap k v)
|
|
instance MonoTraversable (MergeMap k v)
|
|
|
|
instance Traversable (MergeMap k) where
|
|
traverse = _MergeMap . traverse
|
|
|
|
instance FunctorWithIndex k (MergeMap k)
|
|
instance TraversableWithIndex k (MergeMap k) where
|
|
itraverse = _MergeMap .> itraverse
|
|
instance FoldableWithIndex k (MergeMap k)
|
|
|
|
instance (Ord k, Semigroup v) => Semigroup (MergeMap k v) where
|
|
(MergeMap a) <> (MergeMap b) = MergeMap $ Map.unionWith (<>) a b
|
|
instance (Ord k, Semigroup v) => Monoid (MergeMap k v) where
|
|
mempty = MergeMap Map.empty
|
|
instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k v) where
|
|
parseJSON = case Aeson.fromJSONKey of
|
|
Aeson.FromJSONKeyCoerce -> Aeson.withObject "Map ~Text" $
|
|
coerce @(Aeson.Parser (Map k v)) @(Aeson.Parser (MergeMap k v)) . fmap Map.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
|
|
Aeson.FromJSONKeyText f -> Aeson.withObject "Map" $
|
|
fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
|
|
Aeson.FromJSONKeyTextParser f -> Aeson.withObject "Map" $
|
|
fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
|
|
Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
|
|
fmap (MergeMap . Map.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
|
|
where
|
|
parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
|
|
parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
|
|
where
|
|
p = Aeson.withArray "(k, v)" $ \ab ->
|
|
let n = V.length ab
|
|
in if n == 2
|
|
then (,) <$> parseJSONElemAtIndex keyParser 0 ab
|
|
<*> parseJSONElemAtIndex valParser 1 ab
|
|
else fail $ "cannot unpack array of length " ++
|
|
show n ++ " into a pair"
|
|
|
|
parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
|
|
parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
|
|
|
|
--------------
|
|
-- FilePath --
|
|
--------------
|
|
|
|
ensureExtension :: String -> FilePath -> FilePath
|
|
ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
|
|
|
|
infixr 4 <//>
|
|
|
|
(<//>) :: FilePath -> FilePath -> FilePath
|
|
dir <//> file = dir </> dropDrive file
|
|
|
|
|
|
----------------
|
|
-- TH Dungeon --
|
|
----------------
|
|
|
|
makePrisms ''ExitCase
|
|
|
|
|
|
---------------
|
|
-- Normalize --
|
|
---------------
|
|
|
|
-- | Bad hack class for datatypes that have multiple inequal representations which ought to be identical, i.e. Just "" ~= Nothing
|
|
class Canonical a where
|
|
canonical :: a -> a
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where
|
|
canonical (Just t) | null t = Nothing
|
|
canonical other = other
|
|
|
|
{-
|
|
instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
|
|
canonical r@(Just t) = let c = canonical t
|
|
in if null c then Nothing else
|
|
if t==c then r else Just c
|
|
canonical other = other
|
|
-}
|
|
|
|
-- this instance is more of a convenient abuse of the class (expand to Foldable)
|
|
instance (Ord a, Canonical a) => Canonical (Set a) where
|
|
canonical = Set.map canonical
|