{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, 
   NoMonomorphismRestriction #-}

module Web.Horse.Hack where
import Web.Horse.Forms
import Data.Time.Clock
import Data.Maybe
import Data.List
import Data.Function
import Text.Hamlet
import Web.Horse.Forms.Types
import Hack ( Env (..), Response (..) )
import Hack.Contrib.Request (cookies, params, inputs, path)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LB
import Control.Concurrent.MVar
import System.Random (randomIO)
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.List.Split (splitOn)
import Control.Arrow.Transformer.Automaton
import Control.Arrow.Transformer.Automaton.Maybe
import Control.Arrow.Transformer.Automaton.Monad
import Control.Arrow.Transformer.Reader
import Hack.Handler.EvHTTP (run)
import Control.Arrow.Transformer.LabeledArrow
import qualified Data.Map as M

type Url = [String]

runHorse f = runHorse1 run (simpleReqResp g)
    where
      g = runReader $ runLabeledArrow $ f 
          >>> arr renderHtml

runHorse1 :: ((Env -> IO Response) -> IO ()) -> 
             MaybeAutomaton (Kleisli IO) Env Response -> IO ()
runHorse1 runner f = do
  mv <- newMVar []
  runner (runWeb mv f)

sessionTarget = 150

runWeb
  :: MVar [(String, MVar (Automaton (Kleisli IO) Env Response))]
    -> MaybeAutomaton (Kleisli IO) Env Response
    -> Env
    -> IO Response
runWeb mv f0 req = do
   compact mv
   mv_sess <- getSessionMVar mv req
   case mv_sess of
     Just mv_sess -> modifyMVar mv_sess $ \sess -> do
                       (x,y) <- (runKleisli (auto sess) req)
                       return (y,x)
     Nothing -> do
       (resp,f') <- runKleisli (mAut f0) req
       case f' of
         Nothing -> return resp
         Just f' -> do
                     (newSess :: Int) <- abs <$> randomIO
                     var <- newMVar f'
                     modifyMVar_ mv $ return . ((show newSess,var) :)
                     let cookie = ("Set-Cookie", 
                           sessionName ++ "=" ++ show newSess ++ "; path=/")
                     print ("Set cookie " ++ show newSess)
                     return (resp{ headers=(cookie:headers resp) })
                     

compact mv = modifyMVar_ mv $ \lst ->
  case length lst > (2 * sessionTarget) of
    True -> return (take sessionTarget $ nubBy ((==) `on` fst) lst)
    False -> return lst

getSessionMVar
 :: MVar [(String, MVar (Automaton (Kleisli IO) Env Response))]
    -> Env
    -> IO (Maybe (MVar (Automaton (Kleisli IO) Env Response)))
getSessionMVar mv req = modifyMVar mv $ \lst -> do
  case lookup sessionName (cookies req) of
    Just sess -> case lookup sess lst of
                   Just val -> return ((sess,val):lst, Just val)
                   Nothing -> return (lst, Nothing)
    Nothing -> return (lst, Nothing)

sessionName :: [Char]
sessionName = "HaskellOnAHorse"



simpleReqResp :: (Arrow a) => a (Url, FormIn) ByteString -> a Env Response
simpleReqResp f = proc req -> do
  let u = filter (/= "") $ splitOn "/" (path req)
      fi = FormIn $ params req ++ inputs req
  fo <- f -< (u,fi)
  returnA -< asResponse fo

asResponse :: ByteString -> Response
asResponse out = Response { status=200, headers=[typ,len], body = out }
    where
      typ = ("Content-Type", "text/html")
      len = ("Content-Length", show $ LB.length out)