{-# 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.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
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
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
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
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
(Int -> Hashes -> ShowS)
-> (Hashes -> String) -> ([Hashes] -> ShowS) -> Show Hashes
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
(Hashes -> Hashes -> Bool)
-> (Hashes -> Hashes -> Bool) -> Eq Hashes
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 Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
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
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
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
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
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 :: URI -> (MethodHandle -> IO a) -> IO a
withMethodURI URI
uri MethodHandle -> IO a
f =
    do  String
mp <- (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (URI -> IO (Maybe String)
whichMethodPath URI
uri)
        String -> (MethodHandle -> IO a) -> IO a
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 :: String -> (MethodHandle -> IO a) -> IO a
withMethodPath String
methodPath MethodHandle -> IO a
f =
    IO MethodHandle
-> (MethodHandle -> IO ExitCode) -> (MethodHandle -> IO a) -> IO a
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 ((MethodHandle -> IO a) -> IO a) -> (MethodHandle -> IO a) -> IO a
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 = ShowS
forall a. [a] -> [a]
init (URI -> String
uriScheme URI
uri)
        path :: String
path = String
"/usr/lib/apt/methods/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
scheme
    in
      String -> IO Bool
doesFileExist String
path IO Bool -> (Bool -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> (Bool -> Maybe String) -> Bool -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Maybe String -> Bool -> Maybe String
forall a. a -> a -> Bool -> a
bool Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
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 [] = String -> Status
forall a. HasCallStack => String -> a
error String
"parseStatus"
parseStatus (String
code' : [String]
headers') =
    String -> [(String, String)] -> Status
parseStatus' (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 String
code') ((String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, String)
parseHeader [String]
headers')
    where
      parseStatus' :: String -> [(String, String)] -> Status
parseStatus' String
code [(String, String)]
headers
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
capabilities =
              ((String, String) -> Status -> Status)
-> Status -> [(String, String)] -> Status
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String) -> Status -> Status
updateCapability Status
defaultCapabilities [(String, String)]
headers
                  where
                    updateCapability :: (String, String) -> Status -> Status
updateCapability (String
a,String
v) Status
c
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Version"         = Status
c { version :: String
version = String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Single-Instance" = Status
c { singleInstance :: Bool
singleInstance = String -> Bool
parseTrueFalse String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Pre-Scan"        = Status
c { preScan :: Bool
preScan = String -> Bool
parseTrueFalse String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Pipeline"        = Status
c { pipeline :: Bool
pipeline = String -> Bool
parseTrueFalse String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Send-Config"     = Status
c { sendConfig :: Bool
sendConfig = String -> Bool
parseTrueFalse String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Needs-Cleanup"   = Status
c { needsCleanup :: Bool
needsCleanup = String -> Bool
parseTrueFalse String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Local-Only"      = Status
c { localOnly :: Bool
localOnly = String -> Bool
parseTrueFalse String
v }
                        | Bool
otherwise = String -> Status
forall a. HasCallStack => String -> a
error (String -> Status) -> String -> Status
forall a b. (a -> b) -> a -> b
$ String
"unknown capability: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (String
a,String
v)
                    defaultCapabilities :: Status
defaultCapabilities =
                        Capabilities :: String -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Status
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 [(String, String)]
headers
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
logMsg =
              case [(String, String)]
headers of
                [(String
"Message", String
msg)] -> String -> Status
LogMsg String
msg
                [(String, String)]
_ -> String -> Status
forall a. HasCallStack => String -> a
error String
"parseStatus'"
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
status =
                URI -> String -> Status
Status (Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"URI" [(String, String)]
headers) (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [(String, String)]
headers)
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uriStart =
              ((String, String) -> Status -> Status)
-> Status -> [(String, String)] -> Status
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String) -> Status -> Status
updateUriStart (URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Status
URIStart URI
forall a. HasCallStack => a
undefined Maybe Integer
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing) [(String, String)]
headers
                  where
                    updateUriStart :: (String, String) -> Status -> Status
updateUriStart (String
a,String
v) Status
u
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"URI" = Status
u { uri :: URI
uri = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Size" = Status
u { size :: Maybe Integer
size = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (String -> Integer
forall a. Read a => String -> a
read String
v) }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Last-Modified" = Status
u { lastModified :: Maybe UTCTime
lastModified = String -> Maybe UTCTime
forall t. ParseTime t => String -> Maybe t
parseTimeRFC822 String
v } -- if the date is unparseable, we silently truncate. Is that bad ?
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Resume-Point" = Status
u { resumePoint :: Maybe Integer
resumePoint = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (String -> Integer
forall a. Read a => String -> a
read String
v) }
                    updateUriStart (String, String)
_ Status
_ = String -> Status
forall a. HasCallStack => String -> a
error String
"updateUriStart"
      parseStatus' String
code [(String, String)]
headers
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uriDone =
              ((String, String) -> Status -> Status)
-> Status -> [(String, String)] -> Status
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String) -> Status -> Status
updateUriDone (URI
-> Maybe Integer
-> Maybe UTCTime
-> Maybe Integer
-> Maybe String
-> Hashes
-> Bool
-> Status
URIDone URI
forall a. HasCallStack => a
undefined Maybe Integer
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Hashes
emptyHashes Bool
False) [(String, String)]
headers
                  where
                    updateUriDone :: (String, String) -> Status -> Status
updateUriDone (String
a,String
v) Status
u
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"URI" = Status
u { uri :: URI
uri = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Size" = Status
u { size :: Maybe Integer
size = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (String -> Integer
forall a. Read a => String -> a
read String
v) }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Last-Modified" = Status
u { lastModified :: Maybe UTCTime
lastModified = String -> Maybe UTCTime
forall t. ParseTime t => String -> Maybe t
parseTimeRFC822 String
v } -- if the date is unparseable, we silently truncate. Is that bad ?
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Filename" = Status
u { filename :: Maybe String
filename = String -> Maybe String
forall a. a -> Maybe a
Just String
v }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"MD5Sum-Hash" = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { md5 :: Maybe String
md5    = String -> Maybe String
forall a. a -> Maybe a
Just String
v } }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"MD5-Hash" = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { md5 :: Maybe String
md5    = String -> Maybe String
forall a. a -> Maybe a
Just String
v } }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"SHA1-Hash"   = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { sha1 :: Maybe String
sha1   = String -> Maybe String
forall a. a -> Maybe a
Just String
v } }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"SHA256-Hash" = Status
u { hashes :: Hashes
hashes = (Status -> Hashes
hashes Status
u) { sha256 :: Maybe String
sha256 = String -> Maybe String
forall a. a -> Maybe a
Just String
v } }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Resume-Point" = Status
u { resumePoint :: Maybe Integer
resumePoint = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (String -> Integer
forall a. Read a => String -> a
read String
v) }
                        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"IMS-Hit" Bool -> Bool -> Bool
&& String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true" = Status
u { imsHit :: Bool
imsHit = Bool
True }
                        | Bool
otherwise = String -> Status
forall a. HasCallStack => String -> a
error (String -> Status) -> String -> Status
forall a b. (a -> b) -> a -> b
$ String
"updateUriDone: unknown header: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (String
a,String
v)
      parseStatus' String
code [(String, String)]
headers
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uriFailure =
              URI -> String -> Status
URIFailure (Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"URI" [(String, String)]
headers) (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [(String, String)]
headers)
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
generalFailure =
              String -> Status
GeneralFailure (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [(String, String)]
headers)
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
authorizationRequired =
              String -> Status
AuthorizationRequired (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Site" [(String, String)]
headers)
          | String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mediaFailure =
              String -> String -> Status
MediaFailure (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Media" [(String, String)]
headers) (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Drive" [(String, String)]
headers)
      parseStatus' String
_ [(String, String)]
_ = String -> Status
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" URI Acquire"
    , String
"URI: " String -> ShowS
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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> (UTCTime -> [String]) -> Maybe UTCTime -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\UTCTime
lm -> [String
"Last-Modified: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall t. FormatTime t => t -> String
formatTimeRFC822 UTCTime
lm ]) Maybe UTCTime
mLastModified
formatCommand (Configuration [(String, String)]
configItems) =
    (String
configuration String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Configuration") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
formatConfigItem [(String, String)]
configItems)
    where
      formatConfigItem :: (String, String) -> String
formatConfigItem (String
a,String
v) = [String] -> String
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Authorization Credentials") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    [ String
"Site: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
site
    , String
"User: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
user
    , String
"Password: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
passwd
    ]
formatCommand (MediaChanged String
media Maybe Bool
mFail) =
    [ String
mediaChanged String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Media Changed"
    , String
"Media: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
media
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> (Bool -> [String]) -> Maybe Bool -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Bool
b -> [String
"Fail: " String -> ShowS
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 = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Invalid boolean string: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s


recvStatus :: MethodHandle -> IO Status
recvStatus :: MethodHandle -> IO Status
recvStatus MethodHandle
mh = ([String] -> Status) -> IO [String] -> IO Status
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [String] -> Status
parseStatus (IO [String] -> IO Status) -> IO [String] -> IO Status
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 -> (String, String)
parseHeader String
str =
    let (String
a, String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
str
        v :: String
v = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
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:"
      (String -> IO ()) -> [String] -> IO ()
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
"" -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
              String
line ->
                  do
                    -- hPutStrLn stderr ("  " ++ line)
                    [String]
tail <- Handle -> IO [String]
readTillEmptyLine Handle
pOut
                    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String
line String -> [String] -> [String]
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 (String, String))
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 :: [(String, String)] -> URI -> String -> Maybe UTCTime -> IO Bool
simpleFetch = FetchCallbacks
-> [(String, String)] -> 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
-> [(String, String)] -> URI -> String -> Maybe UTCTime -> IO Bool
fetch FetchCallbacks
cb [(String, String)]
configItems URI
uri String
fp Maybe UTCTime
lastModified =
    do URI -> (MethodHandle -> IO Bool) -> IO Bool
forall a. URI -> (MethodHandle -> IO a) -> IO a
withMethodURI URI
uri ((MethodHandle -> IO Bool) -> IO Bool)
-> (MethodHandle -> IO Bool) -> IO Bool
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
"<- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Status -> String
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 (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FetchCallbacks -> String -> IO ()
debugCB FetchCallbacks
cb (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-> " String -> ShowS
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 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
configItems) (MethodHandle -> Command -> IO ()
sendCommand' MethodHandle
mh ([(String, String)] -> Command
Configuration [(String, String)]
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 IO () -> IO Bool -> IO Bool
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 IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
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 IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               GeneralFailure String
m -> FetchCallbacks -> String -> IO ()
generalFailureCB FetchCallbacks
cb String
m IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               AuthorizationRequired String
site ->
                   do Maybe (String, String)
mCredentials <- FetchCallbacks -> String -> IO (Maybe (String, String))
authorizationRequiredCB FetchCallbacks
cb String
site
                      case Maybe (String, String)
mCredentials of
                        Maybe (String, String)
Nothing -> Bool -> IO Bool
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
                       Bool -> IO Bool
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 :: (String -> IO ())
-> (URI -> String -> IO ())
-> (URI
    -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ())
-> (URI
    -> Maybe Integer
    -> Maybe UTCTime
    -> Maybe Integer
    -> Maybe String
    -> Hashes
    -> Bool
    -> IO ())
-> (URI -> String -> IO ())
-> (String -> IO ())
-> (String -> IO (Maybe (String, String)))
-> (String -> String -> IO ())
-> (String -> IO ())
-> FetchCallbacks
FetchCallbacks { logCB :: String -> IO ()
logCB = \ String
_m -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , statusCB :: URI -> String -> IO ()
statusCB = \ URI
_uri String
_m -> () -> IO ()
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 -> () -> IO ()
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 -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , uriFailureCB :: URI -> String -> IO ()
uriFailureCB = \ URI
_uri String
_message -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , generalFailureCB :: String -> IO ()
generalFailureCB = \ String
_m -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , authorizationRequiredCB :: String -> IO (Maybe (String, String))
authorizationRequiredCB = \ String
_site -> Maybe (String, String) -> IO (Maybe (String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, String)
forall a. Maybe a
Nothing
                   , mediaFailureCB :: String -> String -> IO ()
mediaFailureCB = \ String
_media String
_drive -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   , debugCB :: String -> IO ()
debugCB = \ String
_m -> () -> IO ()
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" started. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe UTCTime -> String
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri String -> ShowS
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"URI Failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
uriToString' URI
uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message
                        , generalFailureCB :: String -> IO ()
generalFailureCB = \String
message -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"General Failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message
                        , authorizationRequiredCB :: String -> IO (Maybe (String, String))
authorizationRequiredCB = \String
site ->
                                                    do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Authorization Required for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
site
                                                       String -> IO ()
putStrLn String
"Username: " IO () -> IO () -> IO ()
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: " IO () -> IO () -> IO ()
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
                                                       Maybe (String, String) -> IO (Maybe (String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Maybe (String, String)
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Media Failure: media=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
media String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" drive="String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
drive
                        , debugCB :: String -> IO ()
debugCB = \String
m -> String -> IO ()
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 :: 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 IO FileStatus
-> (FileStatus -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UTCTime -> IO (Maybe UTCTime))
-> (FileStatus -> Maybe UTCTime)
-> FileStatus
-> IO (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime)
-> (FileStatus -> UTCTime) -> FileStatus -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochTime -> UTCTime
epochTimeToUTCTime (EpochTime -> UTCTime)
-> (FileStatus -> EpochTime) -> FileStatus -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> EpochTime
modificationTime
          else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
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)
-}