pgdl 8.5 → 9.0
raw patch · 24 files changed
+845/−1014 lines, 24 filesdep +binarydep +brickdep +conduitdep −HTTPdep −arraydep −network-uridep ~configuratordep ~directorydep ~http-conduit
Dependencies added: binary, brick, conduit, conduit-extra, data-default, directory-listing-webpage-parser, resourcet, time, transformers, unix, vector
Dependencies removed: HTTP, array, network-uri, vty-ui
Dependency ranges changed: configurator, directory, http-conduit
Files
- README.md +39/−18
- pgdl.cabal +32/−23
- src/AskScene.hs +0/−62
- src/Cache.hs +66/−0
- src/Chkcfg.hs +0/−30
- src/Configure.hs +66/−0
- src/CrtInf.hs +0/−27
- src/DownloadInterface.hs +179/−0
- src/EntryAttrViewer.hs +75/−0
- src/FetchHtml.hs +0/−39
- src/GenStat.hs +0/−39
- src/Getconfig.hs +0/−42
- src/Local.hs +23/−0
- src/Log.hs +0/−44
- src/Main.hs +214/−0
- src/NameAlgo.hs +0/−115
- src/Networking.hs +78/−0
- src/Pgdl.hs +0/−235
- src/PrsVid.hs +0/−54
- src/RealWorld.hs +0/−82
- src/Types.hs +10/−0
- src/UI.hs +0/−152
- src/Utils.hs +63/−0
- src/Video.hs +0/−52
README.md view
@@ -1,37 +1,58 @@ # pgdl -a terminal user interface program that downloads a video (or a file) from webpage and xdg-open it immediately.-(Linux: xdg-open "video.mp4", MACOSX: open "video.mp4")+## What can this program do? -Client: Only for Linux and MACOSX.-Server: Only for nginx's file download page.+pgdl is a program for viewing and accessing directory listing webpage in terminal. -The program will sort files and folders by date while files in nginx's download page just sort by name.+Browsing files on directory listings like+[this](https://www.kernel.org/pub/linux/) and+[this](https://nixos.org/channels/)+is often annoying and hard to find the files we want. +pgdl provids a simple interface for browsing and downloading the files in web-engine-generated directory listings.+ ## Installing +by cabal: ```shell cabal update cabal install pgdl ``` -If there is an error occured when installing vty-ui, you may need +via nix: ```shell-cabal install vty-ui -f no-tests +nix-env -iA nixos.haskellPackages.pgdl ``` -to skip build of testing executable.+## example usage +```shell+pgdl https://www.kernel.org/pub/linux/+```+or simply type pgdl if you have set servpath attribute in the config file.+ ## Shortcut keys -q - quit -s - list files that similar with the highlighted file-Key Right - show the detailed information of the highlighted file-Key Left - go back to the previous page -Enter - xdg-open the file -/ - open a input box to enter a keyword to search -n - sort the current list by name -v - show the filess already in the disk -u - show the filess not in the disk -h - shortcut keys' help page+'/' for file searching +press Enter to confirm or to download the selected file++press 'q' to quit the program++press 'd' to delete currently selected file (which have been downloaded)+++## Config file++If you want to access webpage that uses basic authentication, you should at least set+*username* attribute in config file.+(if password is not set, you need to enter password manually when program launch)++(~/.pgdl)+```bash+# example: +username = "jack" # should be set if the webpage have basic authentication+password = "mypassw" # optional+servpath = "example.org/videodir/" # default server location, optional+localdir = "/home/jack/Downloads/" # where to store downloaded files, optional+```
pgdl.cabal view
@@ -1,43 +1,52 @@ name: pgdl-version: 8.5+version: 9.0 license: PublicDomain license-file: LICENSE-author: sifmelcara-maintainer: sifmelcara+author: mingchuan+maintainer: mingchuan category: Network build-type: Simple extra-source-files: README.md cabal-version: >=1.10-description: a terminal user interface program downloads video (or a file) from nginx file index page and xdg-open it.- (Linux: xdg-open "video.mp4", MACOSX: open "video.mp4")- .- Client: Only for Linux and MACOSX.- Server: Only for nginx's file download page.+description: pgdl is a program for viewing and accessing directory listing webpage in terminal. .- The program will sort the files and folders by date while files in nginx's download page just sort by name.+ Browsing files on directory listings like this and this is often annoying and hard to find the files we want. .- For shortcut keys, please visit <https://github.com/sifmelcara/pgdl> or press h in the program.+ pgdl provids a simple interface for browsing and downloading the files in web-engine-generated directory listings. -synopsis: simply download a video (or a file) from a webpage and xdg-open it. +synopsis: browse directory listing webpages and download files from them.+ source-repository head type: git location: https://github.com/sifmelcara/pgdl executable pgdl hs-source-dirs: src- main-is: Pgdl.hs- other-modules: NameAlgo, Chkcfg, FetchHtml, Getconfig,- Log, RealWorld, PrsVid, Video, GenStat, - CrtInf, AskScene, UI- build-depends: base == 4.*, process, - directory, bytestring,- tagsoup, network-uri, - vty, text, vty-ui >= 1.9,- configurator >= 0.3.0.0, HTTP,- filepath, Cabal, array,- http-conduit < 3.0.0- ghc-options: -threaded -O2+ main-is: Main.hs+ other-modules: Cache, DownloadInterface, Local+ Networking, Utils, Configure,+ EntryAttrViewer, Types+ build-depends: base == 4.*,+ tagsoup,+ directory-listing-webpage-parser,+ brick, vty, data-default,+ vector,+ text, bytestring,+ unix,+ conduit, conduit-extra,+ http-conduit, resourcet,+ configurator >= 0.3,+ directory >= 1.2.3.0,+ Cabal,+ filepath,+ transformers,+ process,+ filepath,+ time,+ binary++ ghc-options: -threaded default-language: Haskell2010
− src/AskScene.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module AskScene where--import Graphics.Vty.Widgets.All-import Graphics.Vty.Input.Events--import Control.Monad--data AskScene = AskScene { sceneWidget :: Widget (Bordered Padded)- , playHand :: Handlers AskScene- , downHand :: Handlers AskScene- , quitHand :: Handlers AskScene- , remvHand :: Handlers AskScene- }--newAskScene :: IO (AskScene, Widget FocusGroup)-newAskScene = do- playB <- newButton "No"- downB <- newButton "Yes"- quitB <- newButton "Cancel"- remvB <- newButton "Remov"- buttonBox <- mkwIO playB <++> mkwIO downB <++> mkwIO quitB <++> mkwIO remvB- b <- do- bx <- plainText " Download it again?" <--> return buttonBox- setBoxSpacing bx 1- withPadding (padAll 1) bx- fg <- newFocusGroup- mapM_ (addToFocusGroup fg . buttonWidget) [playB, downB, quitB, remvB]- ui <- withBorderedLabel "File Exists!" =<< bordered b- [phs, dhs, qhs, rhs] <- replicateM 4 newHandlers- let sce = AskScene { sceneWidget = ui- , playHand = phs- , downHand = dhs- , quitHand = qhs- , remvHand = rhs- }- onButtonPressed playB $ \_ -> - fireEvent sce (return . playHand) sce- onButtonPressed downB $ \_ -> - fireEvent sce (return . downHand) sce- onButtonPressed quitB $ \_ -> - fireEvent sce (return . quitHand) sce- onButtonPressed remvB $ \_ ->- fireEvent sce (return . remvHand) sce- setFocusGroupNextKey fg KRight []- setFocusGroupPrevKey fg KLeft []- return (sce, fg)- where mkwIO = return . buttonWidget--onScePlay :: AskScene -> Handler AskScene -> IO ()-onScePlay = addHandler (return . playHand)--onSceDown :: AskScene -> Handler AskScene -> IO ()-onSceDown = addHandler (return . downHand)--onSceQuit :: AskScene -> Handler AskScene -> IO ()-onSceQuit = addHandler (return . quitHand)--onSceRemv :: AskScene -> Handler AskScene -> IO()-onSceRemv = addHandler (return . remvHand)-
+ src/Cache.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Cache+where++import qualified Data.Text as T+import Data.Text (Text)+import Data.Binary+import Data.Maybe+import Data.Time.LocalTime+import Data.Time.Clock.POSIX+import System.Directory+import Text.HTML.DirectoryListing.Type++import Configure+import Types +import Local++-- | this conversion may lose accuracy?+instance Binary LocalTime where+ put = put . toRational . utcTimeToPOSIXSeconds . localTimeToUTC utc+ get = utcToLocalTime utc . posixSecondsToUTCTime . fromRational <$> get++instance Binary Entry where+ put e = do+ put $ visibleName e+ put $ href e+ put $ lastModified e+ put $ fileSize e+ get = do+ v <- get+ h <- get+ l <- get+ f <- get+ return Entry { visibleName = v+ , href = h+ , lastModified = l+ , fileSize = f+ }+ +writeCache :: [Entry] -> IO ()+writeCache es = do+ p <- getCacheFileLocation+ encodeFile p es++readCache :: IO (Maybe [DNode])+readCache = do+ p <- getCacheFileLocation+ lcd <- T.unpack . fromMaybe "" <$> getLocaldir+ doesFileExist p >>= \case+ False -> return Nothing+ True -> decodeFileOrFail p >>= \case+ Right d -> do+ dnodes <- mapM (toDNode lcd) d+ return $ Just dnodes+ Left _ -> return Nothing+ where+ toDNode :: String -> Entry -> IO DNode+ toDNode lcd e+ | isDirectory e = return $ Directory e noData+ | otherwise = do+ downloaded <- isFileDownloaded (decodedName e) lcd+ return $ File e "offline mode" downloaded+ noData = error "offline mode"+
− src/Chkcfg.hs
@@ -1,30 +0,0 @@--module Chkcfg (chkcfg) where--import System.Directory-import System.FilePath-import Control.Monad--chkcfg :: IO ()-chkcfg = do- flp <- fmap (</> ".pgdl") getHomeDirectory- fle <- doesFileExist flp- unless fle $ do- writeFile flp defcfg- error "please config the file \"~/.pgdl\" first!"- where defcfg = unlines [ ""- , "# example: "- , "# username = \"jack\" "- , "# password = \"mypassw\" "- , "# servpath = \"example.org/videodir/\" "- , "# localdir = \"/home/jack/Downloads/\" "- , ""- , "# username and localdir is optional."- , ""- , "username = \"\""- , "password = \"\""- , "servpath = \"\""- , "localdir = \"\""- , ""- ]-
+ src/Configure.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Configure +where++import qualified Data.Text as T+import Data.Text (Text)++import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C++import System.FilePath.Posix+import System.Directory++getConfig :: IO (Maybe C.Config)+getConfig = do+ home <- getUserDocumentsDirectory+ let cfgFile = home </> ".pgdl"+ doesFileExist cfgFile >>= \case+ False -> return Nothing+ True -> Just <$> C.load [C.Required cfgFile]+ +getUsername :: IO (Maybe Text)+getUsername =+ getConfig >>= \case+ Nothing -> return Nothing+ Just cfg -> C.lookup cfg "username" +++getPassword :: IO (Maybe Text)+getPassword = + getConfig >>= \case+ Nothing -> return Nothing+ Just cfg -> C.lookup cfg "password" ++getLocaldir :: IO (Maybe Text)+getLocaldir =+ getConfig >>= \case+ Nothing -> return Nothing+ Just cfg -> C.lookup cfg "localdir" ++-- | return Nothing if there are no servpath or config file do not exist+getServpath :: IO (Maybe Text)+getServpath = do+ cfg <- getConfig+ case cfg of+ Nothing -> return Nothing+ Just c -> fmap unify <$> C.lookup c "servpath"+ where+ -- this is not a good approach, improve it later+ unify :: Text -> Text+ unify p+ | "http://" `T.isPrefixOf` p = p+ | "https://" `T.isPrefixOf` p = p+ | otherwise = "http://" `T.append` p++-- | This function also creates the cache directory+-- if it doesn't exists.+getCacheFileLocation :: IO FilePath+getCacheFileLocation = do+ cdir <- getXdgDirectory XdgCache ""+ createDirectoryIfMissing True cdir+ let cacheFile = cdir </> "pgdl"+ return cacheFile+
− src/CrtInf.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module CrtInf where--import Video--import qualified Data.Text as T--crtInfPg :: Video -> T.Text-crtInfPg vid = T.unlines ["", "",- "File name: " `app` (spl . getName) vid,- "File size: " `app` getSize vid,- "File date: " `app` getDate vid,- "File link: " `app` (spl . getLink) vid- ]- where app = T.append- spl = T.intercalate "\n" . T.chunksOf 60 - getSize v- | isVid v = vidSize v- | otherwise = "I'm a folder"- getDate v- | isVid v = vidDate v- | otherwise = fldDate v- getLink v- | isVid v = vidLink v- | otherwise = fldLink v-
+ src/DownloadInterface.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase#-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module DownloadInterface (downloadInterface)+where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Conduit+import Data.Conduit.Binary+import Data.Default+import Control.Monad+import Control.Monad.Trans.Resource +import Control.Monad.IO.Class+import Control.Concurrent+import qualified Control.Concurrent.Chan as C+import Network.HTTP.Conduit+import System.Posix.Files+import System.Process+import Distribution.System++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 qualified Configure as Conf+import Networking++-- bytes already downloaded+data DownloadState = DownloadState Integer | FinishedState+ | UserInput DownloadState E.Editor+ -- ^ download progress++data DEvent = VtyEvent V.Event+ | UpdateFinishedSize Integer+ | DownloadFinish++-- | Maybe we should try to get file size by other method,+-- that would be more accurate and reliable.+downloadInterface :: NetworkResource -> + Text -> -- ^ url (relative)+ Text -> -- ^ file path (may be a absolute path)+ Integer -> -- ^ filesize in bytes+ Bool -> -- ^ is the download already finished?+ IO ()+downloadInterface nr url filepath filesize alreadyFinished = do+ eventChan <- C.newChan + unless alreadyFinished . void . forkIO $ download nr url filepath (C.writeChan eventChan)+ let+ initialState :: DownloadState + initialState = if alreadyFinished+ 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 + , M.appLiftVtyEvent = VtyEvent+ }+ appEvent :: DownloadState -> DEvent -> T.EventM (T.Next DownloadState)+ appEvent ds@(DownloadState doneB) de = case de of+ 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" (str.unlines) (Just 1) "")+ V.EvKey V.KEnter [] -> do+ liftIO $ filepath `openBy` ""+ M.continue ds+ ev -> M.continue ds+ UpdateFinishedSize b -> M.continue . DownloadState $ b+ DownloadFinish -> M.continue FinishedState+ appEvent FinishedState de = case de of+ 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" (str.unlines) (Just 1) "")+ V.EvKey V.KEnter [] -> do+ liftIO $ filepath `openBy` ""+ M.halt FinishedState+ -- ^ file opened, we can quit download interface now+ ev -> M.continue FinishedState+ _ -> error "received non vty event after FinishedState was reached."+ appEvent (UserInput st ed) de = case de of+ VtyEvent e -> case e of+ V.EvKey V.KEsc [] -> M.continue st+ V.EvKey V.KEnter [] -> do+ liftIO $ filepath `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 <- T.handleEvent ev ed+ M.continue $ UserInput st newEd+ UpdateFinishedSize b -> M.continue (UserInput (DownloadState b) ed)+ DownloadFinish -> M.continue (UserInput FinishedState ed)+ 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]+ drawUI (DownloadState bytes) = [vBox [bar, note]]+ where+ bar = C.vCenter . C.hCenter $ P.progressBar Nothing (fromIntegral bytes / fromIntegral filesize)+ 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 ed+ M.customMain (V.mkVty Data.Default.def) 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 ++ "\""+ +download :: NetworkResource -> + Text -> -- ^ url+ Text -> -- ^ filepath+ (DEvent -> IO ()) -> IO ()+download nr url tFilepath tell = do+ -- this implementation needs to be change+ -- since some filename contains characters that cannot be represented by String+ let+ filepath = T.unpack tFilepath+ checkFile :: IO ()+ checkFile = forever $ do+ threadDelay $ 1000000 * 1+ exist <- fileExist filepath+ when exist $ do+ s <- fileSize <$> getFileStatus filepath+ tell . UpdateFinishedSize . fromIntegral $ s+ checkerThreadID <- forkIO checkFile+ let (req, manager) = nr url+ -- use http and ResumableSource in conduit for constant memory usage+ runResourceT $ do+ response <- http req manager+ let body = responseBody response+ body $$+- sinkFile filepath+ liftIO $ do+ killThread checkerThreadID+ tell DownloadFinish+ return ()+
+ src/EntryAttrViewer.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++module EntryAttrViewer (entryAttrViewer)+where++import Data.Text (Text)+import qualified Data.Text as T+import Control.Monad++import qualified Graphics.Vty as V+import qualified Brick.Main as M+import qualified Brick.Types as T+import qualified Brick.Widgets.ProgressBar as P+import qualified Brick.Widgets.Center as C+import qualified Brick.Widgets.Core as C+import qualified Brick.AttrMap as A+import Brick.Types (Widget)+import Brick.Widgets.Core+import Brick.Util (on)++import Types+import Text.HTML.DirectoryListing.Type++import qualified Utils as U++entryAttrViewer :: DNode -> IO ()+-- | Temporary use File to process Directory...+entryAttrViewer (Directory entry _) = entryAttrViewer (File entry "directory no link." False)+entryAttrViewer (File entry url downloaded) = do+ let+ initialState :: () + initialState = ()+ theApp =+ M.App { M.appDraw = drawUI+ , M.appChooseCursor = M.neverShowCursor+ , M.appHandleEvent = appEvent+ , M.appStartEvent = return+ , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id+ }+ appEvent :: () -> V.Event -> T.EventM (T.Next ())+ appEvent () e = case e of+ V.EvKey V.KEsc [] -> M.halt ()+ V.EvKey (V.KChar 'q') [] -> M.halt ()+ V.EvKey V.KLeft [] -> M.halt ()+ ev -> M.continue ()+ theMap = A.attrMap V.defAttr [ (P.progressCompleteAttr, V.black `on` V.cyan)+ , (P.progressIncompleteAttr, V.black `on` V.white)+ ]+ drawUI :: () -> [Widget]+ drawUI _ = [ui]+ where+ ui = C.vCenter . C.hCenter .+ C.hLimit U.terminalWidth . C.txt $ info+ M.defaultMain theApp initialState+ return ()+ where+ info = T.unlines $+ zipWith (\describ s -> T.intercalate "\n" . + U.cutTextByDisplayLength U.terminalWidth $+ describ `T.append` ": " `T.append` s+ )+ [ "visible name" + , "decoded name" + , "url" + , "file size" + , "downloaded"+ ]+ [ visibleName entry+ , decodedName entry+ , url+ , maybe "directory" (T.pack . U.friendlySize) . fileSize $ entry+ , if downloaded then "Yes" else "No"+ ]+
− src/FetchHtml.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module FetchHtml where- -import Getconfig--import Network.URI-import Data.Text.Encoding-import Data.Maybe-import System.FilePath-import Control.Applicative-import qualified Data.Text as T-import Network.HTTP.Conduit-import Data.ByteString.Lazy---import bytestring?--fetchHtml :: IO T.Text-fetchHtml = getTextContent =<< genURI--fetchFld :: T.Text -> IO T.Text-fetchFld fnt = do- uri <- (</> fn) <$> genURI- getTextContent uri- where fn = T.unpack fnt--genURI :: IO String-genURI = do- usrn <- getUsername- usrp <- getPassword- servp <- getServpath- return $ "http://" ++ usrn ++ ":" ++ usrp ++ "@" ++ servp--getTextContent :: String -> IO T.Text-getTextContent u = do- bs <- simpleHttp u- let t = decodeUtf8 . toStrict $ bs- return t- -
− src/GenStat.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}--module GenStat (genStat, waitingBar) where--import Video-import RealWorld--import qualified Data.Text as T--genStat :: Video -> IO T.Text-genStat vid@(Video _ _ size date) = do- st <- toStr $ downloaded vid- return $ T.concat [ spc 3 , date- , spc 5 , size- , spc 20, st- , spc 30- ]- where spc :: Int -> T.Text- spc i = T.replicate i " "--genStat (Folder _ _ date) = - return $ T.concat [ spc 3- , date- , spc 5- , "I'm a folder"- , spc 99- ]- where spc i = T.replicate i " "--waitingBar :: T.Text-waitingBar = " Waiting for data..." `T.append` T.replicate 99 " "--toStr :: IO Bool -> IO T.Text-toStr b = b >>= \case- True -> return "Downloaded"- _ -> return "Not Downloaded"--
− src/Getconfig.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}--module Getconfig where--import qualified Data.Configurator as C-import qualified Data.Configurator.Types as C--getConfig :: IO C.Config-getConfig = C.load [C.Required "$(HOME)/.pgdl"]--getUsername :: IO String-getUsername = do- cfg <- getConfig- C.lookup cfg "username" >>= \case- Nothing -> noArg- Just s -> return s--getPassword :: IO String-getPassword = do - cfg <- getConfig- C.lookup cfg "password" >>= \case- Nothing -> noArg- Just s -> return s--getServpath :: IO String-getServpath = do- cfg <- getConfig- C.lookup cfg "servpath" >>= \case- Nothing -> noArg- Just s -> return s--getLocaldir :: IO String-getLocaldir = do- cfg <- getConfig- C.lookup cfg "localdir" >>= \case- Nothing -> noArg- Just s -> return s--noArg :: IO String-noArg = error "please correct the config file (~/.pgdl)."-
+ src/Local.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Local+where++import System.Directory+import System.FilePath.Posix+import Data.Text (Text)+import qualified Data.Text as T++import Configure++-- | determine whether a file is in specified directory+isFileDownloaded :: Text -> -- ^ file name+ String -> -- ^ local directory+ IO Bool+isFileDownloaded fn path = doesFileExist $ path </> T.unpack fn+ +deleteFile :: Text -> -- ^ file name (may be a absolute path)+ IO ()+deleteFile = removeFile . T.unpack+
− src/Log.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}--module Log where--import Video--import System.Directory-import System.FilePath--import qualified Data.Text as T-import qualified Data.Text.IO as T--encVid :: [Video] -> T.Text-encVid vs = T.intercalate "\n" $ map genName vs- where genName v- | isVid v = vidName v- | otherwise = fldName v--decVid :: T.Text -> [Video]-decVid = map (\t -> Video t "" "" "") . T.lines--logname :: FilePath-logname = ".pgdl.cache"--writeVid :: [Video] -> IO ()-writeVid vs = do- hdir <- getHomeDirectory- T.writeFile (hdir </> logname) $ encVid vs --readVid :: IO [Video]-readVid = do- hdir <- getHomeDirectory- let absdir = hdir </> logname- doesFileExist absdir >>= \case- True -> do- dat <- T.readFile (hdir </> logname)- return $ decVid dat- False -> return dlnVid--dlnVid :: [Video]-dlnVid = [Video "Downloading..." "" "" ""]--
+ src/Main.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Main+where++import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Text (Text)+import Data.Maybe+import DownloadInterface+import Control.Monad+import Control.Monad.IO.Class+import System.FilePath+import System.Environment+import System.IO+import Text.HTML.DirectoryListing.Type++import qualified Graphics.Vty as V+import qualified Brick.Main as M+import qualified Brick.Types as T+import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.Center as C+import qualified Brick.Widgets.Edit as E+import qualified Brick.AttrMap as A+import Brick.Types (Widget)+import Brick.Widgets.Core+import Brick.Util (on)++import EntryAttrViewer+import Utils+import qualified Configure as Conf+import Cache+import Types+import Local+import Networking+import qualified Utils as U++-- | father contents +data MainState = LState (Maybe MainState) (L.List DNode)+ | SearchState MainState (L.List DNode) E.Editor+++main :: IO ()+main = do+ let askPassword = do+ putStr "please input password: "+ hFlush stdout+ hSetEcho stdin False+ pass <- getLine+ hSetEcho stdin True+ putChar '\n'+ return $ T.pack pass+ (dNodes, nr) <- getArgs >>= \case+ ["--offline"] -> readCache >>= \case+ Nothing -> error "no offline data or data corrupted."+ Just dlst -> return (dlst, error "no network resource, offline mode.")+ online -> do+ (rootUrl, up) <- case online of+ [] -> Conf.getServpath >>= \case+ Nothing -> error "example usage: pgdl https://www.kernel.org/pub/"+ Just ru -> Conf.getUsername >>= \case+ Nothing -> return (ru, Nothing)+ Just user -> Conf.getPassword >>= \case+ Nothing -> do + pass <- askPassword+ return (ru, Just (user, pass))+ Just pass -> return (ru, Just (user, pass))+ [r] -> return (T.pack r, Nothing)+ _ -> error "too many arguments."+ putStrLn "loading webpage..."+ putStrLn "(you can use 'pgdl --offline' to browse the webpage you load last time)"+ nr <- genNetworkResource rootUrl up+ dNodes <- fetch nr + return (dNodes, nr)+ let+ initialState :: MainState+ initialState = LState Nothing lst+ where+ lst = L.list (T.Name "root") (V.fromList dNodes) 3+ theApp =+ M.App { M.appDraw = drawUI+ , M.appChooseCursor = M.neverShowCursor+ , M.appHandleEvent = appEvent+ , M.appStartEvent = return+ , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id+ }+ appEvent :: MainState -> V.Event -> T.EventM (T.Next MainState)+ appEvent ls@(LState father lst) e = case e of+ V.EvKey V.KEsc [] -> M.halt ls+ V.EvKey (V.KChar 'q') [] -> M.halt ls+ V.EvKey V.KEnter [] -> case L.listSelectedElement lst of+ Nothing -> M.continue ls+ Just (rowNum, child) -> case child of+ Directory entry dnsOp -> do+ dns <- liftIO dnsOp -- grab the subdirectory+ M.continue $ LState (Just ls) $ L.list (T.Name "root") (V.fromList dns) 3+ File entry url False -> do+ let fn = decodedName entry+ path <- liftIO $ Conf.getLocaldir >>= \case+ Nothing -> return fn + Just pre -> return $ T.pack (T.unpack pre </> T.unpack fn)+ let+ dui = downloadInterface nr url path (fromJust $ fileSize entry) False+ -- ^ not good, unsafe+ -- | construct a newList, modify the downloaded+ -- file's *downloaded state* to True.+ -- Maybe this is not a good approach?+ newList = L.listMoveTo rowNum . L.listInsert rowNum (File entry url True) . L.listRemove rowNum $ lst+ M.suspendAndResume $ dui >> return (LState father newList)+ File entry url True -> do -- already downloaded file+ let fn = decodedName entry+ path <- liftIO $ Conf.getLocaldir >>= \case+ Nothing -> return fn + Just pre -> return $ T.pack (T.unpack pre </> T.unpack fn)+ let dui = downloadInterface nr url path (fromJust $ fileSize entry) True+ -- ^ not good, unsafe+ M.suspendAndResume $ dui >> return ls+ V.EvKey V.KLeft [] -> M.continue $ fromMaybe ls father+ V.EvKey V.KRight [] -> case L.listSelectedElement lst of+ Nothing -> M.continue ls+ Just (_, sel) -> M.suspendAndResume $ entryAttrViewer sel >> return ls+ V.EvKey (V.KChar '/') [] -> M.continue $ SearchState ls lst (E.editor "searchBar" (str.unlines) (Just 1) "")+ V.EvKey (V.KChar 'd') [] -> case L.listSelectedElement lst of+ Nothing -> M.continue ls+ Just (rowNum, child) -> case child of+ Directory _ _ -> M.continue ls+ File entry url False -> M.continue ls+ File entry url True -> do -- already downloaded file+ let fn = decodedName entry+ path <- liftIO $ Conf.getLocaldir >>= \case+ Nothing -> return fn + Just pre -> return $ T.pack (T.unpack pre </> T.unpack fn)+ liftIO $ deleteFile path+ -- | very bad approach. File deletion may fail.+ let newList = L.listMoveTo rowNum . L.listInsert rowNum (File entry url False) . L.listRemove rowNum $ lst+ M.continue $ LState father newList+ + -- ^ current list which reactively change with editor+ ev -> M.continue =<< (LState father <$> T.handleEvent ev lst)+ appEvent ss@(SearchState ms@(LState _ origLst) lst ed) e = case e of+ V.EvKey V.KEsc [] -> M.halt ss+ V.EvKey V.KEnter [] -> case E.getEditContents ed of+ [""] -> M.continue ms -- ^ do nothing if the editor is empty+ _ -> M.continue $ LState (Just ms) lst+ ev -> do+ newEd <- T.handleEvent ev ed+ -- | update the list, lst+ let + linesToALine [l] = l+ linesToALine _ = error "not one line of words in the search bar, why?"+ -- | Why does L.listReplace require an Eq instance of Vector elements...?+ applyFilter kw lst = replaceList newElms lst+ where+ newElms = V.filter (\dn -> kw `isKeyWordOf` getDNText dn) $ L.listElements lst+ -- | sometime this will crash? how?+ replaceList es l = l {L.listElements = es, L.listSelected = Just 0}+ getDNText (Directory e _) = decodedName e+ getDNText (File e _ _) = decodedName e + isKeyWordOf t1 t2 = T.toCaseFold t1 `T.isInfixOf` T.toCaseFold t2+ M.continue $ SearchState ms (applyFilter (T.pack . linesToALine $ E.getEditContents newEd) origLst) newEd+ appEvent SearchState {} _ = error "unexpected prev state in SearchState."+ theMap = A.attrMap V.defAttr [ (L.listAttr, V.white `on` V.black)+ , ("directory", V.black `on` V.magenta)+ , ("file", V.black `on` V.cyan)+ , ("downloaded file", V.black `on` V.red)+ , ("statusBar", V.black `on` V.green)+ , ("searchBar", V.black `on` V.blue)+ ]+ M.defaultMain theApp initialState+ return ()+++-- | use cropping to draw UI in the future?+drawUI :: MainState -> [Widget]+drawUI mainState = case mainState of+ (LState _ l) -> [ C.hCenter . hLimit U.terminalWidth $+ vBox [entryList l, statusBar l]+ ]+ (SearchState _ l e) -> [ C.hCenter . hLimit U.terminalWidth $+ vBox [entryList l, searchBar e]+ ]+ where+ -- fixme (brick bug?): the vertical size of the list + -- is somewhat strange when the hroizontal size limit+ -- is not the multiple of its element size (it is 3)+ -- This strange behavior do not occur in vty-ui+ entryList lst = L.renderList lst listDrawElement+ listDrawElement False (Directory a _) = C.hCenter . txt . mid . stripWidth $ decodedName a + listDrawElement False (File a _ _) = C.hCenter . txt . mid . stripWidth $ decodedName a + listDrawElement True d@(Directory _ _) = withAttr "directory" $ listDrawElement False d+ listDrawElement True f@(File _ _ False) = withAttr "file" $ listDrawElement False f+ listDrawElement True f@(File _ _ True) = withAttr "downloaded file" $ listDrawElement False f+ mid s = T.unlines ["", s, ""]+ stripWidth :: Text -> Text+ stripWidth t = case U.cutTextByDisplayLength (U.terminalWidth-5) t of+ [] -> ""+ [singleLine] -> singleLine+ (x:_) -> x `T.append` "..."++ searchBar ed = forceAttr "searchBar" $ hBox [txt "search: ", E.renderEditor ed]++ statusBar lst = withAttr "statusBar" . str . expand $ info lst+ expand s = s ++ replicate 88 ' '+ info lst = case L.listSelectedElement lst of+ Nothing -> "Nothing selected by user"+ Just (_, sel) -> " " ++ show (lastModified entry) ++ " " ++ maybe "Nothing" friendlySize (fileSize entry)+ where+ entry = case sel of+ Directory e _ -> e+ File e _ _ -> e+
− src/NameAlgo.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module NameAlgo where--import Video--import Data.Function-import Data.Array-import Data.List-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T---- | the video name parsing is only for specific type of videos...( [subtitle][video name][episode].... )--- for most filename, the parsing function will just return the video name itself.-beaut :: Video -> T.Text-beaut (Video str _ _ _) = beautT str-beaut (Folder str _ _) = beautT str--beautT :: T.Text -> T.Text-beautT str = case cutName str of- Left x -> "\n" `apd` x- Right (sbt:nam:eps:_) -> T.unlines [ ws 4 `apd` sbt- , ws 10 `apd` nam- , ws 30 `apd` eps- ]- _ -> error "something wrong in video name parsing function"- where apd = T.append- ws t = T.replicate t " "---- | cut the name into pisces-cutName :: T.Text -> Either T.Text [T.Text]-cutName str- | length dat < 3 = Left str- -- parsing failure- | otherwise = Right [sbtitle, name, episode]- -- ok.- where (sbtitle:name:episode:_) = dat- dat = filter (not . T.null) . getTags ["[", "]"] $ [str]- getTags :: [T.Text] -> -- ^ the delimiters- [T.Text] -> -- ^ initial patterns- [T.Text]- getTags dl s = foldl (\ls d -> concatMap (T.splitOn d) ls) s dl---- | return the edit distance of two string-editDis :: T.Text -> T.Text -> Int-editDis t1 t2 = dp!(len1, len2)- where (s1, s2) = (T.unpack t1, T.unpack t2)- (len1, len2) = (length s1, length s2)- a1 = listArray (1, len1) s1- a2 = listArray (1, len2) s2- bnd = ((0, 0), (len1, len2))- dp = listArray bnd [go i j | (i, j) <- range bnd]- go i 0 = i- go 0 j = j- go i j = minimum [ dp!(i, j-1) + 1- , dp!(i-1, j) + 1- , dp!(i-1, j-1) + cost- ]- where cost = if a1!i == a2!j then 0 else 1---- | caculate whether the edit distance of two video--- name is less than half of the first video's length-isAlike :: Video -> Video -> Bool-isAlike vf1 vf2 = dis <= lim- where (n1, n2) = (getName vf1, getName vf2)- (e1, e2) = (cutName n1, cutName n2)- vn1 = either id (!!1) e1- vn2 = either id (!!1) e2- -- vn1 and vn2 are the video name without subtitle or episode if being parsed.- lim = length (T.unpack vn1) `div` 2- dis = editDis vn1 vn2--{--search :: [Video] -> -- ^ video list- [String] -> -- ^ a list of target string- [Video]-search vids par = filter (\v -> vidInfx v (map T.pack par)) vids--}--vidInfx :: Video -> [Text] -> Bool-vidInfx _ [] = True-vidInfx v (x:xs) = (x `ifx` getName v) && vidInfx v xs- where ifx = T.isInfixOf `on` T.toCaseFold--sortByName :: [Video] -> [Video]-sortByName = sortBy (comparing getName)--sortVid :: [Video] -> [Video]-sortVid = sortBy cmpv- where cmpv :: Video -> Video -> Ordering- cmpv = cmp `on` dt- where dt v- | isVid v = vidDate v- | otherwise = fldDate v- cmp :: T.Text -> T.Text -> Ordering- cmp = flip compare `on` prs- where prs tx = [year, tranMon mon, day, time] - where [day, mon, year, time] = T.splitOn "-" tx- tranMon :: T.Text -> T.Text- tranMon m = case m of- "Jan" -> "A"- "Feb" -> "B"- "Mar" -> "C"- "Apr" -> "D"- "May" -> "E"- "Jun" -> "F"- "Jul" -> "G"- "Aug" -> "H"- "Sep" -> "I"- "Oct" -> "J"- "Nov" -> "K"- "Dec" -> "L"- _ -> " "-
+ src/Networking.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Networking+where++import Network.HTTP.Conduit+import Data.Text.Encoding+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Ord+import Data.List+import Data.Maybe+import Text.HTML.DirectoryListing.Type+import Text.HTML.DirectoryListing.Parser+import System.FilePath.Posix+import Control.Concurrent++import Cache+import qualified Configure as Conf+import Types+import Local++type NetworkResource = Text -> (Request, Manager) +-- ^ relative path++genNetworkResource :: Text -> -- ^ webpage url (root)+ Maybe (Text, Text) -> -- ^ (username, password)+ IO NetworkResource+genNetworkResource url up = do+ let genReq :: Text -> Request+ genReq rp = case parseUrl path of+ Nothing -> error $ "invalid url: " ++ path+ Just r -> auth r+ where+ path = T.unpack url ++ T.unpack rp+ auth = case up of+ Nothing -> id+ Just (u, p) -> applyBasicAuth (encodeUtf8 u) (encodeUtf8 p)+ manager <- newManager tlsManagerSettings+ return $ \t -> (genReq t, manager)+ ++getWebpage :: NetworkResource -> + Text -> -- relative path+ IO Text+getWebpage nr rp = do+ let (req, mgr) = nr rp+ response <- httpLbs req mgr+ let body = responseBody response+ case decodeUtf8' . B.concat . BL.toChunks $ body of+ Left unicodeException -> error . show $ unicodeException+ Right t -> return t++fetch :: NetworkResource ->+ IO [DNode]+fetch nr = do+ html <- getWebpage nr ""+ lcd <- T.unpack . fromMaybe "" <$> Conf.getLocaldir+ let+ entries = sortBy (flip $ comparing lastModified) $ parseDirectoryListing html+ toDNode :: Text -> Entry -> IO DNode+ toDNode url e+ | isDirectory e = return $ Directory e childs+ | otherwise = do+ downloaded <- isFileDownloaded (decodedName e) lcd+ return $ File e (url `T.append` href e) downloaded+ where+ childs :: IO [DNode]+ childs = do+ html' <- getWebpage nr newUrl+ mapM (toDNode newUrl) . sortBy (flip $ comparing lastModified) $ parseDirectoryListing html'+ newUrl = url `T.append` href e + forkIO $ writeCache entries+ mapM (toDNode "") entries
− src/Pgdl.hs
@@ -1,235 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--import FetchHtml-import PrsVid-import NameAlgo -import RealWorld-import Chkcfg-import Video-import Log-import GenStat-import CrtInf-import AskScene-import UI--import qualified Data.Text as T-import Data.Ord-import Control.Applicative-import Control.Concurrent-import Control.Monad--import Graphics.Vty-import Graphics.Vty.Widgets.All--main :: IO ()-main = do- chkcfg - -- check if there exists a configuration file, if not, then create one-- c <- newCollection-- tmpLst <- newList 3- -- the main list will display on screen-- diskV <- readVid- -- read cache in the disk, if the cache do not exists, return "downloading"-- forM_ diskV $ \v -> addToList tmpLst v =<< plainText (beaut v)- -- add disk videos to list-- tmpLfg <- newFocusGroup- addToFocusGroup tmpLfg tmpLst-- statBar <- plainText waitingBar- -- the state bar show in the bottom- setNormalAttribute statBar (black `on` green)-- tmpUi <- centered =<< hFixed 80 =<< vBox tmpLst statBar- -- ui consists of a list and a state bar- addToCollection c tmpUi tmpLfg- -- (dlg, dfcg) <- newAskScene- dui <- centered =<< hFixed 50 (sceneWidget dlg)- chgdl <- addToCollection c dui dfcg-- ifsfg <- newFocusGroup- -- a focus group for information page- - helpfg <- newFocusGroup- -- a focus group of help page-- -- this function will show the focused item's information to user-- tmpLfg `onKeyPressed` tryExit- dfcg `onKeyPressed` tryExit- ifsfg `onKeyPressed` tryExit- helpfg `onKeyPressed` tryExit-- -- colorDecide tmpLst-- -- let's download video from internet !- schedule $ do- forkIO $ do- vdlst <- prsHtm <$> fetchHtml- -- prsHtm :: Text -> [Video (whether video or folder)]- forkIO . writeVid $ vdlst- -- write cache to the disk- - vlst <- vidsVList vdlst- let lst = listW vlst- - -- move to the selected old item- Just (_, (oldSeleItm, _)) <- getSelected tmpLst- listFindFirst lst oldSeleItm >>= \case- Just idx -> setSelected lst idx- Nothing -> return ()-- -- show new list- lfg <- newFocusGroup- lfg `onKeyPressed` tryExit- addToFocusGroup lfg lst- lui <- centered =<< hFixed 80 =<< vBox lst statBar- chgls <- addToCollection c lui lfg - chgls- ew <- editWidget- -- a widget to enter keyword- kfg <- newFocusGroup- addToFocusGroup kfg ew- kui <- centered =<< hFixed 80 =<< vBox lst ew- chgky <- addToCollection c kui kfg- -- create a scene presents a input box-- colorDecide lst-- -- four button in ask scene's action- onScePlay dlg $ \_ -> do- Just (_, (itm, _)) <- getSelected lst- justPlay itm- chgls- onSceDown dlg $ \_ -> do- Just (_, (itm, _)) <- getSelected lst- playVid itm- chgls- onSceQuit dlg $ const chgls- onSceRemv dlg $ \_ -> do- Just (_, (itm, _)) <- getSelected lst- removeVid itm- chgls-- -- onSelectionChange lst $ \sle -> case sle of- -- SelectionOn _ itm _ -> setText statBar =<< genStat itm- -- -- refresh state bar after any scroll- -- _ -> return ()- refreshStatusBar lst statBar-- let chgInf = do- Just (_, (vid, _)) <- getSelected lst- inf <- centered =<< plainText (crtInfPg vid)- addToFocusGroup ifsfg inf- join $ addToCollection c inf ifsfg-- -- the information scene- onKeyPressed ifsfg $ \_ key _ -> case key of- KLeft -> do- chgls -- return to the list- return True- KUp -> do- scrollUp lst- chgInf- return True- KDown -> do- scrollDown lst- chgInf- return True- _ -> return False-- let chgHelp = do- hp <- centered =<< plainText helpPage- addToFocusGroup helpfg hp- join $ addToCollection c hp helpfg- onKeyPressed helpfg $ \_ _ _ -> (chgls >> return True)-- onKeyPressed lst $ \_ key _ -> case key of- KRight -> do- chgInf- return True- _ -> return False-- onActivate ew $ \e -> do- t <- getEditText e- setEditText e ""- filterVList vlst $ \v -> vidInfx v (T.words t)- chgls- -- return to the list-- let openFld lnk = do- ctnt <- (map (attcLink lnk) . prsHtm) <$> fetchFld lnk - -- attach folder link to the videos in the folder- when (null ctnt) $ error "there is no video in the folder!" - setVList vlst ctnt- return ()-- onKeyPressed lst $ \_ key _ -> case key of- KEnter -> do- -- User can choose a folder or a video !- Just (_, (itm, _)) <- getSelected lst- case itm of- Folder _ lnk _ -> openFld lnk- v -> fex v >>= \case- True -> chgdl- False -> playVid itm- return True- KLeft -> do- -- return to the old list- backVList vlst- return True- KChar 's' -> do- -- filter the videos by the focused video- Just (_, (itm, _)) <- getSelected lst- filterVList vlst (isAlike itm)- return True- KChar 'n' -> do- -- sort videos by their name- sortVList vlst (comparing getName) - return True- KChar 'v' -> do- filterVListIO vlst $ \obj -> if isVid obj then downloaded obj- else return False - return True- KChar 'u' -> do- filterVListIO vlst $ \obj -> if isVid obj then not <$> downloaded obj- else return False - return True- KChar '/' -> do- chgky- return True- KChar 'h' -> do- chgHelp- return True-- _ -> return False-- return ()- return ()-- runUi c $ defaultContext { normalAttr = white `on` black - , focusAttr = black `on` blue- }--helpPage :: T.Text-helpPage = T.unlines [ - "q - quit"- ,"s - list files that similar with the highlighted file"- ,"Key Right - show the detailed information of the highlighted file"- ,"Key Left - go back to the previous page"- ,"Enter - xdg-open the file"- ,"/ - open a input box to enter a keyword to search"- ,"n - sort the current list by name"- ,"v - show all the files already in the disk"- ,"u - show all the files not in the disk"- ]--
− src/PrsVid.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module PrsVid where--import Video-import NameAlgo--import Network.HTTP.Base-import Text.HTML.TagSoup-import qualified Data.Text as T--prsHtm :: T.Text -> [Video]-prsHtm t = if null vs then [noVideo] else vs- where vs = sortVid $ prsVid t ++ prsFld t- noVideo = Video "No video in this folder." "" "" ""--prsVid :: T.Text -> [Video]-prsVid = map (genVid . filter (not . T.null) . map pullText) .- filter isVidLn . map parseTags . T.lines- where isVidLn = any isVidLnk- isVidLnk tg- | isTagOpen tg = not ("/" `T.isSuffixOf` fromAttrib "href" tg) && (not . T.null $ fromAttrib "href" tg)- | otherwise = False- pullText tg- | isTagOpen tg = fromAttrib "href" tg- | isTagText tg = fromTagText tg- | otherwise = ""- genVid [lnk, _, tx] = Video {vidLink = lnk, vidName = nm, vidDate = dt, vidSize = sz}- where dt = T.intercalate "-" . take 2 $ T.words tx- sz = T.pack . hsz . read . last . words . T.unpack $ tx- hsz :: Int -> String- hsz i = show (i `div` (1024*1024)) ++ "M"- nm = genName lnk- genVid _ = Video "Parse Fail" "" "" ""- fmts = [".mp4", ".avi", ".mkv"]--prsFld :: T.Text -> [Video]-prsFld = map (mkFld . filter (not . T.null) . map pullText) . filter isFldLn . map parseTags . T.lines- where isFldLn = isFldLnk . head- isFldLnk tg- | isTagOpen tg = (`T.isSuffixOf` fromAttrib "href" tg) "/"- | otherwise = False- mkFld :: [T.Text] -> Video- mkFld [lnk, _, tx] = Folder {fldName = nm, fldLink = lnk, fldDate = dt}- where nm = T.init . genName $ lnk- dt = T.intercalate "-" . take 2 $ T.words tx- mkFld _ = Folder "Folder Parse Fail" "" ""- pullText tg- | isTagOpen tg = fromAttrib "href" tg- | isTagText tg = fromTagText tg- | otherwise = ""--genName :: T.Text -> T.Text-genName = T.pack . urlDecode . T.unpack
− src/RealWorld.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--module RealWorld where--import Getconfig-import Video--import Control.Monad-import Distribution.System-import System.Process-import System.Directory-import System.FilePath.Posix-import qualified Data.Text as T---- play a video-playVid :: Video -> IO ()-playVid vid = do- when (isFld vid) $ error "give playVid a folder."-- -- don't download a video whoose name is empty- when ("/" `T.isSuffixOf` vidLink vid) $ error "maybe this is not a video?"-- username <- getUsername- password <- getPassword- servpath <- getServpath- localdir <- getLocaldir-- let localloc = localdir </> vn- fex <- doesFileExist localdir- when fex $ removeFile localloc-- let purepath = reverse . dropWhile (/= '/') . reverse $ servpath- let url = "http://" ++ purepath ++ vu- case username of- "" -> runCommand $ "nohup curl -L " ++ addq url ++ " -o " ++ addq localloc ++ "&>/dev/null &"- _ -> runCommand $ "nohup curl -L -u " ++ username ++ ":" ++ password ++ " " ++ addq url ++ " -o " ++ addq localloc ++ "&>/dev/null &"- let checkFile = doesFileExist localloc >>= \ready -> unless ready checkFile- checkFile- case buildOS of- OSX -> runCommand $ "open " ++ addq localloc ++ " "- Linux -> runCommand $ "nohup xdg-open " ++ addq localloc ++ " &>/dev/null &"- _ -> error "OS unsupported!"- return ()- where vn = T.unpack . vidName $ vid- vu = T.unpack . vidLink $ vid- addq :: String -> String- addq s = "\"" ++ s ++ "\""--justPlay :: Video -> IO ()-justPlay vid = do- when (isFld vid) $ error "give playVid a folder."-- localdir <- getLocaldir- let localloc = localdir </> vn- case buildOS of- OSX -> runCommand $ "open " ++ addq localloc ++ " "- Linux -> runCommand $ "nohup xdg-open " ++ addq localloc ++ " &>/dev/null &"- _ -> error "OS unsupported!"- return ()- -- exitSuccess- where vn = T.unpack . vidName $ vid- addq :: String -> String- addq s = "\"" ++ s ++ "\""- --- | remove a video -removeVid :: Video -> IO ()-removeVid vid = do- localDir <- getLocaldir- removeFile $ localDir </> vn- return ()- -- exitSuccess- where vn = T.unpack . vidName $ vid---- | determine whether a video is downloaded-downloaded :: Video -> IO Bool-downloaded v = do- lcd <- getLocaldir- doesFileExist $ lcd </> T.unpack t- where t = if isVid v then vidName v- else error "try to consider a folder downloaded or not" -
+ src/Types.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+module Types+where++import Text.HTML.DirectoryListing.Type+import Data.Text (Text)++data DNode = Directory Entry (IO [DNode]) | File Entry Text Bool+-- downloaded?+
− src/UI.hs
@@ -1,152 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--module UI where--import Video-import RealWorld-import NameAlgo-import GenStat--import Control.Monad-import System.Exit-import Graphics.Vty-import Graphics.Vty.Widgets.All-import Data.IORef-import Data.List-import Control.Concurrent--type WL = Widget (List Video FormattedText)-type VidStat = ([Video], Video)--- videos last select video--data VList = VList WL (IORef [VidStat])--listW :: VList -> WL-listW (VList lw _) = lw--vidsVList :: [Video] -> IO VList-vidsVList vs = do- lst <- newList 3- forM_ vs $ \v -> addToList lst v =<< plainText (beaut v)- ior <- newIORef []- return $ VList lst ior--filterVList :: VList -> (Video -> Bool) -> IO ()-filterVList vl@(VList wl _) ok = do- origVids <- getListVideos wl- case filter ok origVids of- [] -> return ()- res -> do- storeState vl- setListVideos wl res--filterVListIO :: VList -> (Video -> IO Bool) -> IO ()-filterVListIO vl@(VList wl _) ok = do- origVids <- getListVideos wl- newVids <- filterM ok origVids- case newVids of- [] -> return ()- res -> do- storeState vl- setListVideos wl res--sortVList :: VList -> (Video -> Video -> Ordering) -> IO ()-sortVList vl@(VList wl _) cmp = do- storeState vl- setListVideos wl . sortBy cmp =<< getListVideos wl--storeState :: VList -> IO ()-storeState (VList wl st) = do- vs <- getListVideos wl- idx <- getWLSelected wl- modifyIORef st ((vs, idx):)--setVList :: VList -> [Video] -> IO ()-setVList (VList wl st) vs = do- oldVs <- getListVideos wl- idx <- getWLSelected wl- modifyIORef st ((oldVs, idx):)- setListVideos wl vs--backVList :: VList -> IO ()-backVList (VList wl st) = - readIORef st >>= \case- [] -> - return ()- ((bvs, bloc):_) -> do--- putStrLn "something >////<"- setListVideosB wl bvs bloc- modifyIORef st tail--tryExit :: Widget FocusGroup -> Key -> [Modifier] -> IO Bool-tryExit _ key _ = case key of- KChar 'q' -> exitSuccess- KEsc -> exitSuccess- _ -> return False--fex :: Video -> IO Bool-fex itm- | isVid itm = downloaded itm- | otherwise = return False---- return the videos in the list-getListVideos :: WL -> IO [Video]-getListVideos lst = do- sz <- getListSize lst- forM [0..sz-1] $ \idx -> do- Just (itm, _) <- getListItem lst idx- return itm--getWLSelected :: WL -> IO Video-getWLSelected ls = do- Just (_, (idx, _)) <- getSelected ls- return idx---- set lst content to vs-setListVideos :: WL -> [Video] -> IO ()-setListVideos lst vs = do- oldItm <- getWLSelected lst- clearList lst - forM_ vs $ \v -> addToList lst v =<< plainText (beaut v)- listFindFirst lst oldItm >>= \case- Just ind -> setSelected lst ind- Nothing -> return ()--setListVideosB :: WL -> [Video] -> Video -> IO ()-setListVideosB lst vs bvid = do- Just (_, (oldItm, _)) <- getSelected lst- clearList lst - forM_ vs $ \v -> addToList lst v =<< plainText (beaut v)- listFindFirst lst oldItm >>= \case- Just ind -> setSelected lst ind- Nothing -> listFindFirst lst bvid >>= \case- Just ind2 -> setSelected lst ind2- Nothing -> return ()--colorDecide :: WL -> IO ()-colorDecide lst = do- forkIO . forever $ do- schedule $ do- Just (_, (itm, _)) <- getSelected lst- if isFld itm then- setFocusAttribute lst (black `on` magenta)- -- folder's color- else fex itm >>= \case- True -> setFocusAttribute lst (black `on` red) - -- if video have been download, use red color- False -> setFocusAttribute lst (black `on` cyan)- -- if video haven't been download, use cyan- threadDelay 50000 -- 0.05 second- return ()--refreshStatusBar :: WL -> Widget FormattedText-> IO ()-refreshStatusBar lst statBar = do- forkIO . forever $ do- schedule $ do- Just (_, (itm, _)) <- getSelected lst- setText statBar =<< genStat itm- threadDelay 50000 -- 0.05 second- return ()-
+ src/Utils.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Utils +where++import qualified Data.ByteString as B+import qualified Data.Text as T+import Data.Text (Text)+import Text.Printf+import Data.Text.Encoding++-- | give a file size in bytes, return pretty file size +-- represent in KB, MB, GB or TB+friendlySize :: Integer -> String+friendlySize b+ | fb < 1024 = s2s fb ++ " B "+ | kb < 1024 = s2s kb ++ " KB"+ | mb < 1024 = s2s mb ++ " MB"+ | gb < 1024 = s2s gb ++ " GB"+ | otherwise = s2s tb ++ " TB"+ where+ fb :: Double+ fb = fromIntegral b+ kb = fb / 1024.0+ mb = kb / 1024.0+ gb = mb / 1024.0+ tb = gb / 1024.0+ s2s :: Double -> String+ s2s = printf "%6s" . (printf "%.1f" :: Double -> String)++terminalWidth :: Num a => a+terminalWidth = 80++-- | return the estimated display length of a Text+displayLength :: Text -> Integer+displayLength = sum . map charDisplayLen . T.unpack++-- | charDisplayLen determine a unicode character is a wide character or not+-- (a wide character occupy 2 space in the terminal)+-- this method may seem unreliable, but have no better idea.+charDisplayLen :: Char -> Integer+charDisplayLen c+ | (B.length . encodeUtf8 . T.pack $ [c]) > 1 = 2+ | otherwise = 1++-- | given a line of Text, cut it to a group of Text+-- which have 'len' display length+cutTextByDisplayLength :: Integer -> Text -> [Text]+cutTextByDisplayLength len = map T.pack . gp . T.unpack+ where+ gp :: String -> [String]+ gp = go 0 "" . map (\c -> (c, charDisplayLen c))+ where+ go :: Integer -> String -> [(Char, Integer)] -> [String]+ go _ acc []+ | null acc = []+ | otherwise = [reverse acc]+ go lsum acc str@(x:xs) + | lsum + snd x <= len = go (lsum + snd x) (fst x : acc) xs+ | otherwise = reverse acc : go 0 "" str++
− src/Video.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Video where--import System.FilePath-import qualified Data.Text as T--data Video = Video { vidName :: T.Text- , vidLink :: T.Text- , vidSize :: T.Text- , vidDate :: T.Text- } |- Folder { fldName :: T.Text- , fldLink :: T.Text- , fldDate :: T.Text- }--instance Eq Video where- x == y - | isVid x && isVid y = vidName x == vidName y- | isFld x && isFld y = fldName x == fldName y- | otherwise = False--getName :: Video -> T.Text-getName (Video n _ _ _) = n-getName (Folder n _ _) = n--isVid :: Video -> Bool-isVid Video {} = True-isVid _ = False--isFld :: Video -> Bool-isFld v = not $ isVid v---attcLink :: T.Text -> Video -> Video-attcLink fnt (Video name linkt size date) = Video - { vidName = name- , vidLink = T.pack $ fn </> link- , vidSize = size- , vidDate = date- }- where fn = T.unpack fnt- link = T.unpack linkt-attcLink fnt (Folder name linkt date) = Folder- { fldName = name- , fldLink = T.pack $ fn </> link- , fldDate = date- }- where fn = T.unpack fnt- link = T.unpack linkt-