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)