module AptMethod 
    (fetch)
    where

import Data.List
import Network.URI
import System.Cmd
import System.Directory
import System.Exit
import System.IO
import System.Locale
import System.Posix.Files
import System.Posix.Types
import System.Process
import System.Time

type MethodHandle = (Handle, Handle, Handle, ProcessHandle)

logNormal s = hPutStrLn stderr s

capabilities = "100"
logMsg = "101"
status = "102"
uriStart = "200"
uriDone = "201"
uriFailure = "400"
generalFailure = "401"
authorizationRequired = "402"
mediaFailure = "403"
uriAcquire = "600"
configuration = "601"
authorizationCredentials = "602"
mediaChanged = "603"

-- |[fetch uri filename] downloads [uri] to a local file named [filename] 
fetch :: Bool -> URI -> FilePath -> IO ()
fetch allowMissing uri filename =
    do
      ePut ("--> " ++ uriToString id uri "")
      ePut ("  -> " ++ filename)
      methodBinary <-
          doesFileExist methodBinary >>=
          bool (error ("Invalid apt method: " ++ methodBinary)) (return methodBinary)
      modTime <- doesFileExist filename >>=
                 bool (return Nothing) (getFileStatus filename >>= return . Just . clockTime . modificationTime)
      methodHandle <- openMethod methodBinary
      printStatus allowMissing methodHandle
      -- Debian's server has magic that lets it return the .gz file
      -- when you request the uncompressed file, but Ubuntu's doesn't.
      -- That is why I appended ".gz" to the url here.
      sendMethod methodHandle ([uriAcquire,
                                "URI: " ++ uriToString id uri "" ++ ".gz",
                                "Filename: " ++ filenamegz] ++
                               maybe [] (\ t -> ["Last-Modified: " ++ formatTimeRFC822 t]) modTime)
      -- printStatus should return a filename which is where the file was
      -- written.  This will usually match filenamegz, but for the file
      -- method it will just be the path in the uri.
      filename' <- printStatus allowMissing methodHandle
      ePut ("filename': " ++ show filename')
      closeMethod methodHandle
      -- We don't yet know whether the file needs to be uncompressed, even
      -- if has has the gz extension.  We just told it to use that.
      install filename filename'
    where
      -- A file was downloaded and needs to be installed
      install dst (Just src) =
          do
            ePut ("install " ++ dst ++ " <- " ++ src)
            doesFileExist dst >>= bool (return ()) (removeFile dst)
            if src == (dst ++ ".gz") then
                testExit ("gunzip '" ++ src ++ "' || mv '" ++ src ++ "' '" ++ dst ++ "'") else
                testExit ("gunzip -f < '" ++ src ++ "' > '" ++ dst ++ "'")
      -- Download failed, install an empty file.
      install dst Nothing =
          do
            ePut ("touch " ++ dst)
            doesFileExist dst >>= bool (return ()) (removeFile dst)
            writeFile dst ""
      filenamegz = filename ++ ".gz"
      methodBinary = "/usr/lib/apt/methods/" ++ dropTail (uriScheme uri)
      clockTime :: System.Posix.Types.EpochTime -> ClockTime
      clockTime t = TOD (toInteger (fromEnum t)) 0
      dropTail = reverse . drop 1 . reverse

formatTimeRFC822 :: ClockTime -> String
formatTimeRFC822 t = formatCalendarTime defaultTimeLocale rfc822DateFormat (toUTCTime t)

printStatus :: Bool -> MethodHandle -> IO (Maybe FilePath)
printStatus allowMissing methodHandle =
    do
      input <- recv methodHandle
      case input of
        (code : fields) ->
            case take 3 code of
              "100" -> return Nothing
              "101" -> do
                   mapM_ (logNormal . (++ "\n")) input
                   printStatus allowMissing methodHandle
              "102" -> printStatus allowMissing methodHandle
              "200" -> printStatus allowMissing methodHandle
              "201" -> 
                  case filter (== "IMS-Hit: true") fields of
                    [] ->
                        case filter (isPrefixOf "Filename: ") fields of
                          [field] -> return (Just (drop (length "Filename: ") field))
                          [] -> error "uriDone message has no Filename: field"
                          fields -> error ("uriDone message has multiple Filename:\n" ++ unlines fields)
                    _ -> return Nothing	-- Up to date
              -- An empty or non-existant index file will cause this error.
              "400" ->
                  if allowMissing then return Nothing else error ("Unexpected message:\n" ++ unlines (code : fields))
              _ -> error ("Unexpected message:\n" ++ unlines (code : fields))
        _ -> error ("Unexpected message:\n" ++ unlines input)

openMethod :: FilePath -> IO MethodHandle
openMethod methodBinary =
    do
      ePut ("openMethod " ++ methodBinary)
      runInteractiveCommand methodBinary
      -- runInteractiveProcess methodBinary [] Nothing Nothing

sendMethod :: MethodHandle -> [String] -> IO ()
sendMethod (pIn, pOut, _, _) strings =
    do
      ePut "send:"
      mapM_ put strings
      hPutStrLn pIn ""
      hFlush pIn
    where
      put line = 
          do
            ePut ("  " ++ line)
            hPutStrLn pIn line

closeMethod :: MethodHandle -> IO ExitCode
closeMethod (pIn, pOut, pErr, handle) =
    do
      ePut "closeMethod"
      hClose pIn
      hClose pOut
      hClose pErr
      waitForProcess handle

recv :: MethodHandle -> IO [String]
recv (pIn, pOut, pErr, pHandle) =
    do
      ePut "recv:"
      readTillEmptyLine pOut
    where
      readTillEmptyLine pOut =
          do
            line <- hGetLine pOut
            case line of
              "" -> return []
              line -> 
                  do
                    ePut ("  " ++ line)
                    tail <- readTillEmptyLine pOut
                    return $ line : tail
    
bool :: a -> a -> Bool -> a
bool f _ False = f
bool _ t True = t

-- ePut s = hPutStrLn stderr s
ePut s = return ()

{-
let fetch uri filename = 
  let method_binary = 
    let method_binary = "/usr/lib/apt/methods/" ^/^ (Neturl.url_scheme uri) in
      if (not (Unixutils.exists method_binary)) then
	raise (Invalid_method (Neturl.url_scheme uri))
      else
	method_binary
  in
  let method_handle = open_method method_binary in
  let filenamegz = filename ^ ".gz" in
  let _ =
    print_status method_handle ;
    send method_handle ([ string_of_int (uri_aquire)
			; "URI: " ^ (Neturl.string_of_url uri)
			; "Filename: " ^ filenamegz
			] @ (try
			       let st = Unix.stat filenamegz in
				 ["Last-Modified: " ^ (format_time_rfc822 st.Unix.st_mtime)]
			     with
				 Unix.Unix_error (_,_,_) -> []
			    ));
    print_status method_handle ;
    close_method method_handle
  in
    command ("gunzip " ^ filenamegz)
-}

command :: String -> IO ()
command cmd =
    do
      hPutStrLn stderr ("--> " ++ cmd)
      result <- system cmd
      case result of
        ExitSuccess -> return ()
        ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n)

testExit :: String -> IO ()
testExit cmd =
    do
      result <- system cmd
      case result of
        ExitSuccess -> return ()
        ExitFailure n -> error ("Failure: " ++ cmd ++ " -> " ++ show n)