pgdl 7.4 → 7.5
raw patch · 17 files changed
+177/−104 lines, 17 files
Files
- README.md +1/−0
- pgdl.cabal +3/−1
- src/AskScene.hs +0/−1
- src/Beaut.hs +5/−3
- src/Chkcfg.hs +17/−17
- src/CrtInf.hs +16/−6
- src/FetchHtml.hs +18/−4
- src/GenStat.hs +4/−2
- src/Getconfig.hs +7/−1
- src/Log.hs +2/−0
- src/Main.hs +52/−30
- src/PlayVid.hs +1/−2
- src/PrsVid.hs +14/−26
- src/Search.hs +3/−4
- src/SortVid.hs +10/−4
- src/TestExist.hs +1/−2
- src/Video.hs +23/−1
README.md view
@@ -6,4 +6,5 @@ Server: Only for nginx's file download page. The program will sort the files by date while the files in nginx's download page just show in file names' order.+Pass flag -f to read folder.
pgdl.cabal view
@@ -1,6 +1,6 @@ name: pgdl-version: 7.4+version: 7.5 license: PublicDomain license-file: LICENSE author: sifmelcara@@ -16,6 +16,8 @@ Server: Only for nginx's file download page. . The program will sort the files by date while files in nginx's download page just sort in file name.+ Pass argument -f to read folder.+ synopsis: pgdownloader source-repository head
src/AskScene.hs view
@@ -5,7 +5,6 @@ import Graphics.Vty.Widgets.All import Graphics.Vty.Input.Events -import qualified Data.Text as T import Control.Monad data AskScene = AskScene { sceneWidget :: Widget (Bordered Padded)
src/Beaut.hs view
@@ -4,11 +4,14 @@ import Video -import Data.List import qualified Data.Text as T beaut :: Video -> T.Text-beaut (Video str _ _ _)+beaut (Video str _ _ _) = beautT str+beaut (Folder str _ _) = "\n" `T.append` str++beautT :: T.Text -> T.Text+beautT str | length dat < 3 = "\n" `app` str | otherwise = T.intercalate "\n" [tb 4 `app` sbt, tb 10 `app` nme, @@ -20,6 +23,5 @@ app s1 s2 = s1 `T.append` s2 spl = filter (\t -> T.length t /= 0) . getTags ["[", "]"] . return getTags dl s = foldl (\ls d -> concatMap (T.splitOn d) ls) s dl-
src/Chkcfg.hs view
@@ -5,26 +5,26 @@ 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 file at ~/.pgdl first!"--defcfg = unlines [ "",- "# example: ",- "# username = \"jack\" ",- "# password = \"mypassw\" ",- "# servpath = \"example.org/videodir/\" ",- "# localdir = \"/home/jack/Downloads/\" ", - "",- "# username and localdir is optional.",- "",- "username = \"\"",- "password = \"\"",- "servpath = \"\"",- "localdir = \"\"",- ""- ]+ 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/CrtInf.hs view
@@ -8,13 +8,23 @@ crtInfPg :: Video -> T.Text crtInfPg vid = T.unlines ["", "",- "File name: " `app` (spl . vidName) vid,- "File size: " `app` vidSize vid,- "File date: " `app` vidDate vid,- "File link: " `app` (spl . vidLink) vid+ "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 --+ getName v+ | isVid v = vidName v+ | otherwise = fldName v+ 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/FetchHtml.hs view
@@ -7,17 +7,31 @@ import Network.HTTP import Network.URI import Data.Text.Encoding-import Data.ByteString import Data.Maybe+import System.FilePath+import Control.Applicative import qualified Data.Text as T fetchHtml :: IO T.Text-fetchHtml = do+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- let uri = "http://" ++ usrn ++ ":" ++ usrp ++ "@" ++ servp- res <- simpleHTTP . mkRequest GET . fromJust . parseURI $ uri+ return $ "http://" ++ usrn ++ ":" ++ usrp ++ "@" ++ servp++getTextContent :: String -> IO T.Text+getTextContent u = do+ res <- simpleHTTP . mkRequest GET . fromJust . parseURI $ u cnt <- getResponseBody res return $ decodeUtf8 cnt+
src/GenStat.hs view
@@ -16,10 +16,12 @@ , spc 20, st , spc 30 ]- where app = T.append- spc :: Int -> T.Text+ where spc :: Int -> T.Text spc i = T.replicate i " " +genStat (Folder {}) = return "I'm a folder"++waitingBar :: T.Text waitingBar = " Waiting for data..." `T.append` T.replicate 99 " " toStr :: IO Bool -> IO T.Text
src/Getconfig.hs view
@@ -5,7 +5,6 @@ import Control.Monad import Data.Maybe -import qualified Data.Text as T import qualified Data.Configurator as C getConfig :: IO (String, String, String, String)@@ -19,8 +18,15 @@ return (fj username, fj password, fj servpath, fj localdir) where fj = fromJust +getUsername :: IO String getUsername = fmap (\(r, _, _, _) -> r) getConfig++getPassword :: IO String getPassword = fmap (\(_, r, _, _) -> r) getConfig++getServpath :: IO String getServpath = fmap (\(_, _, r, _) -> r) getConfig++getLocaldir :: IO String getLocaldir = fmap (\(_, _, _, r) -> r) getConfig
src/Log.hs view
@@ -17,6 +17,7 @@ decVid :: T.Text -> [Video] decVid = map (\t -> Video t "" "" "") . T.lines +logname :: FilePath logname = ".pgdl.cache" writeVid :: [Video] -> IO ()@@ -34,6 +35,7 @@ return $ decVid dat False -> return dlnVid +dlnVid :: [Video] dlnVid = [Video "Downloading..." "" "" ""]
src/Main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} import FetchHtml import PrsVid@@ -17,16 +18,13 @@ import Control.Applicative import Control.Concurrent import Control.Monad-import System.Directory import System.Exit import System.Environment-import System.FilePath-import System.IO import Graphics.Vty import Graphics.Vty.Widgets.All-import qualified Data.Text as T +main :: IO () main = do chkcfg @@ -35,7 +33,8 @@ lst <- newList 3 diskrd <- readVid args <- getArgs- let diskV = if null args then diskrd else dlnVid+ let diskV = if null args then diskrd+ else dlnVid forM_ diskV $ \v -> addToList lst v =<< plainText (beaut v) lfg <- newFocusGroup addToFocusGroup lfg lst@@ -78,12 +77,12 @@ join $ addToCollection c inf ifsfg return True _ -> return False-- schedule $ do+ if null args || head args /= "-f" + then schedule $ do forkIO $ do- rd <- prsVid <$> fetchHtml- vdlst <- search rd <$> getArgs- when (length vdlst < 1) $ error "empty list!"+ rd <- prsVid <$> fetchHtml+ let vdlst = search rd args+ when (length vdlst < 1) $ error "no video found!" Just (_, (oldItm, _)) <- getSelected lst clearList lst forM_ vdlst $ \v -> addToList lst v =<< plainText (beaut v)@@ -91,32 +90,44 @@ Just ind -> setSelected lst ind Nothing -> return () - onSelectionChange lst $ \sle -> case sle of- SelectionOn _ itm _ -> fex itm >>= \case - True -> setFocusAttribute lst (black `on` red) - False -> setFocusAttribute lst (black `on` cyan)- _ -> return ()-- onSelectionChange lst $ \sle -> case sle of- SelectionOn _ itm _ -> setText statBar =<< genStat itm- _ -> return ()- -- onKeyPressed lst $ \_ key _ -> case key of- KEnter -> do- Just (_, (itm, _)) <- getSelected lst- fex itm >>= \case - True -> chgdl- False -> playVid itm- return True- _ -> return False+ vLstAction lst chgdl statBar - (null <$> getArgs) >>= \case+ (null <$> getArgs) >>= \case True -> void . forkIO $ writeVid vdlst _ -> return () return () return ()+ else schedule $ do+ forkIO $ do+ rd <- prsFld <$> fetchHtml+ let fdlst = search rd (tail args)+ when (length fdlst < 1) $ error "no folder found!"+ clearList lst+ forM_ fdlst $ \v -> addToList lst v =<< plainText (beaut v)+ setFocusAttribute lst (black `on` cyan)+ return ()+ return () + let openFld lnk = do+ ctnt <- (map (attcLink lnk) . prsVid) <$> fetchFld lnk + when (null ctnt) $ error "no video in the folder!" + clearList lst + forM_ ctnt $ \v -> addToList lst v =<< plainText (beaut v) + vLstAction lst chgdl statBar + return () ++ onKeyPressed lst $ \_ key _ -> case key of+ KEnter -> do+ Just (_, (itm, _)) <- getSelected lst+ case itm of+ Folder _ lnk _ -> openFld lnk+ v -> fex v >>= \case+ True -> chgdl+ False -> playVid itm+ return True+ _ -> return False+ + runUi c $ defaultContext {normalAttr = white `on` black, focusAttr = black `on` blue }@@ -125,5 +136,16 @@ KChar 'q' -> exitSuccess _ -> return False +vLstAction lst chgdl statBar = do+ onSelectionChange lst $ \sle -> case sle of+ SelectionOn _ itm _ -> fex itm >>= \case + True -> setFocusAttribute lst (black `on` red) + False -> setFocusAttribute lst (black `on` cyan)+ _ -> return () + onSelectionChange lst $ \sle -> case sle of+ SelectionOn _ itm _ -> setText statBar =<< genStat itm+ _ -> return ()++ where fex itm = downloaded $ vidName itm
src/PlayVid.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module PlayVid where @@ -10,7 +11,6 @@ import System.Process import System.Directory import System.FilePath.Posix-import System.IO import System.Exit import qualified Data.Text as T @@ -44,7 +44,6 @@ justPlay :: Video -> IO () justPlay vid = do- servpath <- getServpath localdir <- getLocaldir let localloc = localdir </> vn case buildOS of
src/PrsVid.hs view
@@ -6,8 +6,6 @@ import GenName import SortVid -import Data.List-import Data.Function import Text.HTML.TagSoup import qualified Data.Text as T @@ -24,7 +22,7 @@ | 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+ 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"@@ -32,30 +30,20 @@ genVid _ = Video "Parse Fail" "" "" "" fmts = [".mp4", ".avi", ".mkv"] --{-- map (genVidInf . filter (not. T.null) . map getInf) .- filter isVideoLine . - map parseTags . T.lines- where isVideoLine = any isNameTag- isNameTag tg- | isTagText tg = any (`T.isSuffixOf` fromTagText tg) vdfmt- | otherwise = False- isLinkTag tg- | isTagOpen tg = not. T.null $ fromAttrib "href" tg- | otherwise = False- isDtSzTag tg- | isTagText tg = all (`T.isInfixOf` fromTagText tg) ["-", ":"]+prsFld :: T.Text -> [Video]+prsFld = sortVid . 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- getInf tg- | isNameTag tg = fromTagText tg- | isLinkTag tg = fromAttrib "href" tg- | isDtSzTag tg = $ fromTagText tg+ 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 = ""- genVidInf [lnk, nm, dt, sz] = Video {vidLink = lnk, vidName = nm, vidDate = dt, vidSize = sz} - genVidInf _ = Video {vidLink = T.empty, vidName = "parse error", vidDate = "", vidSize = ""}- vdfmt = [".avi", ".mp4", ".mkv"] ---}
src/Search.hs view
@@ -4,12 +4,11 @@ import Video -import Data.Function import qualified Data.Text as T search :: [Video] -> [String] -> [Video]-search vids par = filter pred vids- where pred v = all (\tar -> (T.pack tar) `T.isInfixOf` name) par- where name = vidName v+search vids par = filter ok vids+ where ok v = all (\tar -> T.pack tar `T.isInfixOf` name) par+ where name = if isVid v then vidName v else fldName v
src/SortVid.hs view
@@ -9,12 +9,17 @@ import Data.Function sortVid :: [Video] -> [Video]-sortVid = sortBy (cmpDate `on` vidDate)+sortVid = sortBy cmpv -cmpDate :: T.Text -> T.Text -> Ordering-cmpDate = flip compare `on` prs+cmpv :: Video -> Video -> Ordering+cmpv v1 v2+ | isVid v1 = (cmp `on` vidDate) v1 v2+ | otherwise = (cmp `on` fldDate) v1 v2++cmp :: T.Text -> T.Text -> Ordering+cmp = flip compare `on` prs where prs tx = [year, tranMon mon, day, time] - where [day, mon, year, time] = concat . map (T.splitOn "-") . (T.splitOn " ") $ tx+ where [day, mon, year, time] = T.splitOn "-" tx tranMon :: T.Text -> T.Text tranMon m = case m of@@ -30,4 +35,5 @@ "Oct" -> "J" "Nov" -> "K" "Dec" -> "L"+ _ -> " "
src/TestExist.hs view
@@ -4,7 +4,6 @@ import Getconfig -import Data.Function import System.Directory import System.FilePath @@ -13,6 +12,6 @@ downloaded :: T.Text -> IO Bool downloaded t = do lcd <- getLocaldir- doesFileExist $ lcd </> (T.unpack t)+ doesFileExist $ lcd </> T.unpack t
src/Video.hs view
@@ -2,15 +2,37 @@ 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 = vidName x == vidName y +isVid :: Video -> Bool+isVid Video {} = True+isVid _ = False++isFld :: Video -> Bool+isFld v = not $ isVid v+++attcLink :: T.Text -> Video -> Video+attcLink fnt vid = Video { vidName = name+ , vidLink = T.pack $ fn </> link+ , vidSize = size+ , vidDate = date+ }+ where fn = T.unpack fnt+ (Video name linkt size date) = vid+ link = T.unpack linkt