module Hack2.Handler.SnapServer
(
run
, runWithConfig
, runWithSnapServerConfig
, ServerConfig(..)
, hackAppToSnap
) where
import Prelude ()
import Air.Env hiding (def, Default)
import Hack2
import Data.Default (def, Default)
import qualified Data.CaseInsensitive as CaseInsensitive
import Data.ByteString.Char8 (ByteString, pack)
import qualified Data.ByteString.Char8 as B
import Data.Enumerator (Enumerator, Iteratee (..), ($$), joinI, run_, Enumeratee, Step, (=$), ($=))
import qualified Data.Enumerator.List as EL
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import qualified Snap.Core as Snap
import Snap.Types.Headers as Snap.Headers
import qualified Snap.Internal.Http.Types as SnapInternal
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Map (toAscList, fromAscList)
import Data.IORef (readIORef)
import qualified Snap.Http.Server as SnapServer
import System.Directory (createDirectory, doesDirectoryExist)
import Control.Monad (when)
import qualified Data.ByteString.Lazy.Char8 as Lazy
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as Strict
import qualified Data.Enumerator.Binary as EB
import qualified Data.Enumerator.List as EL
import Data.Enumerator (run_, enumList, Enumerator, ($$))
fromEnumerator :: Monad m => Enumerator Strict.ByteString m Lazy.ByteString -> m Lazy.ByteString
fromEnumerator m = run_ m $$ EB.consume
toEnumerator :: Monad m => Lazy.ByteString -> Enumerator Strict.ByteString m a
toEnumerator = enumList 1 < Lazy.toChunks
requestToEnv :: Snap.Request -> Lazy.ByteString -> IO Env
requestToEnv request body = do
return def
{
requestMethod = request.Snap.rqMethod.snapMethodToHackMethod
, pathInfo = B.append "/" request.Snap.rqPathInfo
, queryString = request.Snap.rqQueryString
, serverName = request.Snap.rqServerName
, serverPort = request.Snap.rqServerPort
, httpHeaders = request.SnapInternal.rqHeaders.Snap.Headers.toList.map caseInsensitiveHeaderToHeader
, hackUrlScheme = if request.Snap.rqIsSecure then HTTPS else HTTP
, hackInput = body.l2s
, hackHeaders =
[
("RemoteHost", request.Snap.rqRemoteAddr)
, ("RemotePort", request.Snap.rqRemotePort.show.pack)
]
}
snapMethodToHackMethod :: Snap.Method -> RequestMethod
snapMethodToHackMethod Snap.GET = GET
snapMethodToHackMethod Snap.HEAD = HEAD
snapMethodToHackMethod Snap.POST = POST
snapMethodToHackMethod Snap.PUT = PUT
snapMethodToHackMethod Snap.DELETE = DELETE
snapMethodToHackMethod Snap.TRACE = TRACE
snapMethodToHackMethod Snap.OPTIONS = OPTIONS
snapMethodToHackMethod Snap.CONNECT = CONNECT
caseInsensitiveHeaderToHeader :: (CaseInsensitive.CI ByteString, ByteString) -> (ByteString, ByteString)
caseInsensitiveHeaderToHeader (x, y) = (x.CaseInsensitive.original, y)
headerToCaseInsensitiveHeader :: (ByteString, ByteString) -> (CaseInsensitive.CI ByteString, ByteString)
headerToCaseInsensitiveHeader (x, y) = (x.CaseInsensitive.mk, y)
hackResponseToSnapResponse :: Response -> Snap.Response
hackResponseToSnapResponse response =
Snap.emptyResponse
. Snap.setResponseCode (response.status)
. (\r -> r { SnapInternal.rspHeaders = response.headers.map headerToCaseInsensitiveHeader.Snap.Headers.fromList })
. Snap.setResponseBody (response.body.s2l.toEnumerator $= EL.map fromByteString)
hackAppToSnap :: Application -> Snap.Snap ()
hackAppToSnap app = do
request <- Snap.getRequest
body <- Snap.getRequestBody
env <- io requestToEnv request body
response <- io app env
let snap_response = hackResponseToSnapResponse response
Snap.putResponse snap_response
data ServerConfig = ServerConfig
{
port :: Int
}
deriving (Show, Eq)
instance Default ServerConfig where
def = ServerConfig
{
port = 3000
}
runWithSnapServerConfig :: SnapServer.Config Snap.Snap a -> Application -> IO ()
runWithSnapServerConfig snap_server_config app = do
let snap = hackAppToSnap app :: Snap.Snap ()
SnapServer.httpServe snap_server_config snap
runWithConfig :: ServerConfig -> Application -> IO ()
runWithConfig config app = do
let snap_config = SnapServer.emptyConfig.SnapServer.setPort (config.port)
snap_default_log_path = "log"
log_directory_exist <- doesDirectoryExist snap_default_log_path
when (not log_directory_exist)
createDirectory snap_default_log_path
runWithSnapServerConfig snap_config app
run :: Application -> IO ()
run = runWithConfig def