bugfixes
fdToHandle seems to close the fd avoid excess trailing newline
This commit is contained in:
parent
e5fd8b67b7
commit
8c10f37714
1 changed files with 16 additions and 11 deletions
|
@ -21,20 +21,25 @@ import Data.Time.Clock
|
||||||
|
|
||||||
{- Enough information to uniquely identify a transfer, used as the filename
|
{- Enough information to uniquely identify a transfer, used as the filename
|
||||||
- of the transfer information file. -}
|
- of the transfer information file. -}
|
||||||
data Transfer = Transfer Direction Remote Key
|
data Transfer = Transfer
|
||||||
deriving (Show)
|
{ transferDirection :: Direction
|
||||||
|
, transferRemote :: Remote
|
||||||
|
, transferKey :: Key
|
||||||
|
}
|
||||||
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
{- Information about a Transfer, stored in the transfer information file. -}
|
{- Information about a Transfer, stored in the transfer information file. -}
|
||||||
data TransferInfo = TransferInfo
|
data TransferInfo = TransferInfo
|
||||||
{ transferPid :: Maybe ProcessID
|
{ startedTime :: UTCTime
|
||||||
|
, transferPid :: Maybe ProcessID
|
||||||
, transferThread :: Maybe ThreadId
|
, transferThread :: Maybe ThreadId
|
||||||
, startedTime :: UTCTime
|
|
||||||
, bytesComplete :: Maybe Integer
|
, bytesComplete :: Maybe Integer
|
||||||
, associatedFile :: Maybe FilePath
|
, associatedFile :: Maybe FilePath
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
data Direction = Upload | Download
|
data Direction = Upload | Download
|
||||||
|
deriving (Eq, Ord)
|
||||||
|
|
||||||
instance Show Direction where
|
instance Show Direction where
|
||||||
show Upload = "upload"
|
show Upload = "upload"
|
||||||
|
@ -61,9 +66,9 @@ transfer t file a = do
|
||||||
createAnnexDirectory $ takeDirectory tfile
|
createAnnexDirectory $ takeDirectory tfile
|
||||||
mode <- annexFileMode
|
mode <- annexFileMode
|
||||||
info <- liftIO $ TransferInfo
|
info <- liftIO $ TransferInfo
|
||||||
<$> pure Nothing -- pid not stored in file, so omitted for speed
|
<$> getCurrentTime
|
||||||
|
<*> pure Nothing -- pid not stored in file, so omitted for speed
|
||||||
<*> pure Nothing -- threadid not stored in file, so omitted for speed
|
<*> pure Nothing -- threadid not stored in file, so omitted for speed
|
||||||
<*> getCurrentTime
|
|
||||||
<*> pure Nothing -- not 0; transfer may be resuming
|
<*> pure Nothing -- not 0; transfer may be resuming
|
||||||
<*> pure file
|
<*> pure file
|
||||||
bracketIO (prep tfile mode info) (cleanup tfile) a
|
bracketIO (prep tfile mode info) (cleanup tfile) a
|
||||||
|
@ -103,7 +108,7 @@ checkTransfer t = do
|
||||||
h <- fdToHandle fd
|
h <- fdToHandle fd
|
||||||
info <- readTransferInfo pid
|
info <- readTransferInfo pid
|
||||||
<$> hGetContentsStrict h
|
<$> hGetContentsStrict h
|
||||||
closeFd fd
|
hClose h
|
||||||
return info
|
return info
|
||||||
|
|
||||||
{- Gets all currently running transfers. -}
|
{- Gets all currently running transfers. -}
|
||||||
|
@ -152,9 +157,9 @@ readTransferInfo :: ProcessID -> String -> Maybe TransferInfo
|
||||||
readTransferInfo pid s =
|
readTransferInfo pid s =
|
||||||
case bits of
|
case bits of
|
||||||
[time] -> TransferInfo
|
[time] -> TransferInfo
|
||||||
<$> pure (Just pid)
|
<$> readish time
|
||||||
|
<*> pure (Just pid)
|
||||||
<*> pure Nothing
|
<*> pure Nothing
|
||||||
<*> readish time
|
|
||||||
<*> pure Nothing
|
<*> pure Nothing
|
||||||
<*> pure filename
|
<*> pure filename
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
@ -162,4 +167,4 @@ readTransferInfo pid s =
|
||||||
(bits, filebits) = splitAt 1 $ lines s
|
(bits, filebits) = splitAt 1 $ lines s
|
||||||
filename
|
filename
|
||||||
| null filebits = Nothing
|
| null filebits = Nothing
|
||||||
| otherwise = Just $ unlines filebits
|
| otherwise = Just $ join "\n" filebits
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue