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 <- (Integer -> String -> String) -> String -> Integer -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
junk
  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
. 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 =
  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 -> String -> String
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 -> String -> String
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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
url String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed: " String -> String -> String
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 -> String -> String
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 -> String -> String
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 :: 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 (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 (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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
url String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", reason: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason
    HttpExceptionRequest Request
_ HttpExceptionContent
hec {- :: HttpExceptionContent -}
     -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
url String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
hec)