module Hack.Handler.Hyena (run, runWithConfig, ServerConf(..)) where
import qualified Hack as Hack
import Hyena.Server
import Network.Wai as Wai
import qualified Hyena.Config as Hyena.Config
import Prelude hiding ((.), (^))
import System.IO
import Control.Monad
import Data.Default
import Data.Maybe
import Data.Char
import Control.Applicative ((<$>))
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (newChan,writeChan,getChanContents)
(.) :: a -> (a -> b) -> b
a . f = f a
infixl 9 .
data ServerConf = ServerConf { port :: Int, serverName :: String }
instance Default ServerConf where
def = ServerConf { port = 3000, serverName = "localhost" }
unpack_tuple :: (S.ByteString, S.ByteString) -> (String, String)
unpack_tuple (x,y) = (C.unpack x, C.unpack y)
pack_tuple :: (String, String) -> (S.ByteString, S.ByteString)
pack_tuple (x,y) = (C.pack x, C.pack y)
hyena_env_to_hack_env :: ServerConf -> Environment -> IO Hack.Env
hyena_env_to_hack_env conf e = do
i <- (L.fromChunks <$> (e.Wai.input .enumToList))
return def
{
Hack.requestMethod = convertRequestMethod (e.requestMethod)
, Hack.scriptName = e.scriptName.C.unpack
, Hack.pathInfo = e.pathInfo.C.unpack
, Hack.queryString = e.queryString .fromMaybe C.empty .C.unpack
, Hack.http = e.Wai.headers .map unpack_tuple
, Hack.hackErrors = e.errors
, Hack.serverPort = conf.port
, Hack.serverName = conf.serverName
, Hack.hackInput = i
}
where
convertRequestMethod Wai.Options = Hack.OPTIONS
convertRequestMethod Wai.Get = Hack.GET
convertRequestMethod Wai.Head = Hack.HEAD
convertRequestMethod Wai.Post = Hack.POST
convertRequestMethod Wai.Put = Hack.PUT
convertRequestMethod Wai.Delete = Hack.DELETE
convertRequestMethod Wai.Trace = Hack.TRACE
convertRequestMethod Wai.Connect = Hack.CONNECT
enumToList :: ((() -> S.ByteString -> IO (Either () ())) -> () -> IO ())
-> IO [S.ByteString]
enumToList enum =
do ch <- newChan
forkIO $ enum (writer ch) () >> writeChan ch Nothing
xs <- getChanContents ch
return $ map fromJust $ takeWhile isJust xs
where writer ch () chunk = do writeChan ch (Just chunk)
return (Right ())
listToEnum :: [S.ByteString] -> Enumerator
listToEnum [] _ z = return z
listToEnum (x:xs) f z = f z x >>= either return (listToEnum xs f)
type WaiResponse = (Int, S.ByteString, Wai.Headers, Enumerator)
hack_response_to_hyena_response :: Enumerator -> Hack.Response -> WaiResponse
hack_response_to_hyena_response e r =
( r.Hack.status
, r.Hack.status.show_status_message.fromMaybe "OK" .C.pack
, r.Hack.headers.map pack_tuple
, e
)
hack_to_wai_with_config :: ServerConf -> Hack.Application -> Wai.Application
hack_to_wai_with_config conf app env = do
hack_env <- env.hyena_env_to_hack_env conf
r <- app hack_env
let enum = r.Hack.body.L.toChunks.listToEnum
hyena_response = r.hack_response_to_hyena_response enum
return hyena_response
run :: Hack.Application -> IO ()
run app = runWithConfig def app
runWithConfig :: ServerConf -> Hack.Application -> IO ()
runWithConfig conf app = do
hyena_config <- Hyena.Config.configFromFlags
let hyena_config_with_port =
hyena_config { Hyena.Config.port = port conf
}
app.hack_to_wai_with_config conf .(serveWithConfig hyena_config_with_port)
show_status_message :: Int -> Maybe String
show_status_message x = status_code.M.lookup x
status_code :: M.Map Int String
status_code =
[ x 100 "Continue"
, x 101 "Switching Protocols"
, x 200 "OK"
, x 201 "Created"
, x 202 "Accepted"
, x 203 "Non-Authoritative Information"
, x 204 "No Content"
, x 205 "Reset Content"
, x 206 "Partial Content"
, x 300 "Multiple Choices"
, x 301 "Moved Permanently"
, x 302 "Found"
, x 303 "See Other"
, x 304 "Not Modified"
, x 305 "Use Proxy"
, x 307 "Temporary Redirect"
, x 400 "Bad Request"
, x 401 "Unauthorized"
, x 402 "Payment Required"
, x 403 "Forbidden"
, x 404 "Not Found"
, x 405 "Method Not Allowed"
, x 406 "Not Acceptable"
, x 407 "Proxy Authentication Required"
, x 408 "Request Timeout"
, x 409 "Conflict"
, x 410 "Gone"
, x 411 "Length Required"
, x 412 "Precondition Failed"
, x 413 "Request Entity Too Large"
, x 414 "Request-URI Too Large"
, x 415 "Unsupported Media Type"
, x 416 "Requested Range Not Satisfiable"
, x 417 "Expectation Failed"
, x 500 "Internal Server Error"
, x 501 "Not Implemented"
, x 502 "Bad Gateway"
, x 503 "Service Unavailable"
, x 504 "Gateway Timeout"
, x 505 "HTTP Version Not Supported"
] .M.fromList
where x a b = (a, b)