pgdl 7.6 → 7.77
raw patch · 15 files changed
+340/−219 lines, 15 filesdep +array
Dependencies added: array
Files
- README.md +12/−0
- pgdl.cabal +8/−7
- src/Beaut.hs +0/−27
- src/CrtInf.hs +0/−3
- src/GenName.hs +0/−10
- src/GenStat.hs +2/−2
- src/Getconfig.hs +27/−17
- src/Main.hs +132/−50
- src/NameAlgo.hs +78/−0
- src/PlayVid.hs +0/−68
- src/PrsVid.hs +3/−2
- src/RealWorld.hs +73/−0
- src/Search.hs +0/−15
- src/TestExist.hs +0/−17
- src/Video.hs +5/−1
README.md view
@@ -13,3 +13,15 @@ cabal update <br> cabal install pgdl +## Command line argument++all arguments passed to the program become keywords to filter videos.++## Shortcut keys++q - quit+s - list files that similar with the highlighted video+Key Right - show the detailed information of the highlighted video+Key Left - go back to the previous page+Enter - play the video+
pgdl.cabal view
@@ -1,6 +1,6 @@ name: pgdl-version: 7.6+version: 7.77 license: PublicDomain license-file: LICENSE author: sifmelcara@@ -16,6 +16,8 @@ Server: Only for nginx's file download page. . The program will sort the video files and folders by date while files in nginx's download page just sort by name.+ .+ For shortcut keys, please visit https://github.com/sifmelcara/pgdl synopsis: pgdownloader @@ -26,16 +28,15 @@ executable pgdl hs-source-dirs: src main-is: Main.hs- other-modules: Beaut, Chkcfg, FetchHtml, Getconfig, Log, - PlayVid, PrsVid, Search, Video, GenStat, - TestExist, GenName, SortVid, CrtInf, AskScene- build-depends: base == 4.* , process, + other-modules: NameAlgo, Chkcfg, FetchHtml, Getconfig,+ Log, RealWorld, PrsVid, Video, GenStat, + SortVid, CrtInf, AskScene+ build-depends: base == 4.*, process, directory, bytestring, tagsoup, network-uri, vty, text, vty-ui >= 1.8, configurator >= 0.3.0.0, HTTP,- filepath, Cabal+ filepath, Cabal, array ghc-options: -threaded -O2 default-language: Haskell2010-
− src/Beaut.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Beaut where--import Video--import qualified Data.Text as T--beaut :: Video -> T.Text-beaut (Video str _ _ _) = beautT str-beaut (Folder str _ _) = beautT 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, - tb 30 `app` eps- ]- where dat = spl str- (sbt:nme:eps:_) = dat- tb n = T.replicate n " "- 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/CrtInf.hs view
@@ -15,9 +15,6 @@ ] 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"
− src/GenName.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module GenName where--import Network.HTTP.Base-import qualified Data.Text as T--genName :: T.Text -> T.Text-genName = T.pack . urlDecode . T.unpack-
src/GenStat.hs view
@@ -4,7 +4,7 @@ module GenStat (genStat, waitingBar) where import Video-import TestExist+import RealWorld import qualified Data.Text as T @@ -19,7 +19,7 @@ where spc :: Int -> T.Text spc i = T.replicate i " " -genStat (Folder name _ date) = do+genStat (Folder _ _ date) = do return $ T.concat [ spc 3 , date , spc 5
src/Getconfig.hs view
@@ -1,32 +1,42 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} module Getconfig where -import Control.Monad-import Data.Maybe- import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C -getConfig :: IO (String, String, String, String)-getConfig = do- config <- C.load [C.Required "$(HOME)/.pgdl"]- username <- C.lookup config "username"- password <- C.lookup config "password"- servpath <- C.lookup config "servpath"- localdir <- C.lookup config "localdir"- mapM_ (\x -> when (isNothing x) $ error "please edit config file.") [username, password, servpath, localdir]- return (fj username, fj password, fj servpath, fj localdir)- where fj = fromJust+getConfig :: IO C.Config+getConfig = C.load [C.Required "$(HOME)/.pgdl"] getUsername :: IO String-getUsername = fmap (\(r, _, _, _) -> r) getConfig+getUsername = do+ cfg <- getConfig+ C.lookup cfg "username" >>= \case+ Nothing -> noArg+ Just s -> return s getPassword :: IO String-getPassword = fmap (\(_, r, _, _) -> r) getConfig+getPassword = do + cfg <- getConfig+ C.lookup cfg "password" >>= \case+ Nothing -> noArg+ Just s -> return s getServpath :: IO String-getServpath = fmap (\(_, _, r, _) -> r) getConfig+getServpath = do+ cfg <- getConfig+ C.lookup cfg "servpath" >>= \case+ Nothing -> noArg+ Just s -> return s getLocaldir :: IO String-getLocaldir = fmap (\(_, _, _, r) -> r) getConfig+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/Main.hs view
@@ -4,17 +4,17 @@ import FetchHtml import PrsVid-import Beaut-import PlayVid-import Search+import NameAlgo +import RealWorld import Chkcfg import Video import Log-import TestExist import GenStat import CrtInf import AskScene +import Data.IORef+import Data.Maybe import Control.Applicative import Control.Concurrent import Control.Monad@@ -26,33 +26,40 @@ main :: IO () main = do- chkcfg+ chkcfg + -- check if there exists a configuration file, if not, then create one c <- newCollection - lst <- newList 3 + lst <- newList 3+ -- the main list will display on screen+ diskrd <- readVid+ -- read cache in the disk, if the cache do not exists, return "downloading"+ args <- getArgs let diskV = if null args then diskrd- else dlnVid+ else dlnVid+ -- if user want to search a video, then don't load cache to the screen + forM_ diskV $ \v -> addToList lst v =<< plainText (beaut v)+ -- add disk videos to list+ lfg <- newFocusGroup addToFocusGroup lfg lst statBar <- plainText waitingBar+ -- the state bar show in the bottom setNormalAttribute statBar (black `on` green) ui <- centered =<< hFixed 80 =<< vBox lst statBar+ -- ui consists of a list and a state bar chgls <- addToCollection c ui lfg - (dlg, dfcg) <- newAskScene dui <- centered =<< hFixed 50 (sceneWidget dlg) chgdl <- addToCollection c dui dfcg - dfcg `onKeyPressed` tryExit-- lfg `onKeyPressed` tryExit -- four button in ask scene's action onScePlay dlg $ \_ -> do@@ -67,74 +74,149 @@ removeVid itm ifsfg <- newFocusGroup+ -- a focus group for information page++ -- this function will show the focused item's information to user+ 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 -> chgls >> return True + 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- ifsfg `onKeyPressed` tryExit++ onKeyPressed lst $ \_ key _ -> case key of KRight -> do- Just (_, (itm, _)) <- getSelected lst- inf <- centered =<< plainText (crtInfPg itm)- addToFocusGroup ifsfg inf- join $ addToCollection c inf ifsfg+ chgInf return True _ -> return False++ lfg `onKeyPressed` tryExit+ dfcg `onKeyPressed` tryExit+ ifsfg `onKeyPressed` tryExit++ -- let's download video from internet ! schedule $ do forkIO $ do rd <- prsHtm <$> fetchHtml+ -- prsHtm :: Text -> [Video (whether video or folder)]+ let vdlst = search rd args- when (length vdlst < 1) $ error "no video or folder found!"+ when (length vdlst < 1) $ error "no search result found (or it's empty)."+ Just (_, (oldItm, _)) <- getSelected lst+ -- store the location before page refresh+ clearList lst forM_ vdlst $ \v -> addToList lst v =<< plainText (beaut v)+ -- show new list+ listFindFirst lst oldItm >>= \case Just ind -> setSelected lst ind Nothing -> return () onSelectionChange lst $ \sle -> case sle of- SelectionOn _ itm _ -> if isFld itm then setFocusAttribute lst (black `on` magenta)- else fex itm >>= \case - True -> setFocusAttribute lst (black `on` red) - False -> setFocusAttribute lst (black `on` cyan)+ SelectionOn _ itm _ -> case isFld itm of+ True -> setFocusAttribute lst (black `on` magenta)+ -- folder's color+ _ -> 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 _ -> return ()+ onSelectionChange lst $ \sle -> case sle of SelectionOn _ itm _ -> setText statBar =<< genStat itm+ -- refresh state bar after any scroll _ -> return () - (null <$> getArgs) >>= \case - True -> void . forkIO $ writeVid vdlst- _ -> return ()- return ()- return ()+ astr <- newIORef []+ -- we store ancestors list element in the astr+ -- (those old list we leaved)+ let push = do+ -- store the state into astr+ sz <- getListSize lst+ Just (loc, _) <- getSelected lst+ lem <- catMaybes <$> forM [0..sz-1] (getListItem lst)+ modifyIORef astr ((lem, loc):)+ let pop = do+ -- pop a state from astr and give it to lst+ ast <- readIORef astr+ case ast of+ [] -> return ()+ ((itms, loc):_) -> do+ clearList lst+ forM_ itms $ \(v, w) -> addToList lst v w+ setSelected lst loc+ modifyIORef astr tail+ + 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!" + push+ clearList lst + forM_ ctnt $ \v -> addToList lst v =<< plainText (beaut v) + return () - let openFld lnk = do- ctnt <- (map (attcLink lnk) . prsHtm) <$> fetchFld lnk - when (null ctnt) $ error "no video in the folder!" - clearList lst - forM_ ctnt $ \v -> addToList lst v =<< plainText (beaut v) - 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+ pop+ return True+ KChar 's' -> do+ push+ Just (_, (itm, _)) <- getSelected lst+ size <- getListSize lst+ let itemIdxs = reverse [0..size-1]+ isLik <- forM itemIdxs $ \idx -> do+ Just (now, _) <- getListItem lst idx+ return $ isAlike itm now+ forM_ (zip itemIdxs isLik) $ \(idx, lik) -> unless lik $ do+ removeFromList lst idx+ return ()+ return True+ _ -> return False - -- User chose a folder or video !- 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- + when (null args) $ void . forkIO . writeVid $ vdlst+ -- only write cache when user didn't search video - runUi c $ defaultContext {normalAttr = white `on` black, - focusAttr = black `on` blue+ return ()+ return ()++ runUi c $ defaultContext { normalAttr = white `on` black + , focusAttr = black `on` blue }+ where tryExit _ key _ = case key of KChar 'q' -> exitSuccess _ -> return False+ fex itm+ | isVid itm = downloaded $ vidName itm+ | otherwise = return False -fex itm- | isVid itm = downloaded $ vidName itm- | otherwise = return False
+ src/NameAlgo.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++module NameAlgo where++import Video++import Data.Function+import Data.Array+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 ok vids+ where ok v = all (\tar -> T.pack tar `ifx` name) par+ where name = if isVid v then vidName v else fldName v+ ifx = T.isInfixOf `on` T.toCaseFold+
− src/PlayVid.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--module PlayVid where--import Getconfig-import Video--import Control.Monad-import Distribution.System-import System.Process-import System.Directory-import System.FilePath.Posix-import System.Exit-import qualified Data.Text as T--playVid :: Video -> IO ()-playVid vid = do- when (isFld vid) $ error "give playVid a folder."- - 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- case username of- "" -> let url = "http://" ++ purepath ++ vu- in runCommand $ "nohup curl " ++ addq url ++ " -o " ++ addq localloc ++ "&>/dev/null &"- _ -> let url = "http://" ++ username ++ ":" ++ password ++ "@" ++ purepath ++ vu- in runCommand $ "nohup curl " ++ addq url ++ " -o " ++ addq localloc ++ "&>/dev/null &"- let checkFile = doesFileExist localloc >>= \ready -> unless ready checkFile- checkFile- case buildOS of- OSX -> runCommand $ "open " ++ addq localloc ++ " -a vlc"- Linux -> runCommand $ "nohup vlc -f " ++ addq localloc ++ " &>/dev/null &"- _ -> error "OS unsupported!"- exitSuccess- where vn = T.unpack . vidName $ vid- vu = T.unpack . vidLink $ vid- addq s = "\"" ++ s ++ "\""--justPlay :: Video -> IO ()-justPlay vid = do- localdir <- getLocaldir- let localloc = localdir </> vn- case buildOS of- OSX -> runCommand $ "open " ++ addq localloc ++ " -a vlc"- Linux -> runCommand $ "nohup vlc -f " ++ addq localloc ++ " &>/dev/null &"- _ -> error "OS unsupported!"- exitSuccess- where vn = T.unpack . vidName $ vid- addq s = "\"" ++ s ++ "\""- - -removeVid :: Video -> IO ()-removeVid vid = do- localDir <- getLocaldir- removeFile $ localDir </> vn- exitSuccess- where vn = T.unpack . vidName $ vid---
src/PrsVid.hs view
@@ -3,9 +3,9 @@ module PrsVid where import Video-import GenName import SortVid +import Network.HTTP.Base import Text.HTML.TagSoup import qualified Data.Text as T @@ -48,4 +48,5 @@ | isTagText tg = fromTagText tg | otherwise = "" -+genName :: T.Text -> T.Text+genName = T.pack . urlDecode . T.unpack
+ src/RealWorld.hs view
@@ -0,0 +1,73 @@+{-# 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 System.Exit+import qualified Data.Text as T++-- play a video+playVid :: Video -> IO ()+playVid vid = do+ when (isFld vid) $ error "give playVid a folder."+ + 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+ case username of+ "" -> let url = "http://" ++ purepath ++ vu+ in runCommand $ "nohup curl " ++ addq url ++ " -o " ++ addq localloc ++ "&>/dev/null &"+ _ -> let url = "http://" ++ username ++ ":" ++ password ++ "@" ++ purepath ++ vu+ in runCommand $ "nohup curl " ++ addq url ++ " -o " ++ addq localloc ++ "&>/dev/null &"+ let checkFile = doesFileExist localloc >>= \ready -> unless ready checkFile+ checkFile+ case buildOS of+ OSX -> runCommand $ "open " ++ addq localloc ++ " -a vlc"+ Linux -> runCommand $ "nohup vlc -f " ++ addq localloc ++ " &>/dev/null &"+ _ -> error "OS unsupported!"+ exitSuccess+ where vn = T.unpack . vidName $ vid+ vu = T.unpack . vidLink $ vid+ addq s = "\"" ++ s ++ "\""++justPlay :: Video -> IO ()+justPlay vid = do+ localdir <- getLocaldir+ let localloc = localdir </> vn+ case buildOS of+ OSX -> runCommand $ "open " ++ addq localloc ++ " -a vlc"+ Linux -> runCommand $ "nohup vlc -f " ++ addq localloc ++ " &>/dev/null &"+ _ -> error "OS unsupported!"+ exitSuccess+ where vn = T.unpack . vidName $ vid+ addq s = "\"" ++ s ++ "\""+ +-- | remove a video +removeVid :: Video -> IO ()+removeVid vid = do+ localDir <- getLocaldir+ removeFile $ localDir </> vn+ exitSuccess+ where vn = T.unpack . vidName $ vid++-- | determine whether a video is downloaded+downloaded :: T.Text -> IO Bool+downloaded t = do+ lcd <- getLocaldir+ doesFileExist $ lcd </> T.unpack t+
− src/Search.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Search where--import Video--import Data.Function-import qualified Data.Text as T--search :: [Video] -> [String] -> [Video]-search vids par = filter ok vids- where ok v = all (\tar -> (T.pack tar) `ifx` name) par- where name = if isVid v then vidName v else fldName v- ifx = T.isInfixOf `on` T.toCaseFold-
− src/TestExist.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module TestExist where--import Getconfig--import System.Directory-import System.FilePath--import qualified Data.Text as T--downloaded :: T.Text -> IO Bool-downloaded t = do- lcd <- getLocaldir- doesFileExist $ lcd </> T.unpack t--
src/Video.hs view
@@ -20,7 +20,11 @@ | 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