{-# 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.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)
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 = (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
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
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)
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 }
| 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 }
| 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
, 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
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
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 (m :: * -> *) a. Monad m => a -> m a
return []
String
line ->
do
[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
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 :: 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
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
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
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
}
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