1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as ByteStringC
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Network.Socket.ByteString as NSBS
import Blaze.ByteString.Builder.ByteString ( fromByteString )
import Control.Monad.IO.Class ( liftIO )
import Control.Monad.Trans.Resource ( ResourceT, allocate )
import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( mk, original )
import Data.Conduit ( Flush(Chunk) )
import Data.Conduit ( mapOutput, unwrapResumable )
import Data.Conduit ( ($$), ($$+) )
import Data.Conduit.Network ( sinkSocket, sourceSocket )
import Data.Serialize.Put ( runPut, putWord16le )
import Network.HTTP.Conduit.Internal ( sinkHeaders )
import Network.HTTP.Types ( status500)
import Network.HTTP.Types.Status ( Status(..) )
import Network.Socket ( SockAddr(SockAddrUnix) )
import Network.Socket ( Socket, Family(AF_UNIX) )
import Network.Socket ( SocketType(Stream) )
import Network.Socket ( socket, connect, sClose )
import Network.Wai ( Request(..), Response(..) )
import Network.Wai ( responseLBS)
import Network.Wai.Handler.Warp ( run)
type LazyByteString = LazyByteString.ByteString
main :: IO ()
main =
run 3000 $ uwsgi mkConn
where
mkConn :: IO (Either LazyByteString Socket)
mkConn = do
s <- socket AF_UNIX Stream 0
connect s $ SockAddrUnix "/var/run/uwsgi.sock"
return $ Right s
uwsgi :: IO (Either LazyByteString Socket) -> Request -> ResourceT IO Response
uwsgi mkConn req = do
(_, es) <- allocate mkConn free
case es of
Left bs ->
return $ responseLBS status500 [("Content-Type", "text/html")] bs
Right sock -> go sock
where
go :: Socket -> ResourceT IO Response
go sock = do
let uReq = uwsgiReq req
_ <- liftIO $ NSBS.send sock uReq
_ <- requestBody req $$ sinkSocket sock
let src = sourceSocket sock
(rsrc, ((_, code, msg), headers)) <- src $$+ sinkHeaders
(src2, _rel) <- unwrapResumable rsrc
return $ ResponseSource (Status code msg)
[(mk k, v) | (k, v) <- headers]
$ mapOutput (Chunk . fromByteString) src2
free :: Either LazyByteString Socket -> IO ()
free (Left _) = return ()
free (Right s) = sClose s
uwsgiReq :: Request -> ByteString
uwsgiReq req = let
reqs = [ ("REQUEST_METHOD", requestMethod req)
, ("SCRIPT_NAME", "")
, ("PATH_INFO", rawPathInfo req)
, ("SERVER_NAME", serverName req)
, ("SERVER_PORT", ByteStringC.pack $ show $ Network.Wai.serverPort req)
, ("SERVER_PROTOCOL", "HTTP/1.1")
]
heads = [ (ByteString.append "HTTP_" $ original k, v)
| (k, v) <- requestHeaders req]
nil = ByteString.pack [0]
lenbs = runPut . putWord16le . fromIntegral . ByteString.length
blobs = [ByteString.concat [lenbs k, k, lenbs v, v] | (k, v) <- reqs ++ heads]
blob = ByteString.concat blobs
in
ByteString.concat [nil, lenbs blob, nil, blob]
|