{-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Main where

import Control.Applicative
import Control.Concurrent (forkIO, killThread)
import Control.Monad (msum)
import Data.Acid
import qualified Data.Text as Text
import Happstack.Server
import Happstack.Server.HSP.HTML
import Happstack.State (waitForTermination)
import qualified HSX.XMLGenerator as HSX
import HSP
import Survey.Types
import Survey.State
import Survey.Routing
import Survey.URL (SurveyURL)
import qualified Survey.URL as URL
import Web.Routes
import Web.Routes.Happstack
import Web.Routes.XMLGenT


-- TODO: test that jquery and jquery-ui are installed
main :: IO ()
main = 
    do acid <- openAcidState initialSurveyState
       tid  <- forkIO $ simpleHTTP nullConf $ do decodeBody (defaultBodyPolicy "/tmp/" 0 1024 1024)
                                                 msum [ dir "reset" $ do survey <- update' acid NewSurvey
                                                                         mapM (\(q, c) -> update' acid (NewItemToSurvey (surveyId survey) q c)) defaultSurveys
                                                                         seeOther "/" (toResponse ())
                                                      , dir "jquery"    $ serveDirectory DisableBrowsing [] "/usr/share/javascript/jquery/"
                                                      , dir "jquery-ui" $ serveDirectory DisableBrowsing [] "/usr/share/javascript/jquery-ui/"
                                                      , implSite "http://localhost:8000/" "web/" (site acid)
                                                      ]
       putStrLn "started.."
       waitForTermination
       killThread tid
       closeAcidState acid

template :: 
    forall headers body. ( EmbedAsChild (RouteT SurveyURL (ServerPartT IO)) headers
                         , EmbedAsChild (RouteT SurveyURL (ServerPartT IO)) body
                         ) => 
   String -> headers -> body -> RouteT SurveyURL (ServerPartT IO) Response
template t h b = 
    do hXml <- unXMLGenT $ asChild h
       eXml <- unXMLGenT $ asChild extraHeaders
       xml <- defaultTemplate t (hXml ++ eXml) b
       return $ toResponse xml
    where
      extraHeaders :: [XMLGenT (RouteT SurveyURL (ServerPartT IO)) XML]
      extraHeaders = 
          [ <script type="text/javascript" src="/jquery/jquery.js" ></script>
          , <script type="text/javascript" src="/jquery-ui/jquery-ui.js" ></script>
          ]




site :: (AcidState SurveyState) -> Site SurveyURL (ServerPartT IO Response)
site acid =
    Site { handleSite        = handleSurveyURL acid
         , formatPathSegments  = \u -> (toPathSegments u, [])
         , parsePathSegments = parseSegments fromPathSegments
         }

handleSurveyURL :: (AcidState SurveyState) 
       -> (SurveyURL -> [(String, String)] -> String)
       -> SurveyURL
       -> ServerPartT IO Response
handleSurveyURL acid showFn url =
    unRouteT (route template acid url) showFn

defaultSurveys :: [(Question, Choices)]
defaultSurveys =
    [ (QuestionText (Text.pack "You a rar?")
      , ChoiceTrueFalse
      )
    ]