{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PackageImports #-}
---------------------------------------------------------
--
-- Module        : Yesod.Handler
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : unstable
-- Portability   : portable
--
-- Define Handler stuff.
--
---------------------------------------------------------
module Yesod.Handler
    ( -- * Handler monad
      Handler
    , getYesod
    , runHandler
    , liftIO
    --, ToHandler (..)
      -- * Special handlers
    , redirect
    , notFound
    , permissionDenied
    , invalidArgs
      -- * Setting headers
    , addCookie
    , deleteCookie
    , header
    ) where

import Yesod.Request
import Yesod.Response
import Yesod.Rep

import Control.Exception hiding (Handler)
import Control.Applicative

import "transformers" Control.Monad.Trans
import Control.Monad.Attempt
import Control.Monad (liftM, ap)

import System.IO
import Data.Object.Html

--import Data.Typeable

------ Handler monad
newtype Handler yesod a = Handler {
    unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a)
}
data HandlerContents a =
    forall e. Exception e => HCError e
    | HCSpecial ErrorResult
    | HCContent a

instance Functor (Handler yesod) where
    fmap = liftM
instance Applicative (Handler yesod) where
    pure = return
    (<*>) = ap
instance Monad (Handler yesod) where
    fail = failureString -- We want to catch all exceptions anyway
    return x = Handler $ \_ -> return ([], HCContent x)
    (Handler handler) >>= f = Handler $ \rr -> do
        (headers, c) <- handler rr
        (headers', c') <-
            case c of
                (HCError e) -> return ([], HCError e)
                (HCSpecial e) -> return ([], HCSpecial e)
                (HCContent a) -> unHandler (f a) rr
        return (headers ++ headers', c')
instance MonadIO (Handler yesod) where
    liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
instance Exception e => Failure e (Handler yesod) where
    failure e = Handler $ \_ -> return ([], HCError e)
instance MonadRequestReader (Handler yesod) where
    askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr)
    invalidParam _pt pn pe = invalidArgs [(pn, pe)]
    authRequired = permissionDenied

getYesod :: Handler yesod yesod
getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod)

runHandler :: Handler yesod RepChooser
           -> (ErrorResult -> Handler yesod RepChooser)
           -> RawRequest
           -> yesod
           -> [ContentType]
           -> IO Response
runHandler (Handler handler) eh rr y cts = do
    (headers, contents) <- Control.Exception.catch
        (handler (rr, y))
        (\e -> return ([], HCError (e :: Control.Exception.SomeException)))
    let contents' =
            case contents of
                HCError e -> Left $ InternalError $ show e
                HCSpecial e -> Left e
                HCContent a -> Right a
    case contents' of
        Left e -> do
            Response _ hs ct c <- runHandler (eh e) specialEh rr y cts
            let hs' = headers ++ hs ++ getHeaders e
            return $ Response (getStatus e) hs' ct c
        Right a -> do
            (ct, c) <- a cts
            return $ Response 200 headers ct c

specialEh :: ErrorResult -> Handler yesod RepChooser
specialEh er = do
    liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
    return $ chooseRep $ toHtmlObject "Internal server error"

------ Special handlers
errorResult :: ErrorResult -> Handler yesod a
errorResult er = Handler $ \_ -> return ([], HCSpecial er)

-- | Redirect to the given URL.
redirect :: String -> Handler yesod a
redirect = errorResult . Redirect

-- | Return a 404 not found page. Also denotes no handler available.
notFound :: Handler yesod a
notFound = errorResult NotFound

permissionDenied :: Handler yesod a
permissionDenied = errorResult PermissionDenied

invalidArgs :: [(ParamName, ParamValue)] -> Handler yesod a
invalidArgs = errorResult . InvalidArgs

------- Headers
-- | Set the cookie on the client.
addCookie :: Int -- ^ minutes to timeout
          -> String -- ^ key
          -> String -- ^ value
          -> Handler yesod ()
addCookie a b = addHeader . AddCookie a b

-- | Unset the cookie on the client.
deleteCookie :: String -> Handler yesod ()
deleteCookie = addHeader . DeleteCookie

-- | Set an arbitrary header on the client.
header :: String -> String -> Handler yesod ()
header a = addHeader . Header a

addHeader :: Header -> Handler yesod ()
addHeader h = Handler $ \_ -> return ([h], HCContent ())