{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult

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 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)
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 (Centi)
import Data.Ratio ((%))

import qualified Data.Binary as Binary

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

isVisible :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is visible or invisible
isVisible True  = [shamlet|<i .fas .fa-eye>|]
isVisible False = [shamlet|<i .fas .fa-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  = [shamlet|<i .fas .fa-comment-alt>|]
hasComment False = [shamlet|<i .fas .fa-comment-slash>|] -- comment-alt-slash is not available for free

hasTickmark :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is okay
hasTickmark True  = [shamlet|<i .fas .fa-check>|]
hasTickmark False = mempty

isBad :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is bad
isBad True  = [shamlet|<i .fas .fa-bolt>|] -- or times?!
isBad False = mempty

isNew :: Bool -> Markup
isNew True  = [shamlet|<i .fas .fa-seedling>|] -- was exclamation
isNew False = mempty


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

-- DEPRECATED: use hasTickmark instead;
-- maybe reinstate if needed for @bewertung.txt@ files

-- tickmark :: IsString a => a
-- tickmark = fromString "✔"

text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types

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

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

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




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


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

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



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

-- MOVED TO UTILS.DB due to cyclic dependency
--  Swap 'Nothing' for 'Just' and vice versa
-- flipMaybe :: b -> Maybe b -> 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

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

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

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

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

data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit
  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 . decodeUtf8) <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident)

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

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

cachedHere :: Q Exp
cachedHere = do
  loc <- location
  [e| cachedBy (toStrict $ Binary.encode loc) |]
