module Utils
  ( module Utils
  ) where

import ClassyPrelude.Yesod hiding (foldlM)

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

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

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import 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.Message as Utils
import Utils.Lang as Utils
import Utils.Parameters as Utils

import Text.Blaze (Markup, ToMarkup)

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

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 qualified Database.Esqueleto as E (Value, unValue)

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)

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



-----------
-- 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)
    |]



-- | A @Widget@ for any site; no language interpolation, etc.
type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m)
  => WidgetT site m ()


-----------
-- Icons --
-----------

-- Create an icon from font-awesome without additional space
fontAwesomeIcon :: Text -> Markup
fontAwesomeIcon iconName =
  [shamlet|$newline never
            <i .fas .fa-#{iconName}>|]

-- We collect all used icons here for an overview.
-- For consistency, some conditional icons are also provided, e.g. `isIvisble`

iconQuestion :: Markup
iconQuestion = fontAwesomeIcon "question-circle"

iconHint :: Markup
iconHint = fontAwesomeIcon "life-ring"

iconSolution :: Markup
iconSolution =fontAwesomeIcon "exclamation-circle"

iconMarking :: Markup
iconMarking = fontAwesomeIcon "check-circle"

fileDownload :: Markup
fileDownload = fontAwesomeIcon "file-download"

zipDownload :: Markup
zipDownload = fontAwesomeIcon "file-archive"

-- Conditional icons

isVisible :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is visible or invisible
isVisible True  = fontAwesomeIcon "eye"
isVisible False = fontAwesomeIcon "eye-slash"
--
-- For documentation on how to avoid these unneccessary functions
-- we implement them here just once for the first icon:
--
isVisibleWidget :: Bool -> WidgetSiteless
-- ^ Widget having an icon that denotes that something™ is visible or invisible
isVisibleWidget = toWidget . isVisible

maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless
-- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible
maybeIsVisibleWidget = toWidget . foldMap isVisible

-- Other _frequently_ used icons:
hasComment :: Bool -> Markup
-- ^ Display an icon that denotes that something™ has a comment or not
hasComment True  = fontAwesomeIcon "comment-alt"
hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free

hasTickmark :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is okay
hasTickmark True  = fontAwesomeIcon "check"
hasTickmark False = mempty

isBad :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is bad
isBad True  = fontAwesomeIcon "bolt" -- or times?!
isBad False = mempty

isNew :: Bool -> Markup
isNew True  = fontAwesomeIcon "seedling" -- was exclamation
isNew False = mempty

boolSymbol :: Bool -> Markup
boolSymbol True  = fontAwesomeIcon "check"
boolSymbol False = fontAwesomeIcon "times"



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

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

-- | 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}|]

display2widget ::  (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a)
               => a -> WidgetT site m ()
display2widget = text2widget . display

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


-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
class DisplayAble a where
  display :: a -> Text
  -- Default definitions for types belonging to Show (allows empty instance declarations)
  default display :: Show a => a -> Text
  display = pack . show

instance DisplayAble Text where
  display = id

-- instance DisplayAble String where
--   display = pack

instance DisplayAble Int
instance DisplayAble Int64
instance DisplayAble Integer

instance DisplayAble Rational where
  display r = showFFloat (Just 2) (rat2float r) ""
      & pack
      & dropWhileEnd ('0'==)
      & dropWhileEnd ('.'==)
    where
      rat2float :: Rational -> Double
      rat2float = fromRational

instance DisplayAble a => DisplayAble (Maybe a) where
  display Nothing  = ""
  display (Just x) = display x

instance DisplayAble a => DisplayAble (E.Value a) where
  display = display . E.unValue

instance DisplayAble a => DisplayAble (CI a) where
  display = display . CI.original

instance HasResolution a => DisplayAble (Fixed a) where
  display = pack . showFixed True

instance DisplayAble a => DisplayAble (Sum a) where
  display = display . getSum

{- We do not want DisplayAble for every Show-Class:
   We want to explicitly verify that the resulting text can be displayed to the User!
   For example: UTCTime values were shown without proper format rendering!
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
  display = pack . show
-}

textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> pack (show rx) <> "%"
 where
   rx :: Centi
   rx = realToFrac (x * 100)
   lz = if rx < 10.0 then "0" else ""

textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole

-- | 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



-------------
-- 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

------------
-- 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


---------------
-- 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


maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
maybeAdd (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y  = y
maybeAdd x Nothing  = x

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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)

-- 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 = Text.filter (not . isSpace) chunked
  decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked

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

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

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

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

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

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

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

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

-------------
-- 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