{-# 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 -> String
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 (Port -> IO Catcher) -> IO Port -> IO Catcher
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 <- IO (MVar Request)
forall a. IO (MVar a)
CONC.newEmptyMVar
  MVar Socket
mvarSocket <- IO (MVar Socket)
forall a. IO (MVar a)
CONC.newEmptyMVar

  let set :: Settings
set = (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
WARP.setOnException (\Maybe Request
_ SomeException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Settings -> Settings
WARP.setPort Port
port
          (Settings -> Settings) -> Settings -> Settings
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 <- MVar Socket -> IO Socket
forall a. MVar a -> IO a
CONC.takeMVar MVar Socket
mvarSocket

  Catcher -> IO Catcher
forall (m :: * -> *) a. Monad m => a -> m a
return (Catcher -> IO Catcher) -> Catcher -> IO Catcher
forall a b. (a -> b) -> a -> b
$ String -> ThreadId -> Socket -> MVar Request -> Catcher
Catcher (Port -> String
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 =
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
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 (Port -> PortNumber
forall a. Enum a => Port -> a
toEnum (Port -> PortNumber) -> Port -> PortNumber
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
        MVar Socket -> Socket -> IO ()
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
        () -> IO ()
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 <- MVar Request -> IO Request
forall a. MVar a -> IO a
CONC.takeMVar (Catcher -> MVar Request
catcherCought Catcher
catcher)
  Socket -> IO ()
NW.close (Catcher -> Socket
catcherSocket Catcher
catcher)
  Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req

pickPort :: IO WARP.Port
pickPort :: IO Port
pickPort =
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO Port) -> IO Port
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
        Port -> IO Port
forall (m :: * -> *) a. Monad m => a -> m a
return (PortNumber -> Port
forall a. Enum a => a -> Port
fromEnum PortNumber
port))

buildURL :: WARP.Port -> String
buildURL :: Port -> String
buildURL Port
port = String
"http://localhost:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> String
forall a. Show a => a -> String
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
  MVar Request -> Request -> IO ()
forall a. MVar a -> a -> IO ()
CONC.putMVar MVar Request
mvar Request
req
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
LTXT.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Request -> String
forall a. Show a => a -> String
show Request
req)