{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
---------------------------------------------------------
--
-- Module        : Yesod.Application
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Stable
-- Portability   : portable
--
-- Defining the application.
--
---------------------------------------------------------
module Yesod.Application
    (
      toHackApp
    , RestfulApp (..)
    ) where

import Web.Encodings
import Data.Enumerable
import Control.Monad (when)
import Data.Object.Html

import qualified Hack
import Hack.Middleware.CleanPath
import Hack.Middleware.ClientSession
import Hack.Middleware.Gzip
import Hack.Middleware.Jsonp
import Hack.Middleware.MethodOverride

import Yesod.Request
import Yesod.Response
import Yesod.Utils
import Yesod.Handler
import Yesod.Definitions
import Yesod.Constants
import Yesod.Resource
import Yesod.Rep

import Data.Convertible.Text
import Control.Arrow ((***))

-- | A data type that can be turned into a Hack application.
class ResourceName a => RestfulApp a where
    -- | The encryption key to be used for encrypting client sessions.
    encryptKey :: a -> IO Word256
    encryptKey _ = getKey defaultKeyFile

    -- | All of the middlewares to install.
    hackMiddleware :: a -> [Hack.Middleware]
    hackMiddleware _ =
                [ gzip
                , cleanPath
                , jsonp
                , methodOverride
                ]

    -- | Output error response pages.
    errorHandler :: a -> RawRequest -> ErrorResult -> HtmlObject -- FIXME better type sig?

    -- | Whether or not we should check for overlapping resource names.
    checkOverlaps :: a -> Bool
    checkOverlaps = const True

-- | Given a sample resource name (purely for typing reasons), generating
-- a Hack application.
toHackApp :: RestfulApp resourceName
          => resourceName
          -> IO Hack.Application
toHackApp a = do
    when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time?
    key <- encryptKey a
    let app' = toHackApplication a getHandler
        clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way...
        app = foldr ($) app' $ hackMiddleware a ++ [clientsession']
    return app

findResourceNames :: ResourceName a
                  => Resource
                  -> [(a, [(String, String)])]
findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate

checkPatternHelper :: ResourceName a
                   => Resource
                   -> a
                   -> Maybe (a, [(String, String)])
checkPatternHelper r rn =
    case checkPattern (fromString $ resourcePattern rn) r of
        Nothing -> Nothing
        Just pairs -> Just (rn, pairs)

takeJusts :: [Maybe a] -> [a]
takeJusts [] = []
takeJusts (Nothing:rest) = takeJusts rest
takeJusts (Just x:rest) = x : takeJusts rest

toHackApplication :: RestfulApp resourceName
                  => resourceName
                  -> (resourceName -> Verb -> Handler [(ContentType, Content)])
                  -> Hack.Application
toHackApplication sampleRN hm env = do
    -- The following is safe since we run cleanPath as middleware
    let (Right resource) = splitPath $ Hack.pathInfo env
    let (handler, urlParams') =
          case findResourceNames resource of
            [] -> (notFound, [])
            ((rn, urlParams''):_) ->
                let verb = toVerb $ Hack.requestMethod env
                 in (hm rn verb, urlParams'')
    let rr = envToRawRequest urlParams' env
    let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
        ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept
    r <-
        runHandler handler rr ctypes' >>=
        either (applyErrorHandler sampleRN rr ctypes') return
    responseToHackResponse (rawLanguages rr) r

applyErrorHandler :: (RestfulApp ra, Monad m)
                  => ra
                  -> RawRequest
                  -> [ContentType]
                  -> (ErrorResult, [Header])
                  -> m Response
applyErrorHandler ra rr cts (er, headers) = do
    let (ct, c) = chooseRep (errorHandler ra rr er) cts
    return $ Response
                (getStatus er)
                (getHeaders er ++ headers)
                ct
                c

responseToHackResponse :: [String] -- ^ language list
                       -> Response -> IO Hack.Response
responseToHackResponse _FIXMEls (Response sc hs ct c) = do
    hs' <- mapM toPair hs
    let hs'' = ("Content-Type", show ct) : hs'
    let asLBS = unContent c
    return $ Hack.Response sc hs'' asLBS

envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
envToRawRequest urlParams' env =
    let (Right rawPieces) = splitPath $ Hack.pathInfo env
        gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
        clength = tryLookup "0" "Content-Length" $ Hack.http env
        ctype = tryLookup "" "Content-Type" $ Hack.http env
        (posts, files) = map (convertSuccess *** convertSuccess) ***
                         map (convertSuccess *** convertFileInfo)
                       $ parsePost ctype clength
                       $ Hack.hackInput env
        rawCookie = tryLookup "" "Cookie" $ Hack.http env
        cookies' = decodeCookies rawCookie :: [(String, String)]
        langs = ["en"] -- FIXME
     in RawRequest rawPieces urlParams' gets' posts cookies' files env langs

convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c
convertFileInfo (FileInfo a b c) =
    FileInfo (convertSuccess a) (convertSuccess b) c