{-# LANGUAGE PackageImports #-}
{-# 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 (URI(..), parseURI, uriToString')

import Control.Exception
import Control.Monad (liftM, unless)
import Control.Monad.Except
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 :: String
capabilities = String
"100"
logMsg :: String
logMsg = String
"101"
status :: String
status = String
"102"
uriStart :: String
uriStart = String
"200"
uriDone :: String
uriDone = String
"201"
uriFailure :: String
uriFailure = String
"400"
generalFailure :: String
generalFailure = String
"401"
authorizationRequired :: String
authorizationRequired = String
"402"
mediaFailure :: String
mediaFailure = String
"403"
uriAcquire :: String
uriAcquire = String
"600"
configuration :: String
configuration = String
"601"
authorizationCredentials :: String
authorizationCredentials = String
"602"
mediaChanged :: String
mediaChanged = String
"603"

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

data Status
    = Capabilities { Status -> String
version :: String, Status -> Bool
singleInstance :: Bool, Status -> Bool
preScan :: Bool, Status -> Bool
pipeline :: Bool, Status -> Bool
sendConfig :: Bool
                   , Status -> Bool
needsCleanup :: Bool, Status -> Bool
localOnly :: Bool }
    | LogMsg Message
    | Status URI Message
    | URIStart { Status -> URI
uri :: URI, Status -> Maybe Integer
size :: Maybe Integer, Status -> Maybe UTCTime
lastModified :: Maybe UTCTime, Status -> Maybe Integer
resumePoint :: Maybe Integer }
    | URIDone { uri :: URI, size :: Maybe Integer,  lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer
              , Status -> Maybe String
filename :: Maybe FilePath, Status -> Hashes
hashes :: Hashes, Status -> Bool
imsHit :: Bool }
    | URIFailure { uri :: URI, Status -> String
message :: Message }
    | GeneralFailure Message
    | AuthorizationRequired Site
    | MediaFailure Media Drive
      deriving (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, Status -> Status -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq)

data Hashes
    = Hashes { Hashes -> Maybe String
md5 :: Maybe String
             , Hashes -> Maybe String
sha1 :: Maybe String
             , Hashes -> Maybe String
sha256 :: Maybe String
             }
      deriving (Int -> Hashes -> ShowS
[Hashes] -> ShowS
Hashes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hashes] -> ShowS
$cshowList :: [Hashes] -> ShowS
show :: Hashes -> String
$cshow :: Hashes -> String
showsPrec :: Int -> Hashes -> ShowS
$cshowsPrec :: Int -> Hashes -> ShowS
Show, Hashes -> Hashes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hashes -> Hashes -> Bool
$c/= :: Hashes -> Hashes -> Bool
== :: Hashes -> Hashes -> Bool
$c== :: Hashes -> Hashes -> Bool
Eq)

emptyHashes :: Hashes
emptyHashes = Maybe String -> Maybe String -> Maybe String -> Hashes
Hashes forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
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 (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, Command -> Command -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq)

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

withMethodURI :: URI -> (MethodHandle -> IO a) -> IO a
withMethodURI :: forall a. URI -> (MethodHandle -> IO a) -> IO a
withMethodURI URI
uri MethodHandle -> IO a
f =
    do  String
mp <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. HasCallStack => Maybe a -> a
fromJust (URI -> IO (Maybe String)
whichMethodPath URI
uri)
        forall a. String -> (MethodHandle -> IO a) -> IO a
withMethodPath String
mp MethodHandle -> IO a
f

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

-- |whichMethodBinary - find the method executable associated with a URI
-- throws an exception on failure
whichMethodPath :: URI -> IO (Maybe FilePath)
whichMethodPath :: URI -> IO (Maybe String)
whichMethodPath URI
uri =
    let scheme :: String
scheme = forall a. [a] -> [a]
init (URI -> String
uriScheme URI
uri)
        path :: String
path = String
"/usr/lib/apt/methods/" forall a. [a] -> [a] -> [a]
++ String
scheme
    in
      String -> IO Bool
doesFileExist String
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
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 :: [String] -> Status
parseStatus [] = forall a. HasCallStack => String -> a
error String
"parseStatus"
parseStatus (String
code' : [String]
headers') =
    String -> [ConfigItem] -> Status
parseStatus' (forall a. Int -> [a] -> [a]
take Int
3 String
code') (forall a b. (a -> b) -> [a] -> [b]
map String -> ConfigItem
parseHeader [String]
headers')
    where
      parseStatus' :: String -> [ConfigItem] -> Status
parseStatus' String
code [ConfigItem]
headers
          | String
code forall a. Eq a => a -> a -> Bool
== String
capabilities =
              forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ConfigItem -> Status -> Status
updateCapability Status
defaultCapabilities [ConfigItem]
headers
                  where
                    updateCapability :: ConfigItem -> Status -> Status
updateCapability (String
a,String
v) Status
c
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Version"         = Status
c { version :: String
version = String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Single-Instance" = Status
c { singleInstance :: Bool
singleInstance = String -> Bool
parseTrueFalse String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Pre-Scan"        = Status
c { preScan :: Bool
preScan = String -> Bool
parseTrueFalse String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Pipeline"        = Status
c { pipeline :: Bool
pipeline = String -> Bool
parseTrueFalse String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Send-Config"     = Status
c { sendConfig :: Bool
sendConfig = String -> Bool
parseTrueFalse String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Needs-Cleanup"   = Status
c { needsCleanup :: Bool
needsCleanup = String -> Bool
parseTrueFalse String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Local-Only"      = Status
c { localOnly :: Bool
localOnly = String -> Bool
parseTrueFalse String
v }
                        | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unknown capability: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
a,String
v)
                    defaultCapabilities :: Status
defaultCapabilities =
                        Capabilities { version :: String
version = String
""
                                     , singleInstance :: Bool
singleInstance = Bool
False
                                     , preScan :: Bool
preScan        = Bool
False
                                     , pipeline :: Bool
pipeline       = Bool
False
                                     , sendConfig :: Bool
sendConfig     = Bool
False
                                     , needsCleanup :: Bool
needsCleanup   = Bool
False
                                     , localOnly :: Bool
localOnly      = Bool
False
                                     }
      parseStatus' String
code [ConfigItem]
headers
          | String
code forall a. Eq a => a -> a -> Bool
== String
logMsg =
              case [ConfigItem]
headers of
                [(String
"Message", String
msg)] -> String -> Status
LogMsg String
msg
                [ConfigItem]
_ -> forall a. HasCallStack => String -> a
error String
"parseStatus'"
          | String
code forall a. Eq a => a -> a -> Bool
== String
status =
                URI -> String -> Status
Status (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"URI" [ConfigItem]
headers) (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [ConfigItem]
headers)
          | String
code forall a. Eq a => a -> a -> Bool
== String
uriStart =
              forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ConfigItem -> Status -> Status
updateUriStart (URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Status
URIStart forall a. HasCallStack => a
undefined forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing) [ConfigItem]
headers
                  where
                    updateUriStart :: ConfigItem -> Status -> Status
updateUriStart (String
a,String
v) Status
u
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"URI" = Status
u { uri :: URI
uri = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Size" = Status
u { size :: Maybe Integer
size = forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
v) }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Last-Modified" = Status
u { lastModified :: Maybe UTCTime
lastModified = forall t. ParseTime t => String -> Maybe t
parseTimeRFC822 String
v } -- if the date is unparseable, we silently truncate. Is that bad ?
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Resume-Point" = Status
u { resumePoint :: Maybe Integer
resumePoint = forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
v) }
                    updateUriStart ConfigItem
_ Status
_ = forall a. HasCallStack => String -> a
error String
"updateUriStart"
      parseStatus' String
code [ConfigItem]
headers
          | String
code forall a. Eq a => a -> a -> Bool
== String
uriDone =
              forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ConfigItem -> Status -> Status
updateUriDone (URI
-> Maybe Integer
-> Maybe UTCTime
-> Maybe Integer
-> Maybe String
-> Hashes
-> Bool
-> Status
URIDone forall a. HasCallStack => a
undefined forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing Hashes
emptyHashes Bool
False) [ConfigItem]
headers
                  where
                    updateUriDone :: ConfigItem -> Status -> Status
updateUriDone (String
a,String
v) Status
u
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"URI" = Status
u { uri :: URI
uri = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Size" = Status
u { size :: Maybe Integer
size = forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
v) }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Last-Modified" = Status
u { lastModified :: Maybe UTCTime
lastModified = forall t. ParseTime t => String -> Maybe t
parseTimeRFC822 String
v } -- if the date is unparseable, we silently truncate. Is that bad ?
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Filename" = Status
u { filename :: Maybe String
filename = forall a. a -> Maybe a
Just String
v }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"MD5Sum-Hash" = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { md5 :: Maybe String
md5    = forall a. a -> Maybe a
Just String
v } }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"MD5-Hash" = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { md5 :: Maybe String
md5    = forall a. a -> Maybe a
Just String
v } }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"SHA1-Hash"   = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { sha1 :: Maybe String
sha1   = forall a. a -> Maybe a
Just String
v } }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"SHA256-Hash" = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { sha256 :: Maybe String
sha256 = forall a. a -> Maybe a
Just String
v } }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"Resume-Point" = Status
u { resumePoint :: Maybe Integer
resumePoint = forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
v) }
                        | String
a forall a. Eq a => a -> a -> Bool
== String
"IMS-Hit" Bool -> Bool -> Bool
&& String
v forall a. Eq a => a -> a -> Bool
== String
"true" = Status
u { imsHit :: Bool
imsHit = Bool
True }
                        | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"updateUriDone: unknown header: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
a,String
v)
      parseStatus' String
code [ConfigItem]
headers
          | String
code forall a. Eq a => a -> a -> Bool
== String
uriFailure =
              URI -> String -> Status
URIFailure (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"URI" [ConfigItem]
headers) (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [ConfigItem]
headers)
          | String
code forall a. Eq a => a -> a -> Bool
== String
generalFailure =
              String -> Status
GeneralFailure (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [ConfigItem]
headers)
          | String
code forall a. Eq a => a -> a -> Bool
== String
authorizationRequired =
              String -> Status
AuthorizationRequired (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Site" [ConfigItem]
headers)
          | String
code forall a. Eq a => a -> a -> Bool
== String
mediaFailure =
              String -> String -> Status
MediaFailure (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Media" [ConfigItem]
headers) (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Drive" [ConfigItem]
headers)
      parseStatus' String
_ [ConfigItem]
_ = forall a. HasCallStack => String -> a
error String
"parseStatus'"

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


parseTrueFalse :: String -> Bool
parseTrueFalse :: String -> Bool
parseTrueFalse String
"true" = Bool
True
parseTrueFalse String
"false" = Bool
False
parseTrueFalse String
s = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid boolean string: " forall a. [a] -> [a] -> [a]
++ String
s


recvStatus :: MethodHandle -> IO Status
recvStatus :: MethodHandle -> IO Status
recvStatus MethodHandle
mh = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [String] -> Status
parseStatus forall a b. (a -> b) -> a -> b
$ MethodHandle -> IO [String]
recv MethodHandle
mh

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


parseHeader :: String -> Header
parseHeader :: String -> ConfigItem
parseHeader String
str =
    let (String
a, String
r) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
':') String
str
        v :: String
v = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
": \t") String
r
    in
      (String
a, String
v)

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

sendMethod :: MethodHandle -> [String] -> IO ()
sendMethod :: MethodHandle -> [String] -> IO ()
sendMethod (Handle
pIn, Handle
_pOut, Handle
_, ProcessHandle
_) [String]
strings =
    do
      -- hPutStrLn stderr "send:"
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
put [String]
strings
      Handle -> String -> IO ()
hPutStrLn Handle
pIn String
""
      Handle -> IO ()
hFlush Handle
pIn
    where
      put :: String -> IO ()
put String
line =
          do
            -- hPutStrLn stderr ("  " ++ line)
            Handle -> String -> IO ()
hPutStrLn Handle
pIn String
line

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

recv :: MethodHandle -> IO [String]
recv :: MethodHandle -> IO [String]
recv (Handle
_pIn, Handle
pOut, Handle
_pErr, ProcessHandle
_pHandle) =
    do
      -- hPutStrLn stderr "recv:"
      Handle -> IO [String]
readTillEmptyLine Handle
pOut
    where
      readTillEmptyLine :: Handle -> IO [String]
readTillEmptyLine Handle
pOut =
          do
            String
line <- Handle -> IO String
hGetLine Handle
pOut
            case String
line of
              String
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return []
              String
line ->
                  do
                    -- hPutStrLn stderr ("  " ++ line)
                    [String]
tail <- Handle -> IO [String]
readTillEmptyLine Handle
pOut
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
line forall a. a -> [a] -> [a]
: [String]
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 { FetchCallbacks -> String -> IO ()
logCB :: Message ->  IO ()
                     , FetchCallbacks -> URI -> String -> IO ()
statusCB :: URI -> Message -> IO ()
                     , FetchCallbacks
-> URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()
uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()
                     , FetchCallbacks
-> URI
-> Maybe Integer
-> Maybe UTCTime
-> Maybe Integer
-> Maybe String
-> Hashes
-> Bool
-> IO ()
uriDoneCB ::  URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Maybe FilePath -> Hashes -> Bool -> IO ()
                     , FetchCallbacks -> URI -> String -> IO ()
uriFailureCB :: URI -> Message -> IO ()
                     , FetchCallbacks -> String -> IO ()
generalFailureCB :: Message -> IO ()
                     , FetchCallbacks -> String -> IO (Maybe ConfigItem)
authorizationRequiredCB :: Site -> IO (Maybe (User, Password))
                     , FetchCallbacks -> String -> String -> IO ()
mediaFailureCB :: Media -> Drive -> IO ()
                     , FetchCallbacks -> String -> IO ()
debugCB :: String -> IO ()
                     }

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

-- |fetch a single item, show console output
-- see also: getLastModified
fetch :: FetchCallbacks -> [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool
fetch :: FetchCallbacks
-> [ConfigItem] -> URI -> String -> Maybe UTCTime -> IO Bool
fetch FetchCallbacks
cb [ConfigItem]
configItems URI
uri String
fp Maybe UTCTime
lastModified =
    do forall a. URI -> (MethodHandle -> IO a) -> IO a
withMethodURI URI
uri forall a b. (a -> b) -> a -> b
$ \MethodHandle
mh ->
        do Status
s <- MethodHandle -> IO Status
recvStatus MethodHandle
mh
           FetchCallbacks -> String -> IO ()
debugCB FetchCallbacks
cb (String
"<- " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Status
s)
           MethodHandle -> Command -> IO ()
sendCommand' MethodHandle
mh (URI -> String -> Maybe UTCTime -> Command
URIAcquire URI
uri String
fp Maybe UTCTime
lastModified)
           MethodHandle -> IO Bool
loop MethodHandle
mh
    where
      sendCommand' :: MethodHandle -> Command -> IO ()
sendCommand' MethodHandle
mh Command
c =
          do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FetchCallbacks -> String -> IO ()
debugCB FetchCallbacks
cb forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-> " forall a. [a] -> [a] -> [a]
++)) (Command -> [String]
formatCommand Command
c)
             MethodHandle -> Command -> IO ()
sendCommand MethodHandle
mh Command
c
      loop :: MethodHandle -> IO Bool
loop MethodHandle
mh =
          do Status
r <- MethodHandle -> IO Status
recvStatus MethodHandle
mh
             case Status
r of
               Capabilities {} ->
                   do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConfigItem]
configItems) (MethodHandle -> Command -> IO ()
sendCommand' MethodHandle
mh ([ConfigItem] -> Command
Configuration [ConfigItem]
configItems))
                      MethodHandle -> IO Bool
loop MethodHandle
mh
               LogMsg String
m ->
                   do FetchCallbacks -> String -> IO ()
logCB FetchCallbacks
cb String
m
                      MethodHandle -> IO Bool
loop MethodHandle
mh
               Status URI
uri String
m ->
                   do FetchCallbacks -> URI -> String -> IO ()
statusCB FetchCallbacks
cb URI
uri String
m
                      MethodHandle -> IO Bool
loop MethodHandle
mh
               URIStart URI
uri Maybe Integer
size Maybe UTCTime
lastModified Maybe Integer
resumePoint ->
                   FetchCallbacks
-> URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()
uriStartCB FetchCallbacks
cb URI
uri Maybe Integer
size Maybe UTCTime
lastModified Maybe Integer
resumePoint forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MethodHandle -> IO Bool
loop MethodHandle
mh
               URIDone URI
uri Maybe Integer
size Maybe UTCTime
lastModified Maybe Integer
resumePoint Maybe String
filename Hashes
hashes Bool
imsHit ->
                   FetchCallbacks
-> URI
-> Maybe Integer
-> Maybe UTCTime
-> Maybe Integer
-> Maybe String
-> Hashes
-> Bool
-> IO ()
uriDoneCB FetchCallbacks
cb URI
uri Maybe Integer
size Maybe UTCTime
lastModified Maybe Integer
resumePoint Maybe String
filename Hashes
hashes Bool
imsHit forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               URIFailure URI
uri String
message ->
                   FetchCallbacks -> URI -> String -> IO ()
uriFailureCB FetchCallbacks
cb URI
uri String
message forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               GeneralFailure String
m -> FetchCallbacks -> String -> IO ()
generalFailureCB FetchCallbacks
cb String
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               AuthorizationRequired String
site ->
                   do Maybe ConfigItem
mCredentials <- FetchCallbacks -> String -> IO (Maybe ConfigItem)
authorizationRequiredCB FetchCallbacks
cb String
site
                      case Maybe ConfigItem
mCredentials of
                        Maybe ConfigItem
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- FIXME: do we need a force close option for closeMethod ?
                        Just (String
user, String
passwd) ->
                            do MethodHandle -> Command -> IO ()
sendCommand' MethodHandle
mh (String -> String -> String -> Command
AuthorizationCredentials String
site String
user String
passwd)
                               MethodHandle -> IO Bool
loop MethodHandle
mh
               MediaFailure String
media String
drive ->
                    do FetchCallbacks -> String -> String -> IO ()
mediaFailureCB FetchCallbacks
cb String
media String
drive
                       forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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
emptyFetchCallbacks =
    FetchCallbacks { logCB :: String -> IO ()
logCB = \ String
_m -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , statusCB :: URI -> String -> IO ()
statusCB = \ URI
_uri String
_m -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()
uriStartCB = \ URI
_uri Maybe Integer
_size Maybe UTCTime
_lastModified Maybe Integer
_resumePoint -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , uriDoneCB :: URI
-> Maybe Integer
-> Maybe UTCTime
-> Maybe Integer
-> Maybe String
-> Hashes
-> Bool
-> IO ()
uriDoneCB = \ URI
_uri Maybe Integer
_size Maybe UTCTime
_lastModified Maybe Integer
_resumePoint Maybe String
_filename Hashes
_hashes Bool
_imsHit -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , uriFailureCB :: URI -> String -> IO ()
uriFailureCB = \ URI
_uri String
_message -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , generalFailureCB :: String -> IO ()
generalFailureCB = \ String
_m -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , authorizationRequiredCB :: String -> IO (Maybe ConfigItem)
authorizationRequiredCB = \ String
_site -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                   , mediaFailureCB :: String -> String -> IO ()
mediaFailureCB = \ String
_media String
_drive -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , debugCB :: String -> IO ()
debugCB = \ String
_m -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   }

cliFetchCallbacks :: FetchCallbacks
cliFetchCallbacks =
    FetchCallbacks
emptyFetchCallbacks { statusCB :: URI -> String -> IO ()
statusCB = \URI
uri String
m -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ String
m
                        , uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()
uriStartCB = \ URI
uri Maybe Integer
_size Maybe UTCTime
lastModified Maybe Integer
_resumePoint -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri forall a. [a] -> [a] -> [a]
++ String
" started. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe UTCTime
lastModified
                        , uriDoneCB :: URI
-> Maybe Integer
-> Maybe UTCTime
-> Maybe Integer
-> Maybe String
-> Hashes
-> Bool
-> IO ()
uriDoneCB = \URI
uri Maybe Integer
_size Maybe UTCTime
_lastModified Maybe Integer
_resumePoint Maybe String
_filename Hashes
_hashes Bool
imsHit -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri forall a. [a] -> [a] -> [a]
++ (if Bool
imsHit then String
" cached." else String
" downloaded.")
                        , uriFailureCB :: URI -> String -> IO ()
uriFailureCB = \URI
uri String
message -> Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"URI Failure: " forall a. [a] -> [a] -> [a]
++ URI -> String
uriToString' URI
uri forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ String
message
                        , generalFailureCB :: String -> IO ()
generalFailureCB = \String
message -> Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"General Failure: " forall a. [a] -> [a] -> [a]
++ String
message
                        , authorizationRequiredCB :: String -> IO (Maybe ConfigItem)
authorizationRequiredCB = \String
site ->
                                                    do String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Authorization Required for " forall a. [a] -> [a] -> [a]
++ String
site
                                                       String -> IO ()
putStrLn String
"Username: " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
                                                       String
user <- IO String
getLine
                                                       String -> IO ()
putStrLn String
"Password: " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
                                                       String
passwd <- IO String
getLine -- TODO: write a getPasswd function which does not echo input
                                                       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (String
user, String
passwd))
                        , mediaFailureCB :: String -> String -> IO ()
mediaFailureCB = \String
media String
drive -> Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Media Failure: media=" forall a. [a] -> [a] -> [a]
++ String
media forall a. [a] -> [a] -> [a]
++String
" drive="forall a. [a] -> [a] -> [a]
++ String
drive
                        , debugCB :: String -> IO ()
debugCB = \String
m -> forall a. Show a => a -> IO ()
print String
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 :: forall a. a -> a -> Bool -> a
bool a
f a
_ Bool
False = a
f
bool a
_ a
t Bool
True = a
t


getLastModified :: FilePath -> IO (Maybe UTCTime)
getLastModified :: String -> IO (Maybe UTCTime)
getLastModified String
fp =
    do Bool
e <- String -> IO Bool
doesFileExist String
fp
       if Bool
e
          then String -> IO FileStatus
getFileStatus String
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochTime -> UTCTime
epochTimeToUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> EpochTime
modificationTime
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
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)
-}