module Utils
  ( module Utils
  ) where

import ClassyPrelude.Yesod hiding (foldlM, Proxy)

-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import qualified Data.Foldable as Fold
import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (Sum(..))
import Data.Proxy

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

-- import Utils.DB as Utils
import Utils.TH as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Route as Utils
import Utils.Icon as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Utils.Parameters as Utils
import Utils.Csv as Utils
import Control.Concurrent.Async.Lifted.Safe.Utils as Utils

import Text.Blaze (Markup, ToMarkup)

import Data.Char (isDigit, isSpace, isAscii)
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)

import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
-- import qualified Data.List as List

import Control.Lens
import Control.Lens as Utils (none)

import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Catch hiding (throwM)

import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
import Instances.TH.Lift ()

import Text.Shakespeare.Text (st)

import qualified Data.Aeson as Aeson

import Data.Universe

import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
import qualified Data.ByteString.Base64.URL as Base64
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Data.PKCS7 as PKCS7

import Data.Fixed
-- import Data.Ratio ((%))

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Network.Wai (requestMethod)

import Data.Time.Clock

import Data.List.NonEmpty (NonEmpty, nonEmpty)

import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)

import Data.Constraint (Dict(..))

{-# ANN module ("HLint: ignore Use asum" :: String) #-}


$(iconShortcuts) -- declares constants for all known icons

-----------
-- Yesod --
-----------

newtype MsgRendererS site = MsgRenderer { render :: forall msg. RenderMessage site msg => msg -> Text }

getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
getMsgRenderer = do
  mr <- getMessageRender
  return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)


guardAuthResult :: MonadHandler m => AuthResult -> m ()
guardAuthResult AuthenticationRequired = notAuthenticated
guardAuthResult (Unauthorized t) = permissionDenied t
guardAuthResult Authorized = return ()

data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route
  deriving (Eq, Ord, Typeable, Show)
instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)

unsupportedAuthPredicate :: ExpQ
unsupportedAuthPredicate = do
  logFunc <- logErrorS
  [e| \tag route -> do
        $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
        unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
    |]

-- | allows conditional attributes in hamlet via *{..} syntax
maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
maybeAttribute _ _ Nothing  = []
maybeAttribute a c (Just v) = [(a,c v)]


---------------------
-- Text and String --
---------------------

-- DEPRECATED: use hasTickmark instead;
-- maybe reinstate if needed for @bewertung.txt@ files
-- tickmark :: IsString a => a
-- tickmark = fromString "✔"

-- | remove all Whitespace from Text
stripAll :: Text -> Text
stripAll = Text.filter (not . isSpace)

-- | Convert text as it is to Html, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2Html :: Text -> Html
text2Html = toHtml

-- | Convert text as it is to Message, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2message :: Text -> SomeMessage site
text2message = SomeMessage

toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
      => a -> WidgetT site m ()
toWgt = toWidget . toHtml

-- Convenience Functions to avoid type signatures:
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
            => Text -> WidgetT site m ()
text2widget t = [whamlet|#{t}|]

citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
              => CI Text -> WidgetT site m ()
citext2widget t = [whamlet|#{CI.original t}|]

str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
           => String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|]

withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = flip fmap form $ over _2 (toWidget html >>)

rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a
rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy :: HasResolution a => Proxy a)))

rationalToFixed3 :: Rational -> Fixed E3
rationalToFixed3 = rationalToFixed

rationalToFixed2 :: Rational -> Fixed E2
rationalToFixed2 = rationalToFixed

-- | Convert `part` and `whole` into percentage including symbol
--   showing trailing zeroes and to decimal digits
textPercent :: Real a => a -> a -> Text
textPercent = textPercent' False 2

-- | Convert `part` and `whole` into percentage including symbol
--   `trailZero` shows trailing Zeros, `precision` is number of decimal digits
textPercent' :: Real a => Bool -> Int -> a -> a -> Text
textPercent' trailZero precision part whole
    | precision == 0 = showPercent (frac :: Uni)
    | precision == 1 = showPercent (frac :: Deci)
    | precision == 2 = showPercent (frac :: Centi)
    | precision == 3 = showPercent (frac :: Milli)
    | precision == 4 = showPercent (frac :: Micro)
    | otherwise      = showPercent (frac :: Pico)
  where
    frac :: forall a. HasResolution a => Fixed a
    frac = rationalToFixed $ (100*) $ toRational part / toRational whole

    showPercent :: HasResolution a => Fixed a -> Text
    showPercent f = pack $ showFixed trailZero f <> "%"


-- | Convert number of bytes to human readable format
textBytes :: Integral a => a -> Text
textBytes x
  | v < kb    = rshow  v     <>  "B"
  | v < mb    = rshow (v/kb) <> "KB"
  | v < gb    = rshow (v/mb) <> "MB"
  | otherwise = rshow (v/gb) <> "GB"
 where
  v  = fromIntegral x
  kb = 1024
  mb = 1024 * kb
  gb = 1024 * mb
  rshow :: Double -> Text
  rshow = tshow . floorToDigits 1


stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounterCI = CI.map stepTextCounter

stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
stepTextCounter text
    | (Just i) <- readMay number =
        let iplus1 = tshow (succ i :: Int)
            zeroip = justifyRight (length number) '0' iplus1
        in  prefix <> zeroip <> suffix
    | otherwise = text
  where -- no splitWhile nor findEnd in Data.Text
    suffix =                        takeWhileEnd (not . isDigit) text
    number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
    prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text

-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
-- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]

-- | Ignore warnings for unused variables with a more specific type
notUsedT :: a -> Text
notUsedT = notUsed



----------
-- Bool --
----------

-- | Logical implication, readable synonym for (<=) which appears the wrong way around
implies :: Bool -> Bool -> Bool
implies True x = x
implies _    _ = True



-------------
-- Numeric --
-------------

-- | round n to nearest multiple of m
roundToNearestMultiple :: Int -> Int -> Int
roundToNearestMultiple m n = (n `div` m + 1) * m

roundToDigits :: (RealFrac a, Integral b) => b -> a -> a
roundToDigits d x = fromInteger (round $ x * prec) / prec
  where prec = 10^d

floorToDigits :: (RealFrac a, Integral b) => b -> a -> a
floorToDigits d x = fromInteger (floor $ x * prec) / prec
  where prec = 10^d

-- | Integral division, but rounded upwards.
ceilingDiv :: Integral a => a -> a -> a
ceilingDiv d n = (d+n-1) `div` n

-- | Integral division, rounded to custom digit; convenience function for hamlets
roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
roundDiv digits numerator denominator
  = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator

-- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all
--   `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved)
--   Useful for heat maps, with offset giving a visual step between completed and not yet completed
cutOffPercent :: Double -> Double -> Double -> Double
cutOffPercent offset full achieved
  | full <= achieved = 0
  | full <= 0        = 0
  | otherwise        = offset + (1-offset) * (1 - percent)
  where
    percent = achieved / full



------------
-- Monoid --
------------

-- | Ignore warnings for unused variables
notUsed :: Monoid m => a -> m
notUsed = const mempty


------------
-- Tuples --
------------

fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,y,_) = y
trd3 :: (a,b,c) -> c
trd3 (_,_,z) = z

-- Further projections are available via TemplateHaskell, defined in Utils.Common:
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-- snd3 = $(projNI 3 2)



-----------
-- Lists --
-----------

-- notNull = not . null

lastMaybe :: [a] -> Maybe a
lastMaybe []    = Nothing
lastMaybe [h]   = Just h
lastMaybe (_:t) = lastMaybe t

lastMaybe' :: [a] -> Maybe a
lastMaybe' l = fmap snd $ l ^? _Snoc


-- | Merge/Add any attribute-value pair to an existing list of such pairs.
--   If the attribute exists, the new valu will be prepended, separated by a single empty space
--   Also see `Utils.mergeAttrs`
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
insertAttr attr valu = aux
  where
    aux :: [(Text,Text)] -> [(Text,Text)]
    aux [] = [(attr,valu)]
    aux (p@(a,v) : t)
      | attr==a   = (a, Text.append valu $ Text.cons ' ' v) : t
      | otherwise = p : aux t

-- | Add another class attribute; special function for a frequent case to avoid mistyping "class".
--  Also see `Utils.insertAttrs`
insertClass :: Text -> [(Text,Text)] -> [(Text,Text)]
insertClass = insertAttr "class"

-- | Append two lists of attributes, merging the class attribute only.
--   Also see `Utils.insertAttr` to merge any attribute
mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
mergeAttrs = mergeAttrs' `on` sort
  where
    special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
              ]

    mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
      | Just merge <- lookup n1 special
      , n2 == n1
      = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
      | Just _ <- lookup n1 special
      , n1 < n2
      = x2 : mergeAttrs' (x1:xs1) xs2
      | otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
    mergeAttrs' [] xs2 = xs2
    mergeAttrs' xs1 [] = xs1


-- | Copied form Util from package ghc
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
-- ^ Uses a function to determine which of two output lists an input element should join
partitionWith _ [] = ([],[])
partitionWith f (x:xs) = case f x of
                         Left  b -> (b:bs, cs)
                         Right c -> (bs, c:cs)
    where (bs,cs) = partitionWith f xs

nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
nonEmpty' = maybe empty pure . nonEmpty

----------
-- Sets --
----------

-- | Intersection of multiple sets. Returns empty set for empty input list
setIntersections :: Ord a => [Set a] -> Set a
setIntersections []    = Set.empty
setIntersections (h:t) = foldl' Set.intersection h t

setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList

----------
-- Maps --
----------

infixl 5 !!!


(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
(!!!) m k = fromMaybe mempty $ Map.lookup k m

groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]

partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend

invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList

-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons)
countMapElems :: (Ord v) => Map k v -> Map v Int
countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList



---------------
-- Functions --
---------------

-- curryN, uncurryN see Utils.TH

-- | Just @flip (.)@ for convenient formatting in some cases,
--   Deprecated in favor of Control.Arrow.(>>>)
compose :: (a -> b) -> (b -> c) -> (a -> c)
compose = flip (.)


-----------
-- Maybe --
-----------

toMaybe :: Bool -> a -> Maybe a
toMaybe True  = Just
toMaybe False = const Nothing

toNothing :: a -> Maybe b
toNothing = const Nothing

toNothingS :: String -> Maybe b
toNothingS = const Nothing

-- | Swap 'Nothing' for 'Just' and vice versa
-- This belongs into Module 'Utils' but we have a weird cyclic
-- dependency
flipMaybe :: b -> Maybe a -> Maybe b
flipMaybe x Nothing  = Just x
flipMaybe _ (Just _) = Nothing

-- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased
deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a)
deepAlt Nothing        altSnd  = altSnd
deepAlt altFst         Nothing = altFst
deepAlt (Just Nothing) altSnd  = altSnd
deepAlt altFst         _       = altFst

maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap

whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x
whenIsJust Nothing  _ = return ()

ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
ifMaybeM Nothing dft _  = return dft
ifMaybeM (Just x) _ act = act x

maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if
maybePositive a | a > 0     = Just a
                | otherwise = Nothing

positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
positiveSum = maybePositive . getSum

maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act

maybeT :: Monad m => m a -> MaybeT m a -> m a
maybeT x m = runMaybeT m >>= maybe x return

maybeT_ :: Monad m => MaybeT m () -> m ()
maybeT_ = void . runMaybeT

hoistMaybe :: MonadPlus m => Maybe a -> m a
-- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
hoistMaybe = maybe mzero return

catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero)

mcons :: Maybe a -> [a] -> [a]
mcons Nothing  xs = xs
mcons (Just x) xs = x:xs

-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
ignoreNothing _ Nothing y = y
ignoreNothing _ x Nothing = x
ignoreNothing f (Just x) (Just y) = Just $ f x y

newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom

instance Eq a  => Eq (NTop (Maybe a)) where
  (NTop x) == (NTop y) = x == y

instance Ord a => Ord (NTop (Maybe a)) where
  compare (NTop Nothing)  (NTop Nothing) = EQ
  compare (NTop Nothing)  _              = GT
  compare _               (NTop Nothing) = LT
  compare (NTop (Just x)) (NTop (Just y)) = compare x y

exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT

formResultToMaybe :: Alternative m => FormResult a -> m a
formResultToMaybe (FormSuccess x) = pure x
formResultToMaybe  _              = empty

maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
maybeThrow exc = maybe (throwM exc) return

maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a
maybeThrowM excM = maybe (throwM =<< excM) return

------------
-- Either --
------------

maybeLeft  :: Either a b -> Maybe a
maybeLeft  (Left a) = Just a
maybeLeft  _ = Nothing

maybeRight :: Either a b -> Maybe b
maybeRight (Right b) = Just b
maybeRight _ = Nothing

whenIsLeft  :: Monad m => Either a b -> (a -> m ()) -> m ()
whenIsLeft (Left   x) f = f x
whenIsLeft (Right  _) _ = return ()

whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
whenIsRight (Right x) f = f x
whenIsRight (Left  _) _ = return ()


---------------
-- Exception --
---------------

maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return

maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return

maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
maybeTExceptT err act = maybeExceptT err $ runMaybeT act

maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act

whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err

whenMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
whenMExceptT b err = when b $ lift err >>= throwE

guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
guardExceptT b err = unless b $ throwE err

guardMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
guardMExceptT b err = unless b $ lift err >>= throwE

exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT

catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)

throwExceptT :: ( Exception e, MonadThrow m )
             => ExceptT e m a -> m a
throwExceptT = exceptT throwM return

------------
-- Monads --
------------

shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
shortCircuitM sc binOp mx my = do
  x <- mx
  if
    | sc x      -> return x
    | otherwise -> binOp <$> pure x <*> my


guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f

assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f

assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
assertM_ f x = guard . f =<< x

assertM' :: Alternative m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)

guardOn :: Alternative m => Bool -> a -> m a
guardOn b x = x <$ guard b

-- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c m m' =
    do  b <- c
        if b then m else m'

-- | @ifNotM mc = ifM (not <$> mc)@  from Agda.Utils.Monad
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c

-- | Short-circuiting monadic boolean function, copied from Andreas Abel's utility function
and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)
or2M ma = ifM ma (return True)

andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)
orM = Fold.foldr or2M (return False)

-- | Short-circuiting monady any
allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs
anyM xs f = orM $ fmap f xs

ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
ofoldr1M f (otoList -> x:xs) = foldrM f x xs
ofoldr1M _ _ = error "otoList of NonNull is empty"
ofoldl1M f (otoList -> x:xs) = foldlM f x xs
ofoldl1M _ _ = error "otoList of NonNull is empty"

partitionM :: forall mono m .
  ( MonoFoldable mono
  , Monoid mono
  , MonoPointed mono
  , Monad m)
    => (Element mono -> m Bool) -> mono -> m (mono, mono)
partitionM crit = ofoldlM dist mempty
  where
    dist :: (mono,mono) -> Element mono -> m (mono,mono)
    dist acc x = do
      okay <- crit x
      return $ if
        | okay ->      acc `mappend` (opoint x, mempty)
        | otherwise -> acc `mappend` (mempty, opoint x)

mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList

mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
mconcatForM = flip mconcatMapM

findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero

-------------
-- Conduit --
-------------

peekN :: (Integral n, Monad m) => n -> Consumer a m [a]
peekN n = do
  peeked <- catMaybes <$> replicateM (fromIntegral n) await
  mapM_ leftover peeked
  return peeked

-----------------
-- Alternative --
-----------------

choice :: forall f mono a. (Alternative f, MonoFoldable mono, Element mono ~ f a) => mono -> f a
choice = foldr (<|>) empty

--------------
-- Sessions --
--------------

data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
                | SessionNewStudyTerms
                | SessionBearer
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe SessionKey
instance Finite SessionKey

nullaryPathPiece ''SessionKey $ camelToPathPiece' 1

setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val

lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key

modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f

tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty

takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
-- ^ `lookupSessionJson` followed by `deleteSession`
takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)

--------------------
-- GET Parameters --
--------------------

-- Moved to Utils.Parameters

---------------------------------
-- Custom HTTP Headers --
---------------------------------

data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit | HeaderAlerts
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe CustomHeader
instance Finite CustomHeader
nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel)

lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result)
lookupCustomHeader ident = (=<<) (fromPathPiece <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)

hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool
hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)

addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) => CustomHeader -> payload -> m ()
addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload)

------------------
-- HTTP Headers --
------------------

data ContentDisposition = ContentInline | ContentAttachment
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ContentDisposition
instance Finite ContentDisposition
nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1

setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m ()
-- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader`
--
-- Takes care of correct formatting and encoding of non-ascii filenames
setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal
  where
    headerVal
      | Just fName <- mFName
      , Text.all isAscii fName
      , Text.all (not . flip elem ['"', '\\']) fName
      = [st|#{toPathPiece cd}; filename="#{fName}"|]
      | Just fName <- mFName
      = let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName
         in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|]
      | otherwise
      = toPathPiece cd

------------------
-- Cryptography --
------------------

data SecretBoxEncoding = SecretBoxShort | SecretBoxPretty
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe SecretBoxEncoding
instance Finite SecretBoxEncoding
instance Default SecretBoxEncoding where
  def = SecretBoxShort

encodedSecretBoxBlocksize :: Word8
-- | `encodedSecretBox'` tries to hide plaintext length by ensuring the message
--   length (before addition of HMAC and nonce) is always a multiple of
--   `encodedSecretBlocksize`.
--   Bigger blocksizes hide exact message length better but lead to longer messages
encodedSecretBoxBlocksize = maxBound


encodedSecretBox' :: ( ToJSON a, MonadIO m )
                  => SecretBox.Key
                  -> SecretBoxEncoding
                  -> a -> m Text
encodedSecretBox' sKey pretty val = liftIO $ do
  nonce <- SecretBox.newNonce
  let
    encrypt = SecretBox.secretbox sKey nonce
    base64 = decodeUtf8 . Base64.encode
    pad = PKCS7.padBytesN (fromIntegral encodedSecretBoxBlocksize)
    attachNonce = mappend $ Saltine.encode nonce
    chunk
      | SecretBoxPretty <- pretty = Text.intercalate "\n" . Text.chunksOf 76
      | otherwise                 = id

  return . chunk . base64 . attachNonce . encrypt . pad . toStrict $ Aeson.encode val

data EncodedSecretBoxException
  = EncodedSecretBoxInvalidBase64 !String
  | EncodedSecretBoxInvalidPadding
  | EncodedSecretBoxCiphertextTooShort
  | EncodedSecretBoxCouldNotDecodeNonce
  | EncodedSecretBoxCouldNotOpenSecretBox
  | EncodedSecretBoxCouldNotDecodePlaintext !String
  deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Exception EncodedSecretBoxException

encodedSecretBoxOpen' :: (FromJSON a, MonadError EncodedSecretBoxException m)
                      => SecretBox.Key
                      -> Text -> m a
encodedSecretBoxOpen' sKey chunked = do
  let unchunked = stripAll chunked
  decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked

  unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
    throwError EncodedSecretBoxCiphertextTooShort
  let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce decoded
  nonce <- maybe (throwError EncodedSecretBoxCouldNotDecodeNonce) return $ Saltine.decode nonceBS
  padded <- maybe (throwError EncodedSecretBoxCouldNotOpenSecretBox) return $ SecretBox.secretboxOpen sKey nonce encrypted

  unpadded <- maybe (throwError EncodedSecretBoxInvalidPadding) return $ PKCS7.unpadBytesN (fromIntegral encodedSecretBoxBlocksize) padded

  either (throwError . EncodedSecretBoxCouldNotDecodePlaintext) return $ Aeson.eitherDecodeStrict' unpadded

class Monad m => MonadSecretBox m where
  secretBoxKey :: m SecretBox.Key

instance MonadSecretBox ((->) SecretBox.Key) where
  secretBoxKey = id

instance Monad m => MonadSecretBox (ReaderT SecretBox.Key m) where
  secretBoxKey = ask

encodedSecretBox :: ( ToJSON a, MonadSecretBox m, MonadIO m )
                 => SecretBoxEncoding
                 -> a -> m Text
encodedSecretBox pretty val = do
  sKey <- secretBoxKey
  encodedSecretBox' sKey pretty val

encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
                     => Text -> m a
encodedSecretBoxOpen ciphertext = do
  sKey <- secretBoxKey
  encodedSecretBoxOpen' sKey ciphertext

-------------
-- Caching --
-------------

cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
cachedByBinary k = cachedBy (toStrict $ Binary.encode k)

cachedHere :: Q Exp
cachedHere = do
  loc <- location
  [e| cachedByBinary loc |]

cachedHereBinary :: Q Exp
cachedHereBinary = do
  loc <- location
  [e| \k -> cachedByBinary (loc, k) |]

hashToText :: Hashable a => a -> Text
hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash

setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m ()
setEtagHashable = setEtag . hashToText
setWeakEtagHashable = setEtag . hashToText

setLastModified :: (MonadHandler m, MonadLogger m) => UTCTime -> m ()
setLastModified lastModified = do
  rMethod <- requestMethod <$> waiRequest

  when (rMethod `elem` safeMethods) $ do
    ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since"
    $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince)
    when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince)
      notModified

  addHeader "Last-Modified" $ formatRFC1123 lastModified
  where
    precision :: NominalDiffTime
    precision = 1

    safeMethods = [ methodGet, methodHead, methodOptions ]

--------------
-- Lattices --
--------------

foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono
foldJoin = foldr (\/) bottom

foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
foldMeet = foldr (/\) top

-----------------
-- Constraints --
-----------------

type DictMaybe constr a = Maybe (Dict constr, a)

pattern DictJust :: constr => a -> DictMaybe constr a
pattern DictJust a = Just (Dict, a)
