module Darcs.Util.HTTP ( copyRemote, copyRemoteLazy, speculateRemote, postUrl ) 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 Network.HTTP.Simple
    ( HttpException(..)
    , Request
    , httpBS
    , httpSink
    , httpNoBody
    , getResponseBody
    , setRequestHeaders
    , setRequestMethod
    )
import Network.HTTP.Conduit ( parseUrlThrow )
import Network.HTTP.Types.Header
    ( hCacheControl
    , hPragma
    , hContentType
    , hAccept
    , hContentLength
    )
import Numeric ( showHex )
import System.Directory ( renameFile )

import Darcs.Prelude

import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Download.Request ( Cachable(..) )
import Darcs.Util.Global ( debugMessage )

copyRemote :: String -> FilePath -> Cachable -> IO ()
copyRemote :: String -> String -> Cachable -> IO ()
copyRemote String
url String
path Cachable
cachable = do
  String
junk <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Integral a, Show a) => a -> ShowS
showHex String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seed -> Integer
seedToInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (randomly :: * -> *). MonadRandom randomly => randomly Seed
seedNew
  let tmppath :: String
tmppath = String
path forall a. [a] -> [a] -> [a]
++ String
".new_" forall a. [a] -> [a] -> [a]
++ String
junk
  forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url
    (forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cachable -> Request -> Request
addCacheControl Cachable
cachable forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> ByteString -> IO ()
B.writeFile String
tmppath forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url
    (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM ByteString Void m a) -> m a
httpSink (forall a b. a -> b -> a
const forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy) 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 <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Start speculating on " 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 forall a b. (a -> b) -> a -> b
$ String
"Completed speculating on " forall a. [a] -> [a] -> [a]
++ String
url
  IO () -> IO ()
atexit forall a b. (a -> b) -> a -> b
$ do
    Maybe (Either SomeException ())
result <- forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async ()
r
    case Maybe (Either SomeException ())
result of
      Just (Right ()) ->
        String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Already completed speculating on " forall a. [a] -> [a] -> [a]
++ String
url
      Just (Left SomeException
e) ->
        String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Speculating on " forall a. [a] -> [a] -> [a]
++ String
url forall a. [a] -> [a] -> [a]
++ String
" failed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
      Maybe (Either SomeException ())
Nothing -> do
        String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Abort speculating on " forall a. [a] -> [a] -> [a]
++ String
url
        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 =
    forall a. String -> (Request -> IO a) -> IO a
handleHttpAndUrlExn String
url (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody 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") 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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show 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 forall a. Ord a => a -> a -> Bool
> CInt
0 =
  RequestHeaders -> Request -> Request
setRequestHeaders [(HeaderName
hCacheControl, String -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ String
"max-age=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
seconds)]
addCacheControl Cachable
_ = 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 =
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
url forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO a
action) (\case
    InvalidUrlException String
_ String
reason ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid URI: " forall a. [a] -> [a] -> [a]
++ String
url forall a. [a] -> [a] -> [a]
++ String
", reason: " forall a. [a] -> [a] -> [a]
++ String
reason
    HttpExceptionRequest Request
_ HttpExceptionContent
hec {- :: HttpExceptionContent -}
     -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Error getting " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
url forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HttpExceptionContent
hec)