content: {-# LANGUAGE ScopedTypeVariables, RecordWildCards, OverloadedStrings, CPP #-}
  {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Use conduitManagerSettings to work with http-conduit-2.1.6 and below
  
  module General.Web(
      Input(..), Output(..), send, server
      ) where
  
  -- #define PROFILE
  
  -- For some reason, profiling stops working if I import warp
  -- Tracked as https://github.com/yesodweb/wai/issues/311
  #ifndef PROFILE
  import Network.Wai.Handler.Warp hiding (Port)
  #endif
  
  -- S for server, C for client
  import Development.Bake.Core.Type hiding (run)
  import Network.Wai as S
  import Network.Wai.Parse as P
  import Data.Function
  import General.Extra
  import General.BigString
  import Control.DeepSeq
  import Control.Exception
  import Control.Applicative
  import Control.Monad
  import System.IO
  import Network.HTTP.Conduit as C
  import Network.HTTP.Client.MultipartFormData
  import Network.HTTP.Types.Status
  import qualified Data.Text as Text
  import qualified Data.ByteString.Char8 as BS
  import qualified Data.ByteString.Lazy.Char8 as LBS
  import System.Console.CmdArgs.Verbosity
  import Prelude
  
  
  data Input = Input
      {inputURL :: [String]
      ,inputArgs :: [(String, String)]
      ,inputBody :: [(String, BigString)]
      } deriving Show
  
  data Output
      = OutputString String
      | OutputHTML String
      | OutputFile FilePath
      | OutputError String
      | OutputMissing
        deriving Show
  
  instance NFData Output where
      rnf (OutputString x) = rnf x
      rnf (OutputHTML x) = rnf x
      rnf (OutputFile x) = rnf x
      rnf (OutputError x) = rnf x
      rnf OutputMissing = ()
  
  {-
  -- | Number of time to retry sending messages
  maxRetryCount :: Int
  maxRetryCount = 3
  
  -- | Timeout between each message sending attempt
  retryTimeout :: Seconds
  retryTimeout = 10
  -}
  
  
  send :: (Host,Port) -> Input -> IO LBS.ByteString
  send (host,port) Input{..} = do
      let url = "http://" ++ host ++ ":" ++ show port ++ concatMap ('/':) inputURL ++
                concat (zipWith (++) ("?":repeat "&") [a ++ "=" ++ b | (a,b) <- inputArgs])
      whenLoud $ print ("sending",length inputBody,host,port)
      req <- parseUrl url
      m <- newManager conduitManagerSettings
      withs (map (uncurry withBigStringPart) inputBody) $ \parts -> do
          body <- formDataBody parts req
          responseBody <$> httpLbs body m
  {-
      -- http-client 0.5 completely changes this API, so give up retrying until it can be tested
          responseBody <$> retrySleep retryTimeout maxRetryCount isConnFailure (httpLbs body m)
      where
          isConnFailure FailedConnectionException2{} = True
          isConnFailure _ = False
  -}
  
  
  server :: Port -> (Input -> IO Output) -> IO ()
  #ifdef PROFILE
  server port act = return ()
  #else
  server port act = runSettings settings $ \req reply -> do
      whenLoud $ print ("receiving", map Text.unpack $ pathInfo req, S.requestHeaders req, port)
      (params, files) <- parseRequestBody bigStringBackEnd req
  
      let pay = Input
              (map Text.unpack $ pathInfo req)
              [(BS.unpack a, maybe "" BS.unpack b) | (a,b) <- S.queryString req] $
              [(BS.unpack name, bigStringFromByteString x) | (name,x) <- params] ++ [(BS.unpack name, fileContent) | (name, P.FileInfo{..}) <- files]
      res <- act pay
      -- from http://stackoverflow.com/questions/49547/making-sure-a-web-page-is-not-cached-across-all-browsers
      let nocache = [("Cache-Control","no-cache, no-store, must-revalidate")
                    ,("Pragma","no-cache")
                    ,("Expires","0")]
      reply $ case res of
          OutputFile file -> responseFile status200 nocache file Nothing
          OutputString msg -> responseLBS status200 nocache $ LBS.pack msg
          OutputHTML msg -> responseLBS status200 (("content-type","text/html"):nocache) $ LBS.pack msg
          OutputError msg -> responseLBS status500 nocache $ LBS.pack msg
          OutputMissing -> responseLBS status404 nocache $ LBS.pack "Resource not found"
      where
          settings = setOnExceptionResponse exceptionResponseForDebug $
                     setOnException exception $
                     setPort port defaultSettings
  
  
  
  exception :: Maybe S.Request -> SomeException -> IO ()
  exception r e = when (defaultShouldDisplayException e) $
      hPutStrLn stderr $ "Error when processing " ++ maybe "Nothing" (show . rawPathInfo) r ++ "\n    " ++ show e
  #endif
  