{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-name-shadowing #-}
-- |an interface for using the methods in /var/lib/apt/methods
module Debian.Apt.Methods
    ( withMethodPath
    , withMethodURI
    , whichMethodPath
    , openMethod
    , closeMethod
    , recvStatus
    , sendCommand
    , getLastModified
    , simpleFetch
    , fetch
    , FetchCallbacks(..)
    , emptyFetchCallbacks
    , cliFetchCallbacks
    , Command(..)
    , Status(..)
    , Message, Site, User, Password, Media, Drive, Header, ConfigItem
    )
    where

import Debian.Time
import Debian.URI

import Control.Exception
import Control.Monad.Error
import Data.Maybe
import Data.Time
import System.Directory
import System.Exit
import System.IO
import System.Posix.Files
import System.Process

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

capabilities, logMsg, status, uriStart, uriDone, uriFailure, generalFailure, authorizationRequired, mediaFailure, uriAcquire, configuration, authorizationCredentials, mediaChanged :: String
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"

type Message = String
type Site = String
type User = String
type Password = String
type Media = String
type Drive = String

data Status
    = Capabilities { version :: String, singleInstance :: Bool, preScan :: Bool, pipeline :: Bool, sendConfig :: Bool
                   , needsCleanup :: Bool, localOnly :: Bool }
    | LogMsg Message
    | Status URI Message
    | URIStart { uri :: URI, size :: Maybe Integer, lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer }
    | URIDone { uri :: URI, size :: Maybe Integer,  lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer
              , filename :: Maybe FilePath, hashes :: Hashes, imsHit :: Bool }
    | URIFailure { uri :: URI, message :: Message }
    | GeneralFailure Message
    | AuthorizationRequired Site
    | MediaFailure Media Drive
      deriving (Show, Eq)

data Hashes 
    = Hashes { md5 :: Maybe String
             , sha1 :: Maybe String
             , sha256 :: Maybe String
             }
      deriving (Show, Eq)

emptyHashes = Hashes Nothing Nothing Nothing

data Command
    = URIAcquire URI FilePath (Maybe UTCTime)
    | Configuration [ConfigItem]
    | AuthorizationCredentials Site User Password
    | MediaChanged Media (Maybe Bool) -- I don't really understand the Fail field, I am assuming it is 'Fail: true'
      deriving (Show, Eq)

type Header = (String, String)
type ConfigItem = (String, String)

withMethodURI :: URI -> (MethodHandle -> IO a) -> IO a
withMethodURI uri f =
    do  mp <- liftM fromJust (whichMethodPath uri)
        withMethodPath mp f

-- |withMethod - run |methodPath| bracketed with
-- openMethod\/closeMethod. |f| gets the open handle.
withMethodPath :: FilePath -> (MethodHandle -> IO a) -> IO a
withMethodPath methodPath f =
    bracket (openMethod methodPath) closeMethod $ f

-- |whichMethodBinary - find the method executable associated with a URI
-- throws an exception on failure
whichMethodPath :: URI -> IO (Maybe FilePath)
whichMethodPath uri = 
    let scheme = init (uriScheme uri)
        path = "/usr/lib/apt/methods/" ++ scheme
    in
      doesFileExist path >>= return . bool Nothing (Just path)

{-
The flow of messages starts with the method sending out a 
100 Capabilities and APT sending out a 601 Configuration.

The flow is largely unsynchronized, but our function may have to
respond to things like authorization requests. Perhaps we do a
recvContents and then mapM_ over that ? Not all incoming messages
require a response, so...

-}

parseStatus :: [String] -> Status
parseStatus (code' : headers') =
    parseStatus' (take 3 code') (map parseHeader headers')
    where
      parseStatus' code headers
          | code == capabilities =
              foldr updateCapability defaultCapabilities headers
                  where
                    updateCapability (a,v) c
                        | a == "Version"         = c { version = v }
                        | a == "Single-Instance" = c { singleInstance = parseTrueFalse v }
                        | a == "Pre-Scan"        = c { preScan = parseTrueFalse v }
                        | a == "Pipeline"        = c { pipeline = parseTrueFalse v }
                        | a == "Send-Config"     = c { sendConfig = parseTrueFalse v }
                        | a == "Needs-Cleanup"   = c { needsCleanup = parseTrueFalse v }
                        | a == "Local-Only"	 = c { localOnly = parseTrueFalse v }
                        | otherwise = error $ "unknown capability: " ++ show (a,v)
                    defaultCapabilities = 
                        Capabilities { version = ""
                                     , singleInstance = False
                                     , preScan 	      = False 
                                     , pipeline	      = False
                                     , sendConfig     = False
                                     , needsCleanup   = False
                                     , localOnly      = False
                                     }
      parseStatus' code headers
          | code == logMsg =
              case headers of
                [("Message", msg)] -> LogMsg msg
          | code == status =
                Status (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers)
          | code == uriStart =
              foldr updateUriStart (URIStart undefined Nothing Nothing Nothing) headers
                  where
                    updateUriStart (a,v) u
                        | a == "URI" = u { uri = fromJust $ parseURI v }
                        | a == "Size" = u { size = Just (read v) }
                        | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ?
                        | a == "Resume-Point" = u { resumePoint = Just (read v) }
      parseStatus' code headers
          | code == uriDone =
              foldr updateUriDone (URIDone undefined Nothing Nothing Nothing Nothing emptyHashes False) headers
                  where
                    updateUriDone (a,v) u
                        | a == "URI" = u { uri = fromJust $ parseURI v }
                        | a == "Size" = u { size = Just (read v) }
                        | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ?
                        | a == "Filename" = u { filename = Just v }
                        | a == "MD5Sum-Hash" = u { hashes = (hashes u) { md5    = Just v } }
                        | a == "MD5-Hash" = u { hashes = (hashes u) { md5    = Just v } }
                        | a == "SHA1-Hash"   = u { hashes = (hashes u) { sha1   = Just v } }
                        | a == "SHA256-Hash" = u { hashes = (hashes u) { sha256 = Just v } }
                        | a == "Resume-Point" = u { resumePoint = Just (read v) }
                        | a == "IMS-Hit" && v == "true" = u { imsHit = True }
                        | otherwise = error $ "updateUriDone: unknown header: " ++ show (a,v)
      parseStatus' code headers
          | code == uriFailure =
              URIFailure (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers)
          | code == generalFailure =
              GeneralFailure (fromJust $ lookup "Message" headers)
          | code == authorizationRequired = 
              AuthorizationRequired (fromJust $ lookup "Site" headers)
          | code == mediaFailure =
              MediaFailure (fromJust $ lookup "Media" headers) (fromJust $ lookup "Drive" headers)


formatCommand :: Command -> [String]
formatCommand (URIAcquire uri filepath mLastModified) =
    [ uriAcquire ++ " URI Acquire"
    , "URI: " ++ uriToString' uri -- will this get credentials correct ? Or do we always pass those in seperately
    , "FileName: " ++ filepath
    ] ++ maybe [] (\lm -> ["Last-Modified: " ++ formatTimeRFC822 lm ]) mLastModified
formatCommand (Configuration configItems) =
    (configuration ++ " Configuration") : (map formatConfigItem configItems) 
    where
      formatConfigItem (a,v) = concat ["Config-Item: ", a, "=", v]
formatCommand (AuthorizationCredentials site user passwd) =
    (authorizationCredentials ++ " Authorization Credentials") :
    [ "Site: " ++ site
    , "User: " ++ user
    , "Password: " ++ passwd
    ]
formatCommand (MediaChanged media mFail) =
    [ mediaChanged ++ " Media Changed"
    , "Media: " ++ media
    ] ++ maybe [] (\b -> ["Fail: " ++ case b of True -> "true" ; False -> "false"]) mFail
      

parseTrueFalse :: String -> Bool
parseTrueFalse "true" = True
parseTrueFalse "false" = False
parseTrueFalse s = error $ "Invalid boolean string: " ++ s


recvStatus :: MethodHandle -> IO Status
recvStatus mh = liftM parseStatus $ recv mh

sendCommand :: MethodHandle -> Command -> IO ()
sendCommand mh cmd = sendMethod mh (formatCommand cmd)


parseHeader :: String -> Header
parseHeader str =
    let (a, r) = span (/= ':') str
        v = dropWhile (flip elem ": \t") r
    in 
      (a, v)
       
openMethod :: FilePath -> IO MethodHandle
openMethod methodBinary =
    do
      -- hPutStrLn stderr ("openMethod " ++ methodBinary)
      runInteractiveCommand methodBinary
      -- runInteractiveProcess methodBinary [] Nothing Nothing

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

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

recv :: MethodHandle -> IO [String]
recv (_pIn, pOut, _pErr, _pHandle) =
    do
      -- hPutStrLn stderr "recv:"
      readTillEmptyLine pOut
    where
      readTillEmptyLine pOut =
          do
            line <- hGetLine pOut
            case line of
              "" -> return []
              line -> 
                  do
                    -- hPutStrLn stderr ("  " ++ line)
                    tail <- readTillEmptyLine pOut
                    return $ line : tail
{-
The flow of messages starts with the method sending out a 
<em>100 Capabilities</> and APT sending out a <em>601 Configuration</>.

The flow is largely unsynchronized, but our function may have to
respond to things like authorization requests. Perhaps we do a
recvContents and then mapM_ over that ? Not all incoming messages
require a response. 

We probably also need to track state, for example, if we are
pipelining multiple downloads and want to show seperate progress bars
for each download.

If someone wants to use fetch, they will need to provide methods to:

 1. prompt for and provide authentication
 2. show progress
 3. show media change dialog
 4. Show log messages
 5. Show failures
 6. Send Configuration

pipeline vs non-pipeline mode.
what if different methods are being used ?

when pipelining, we probably don't want to have too many pipelines to
the same server. Perhaps there can be a limit, and for non-pipelinable
methods, we set the limit to 1.

Each method can run in a seperate thread, since methods do not
interact with each other. In fact, each unique method+uri can be a
seperate thread. We can use a MVar to track the global max download
count. Perhaps we also want a per host throttle, since it is the host
connect that is likely to max out, not the access method.

Plan:

partition fetches by (host,method).
fork off threads for each (host, method).
Use MVar to throttle per host, and total connections

We don't know if a method supports pipelining until we connect atleast
once. So if we have a non-pipelined method, we might want to start
multiple streams. On the other hand, for something like a CDROM, that
will just cause the system to thrash.

cdrom, file, etc, don't have a host, so that is not a unique key then.
Pipelining on local methods is tricky, because it is hard to tell if
the local methods point to the same device or not.

Even though we have multiple threads, the interactor can view the
incoming Stream as a single Stream because all the events are tagged
with the URI (i think). But, sending commands involves a fancy
router. We could include a reference to corresponding command for each
stream.

For now, let's serialize the transfers, but allow pipeling for methods
that really allow pipelining.

-}

data FetchCallbacks 
    = FetchCallbacks { logCB :: Message ->  IO ()
                     , statusCB :: URI -> Message -> IO ()
                     , uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()
                     , uriDoneCB ::  URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Maybe FilePath -> Hashes -> Bool -> IO ()
                     , uriFailureCB :: URI -> Message -> IO ()
                     , generalFailureCB :: Message -> IO ()
                     , authorizationRequiredCB :: Site -> IO (Maybe (User, Password))
                     , mediaFailureCB :: Media -> Drive -> IO ()
                     , debugCB :: String -> IO ()
                     }

simpleFetch :: [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool
simpleFetch = fetch cliFetchCallbacks

-- |fetch a single item, show console output
-- see also: getLastModified
fetch :: FetchCallbacks -> [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool
fetch cb configItems uri fp lastModified =
    do withMethodURI uri $ \mh ->
        do s <- recvStatus mh
           debugCB cb ("<- " ++ show s)
           sendCommand' mh (URIAcquire uri fp lastModified)
           loop mh
    where
      sendCommand' mh c =
          do mapM_ (debugCB cb . ("-> " ++)) (formatCommand c)
             sendCommand mh c
      loop mh =
          do r <- recvStatus mh
             case r of
               Capabilities {} ->
                   do unless (null configItems) (sendCommand' mh (Configuration configItems))
                      loop mh
               LogMsg m -> 
                   do logCB cb m
                      loop mh
               Status uri m -> 
                   do statusCB cb uri m
                      loop mh
               URIStart uri size lastModified resumePoint -> 
                   uriStartCB cb uri size lastModified resumePoint >> loop mh
               URIDone uri size lastModified resumePoint filename hashes imsHit ->
                   uriDoneCB cb uri size lastModified resumePoint filename hashes imsHit >> return True
               URIFailure uri message ->
                   uriFailureCB cb uri message >> return False
               GeneralFailure m -> generalFailureCB cb m >> return False
               AuthorizationRequired site -> 
                   do mCredentials <- authorizationRequiredCB cb site
                      case mCredentials of
                        Nothing -> return False -- FIXME: do we need a force close option for closeMethod ?
                        Just (user, passwd) -> 
                            do sendCommand' mh (AuthorizationCredentials site user passwd)
                               loop mh
               MediaFailure media drive ->
                    do mediaFailureCB cb media drive
                       return False

-- |set of callbacks which do nothing.
-- suitable for non-interactive usage. In the case authorization is
-- required, no credentials will be supplied and the download should
-- abort.
emptyFetchCallbacks =
    FetchCallbacks { logCB = \ _m -> return ()
                   , statusCB = \ _uri _m -> return ()
                   , uriStartCB = \ _uri _size _lastModified _resumePoint -> return ()
                   , uriDoneCB = \ _uri _size _lastModified _resumePoint _filename _hashes _imsHit -> return ()
                   , uriFailureCB = \ _uri _message -> return ()
                   , generalFailureCB = \ _m -> return ()
                   , authorizationRequiredCB = \ _site -> return Nothing
                   , mediaFailureCB = \ _media _drive -> return ()
                   , debugCB = \ _m -> return ()
                   }

cliFetchCallbacks =
    emptyFetchCallbacks { statusCB = \uri m -> putStrLn $ uriToString' uri ++ " : " ++ m
                        , uriStartCB = \ uri _size lastModified _resumePoint -> putStrLn $ uriToString' uri ++ " started. " ++ show lastModified
                        , uriDoneCB = \uri _size _lastModified _resumePoint _filename _hashes imsHit -> putStrLn $ uriToString' uri ++ (if imsHit then " cached." else " downloaded.")
                        , uriFailureCB = \uri message -> hPutStrLn stderr $ "URI Failure: " ++ uriToString' uri ++ " : " ++ message
                        , generalFailureCB = \message -> hPutStrLn stderr $ "General Failure: " ++ message
                        , authorizationRequiredCB = \site ->
                                                    do putStrLn $ "Authorization Required for " ++ site
                                                       putStrLn "Username: " >> hFlush stdout
                                                       user <- getLine
                                                       putStrLn "Password: " >> hFlush stdout
                                                       passwd <- getLine -- TODO: write a getPasswd function which does not echo input
                                                       return (Just (user, passwd))
                        , mediaFailureCB = \media drive -> hPutStrLn stderr $ "Media Failure: media=" ++ media ++" drive="++ drive
                        , debugCB = \m -> print m
                        }

{-
    FetchCallbacks { logCB = \m -> hPutStrLn stderr m
                   , statusCB = \uri m -> putStrLn (show uri ++" : "++ m)
                   , uriStartCB = \uri 
                   }

defaultAuthenticate site =
    do putStrLn $ "Authorization Required for " ++ site
       putStrLn "Username: " >> hFlush stdout
       user <- getLine
       putStrLn "Password: " >> hFlush stdout
       passwd <- getLine -- TODO: write a getPasswd function which does not echo input
       return (user, passwd)
-}

{-
    let itemsByHost = groupOn (regName . fst) items
    in
      do totalQSem <- newQSem 16 -- max number of streams allowed for 
         forkIO 
    where
      regName = fmap uriRegName . uriAuthority
      withQSem :: QSem -> IO a -> IO a
      withQSem qSem f = bracket (waitQSem qSem) (const $ signalQSem qSem) (const f)

uris = map (fromJust . parseURI) [ "http://n-heptane.com/whee"
                                 , "file:/one/two/three"
                                 , "ssh://jeremy:aoeu@n-heptane.com"
                                 , "cdrom:/one"
                                 ]
-}    

-- * Misc Helper Functions

bool :: a -> a -> Bool -> a
bool f _ False = f
bool _ t True = t


getLastModified :: FilePath -> IO (Maybe UTCTime)
getLastModified fp =
    do e <- doesFileExist fp
       if e
          then getFileStatus fp >>= return . Just . epochTimeToUTCTime . modificationTime
          else return Nothing

{-
groupOn :: (Ord b) => (a -> b) -> [a] -> [[a]]
groupOn f = groupBy ((==) `on` f) . sortBy (compare `on` f)

on :: (a -> a -> b) -> (c -> a) -> c -> c -> b
on f g x y = f (g x) (g y)
-}