{-# OPTIONS_GHC -cpp -fffi #-}
module URL ( copyUrl, copyUrlFirst, waitUrl,
             Cachable(Cachable, Uncachable, MaxAge)
           ) where

import Data.IORef
import Data.Map ( Map )
import Data.List ( delete )
import qualified Data.Map as Map
import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad ( when )
import Autoconf ( have_libwww )
import Foreign.C.Types ( CInt )
import Foreign.C.String ( withCString, peekCString, CString )

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

#if !defined(HAVE_CURL) || !defined(HAVE_LIBWWW)
import Foreign.Ptr ( nullPtr )
#endif
#include "impossible.h"

data Cachable = Cachable | Uncachable | MaxAge !CInt deriving Eq

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

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 [] []

data Priority = High | Low deriving Eq

maxPipeLength :: Int
maxPipeLength = if have_libwww then 100
#ifdef CURL_PIPELINING
                               else 100
#else
                               else 1
#endif

urlState :: IORef UrlState
urlState = unsafePerformIO $ newIORef (UrlState Map.empty emptyQ 0)

copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()
copyUrlWithPriority prio url file c = do
  st <- readIORef urlState
  let p = inProgress st
      w = waitToStart st
      new_w = case prio of
                High -> pushQ (url, file, c) w
                Low  -> insertQ (url, file, c) w
      new_st = st { inProgress = Map.insert url file p,
                    waitToStart = new_w
                  }
  if Map.member url p
     then if prio == High && (url, file, c) `elemQ` w
          then do writeIORef urlState (st { waitToStart = pushQ (url, file, c) (deleteQ (url, file, c) w) })
                  debugMessage $ "Moving "++url++" to head of download queue."
                  checkWaitToStart
          else debugMessage "Ignoring copyUrlWithPriority of file that's already queued."
     else do writeIORef urlState new_st
             checkWaitToStart

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

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

waitNextUrl :: IO (String, Maybe String)
waitNextUrl = do st <- readIORef urlState
                 let l = pipeLength st
                 if l > 0
                    then do err <- waitNextUrl'
                            url <- lastUrl'
                            let p = inProgress st
                                new_st = st { inProgress = Map.delete url p,
                                              pipeLength = l - 1
                                            }
                            if null err
                               then
                                 case Map.lookup url p of
                                 Just f -> do renameFile (f++"-new") f
                                              debugMessage $ "URL.waitNextUrl succeeded: "++url++" "++f
                                 Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++url
                               else when (not $ null url) $ case Map.lookup url p of
                                      Just f -> do removeFileMayNotExist (f++"-new")
                                                   debugMessage $ "URL.waitNextUrl failed: "++
                                                                url++" "++f++" "++err
                                      Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++url++" "++err
                            when (not $ null url) $ do
                              writeIORef urlState new_st
                              checkWaitToStart
                            return (url, if null err then Nothing else Just err)
                    else return ("", Nothing)
    where waitNextUrl' = do let fn = if have_libwww then libwww_wait_next_url
                                                    else curl_wait_next_url
                            err <- fn >>= peekCString
                            return err
          lastUrl' = let fn = if have_libwww then libwww_last_url
                                             else curl_last_url
                     in fn >>= peekCString

waitUrl :: String -> IO ()
waitUrl u = do st <- readIORef urlState
               when (u `Map.member` inProgress st) waitUrl'
               debugMessage ("URL.waitUrl "++u++" succeeded")
    where waitUrl' = do (url, merr) <- waitNextUrl
                        if u /= url
                           then waitUrl'
                           else case merr of
                                Just err -> debugFail $ "Failed to download URL "++url++": "++err
                                Nothing -> return ()

checkWaitToStart :: IO ()
checkWaitToStart = do st <- readIORef urlState
                      let l = pipeLength st
                      when (l < maxPipeLength) $
                           do let w = waitToStart st
                              case readQ w of
                                Just ((u,f,c),rest) -> do
                                       let new_st = st { waitToStart = rest,
                                                         pipeLength = l + 1
                                                       }
                                       writeIORef urlState new_st
                                       err <- copyUrl' u f c
                                       when (not $ null err) (debugFail $ "Failed to start download URL "
                                                                     ++u++": "++err)
                                       checkWaitToStart
                                _ -> return ()
    where copyUrl' u f cache = withCString u $ \ustr ->
                               withCString (f++"-new") $ \fstr -> do
                               atexit $ removeFileMayNotExist (f++"-new")
                               debugMessage ("URL.copyUrl ("++u++"\n"++
                                             "          -> "++f++")")
                               let fn = if have_libwww then libwww_request_url
                                                       else curl_request_url
                               err <- fn ustr fstr (cachableToInt cache) >>= peekCString
                               when (null err) (debugMessage "URL.copyUrl succeeded")
                               return err

cachableToInt :: Cachable -> CInt
cachableToInt Cachable = -1
cachableToInt Uncachable = 0
cachableToInt (MaxAge n) = n

#ifdef HAVE_CURL
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
#else
no_curl :: IO ()
no_curl = debugFail "There is no libcurl!"

curl_request_url :: CString -> CString -> CInt -> IO CString
curl_request_url _ _ _ = no_curl >> return nullPtr

curl_wait_next_url :: IO CString
curl_wait_next_url = no_curl >> return nullPtr

curl_last_url :: IO CString
curl_last_url = no_curl >> return nullPtr
#endif

#ifdef HAVE_LIBWWW
foreign import ccall "hslibwww.h libwww_request_url"
  libwww_request_url :: CString -> CString -> CInt -> IO CString

foreign import ccall "hslibwww.h libwww_wait_next_url"
  libwww_wait_next_url :: IO CString

foreign import ccall "hslibwww.h libwww_last_url"
  libwww_last_url :: IO CString
#else
no_libwww :: IO ()
no_libwww = debugFail "There is no libwww!"

libwww_request_url :: CString -> CString -> CInt -> IO CString
libwww_request_url _ _ _ = no_libwww >> return nullPtr

libwww_wait_next_url :: IO CString
libwww_wait_next_url = no_libwww >> return nullPtr

libwww_last_url :: IO CString
libwww_last_url = no_libwww >> return nullPtr
#endif