{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
-- | The basic typeclass for a Yesod application.
module Yesod.Yesod
    ( -- * Type classes
      Yesod (..)
    , YesodSite (..)
      -- * Convenience functions
    , applyLayout
    , applyLayoutJson
      -- * Defaults
    , defaultErrorHandler
    ) where

import Yesod.Content
import Yesod.Request
import Yesod.Hamlet
import Yesod.Handler
import Data.Convertible.Text
import Control.Arrow ((***))
import Network.Wai.Middleware.ClientSession
import qualified Network.Wai as W
import Yesod.Json
import Yesod.Internal

import Web.Routes.Quasi (QuasiSite (..), Routes)

-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class YesodSite y where
    getSite :: QuasiSite YesodApp y y

-- | Define settings for a Yesod applications. The only required setting is
-- 'approot'; other than that, there are intelligent defaults.
class YesodSite a => Yesod a where
    -- | An absolute URL to the root of the application. Do not include
    -- trailing slash.
    --
    -- If you want to be lazy, you can supply an empty string under the
    -- following conditions:
    --
    -- * Your application is served from the root of the domain.
    --
    -- * You do not use any features that require absolute URLs, such as Atom
    -- feeds and XML sitemaps.
    approot :: a -> String

    -- | The encryption key to be used for encrypting client sessions.
    encryptKey :: a -> IO Word256
    encryptKey _ = getKey defaultKeyFile

    -- | Number of minutes before a client session times out. Defaults to
    -- 120 (2 hours).
    clientSessionDuration :: a -> Int
    clientSessionDuration = const 120

    -- | Output error response pages.
    errorHandler :: Yesod y
                 => a
                 -> ErrorResponse
                 -> Handler y ChooseRep
    errorHandler _ = defaultErrorHandler

    -- | Applies some form of layout to the contents of a page.
    defaultLayout :: PageContent (Routes a) -> GHandler sub a Content
    defaultLayout p = hamletToContent $ [$hamlet|
!!!
%html
    %head
        %title $p.pageTitle$
        ^p.pageHead^
    %body
        ^p.pageBody^
|] ()

    -- | Gets called at the beginning of each request. Useful for logging.
    onRequest :: a -> Request -> IO ()
    onRequest _ _ = return ()

    -- | Override the rendering function for a particular URL. One use case for
    -- this is to offload static hosting to a different domain name to avoid
    -- sending cookies.
    urlRenderOverride :: a -> Routes a -> Maybe String
    urlRenderOverride _ _ = Nothing

-- | Apply the default layout ('defaultLayout') to the given title and body.
applyLayout :: Yesod master
            => String -- ^ title
            -> Hamlet (Routes master) IO () -- ^ body
            -> GHandler sub master RepHtml
applyLayout t b =
    RepHtml `fmap` defaultLayout PageContent
                { pageTitle = cs t
                , pageHead = return ()
                , pageBody = b
                }

-- | Provide both an HTML and JSON representation for a piece of data, using
-- the default layout for the HTML output ('defaultLayout').
applyLayoutJson :: Yesod master
                => String -- ^ title
                -> x
                -> (x -> Hamlet (Routes master) IO ())
                -> (x -> Json (Routes master) ())
                -> GHandler sub master RepHtmlJson
applyLayoutJson t x toH toJ = do
    html <- defaultLayout PageContent
                { pageTitle = cs t
                , pageHead = return ()
                , pageBody = toH x
                }
    json <- jsonToContent $ toJ x
    return $ RepHtmlJson html json

applyLayout' :: Yesod master
             => String -- ^ title
             -> Hamlet (Routes master) IO () -- ^ body
             -> GHandler sub master ChooseRep
applyLayout' s = fmap chooseRep . applyLayout s

-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod y
                    => ErrorResponse
                    -> Handler y ChooseRep
defaultErrorHandler NotFound = do
    r <- waiRequest
    applyLayout' "Not Found" $ [$hamlet|
%h1 Not Found
%p $.helper$
|] r
  where
    helper = Unencoded . cs . W.pathInfo
defaultErrorHandler PermissionDenied =
    applyLayout' "Permission Denied" $ [$hamlet|
%h1 Permission denied|] ()
defaultErrorHandler (InvalidArgs ia) =
    applyLayout' "Invalid Arguments" $ [$hamlet|
%h1 Invalid Arguments
%dl
    $forall ias pair
        %dt $pair.fst$
        %dd $pair.snd$
|] ()
  where
    ias _ = map (cs *** cs) ia
defaultErrorHandler (InternalError e) =
    applyLayout' "Internal Server Error" $ [$hamlet|
%h1 Internal Server Error
%p $e.cs$
|] ()
defaultErrorHandler (BadMethod m) =
    applyLayout' "Bad Method" $ [$hamlet|
%h1 Method Not Supported
%p Method "$m.cs$" not supported
|] ()