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)