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

module Web.Horse.Hack where
import Web.Horse.Forms
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.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 ()) -> 
             Automaton (Kleisli IO) Env Response -> IO ()
runHorse1 runner f = do
  mv <- newMVar M.empty
  runner (runWeb mv f)

runWeb
  :: MVar (M.Map String (MVar (Automaton (Kleisli IO) Env Response)))
    -> Automaton (Kleisli IO) Env Response
    -> Env
    -> IO Response
runWeb mv f0 req = do
   (mv_sess, cookie) <- getSessionMVar mv f0 req
   sess <- takeMVar mv_sess                          
   (resp,sess') <- runKleisli (auto sess) req 
   putMVar mv_sess sess'
   return (resp{ headers= cookie ++ headers resp })  

getSessionMVar
 :: MVar (M.Map String (MVar a))
    -> a
    -> Env
    -> IO (MVar a, [(String, String)])
getSessionMVar mv f0 req = do
  let sess = lookup sessionName (cookies req)
  mp <- takeMVar mv
  case join $ M.lookup <$> sess <*> (Just mp) of
    Just val -> putMVar mv mp >> return (val,[])
    Nothing -> do
      (newSess :: Int) <- abs <$> randomIO
      var <- newMVar f0
      putMVar mv (M.insert (show newSess) var mp)
      return (var, [("Set-Cookie", 
                     sessionName ++ "=" ++ show newSess ++ "; path=/")]) 

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)