module Hackage (resource) where

import Control.Monad.State                ( liftIO )
import Data.Char                          ( toLower )
import Data.List                          ( intersperse )
import Control.Exception
import Prelude hiding (catch)

import API                                ( HapPlugin (..) )
import HapActions         --                ( hapPutStrLn, hapCatch )
import Apache
import HapMonad                           ( Hap )

import HSP.Data hiding (catch)
import HSP.Data.Application
import HSP.Data.PCDATA
import HSP.HTML

import Database.HaskellDB                 ( Database )
import Database.HaskellDB.DriverAPI       ( DriverInterface (..) )
import Database.HaskellDB.HSQL.PostgreSQL ( driver )

import HackageState                       ( getArg, mkHackageState, setHeaders, hArgs )
import Pages.View                         ( view )
import Pages.Home                         ( home )
import Pages.Info                         ( info )
import Pages.Search                       ( search )
import Pages.Error                        ( handleError )
import XmlRpc                             ( handleXmlRpcRequest )

import Config                             ( databaseName, databaseUser, databasePassword )

resource :: Hap HapPlugin
resource = do (db,conn) <- liftIO $ connect driver ["", databaseName, databaseUser, databasePassword]
              return (HapPlugin (Just (execHSP db loadCorrectPage)) (Just (liftIO $ disconnect driver conn)))

execHSP :: Database -> HSP XML -> Hap ()
execHSP db hsp
    = do hapLogError Notice "mkHackageState"
         state <- mkHackageState db
         let hspEnv = (toApplication state,undefined,undefined,undefined)
         hapLogError Notice $ "action: " ++ show (lookup "action" (hArgs state))
         xml <- (case lookup "action" (hArgs state) of -- Handle the special case of an XML-RPC request
                   Just xmlrpc | map toLower xmlrpc == "xmlrpc"
                      -> do input <- hapGetPostBody
                            hapLogError Notice $ "input length: " ++ show (length input)
                            liftIO (runHSP (handleXmlRpcRequest input) hspEnv)
                   _  -> liftIO (fmap renderXML (runHSP hsp hspEnv)))
                `hapCatch` \e -> liftIO (fmap renderXML (runHSP (handleError e) hspEnv))
         setHeaders state
         hapLogError Notice xml
         hapPutStrLn xml
         return ()

loadCorrectPage :: HSP XML
loadCorrectPage = do action <- getArg "action"
                     case map toLower action of
                       "view"   -> view
                       "home"   -> home
                       "info"   -> info
                       "search" -> search
                       _        -> view