{-# LANGUAGE CPP #-}
module Darcs.Util.HTTP
    ( Cachable(..)
    , copyRemote
    , copyRemoteLazy
    , speculateRemote
    , postUrl
    , configureHttpConnectionManager
    ) where

import Control.Concurrent.Async ( async, cancel, poll )
import Control.Exception ( catch )
import Control.Monad ( void , (>=>) )
import Crypto.Random ( seedNew, seedToInteger )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC

import Data.Conduit.Combinators ( sinkLazy )

import Foreign.C.Types ( CInt )

import Network.HTTP.Simple
    ( HttpException(..)
    , Request
    , httpBS
    , httpSink
    , httpNoBody
    , getResponseBody
    , setRequestHeaders
    , setRequestMethod
    , setRequestResponseTimeout
    )
import Network.HTTP.Conduit
    ( ResponseTimeout
    , parseUrlThrow
    , responseTimeoutDefault
    , responseTimeoutMicro
    )
import Network.HTTP.Types.Header
    ( hCacheControl
    , hPragma
    , hContentType
    , hAccept
    , hContentLength
    )

#ifdef HAVE_CRYPTON_CONNECTION
import Data.Default.Class ( def )
import qualified Network.Connection as NC
import Network.HTTP.Client.TLS
    ( mkManagerSettings
    , newTlsManagerWith
    , setGlobalManager
    )
import qualified Network.TLS as TLS
#endif

import Numeric ( showHex )
import System.Directory ( renameFile )
import System.Environment ( lookupEnv )
import Text.Read ( readMaybe )

import Darcs.Prelude

import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Global ( debugMessage )

data Cachable
  = Cachable
  | Uncachable
  | MaxAge !CInt
  deriving (Int -> Cachable -> ShowS
[Cachable] -> ShowS
Cachable -> String
(Int -> Cachable -> ShowS)
-> (Cachable -> String) -> ([Cachable] -> ShowS) -> Show Cachable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cachable -> ShowS
showsPrec :: Int -> Cachable -> ShowS
$cshow :: Cachable -> String
show :: Cachable -> String
$cshowList :: [Cachable] -> ShowS
showList :: [Cachable] -> ShowS
Show, Cachable -> Cachable -> Bool
(Cachable -> Cachable -> Bool)
-> (Cachable -> Cachable -> Bool) -> Eq Cachable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cachable -> Cachable -> Bool
== :: Cachable -> Cachable -> Bool
$c/= :: Cachable -> Cachable -> Bool
/= :: Cachable -> Cachable -> Bool
Eq)

darcsResponseTimeout :: IO ResponseTimeout
darcsResponseTimeout :: IO ResponseTimeout
darcsResponseTimeout =
  String -> IO (Maybe String)
lookupEnv String
"DARCS_CONNECTION_TIMEOUT" IO (Maybe String)
-> (Maybe String -> IO ResponseTimeout) -> IO ResponseTimeout
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
s | Just Int
n <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
s ->
      ResponseTimeout -> IO ResponseTimeout
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseTimeout -> IO ResponseTimeout)
-> ResponseTimeout -> IO ResponseTimeout
forall a b. (a -> b) -> a -> b
$ Int -> ResponseTimeout
responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n
    Maybe String
_ -> ResponseTimeout -> IO ResponseTimeout
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseTimeout
responseTimeoutDefault -- 30 s, seems a bit long

copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote :: String -> String -> Cachable -> IO ()
copyRemote String
url String
path Cachable
cachable = do
  String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"copyRemote: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url
  String
junk <- (Integer -> ShowS) -> String -> Integer -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex String
"" (Integer -> String) -> (Seed -> Integer) -> Seed -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seed -> Integer
seedToInteger (Seed -> String) -> IO Seed -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Seed
forall (randomly :: * -> *). MonadRandom randomly => randomly Seed
seedNew
  let tmppath :: String
tmppath = String
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".new_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
junk
  ResponseTimeout
tmo <- IO ResponseTimeout
darcsResponseTimeout
  String -> (Request -> IO ()) -> IO ()
forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url
    (Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS (Request -> IO (Response ByteString))
-> (Request -> Request) -> Request -> IO (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseTimeout -> Request -> Request
setRequestResponseTimeout ResponseTimeout
tmo (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cachable -> Request -> Request
addCacheControl Cachable
cachable (Request -> IO (Response ByteString))
-> (Response ByteString -> IO ()) -> Request -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
     String -> ByteString -> IO ()
B.writeFile String
tmppath (ByteString -> IO ())
-> (Response ByteString -> ByteString)
-> Response ByteString
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody)
  String -> String -> IO ()
renameFile String
tmppath String
path

-- TODO instead of producing a lazy ByteString we should re-write the
-- consumer (Darcs.Repository.Packs) to use proper streaming (e.g. conduit)
copyRemoteLazy :: String -> Cachable -> IO (BL.ByteString)
copyRemoteLazy :: String -> Cachable -> IO ByteString
copyRemoteLazy String
url Cachable
cachable = do
  String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"copyRemoteLazy: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url
  String -> (Request -> IO ByteString) -> IO ByteString
forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url
    ((Request
 -> (Response () -> ConduitM ByteString Void IO ByteString)
 -> IO ByteString)
-> (Response () -> ConduitM ByteString Void IO ByteString)
-> Request
-> IO ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request
-> (Response () -> ConduitM ByteString Void IO ByteString)
-> IO ByteString
forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM ByteString Void m a) -> m a
httpSink (ConduitM ByteString Void IO ByteString
-> Response () -> ConduitM ByteString Void IO ByteString
forall a b. a -> b -> a
const ConduitM ByteString Void IO ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy) (Request -> IO ByteString)
-> (Request -> Request) -> Request -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cachable -> Request -> Request
addCacheControl Cachable
cachable)

speculateRemote :: String -> FilePath -> IO ()
speculateRemote :: String -> String -> IO ()
speculateRemote String
url String
path = do
  Async ()
r <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Start speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url
    -- speculations are always Cachable
    String -> String -> Cachable -> IO ()
copyRemote String
url String
path Cachable
Cachable
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Completed speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url
  IO () -> IO ()
atexit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Either SomeException ())
result <- Async () -> IO (Maybe (Either SomeException ()))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async ()
r
    case Maybe (Either SomeException ())
result of
      Just (Right ()) ->
        String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Already completed speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url
      Just (Left SomeException
e) ->
        String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
      Maybe (Either SomeException ())
Nothing -> do
        String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Abort speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url
        Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
r

postUrl
  :: String -- ^ url
  -> BC.ByteString -- ^ body
  -> String -- ^ mime type
  -> IO () -- ^ result
postUrl :: String -> ByteString -> String -> IO ()
postUrl String
url ByteString
body String
mime =
    String -> (Request -> IO ()) -> IO ()
forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url (IO (Response ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Response ()) -> IO ())
-> (Request -> IO (Response ())) -> Request -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO (Response ())
forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody (Request -> IO (Response ()))
-> (Request -> Request) -> Request -> IO (Response ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
setMethodAndHeaders)
  where
    setMethodAndHeaders :: Request -> Request
setMethodAndHeaders =
      ByteString -> Request -> Request
setRequestMethod (String -> ByteString
BC.pack String
"POST") (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      RequestHeaders -> Request -> Request
setRequestHeaders
        [ (HeaderName
hContentType, String -> ByteString
BC.pack String
mime)
        , (HeaderName
hAccept, String -> ByteString
BC.pack String
"text/plain")
        , (HeaderName
hContentLength, String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
body)
        ]

addCacheControl :: Cachable -> Request -> Request
addCacheControl :: Cachable -> Request -> Request
addCacheControl Cachable
Uncachable =
  RequestHeaders -> Request -> Request
setRequestHeaders [(HeaderName
hCacheControl, ByteString
noCache), (HeaderName
hPragma, ByteString
noCache)]
addCacheControl (MaxAge CInt
seconds) | CInt
seconds CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0 =
  RequestHeaders -> Request -> Request
setRequestHeaders [(HeaderName
hCacheControl, String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"max-age=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
seconds)]
addCacheControl Cachable
_ = Request -> Request
forall a. a -> a
id

noCache :: BC.ByteString
noCache :: ByteString
noCache = String -> ByteString
BC.pack String
"no-cache"

handleHttpAndUrlExn :: String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn :: forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url Request -> IO a
action =
  IO a -> (HttpException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
url IO Request -> (Request -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO a
action) (\case
    InvalidUrlException String
_ String
reason ->
      String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Invalid URI: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", reason: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
    HttpExceptionRequest Request
_ HttpExceptionContent
hec {- :: HttpExceptionContent -}
     -> String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Error getting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
url String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
hec)

-- | To be called from main program in order to set up a connection manager
-- with changed TLS settings. Particularly, since tls-2.0 the default value for
-- 'TLS.supportedExtendedMainSecret' was changed from 'TLS.AllowEMS' to
-- 'TLS.RequireEMS', which is currently (2024-05-19) not yet supported by
-- hub.darcs.net.
configureHttpConnectionManager :: IO ()
#ifdef HAVE_CRYPTON_CONNECTION
configureHttpConnectionManager :: IO ()
configureHttpConnectionManager = do
  let tlsSettings :: TLSSettings
tlsSettings =
        Bool -> Bool -> Bool -> Supported -> TLSSettings
NC.TLSSettingsSimple Bool
False Bool
False Bool
False
          Supported
forall a. Default a => a
def { TLS.supportedExtendedMainSecret = TLS.AllowEMS }
  Manager
manager <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
tlsSettings Maybe SockSettings
forall a. Maybe a
Nothing
  Manager -> IO ()
setGlobalManager Manager
manager
#else
configureHttpConnectionManager = return ()
#endif