yesod/Yesod/Handler.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove
{-# LANGUAGE FlexibleContexts #-}
---------------------------------------------------------
--
-- 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
    , runHandler
    , liftIO
    --, ToHandler (..)
      -- * Special handlers
    , redirect
    , notFound
      -- * Setting headers
    , addCookie
    , deleteCookie
    , header
    ) where

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

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

import Control.Monad.Writer
import Control.Monad.Attempt

--import Data.Typeable

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

instance Functor Handler where
    fmap = liftM
instance Applicative Handler where
    pure = return
    (<*>) = ap
instance Monad Handler 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 where
    liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
instance Exception e => Failure e Handler where
    failure e = Handler $ \_ -> return ([], HCError e)
instance MonadRequestReader Handler where
    askRawRequest = Handler $ \rr -> return ([], HCContent rr)
    invalidParam _pt _pn _pe = error "invalidParam"
    authRequired = error "authRequired"

-- FIXME this is a stupid signature
runHandler :: HasReps a
           => Handler a
           -> RawRequest
           -> [ContentType]
           -> IO (Either (ErrorResult, [Header]) Response)
runHandler (Handler handler) rr cts = do
    (headers, contents) <- handler rr
    case contents of
        HCError e -> return $ Left (InternalError $ show e, headers)
        HCSpecial e -> return $ Left (e, headers)
        HCContent a ->
            let (ct, c) = chooseRep a cts
             in return $ Right $ Response 200 headers ct c
{- FIXME
class ToHandler a where
    toHandler :: a -> Handler

instance (Request r, ToHandler h) => ToHandler (r -> h) where
    toHandler f = parseRequest >>= toHandler . f

instance ToHandler Handler where
    toHandler = id

instance HasReps r HandlerIO => ToHandler (HandlerIO r) where
    toHandler = fmap reps

runHandler :: Handler
           -> RawRequest
           -> [ContentType]
           -> IO (Either (ErrorResult, [Header]) Response)
runHandler h rr cts = do
    --let (ares, _FIXMEheaders) =
    let x :: IO (Attempt (ContentType, Content), [Header])
        x =
         runWriterT $ runAttemptT $ runReaderT (joinHandler cts h) rr
        y :: IO (Attempt (Attempt (ContentType, Content), [Header]))
        y = takeAllExceptions x
    z <- y
    let z' :: Attempt (Attempt (ContentType, Content), [Header])
        z' = z
        a :: (Attempt (ContentType, Content), [Header])
        a = attempt (\e -> (failure e, [])) id z'
        (b, headers) = a
    return $ attempt (\e -> (Left (toErrorResult e, headers))) (Right . toResponse headers) b
    where
        takeAllExceptions :: MonadFailure SomeException m => IO x -> IO (m x)
        takeAllExceptions ioa =
            Control.Exception.catch (return `fmap` ioa) (\e -> return $ failure (e :: SomeException))
        toErrorResult :: Exception e => e -> ErrorResult
        toErrorResult e =
            case cast e of
                Just x -> x
                Nothing -> InternalError $ show e
        toResponse :: [Header] -> (ContentType, Content) -> Response
        toResponse hs (ct, c) = Response 200 hs ct c

joinHandler :: Monad m
            => [ContentType]
            -> m [RepT m]
            -> m (ContentType, Content)
joinHandler cts rs = do
    rs' <- rs
    let (ct, c) = chooseRep cts rs'
    c' <- c
    return (ct, c')
-}

{-
runHandler :: (ErrorResult -> Reps)
            -> (ContentType -> B.ByteString -> IO B.ByteString)
            -> [ContentType]
            -> Handler
            -> RawRequest
            -> IO Hack.Response
runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
    let extraHeaders =
            case x of
                Left r -> getHeaders r
                Right _ -> []
    headers <- mapM toPair (headers' ++ extraHeaders)
    let outReps = either (reps . eh) reps x
    let statusCode =
            case x of
                Left r -> getStatus r
                Right _ -> 200
    (ctype, selectedRep) <- chooseRep outReps ctypesAll
    let languages = [] -- FIXME
    finalRep <- wrapper ctype $ selectedRep languages
    let headers'' = ("Content-Type", ctype) : headers
    return $! Hack.Response statusCode headers'' finalRep
-}

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

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

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

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

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

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

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