{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Web where
import Control.Applicative   (Applicative(pure, (<*>)), (<$>), (<|>))
import Control.Monad         (msum, mzero)
import Control.Monad.State   (StateT)
import ConfigT               (ConfigT, askConfig, localConfig)
import qualified Data.Text   as Text
import Happstack.Crypto.SHA1 (sha1)
import Happstack.Server      (Response, ServerPartT, decodeBody, defaultBodyPolicy, getDataFn, look, lookCookieValue)
import Pages.Board           (boardPage)
import Pages.Image           (imagePage)
import Pages.Reply           (replyPage)
import Pages.Login           (loginPage)
import Pages.Moderator       (moderatorPage)
import Pages.Admin           (adminPage)
import Server                (Config(appSecret, role), Server, toServerPartT)
import Types                 (Role(..), BoardName(..))
import URL
import Web.Routes (RouteT, Site, showURL, setDefault, withRouteT, mkSitePI, runRouteT)
import Web.Routes.Happstack (implSite)
import Web.Routes.XMLGenT ()

web :: WebURL -> Server Response
web url =
    case url of
      (W_Board boardName page)  -> boardPage url boardName page
      (W_Reply threadId)        -> replyPage url threadId
      (W_Image mediumId size _) -> imagePage mediumId size
      (W_Login dest)            -> loginPage url dest
      W_Moderator               -> moderatorPage
      W_Admin                   -> adminPage

addAuth :: String -> Maybe String -> Role -> RouteT url m a -> RouteT url m a
addAuth _          Nothing          _    = id
addAuth appSecret (Just userSecret) role =
    withRouteT (\f -> \url params -> -- authURL appSecret userSecret f url
                    let link = Text.unpack (f url params)
                        authKey = sha1 (appSecret ++ userSecret ++ show role ++ link)
                    in Text.pack $ link ++ "?auth="++authKey
             )


authWeb :: WebURL -> Server Response
authWeb url@(W_Login {}) = web url
authWeb url =
    do config <- askConfig
       r <- getDataFn $ (,,) <$> ((Just <$> look "auth") <|> pure Nothing) <*> lookCookieValue "secret" <*> lookCookieValue "role"
       case r of
         (Left _errs) -> web (authRewrite User url)
         (Right (mAuth, userSecret, role')) -> 
             let role = read role' in
             case mAuth of
               Nothing -> web (authRewrite User url)
               (Just auth) ->
                   do link <- Text.unpack <$> showURL url
                      let auth' = sha1 ((appSecret config) ++ userSecret ++ show role ++ link)
                      if auth == auth'
                         then addAuth (appSecret config) (Just userSecret) role $ 
                              localConfig (\c -> c { role = role}) (web (authRewrite role url))
                         else web (W_Login url)

authRewrite role W_Admin 
    | role /= Admin = W_Login W_Admin
authRewrite role W_Moderator 
    | (role /= Admin) && (role /= Moderator) = W_Login W_Moderator
authRewrite _ url         = url

webSpec :: Site WebURL (ServerPartT (StateT Integer (ConfigT Config IO)) Response)
webSpec =
    setDefault (W_Board (BoardName $ Text.pack "codez") Nothing) $
               mkSitePI (runRouteT authWeb)

webImpl :: Config -> ServerPartT IO Response
webImpl config = 
    do decodeBody (defaultBodyPolicy "/tmp/" (2 * 1000000) 10000 10000)
       msum [ mzero
            , toServerPartT config $ implSite "/" "web/" webSpec
            ]