{-# LANGUAGE CPP, ForeignFunctionInterface #-}

module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault,
             setDebugHTTP, setHTTPPipelining, waitUrl,
             Cachable(Cachable, Uncachable, MaxAge),
             environmentHelpProxy, environmentHelpProxyPassword
           ) where

import Data.IORef ( newIORef, readIORef, writeIORef, IORef )
import Data.Map ( Map )
import Data.List ( delete )
import qualified Data.Map as Map
import System.Directory ( copyFile )
import System.IO.Unsafe ( unsafePerformIO )
import Control.Concurrent ( forkIO )
import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, Chan )
import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar )
import Control.Monad ( unless, when )
import Control.Monad.Trans ( liftIO )
import Control.Monad.State ( evalStateT, get, modify, put, StateT )
import Foreign.C.Types ( CInt )

import Workaround ( renameFile )
import Darcs.Global ( atexit )
import Progress ( debugFail, debugMessage )
import Darcs.Lock ( removeFileMayNotExist )

import Numeric ( showHex )
import System.Random ( randomRIO )

#ifdef HAVE_CURL
import Foreign.C.String ( withCString, peekCString, CString )
#else
import qualified HTTP ( request_url, wait_next_url )
#endif
#include "impossible.h"

data UrlRequest = UrlRequest { url :: String
                             , file :: FilePath
                             , cachable :: Cachable
                             , priority :: Priority
                             , notifyVar :: MVar String }

data Cachable = Cachable | Uncachable | MaxAge !CInt
                deriving (Show, Eq)

data UrlState = UrlState { inProgress :: Map String ( FilePath
                                                    , [FilePath]
                                                    , Cachable
                                                    , (MVar String) )
                         , waitToStart :: Q String
                         , pipeLength :: Int
                         , randomJunk :: String }

data Q a = Q [a] [a]

readQ :: Q a -> Maybe (a, Q a)
readQ (Q (x:xs) ys) = Just (x, Q xs ys)
readQ (Q [] ys) = do x:xs <- Just $ reverse ys
                     Just (x, Q xs [])

insertQ :: a -> Q a -> Q a
insertQ y (Q xs ys) = Q xs (y:ys)

pushQ :: a -> Q a -> Q a
pushQ x (Q xs ys) = Q (x:xs) ys

deleteQ :: Eq a => a -> Q a -> Q a
deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)

elemQ :: Eq a => a -> Q a -> Bool
elemQ x (Q xs ys) = x `elem` xs || x `elem` ys

emptyQ :: Q a
emptyQ = Q [] []

nullQ :: Q a -> Bool
nullQ (Q [] []) = True
nullQ _         = False

data Priority = High | Low deriving Eq

#if defined(CURL_PIPELINING) || defined(CURL_PIPELINING_DEFAULT)
pipeliningLimit :: Int
pipeliningLimit = 100
#endif

pipeliningEnabledByDefault :: Bool
#ifdef CURL_PIPELINING_DEFAULT
pipeliningEnabledByDefault = True
#else
pipeliningEnabledByDefault = False
#endif

{-# NOINLINE maxPipeLength #-}
maxPipeLength :: IORef Int
maxPipeLength = unsafePerformIO $ newIORef $
#ifdef CURL_PIPELINING_DEFAULT
                pipeliningLimit
#else
                1
#endif

{-# NOINLINE urlNotifications #-}
urlNotifications :: MVar (Map String (MVar String))
urlNotifications = unsafePerformIO $ newMVar Map.empty

{-# NOINLINE urlChan #-}
urlChan :: Chan UrlRequest
urlChan = unsafePerformIO $ do
  ch <- newChan
  forkIO (urlThread ch)
  return ch

urlThread :: Chan UrlRequest -> IO ()
urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange
                  evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk)
    where rrange = (0, 2^(128 :: Integer) :: Integer)
          urlThread' = do
            empty <- liftIO $ isEmptyChan ch
            st <- get
            let l = pipeLength st
                w = waitToStart st
            reqs <- if not empty || (nullQ w && l == 0)
                    then liftIO readAllRequests
                    else return []
            mapM_ addReq reqs
            checkWaitToStart
            waitNextUrl
            urlThread'
          readAllRequests = do
            r <- readChan ch
            debugMessage $ "URL.urlThread ("++url r++"\n"++
                           "            -> "++file r++")"
            empty <- isEmptyChan ch
            reqs <- if not empty
                    then readAllRequests
                    else return []
            return (r:reqs)
          addReq r = do
            let u = url r
                f = file r
                c = cachable r
            d <- liftIO $ alreadyDownloaded u
            if d
               then dbg "Ignoring UrlRequest of URL that is already downloaded."
               else do
                 st <- get
                 let p = inProgress st
                     w = waitToStart st
                     e = (f, [], c, notifyVar r)
                     new_w = case priority r of
                               High -> pushQ u w
                               Low  -> insertQ u w
                     new_st = st { inProgress = Map.insert u e p
                                 , waitToStart = new_w }
                 case Map.lookup u p of
                   Just (f', fs', c', v) -> do
                     let new_c = minCachable c c'
                     when (c /= c') $ let new_p = Map.insert u (f', fs', new_c, v) p
                                      in do modify (\s -> s { inProgress = new_p })
                                            dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c
                     when (u `elemQ` w && priority r == High) $ do
                       modify (\s -> s { waitToStart = pushQ u (deleteQ u w) })
                       dbg $ "Moving "++u++" to head of download queue."
                     if f `notElem` (f':fs')
                        then let new_p = Map.insert u (f', f:fs', new_c, v) p
                             in do modify (\s -> s { inProgress = new_p })
                                   dbg "Adding new file to existing UrlRequest."
                        else dbg "Ignoring UrlRequest of file that's already queued."
                   _ -> put new_st
          alreadyDownloaded u = do
            n <- liftIO $ withMVar urlNotifications (return . (Map.lookup u))
            case n of
              Just v  -> not `fmap` isEmptyMVar v
              Nothing -> return True

checkWaitToStart :: StateT UrlState IO ()
checkWaitToStart = do
  st <- get
  let l = pipeLength st
  mpl <- liftIO $ readIORef maxPipeLength
  when (l < mpl) $ do
    let w = waitToStart st
    case readQ w of
      Just (u,rest) -> do
        case Map.lookup u (inProgress st) of
          Just (f, _, c, v) -> do
            dbg ("URL.request_url ("++u++"\n"++
                 "              -> "++f++")")
            let f_new = f++"-new_"++randomJunk st
            err <- liftIO $ request_url u f_new c
            if null err
               then do dbg "URL.request_url succeeded"
                       liftIO $ atexit (removeFileMayNotExist f_new)
                       put $ st { waitToStart = rest
                                , pipeLength = l + 1 }
               else do dbg $ "Failed to start download URL "++u++": "++err
                       liftIO $ do removeFileMayNotExist f_new
                                   putMVar v err
                       put $ st { waitToStart = rest }
          _              -> bug $ "Possible bug in URL.checkWaitToStart "++u
        checkWaitToStart
      _ -> return ()

copyUrlFirst :: String -> FilePath -> Cachable -> IO ()
copyUrlFirst = copyUrlWithPriority High

copyUrl :: String -> FilePath -> Cachable -> IO ()
copyUrl = copyUrlWithPriority Low

copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority p u f c = do
  debugMessage ("URL.copyUrlWithPriority ("++u++"\n"++
                "                      -> "++f++")")
  v <- newEmptyMVar
  let fn _ old_val = old_val
  modifyMVar_ urlNotifications (return . (Map.insertWith fn u v))
  let r = UrlRequest u f c p v
  writeChan urlChan r

waitNextUrl :: StateT UrlState IO ()
waitNextUrl = do
  st <- get
  let l = pipeLength st
  when (l > 0) $ do
                dbg "URL.waitNextUrl start"
                (u, e) <- liftIO $ wait_next_url
                let p = inProgress st
                    new_st = st { inProgress = Map.delete u p
                                , pipeLength = l - 1 }
                liftIO $ if null e
                         then case Map.lookup u p of
                                Just (f, fs, _, v) -> do
                                  renameFile (f++"-new_"++randomJunk st) f
                                  mapM_ (safeCopyFile st f) fs
                                  putMVar v e
                                  debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f
                                Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u
                         else case Map.lookup u p of
                                Just (f, _, _, v) -> do
                                  removeFileMayNotExist (f++"-new_"++randomJunk st)
                                  putMVar v e
                                  debugMessage $ "URL.waitNextUrl failed: "++
                                               u++" "++f++" "++e
                                Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e
                unless (null u) $ put new_st
    where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st
                                in do copyFile f new_t
                                      renameFile new_t t

waitUrl :: String -> IO ()
waitUrl u = do debugMessage $ "URL.waitUrl "++u
               r <- withMVar urlNotifications (return . (Map.lookup u))
               case r of
                 Just var -> do
                        e <- readMVar var
                        modifyMVar_ urlNotifications (return . (Map.delete u))
                        unless (null e) (debugFail $ "Failed to download URL "++u++": "++e)
                 Nothing  -> return () -- file was already downloaded

dbg :: String -> StateT a IO ()
dbg = liftIO . debugMessage

minCachable :: Cachable -> Cachable -> Cachable
minCachable Uncachable _          = Uncachable
minCachable _          Uncachable = Uncachable
minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b
minCachable (MaxAge a) _          = MaxAge a
minCachable _          (MaxAge b) = MaxAge b
minCachable _          _          = Cachable

#ifdef HAVE_CURL
cachableToInt :: Cachable -> CInt
cachableToInt Cachable = -1
cachableToInt Uncachable = 0
cachableToInt (MaxAge n) = n
#endif

setHTTPPipelining :: Bool -> IO ()
setHTTPPipelining False = writeIORef maxPipeLength 1
setHTTPPipelining True = writeIORef maxPipeLength
#ifdef CURL_PIPELINING
    pipeliningLimit
#else
    1 >> (putStrLn $ "Warning: darcs is compiled without HTTP pipelining "++
                     "support, '--http-pipelining' argument is ignored.")
#endif

setDebugHTTP :: IO ()
request_url :: String -> FilePath -> Cachable -> IO String
wait_next_url :: IO (String, String)

#ifdef HAVE_CURL

setDebugHTTP = curl_enable_debug

request_url u f cache =
    withCString u $ \ustr ->
    withCString f $ \fstr -> do
      err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString
      return err

wait_next_url = do
  e <- curl_wait_next_url >>= peekCString
  u <- curl_last_url >>= peekCString
  return (u, e)

foreign import ccall "hscurl.h curl_request_url"
  curl_request_url :: CString -> CString -> CInt -> IO CString

foreign import ccall "hscurl.h curl_wait_next_url"
  curl_wait_next_url :: IO CString

foreign import ccall "hscurl.h curl_last_url"
  curl_last_url :: IO CString

foreign import ccall "hscurl.h curl_enable_debug"
  curl_enable_debug :: IO ()

#elif defined(HAVE_HTTP)

setDebugHTTP = return ()
request_url = HTTP.request_url
wait_next_url = HTTP.wait_next_url

#else

setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"
request_url _ _ _ = debugFail "URL.request_url: there is no libcurl!"
wait_next_url = debugFail "URL.wait_next_url: there is no libcurl!"

#endif

-- Usage of these environment variables happens in C code, so the
-- closest to "literate" user documentation is here, where the
-- offending function 'curl_request_url' is imported.
environmentHelpProxy :: ([String], [String])
environmentHelpProxy = (["HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY",
                         "ALL_PROXY", "NO_PROXY"], [
 "If Darcs was built with libcurl, the environment variables HTTP_PROXY,",
 "HTTPS_PROXY and FTP_PROXY can be set to the URL of a proxy in the form",
 "",
 "  [protocol://]<host>[:port]",
 "",
 "In which case libcurl will use the proxy for the associated protocol",
 "(HTTP, HTTPS and FTP).  The environment variable ALL_PROXY can be used",
 "to set a single proxy for all libcurl requests.",
 "",
 "If the environment variable NO_PROXY is a comma-separated list of host",
 "names, access to those hosts will bypass proxies defined by the above",
 "variables.  For example, it is quite common to avoid proxying requests",
 "to machines on the local network with",
 "",
 "  NO_PROXY=localhost,*.localdomain",
 "",
 "For compatibility with lynx et al, lowercase equivalents of these",
 "environment variables (e.g. $http_proxy) are also understood and are",
 "used in preference to the uppercase versions.",
 "",
 "If Darcs was not built with libcurl, all these environment variables",
 "are silently ignored, and there is no way to use a web proxy."])

environmentHelpProxyPassword :: ([String], [String])
environmentHelpProxyPassword = (["DARCS_PROXYUSERPWD"], [
 "If Darcs was built with libcurl, and you are using a web proxy that",
 "requires authentication, you can set the $DARCS_PROXYUSERPWD",
 "environment variable to the username and password expected by the",
 "proxy, separated by a colon.  This environment variable is silently",
 "ignored if Darcs was not built with libcurl."])