module Web.Horse.Server where
import Web.Horse.Forms
import Web.Cookie (parseCookiesText)
import Data.Time.Clock
import Data.Maybe
import Data.Monoid
import Data.List
import Data.CaseInsensitive (mk, original)
import Control.Monad.IO.Class
import Data.Function
import Network.Wai.Handler.Warp
import Network.Wai
import Network.HTTP.Types
import Network.Wai.Parse
import Web.Horse.Forms.Types
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.UTF8 (fromString)
import qualified Data.Text as T
import qualified Data.ByteString as SB
import qualified Data.ByteString.Char8 as SBC
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LBC
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 Control.Arrow.Transformer.LabeledArrow
import qualified Data.Map as M
type Url = [String]
runHorse f = runHorse1 g
where
g = runReader $ runLabeledArrow $ f
runHorse1 :: MaybeAutomaton (Kleisli IO) (Url, FormIn) String -> IO Application
runHorse1 f = do
mv <- newMVar []
return $ runWeb mv f
sessionTarget = 150
runWeb
:: MVar [(String, MVar (Automaton (Kleisli IO) (Url, FormIn) String))]
-> MaybeAutomaton (Kleisli IO) (Url, FormIn) String
-> Application
runWeb mv f0 req = do
liftIO $ compact mv
mv_sess <- liftIO $ getSessionMVar mv req
inp <- extractFormInputs req
case mv_sess of
Just mv_sess -> liftIO $ modifyMVar mv_sess $ \sess -> do
(x,y) <- runKleisli (auto sess) inp
return (y, asResponse x [])
Nothing -> liftIO $ do
(resp,f') <- runKleisli (mAut f0) inp
case f' of
Nothing -> return (asResponse resp [])
Just f' -> do
(newSess :: Int) <- abs <$> randomIO
var <- newMVar f'
modifyMVar_ mv $ return . ((show newSess,var) :)
let cookie = ("Set-Cookie", mconcat [sessionName, "=", show newSess, "; path=/"])
return (asResponse resp [cookie])
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) (Url, FormIn) String))]
-> Request
-> IO (Maybe (MVar (Automaton (Kleisli IO) (Url, FormIn) String)))
getSessionMVar mv req = modifyMVar mv $ \lst -> do
case lookup sessionName (getRequestCookies 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"
extractFormInputs req = do
let queryParams = map (\(x,y) -> (x,fromMaybe (SBC.pack "") y)) (queryString req)
(params, _) <- parseRequestBody lbsBackEnd req
return (map T.unpack (pathInfo req), FormIn $ (map (\(x,y) -> (SBC.unpack x, SBC.unpack y)) (queryParams ++ params)))
asResponse :: String -> [(String, String)] -> Response
asResponse out hdrs = responseLBS ok200 (map (\(x,y) -> (mk (SBC.pack x), SBC.pack y)) (typ:len:hdrs)) (fromString out)
where
typ = ("Content-Type", "text/html")
len = ("Content-Length", show $ LB.length $ fromString out)
getRequestCookies :: Request -> [(String, String)]
getRequestCookies req =
map (\(x,y) -> (T.unpack x, T.unpack y))
$ parseCookiesText
$ fromMaybe "" (lookup "Cookie" (requestHeaders req))