{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Web.ReqCatcher
Description : A tiny tool to catch HTTP redirects from the browser
Copyright   : (c) 2016- hiratara
License     : BSD-style
Maintainer  : hiratara@cpan.org
Stability   : experimental

Web.ReqCatcher starts a local HTTP server which handles just one request and
returns that request to the client program. It is useful for CLI program to
capture HTTP redirects from outer WEB services by using browser.

@
  import Web.Authenticate.OAuth

  oauth :: OAuth
  manager :: Manager

  main :: IO ()
  main = do
    c <- newCatcher
    let url = pack (catcherUrl c)
        oauth' = oauth {oauthCallback = Just url}

    credential <- getTemporaryCredential oauth' manager
    putStrLn $ "Access to:\\n" ++ (authorizeUrl oauth credential)
    req <- catchRedirect c

    let (Just (Just verifier)) = lookup "oauth_verifier" (queryString req)
    ...
@
-}
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

-- | Catcher holds the HTTP server instance and wait for a request.
data Catcher = Catcher
  { Catcher -> [Char]
catcherUrl :: String -- ^ Target URL of this Catcher
  , Catcher -> ThreadId
catcherWarpThread :: CONC.ThreadId
  , Catcher -> Socket
catcherSocket :: NW.Socket
  , Catcher -> MVar Request
catcherCought :: CONC.MVar WAI.Request
  }

-- | Creates the new Catcher instance.
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

-- | Creates the new Catcher instance with the specific port.
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
        -- TODO: set Close-On-Exec to socket
        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 -- Handle Just 1 connection
        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 ())

-- | Returns the HTTP request cought by Catcher.
--   This function blocks until Catcher catches some requests.
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)