{-# LANGUAGE OverloadedStrings #-}
module Web.ReqCatcher
( Catcher (catcherUrl)
, newCatcher
, newCatcherWithPort
, catchRedirect
) where
import qualified Control.Concurrent as CONC
import qualified Control.Exception as EX
import qualified Network.HTTP.Types as HTTP
import qualified Network.Socket as NW
import qualified Network.Wai as WAI
import qualified Network.Wai.Handler.Warp as WARP
import qualified Data.Text.Lazy as LTXT
import qualified Data.Text.Lazy.Encoding as LTXT
data Catcher = Catcher
{ Catcher -> [Char]
catcherUrl :: String
, Catcher -> ThreadId
catcherWarpThread :: CONC.ThreadId
, Catcher -> Socket
catcherSocket :: NW.Socket
, Catcher -> MVar Request
catcherCought :: CONC.MVar WAI.Request
}
newCatcher :: IO Catcher
newCatcher :: IO Catcher
newCatcher = Port -> IO Catcher
newCatcherWithPort forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Port
pickPort
newCatcherWithPort :: WARP.Port -> IO Catcher
newCatcherWithPort :: Port -> IO Catcher
newCatcherWithPort Port
port = do
MVar Request
mvar <- forall a. IO (MVar a)
CONC.newEmptyMVar
MVar Socket
mvarSocket <- forall a. IO (MVar a)
CONC.newEmptyMVar
let set :: Settings
set = (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
WARP.setOnException (\Maybe Request
_ SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Settings -> Settings
WARP.setPort Port
port
forall a b. (a -> b) -> a -> b
$ Settings
WARP.defaultSettings
ThreadId
tid <- IO () -> IO ThreadId
CONC.forkIO (MVar Socket -> Settings -> Application -> IO ()
httpWorker MVar Socket
mvarSocket Settings
set (MVar Request -> Application
newCatchApp MVar Request
mvar))
Socket
socket <- forall a. MVar a -> IO a
CONC.takeMVar MVar Socket
mvarSocket
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> ThreadId -> Socket -> MVar Request -> Catcher
Catcher (Port -> [Char]
buildURL Port
port) ThreadId
tid Socket
socket MVar Request
mvar
httpWorker :: CONC.MVar NW.Socket -> WARP.Settings -> WAI.Application -> IO ()
httpWorker :: MVar Socket -> Settings -> Application -> IO ()
httpWorker MVar Socket
mvar Settings
set Application
app =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
EX.bracket
(Family -> SocketType -> ProtocolNumber -> IO Socket
NW.socket Family
NW.AF_INET SocketType
NW.Stream ProtocolNumber
NW.defaultProtocol)
Socket -> IO ()
NW.close
(\Socket
socket -> do
Socket -> SocketOption -> Port -> IO ()
NW.setSocketOption Socket
socket SocketOption
NW.ReuseAddr Port
1
let addr :: SockAddr
addr = PortNumber -> HostAddress -> SockAddr
NW.SockAddrInet (forall a. Enum a => Port -> a
toEnum forall a b. (a -> b) -> a -> b
$ Settings -> Port
WARP.getPort Settings
set) HostAddress
0
Socket -> SockAddr -> IO ()
NW.bind Socket
socket SockAddr
addr
Socket -> Port -> IO ()
NW.listen Socket
socket Port
1
forall a. MVar a -> a -> IO ()
CONC.putMVar MVar Socket
mvar Socket
socket
Settings -> Socket -> Application -> IO ()
WARP.runSettingsSocket Settings
set Socket
socket Application
app
forall (m :: * -> *) a. Monad m => a -> m a
return ())
catchRedirect :: Catcher -> IO WAI.Request
catchRedirect :: Catcher -> IO Request
catchRedirect Catcher
catcher = do
Request
req <- forall a. MVar a -> IO a
CONC.takeMVar (Catcher -> MVar Request
catcherCought Catcher
catcher)
Socket -> IO ()
NW.close (Catcher -> Socket
catcherSocket Catcher
catcher)
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
pickPort :: IO WARP.Port
pickPort :: IO Port
pickPort =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
EX.bracket
(Family -> SocketType -> ProtocolNumber -> IO Socket
NW.socket Family
NW.AF_INET SocketType
NW.Stream ProtocolNumber
NW.defaultProtocol)
Socket -> IO ()
NW.close
(\Socket
sock -> do
Socket -> SocketOption -> Port -> IO ()
NW.setSocketOption Socket
sock SocketOption
NW.ReuseAddr Port
1
Socket -> SockAddr -> IO ()
NW.bind Socket
sock (PortNumber -> HostAddress -> SockAddr
NW.SockAddrInet PortNumber
0 HostAddress
0)
PortNumber
port <- Socket -> IO PortNumber
NW.socketPort Socket
sock
Socket -> IO ()
NW.close Socket
sock
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => a -> Port
fromEnum PortNumber
port))
buildURL :: WARP.Port -> String
buildURL :: Port -> [Char]
buildURL Port
port = [Char]
"http://localhost:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Port
port
newCatchApp :: CONC.MVar WAI.Request -> WAI.Application
newCatchApp :: MVar Request -> Application
newCatchApp MVar Request
mvar Request
req Response -> IO ResponseReceived
respond = do
forall a. MVar a -> a -> IO ()
CONC.putMVar MVar Request
mvar Request
req
Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
WAI.responseLBS
Status
HTTP.status200
[(HeaderName
"Content-Type", ByteString
"text/plain")]
(Text -> ByteString
LTXT.encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
LTXT.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Request
req)