pgdl-10.10: src/DownloadInterface.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase#-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module DownloadInterface (downloadInterface, DownloadSettings(..))
where
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BC
import Data.Conduit
import Data.Conduit.Binary
import Data.List
import Data.Monoid
import Control.Monad
import Control.Monad.Trans.Resource
import Control.Monad.IO.Class
import Control.Concurrent
import Control.Applicative
import Network.HTTP.Conduit
import Network.HTTP.Types.Header
import System.Posix.Files
import System.Process
import qualified System.IO as IO
import Distribution.System
import qualified Control.Concurrent.Chan as C
import qualified Brick.BChan as BC
import qualified Graphics.Vty as V
import qualified Brick.Main as M
import qualified Brick.Types as T
import qualified Brick.Widgets.Edit as E
import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.ProgressBar as P
import qualified Brick.Widgets.Center as C
import qualified Brick.AttrMap as A
import Brick.Types (Widget)
import Brick.Widgets.Core
import Brick.Util (on)
import Networking
data DownloadSettings =
DownloadSettings { networkResource :: NetworkResource
, relativeUrl :: Text
, localStoragePath :: Text
-- ^ file name included
, justOpen :: Bool
-- ^ when True, don't use any network resource
, continueDownload :: Bool
-- ^ when True, continue the download progress (use "Range" in http header)
-- else redownload the whole file
}
-- bytes already downloaded
data DownloadState = DownloadState Integer | FinishedState
| UserInput DownloadState (E.Editor String String)
-- ^ download progress
data DownloadEvent = UpdateFinishedSize Integer
| DownloadFinish
downloadInterface :: DownloadSettings -> IO ()
downloadInterface dSettings = do
eventChan <- BC.newBChan 100000000 -- select a big enough number
unless (justOpen dSettings) . void . forkIO $
download dSettings (BC.writeBChan eventChan)
progressBarTotSize <- if justOpen dSettings
then getLocalFileSize (T.unpack $ localStoragePath dSettings) >>= \case
Nothing -> error "file do not exist."
Just s -> return s
else getContentLength dSettings
let
initialState = if justOpen dSettings
then FinishedState
else DownloadState 0
theApp =
M.App { M.appDraw = drawUI
, M.appChooseCursor = M.neverShowCursor
, M.appHandleEvent = appEvent
, M.appStartEvent = return
, M.appAttrMap = const theMap
}
appEvent :: DownloadState -> T.BrickEvent String DownloadEvent -> T.EventM String (T.Next DownloadState)
appEvent ds@(DownloadState _) be = case be of
T.VtyEvent e -> case e of
V.EvKey V.KEsc [] -> M.halt ds
V.EvKey (V.KChar 'q') _ -> M.halt ds
V.EvKey (V.KChar 'o') [] -> M.continue $ UserInput ds (E.editor "command" (Just 1) "")
V.EvKey V.KEnter [] -> do
liftIO $ localStoragePath dSettings `openBy` ""
M.continue ds
_ -> M.continue ds
T.AppEvent ae -> case ae of
UpdateFinishedSize b -> M.continue . DownloadState $ b
DownloadFinish -> M.continue FinishedState
appEvent FinishedState be = case be of
T.VtyEvent e -> case e of
V.EvKey (V.KChar 'q') _ -> M.halt FinishedState
V.EvKey (V.KChar 'o') [] -> M.continue $ UserInput FinishedState (E.editor "command" (Just 1) "")
V.EvKey V.KEnter [] -> do
liftIO $ localStoragePath dSettings `openBy` ""
M.halt FinishedState
-- ^ file opened, we can quit download interface now
_ -> M.continue FinishedState
_ -> error "received non vty event after FinishedState was reached."
appEvent (UserInput st ed) be = case be of
T.VtyEvent e -> case e of
V.EvKey V.KEsc [] -> M.continue st
V.EvKey V.KEnter [] -> do
liftIO $ localStoragePath dSettings `openBy` concat (E.getEditContents ed)
case st of
DownloadState _ -> M.continue st
FinishedState -> M.halt FinishedState
_ -> error "unexpected state in UserInput state."
ev -> do
newEd <- E.handleEditorEvent ev ed
M.continue $ UserInput st newEd
T.AppEvent de -> case de of
UpdateFinishedSize b -> M.continue (UserInput (DownloadState b) ed)
DownloadFinish -> M.continue (UserInput FinishedState ed)
appEvent _ _ = error "unknown event received in event loop. (DL interface)"
theMap = A.attrMap V.defAttr [ (P.progressCompleteAttr, V.black `on` V.cyan)
, (P.progressIncompleteAttr, V.black `on` V.white)
, ("input box", V.black `on` V.blue)
]
drawUI :: DownloadState -> [Widget String]
drawUI (DownloadState bytes) = [vBox [bar, note]]
where
bar = C.vCenter . C.hCenter $ P.progressBar Nothing (fromIntegral bytes / fromIntegral progressBarTotSize)
note = C.vCenter . C.hCenter . str $ unlines [ "press Enter to open the file (even if its download has not finished)"
, "press 'o' to specify which program should be used to open the file."
]
drawUI FinishedState = [ui]
where
ui = C.vCenter . C.hCenter . str $ unlines [ "The file is ready for open."
, "press Enter to open the file, or press 'q' to return to file listing"
, "press 'o' to specify which program should be used to open the file."
]
drawUI (UserInput (UserInput _ _) _) = error "unexpected state in UserInput state."
drawUI (UserInput s ed) = (padTop (T.Pad 1) . vLimit 5 $ ask) : drawUI s
where
ask = C.vCenter . C.hCenter .
hLimit 50 . vLimit 5 .
B.borderWithLabel (str "please input a program name") .
forceAttr "input box" .
hLimit 40 $
E.renderEditor (str . unlines) True ed
M.customMain (V.mkVty mempty) (Just eventChan) theApp initialState
return ()
openBy :: Text -> String -> IO ()
openBy file "" = case buildOS of
OSX -> openBy file "open"
Linux -> openBy file "xdg-open"
_ -> error "don't know how to open file in this OS"
openBy file cmd = void $
case buildOS of
OSX -> runCommand $ cmd ++ " " ++ addq filepath ++ " "
Linux -> runCommand $ "nohup " ++ cmd ++ " " ++ addq filepath ++ " &>/dev/null &"
_ -> error "don't know how to open file in this OS"
where
filepath = T.unpack file
addq :: String -> String
addq s = "\"" ++ s ++ "\""
getContentLength :: DownloadSettings -> IO Integer
getContentLength dSettings = do
let (req, manager) = networkResource dSettings $ relativeUrl dSettings
runResourceT $ do
response <- http req manager
let headers = responseHeaders response
case find (\(hn, bs) -> hn == hContentLength) headers of
Nothing -> error "no content-length presents in response header"
Just (hn, bs) -> case BC.readInteger bs of
Nothing -> error "no integer in content-length header"
Just (sz, _) -> return sz
getLocalFileSize :: String -> IO (Maybe Integer)
getLocalFileSize path =
fileExist path >>= \case
False -> return Nothing
True -> Just . fromIntegral . fileSize <$> getFileStatus path
download :: DownloadSettings ->
(DownloadEvent -> IO ()) ->
IO ()
download dSettings tell = do
-- this implementation needs to be change
-- since some filename contains characters that cannot be represented by String
let
filepath = T.unpack $ localStoragePath dSettings
checkFile :: IO ()
checkFile = forever $ do
threadDelay 100000 -- 0.1 second
getLocalFileSize filepath >>= \case
Nothing -> return ()
Just s -> tell . UpdateFinishedSize $ s
checkerThreadID <- forkIO checkFile
let (req, manager) = networkResource dSettings $ relativeUrl dSettings
localFileSize <- getLocalFileSize (T.unpack $ localStoragePath dSettings) >>= \case
Nothing -> return 0
Just s -> return s
remoteFileSize <- getContentLength dSettings
let extraHeaders = [("Range", "bytes=" `BC.append` BC.pack (show localFileSize) `BC.append` "-")]
let req' = if continueDownload dSettings
then req { requestHeaders = extraHeaders ++ requestHeaders req }
else req
-- use http and ResumableSource in conduit for constant memory usage
runResourceT $ do
if continueDownload dSettings then
when (localFileSize < remoteFileSize) $ do
response <- http req' manager
let body = responseBody response
body $$+- sinkIOHandle (IO.openBinaryFile filepath IO.AppendMode)
else do
response <- http req' manager
let body = responseBody response
body $$+- sinkIOHandle (IO.openBinaryFile filepath IO.WriteMode)
liftIO $ do
killThread checkerThreadID
tell DownloadFinish
return ()