{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-name-shadowing #-}
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
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show, Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
/= :: 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
$cshowsPrec :: Int -> Hashes -> ShowS
showsPrec :: Int -> Hashes -> ShowS
$cshow :: Hashes -> String
show :: Hashes -> String
$cshowList :: [Hashes] -> ShowS
showList :: [Hashes] -> ShowS
Show, Hashes -> Hashes -> Bool
(Hashes -> Hashes -> Bool)
-> (Hashes -> Hashes -> Bool) -> Eq Hashes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hashes -> Hashes -> Bool
== :: Hashes -> Hashes -> Bool
$c/= :: Hashes -> Hashes -> Bool
/= :: 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)
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
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> String
show :: Command -> String
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
/= :: Command -> Command -> Bool
Eq)
type = (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 <- (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
withMethodPath :: FilePath -> (MethodHandle -> IO a) -> IO a
withMethodPath :: forall a. 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
whichMethodPath :: URI -> IO (Maybe FilePath)
whichMethodPath :: URI -> IO (Maybe String)
whichMethodPath URI
uri =
let scheme :: String
scheme = ShowS
forall a. HasCallStack => [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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
forall a. a -> IO a
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)
parseStatus :: [String] -> Status
parseStatus :: [String] -> Status
parseStatus [] = String -> Status
forall a. HasCallStack => String -> a
error String
"parseStatus"
parseStatus (String
code' : [String]
headers') =
String -> [ConfigItem] -> Status
parseStatus' (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 String
code') ((String -> ConfigItem) -> [String] -> [ConfigItem]
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
capabilities =
(ConfigItem -> Status -> Status)
-> Status -> [ConfigItem] -> Status
forall a b. (a -> b -> b) -> b -> [a] -> b
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 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]
++ ConfigItem -> String
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
logMsg =
case [ConfigItem]
headers of
[(String
"Message", String
msg)] -> String -> Status
LogMsg String
msg
[ConfigItem]
_ -> 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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"URI" [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [ConfigItem]
headers)
| String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uriStart =
(ConfigItem -> Status -> Status)
-> Status -> [ConfigItem] -> Status
forall a b. (a -> b -> b) -> b -> [a] -> b
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 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) [ConfigItem]
headers
where
updateUriStart :: ConfigItem -> 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 }
| 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 ConfigItem
_ Status
_ = String -> Status
forall a. HasCallStack => String -> a
error String
"updateUriStart"
parseStatus' String
code [ConfigItem]
headers
| String
code String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uriDone =
(ConfigItem -> Status -> Status)
-> Status -> [ConfigItem] -> Status
forall a b. (a -> b -> b) -> b -> [a] -> b
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 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) [ConfigItem]
headers
where
updateUriDone :: ConfigItem -> 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 }
| 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]
++ ConfigItem -> String
forall a. Show a => a -> String
show (String
a,String
v)
parseStatus' String
code [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"URI" [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Message" [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Site" [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Media" [ConfigItem]
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 -> [ConfigItem] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Drive" [ConfigItem]
headers)
parseStatus' String
_ [ConfigItem]
_ = 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
, 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 [ConfigItem]
configItems) =
(String
configuration String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Configuration") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((ConfigItem -> String) -> [ConfigItem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ConfigItem -> String
formatConfigItem [ConfigItem]
configItems)
where
formatConfigItem :: ConfigItem -> 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
String
str =
let (String
a, String
r) = (Char -> Bool) -> String -> ConfigItem
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 a. Eq a => a -> [a] -> 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
String -> IO MethodHandle
runInteractiveCommand String
methodBinary
sendMethod :: MethodHandle -> [String] -> IO ()
sendMethod :: MethodHandle -> [String] -> IO ()
sendMethod (Handle
pIn, Handle
_pOut, Handle
_, ProcessHandle
_) [String]
strings =
do
(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
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
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
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
String
line ->
do
[String]
tail <- Handle -> IO [String]
readTillEmptyLine Handle
pOut
[String] -> IO [String]
forall a. a -> IO a
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
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 :: 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 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 ([ConfigItem] -> Bool
forall a. [a] -> Bool
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 IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
emptyFetchCallbacks :: FetchCallbacks
emptyFetchCallbacks =
FetchCallbacks { logCB :: String -> IO ()
logCB = \ String
_m -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, statusCB :: URI -> String -> IO ()
statusCB = \ URI
_uri String
_m -> () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, uriFailureCB :: URI -> String -> IO ()
uriFailureCB = \ URI
_uri String
_message -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, generalFailureCB :: String -> IO ()
generalFailureCB = \ String
_m -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, authorizationRequiredCB :: String -> IO (Maybe ConfigItem)
authorizationRequiredCB = \ String
_site -> Maybe ConfigItem -> IO (Maybe ConfigItem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConfigItem
forall a. Maybe a
Nothing
, mediaFailureCB :: String -> String -> IO ()
mediaFailureCB = \ String
_media String
_drive -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, debugCB :: String -> IO ()
debugCB = \ String
_m -> () -> IO ()
forall a. a -> IO a
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 ConfigItem)
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 a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
String
passwd <- IO String
getLine
Maybe ConfigItem -> IO (Maybe ConfigItem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigItem -> Maybe ConfigItem
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
}
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 IO FileStatus
-> (FileStatus -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing