pgdl 7.77 → 8.0
raw patch · 8 files changed
+276/−176 lines, 8 files
Files
- README.md +8/−4
- pgdl.cabal +3/−3
- src/GenStat.hs +1/−1
- src/Main.hs +97/−122
- src/NameAlgo.hs +41/−4
- src/PrsVid.hs +4/−2
- src/SortVid.hs +0/−40
- src/UI.hs +122/−0
README.md view
@@ -13,15 +13,19 @@ cabal update <br> cabal install pgdl -## Command line argument--all arguments passed to the program become keywords to filter videos.- ## Shortcut keys q - quit+<br> s - list files that similar with the highlighted video+<br> Key Right - show the detailed information of the highlighted video+<br> Key Left - go back to the previous page+<br> Enter - play the video+<br>+/ - open a input box to enter a keyword to search+<br>+n - sort the current list by name
pgdl.cabal view
@@ -1,6 +1,6 @@ name: pgdl-version: 7.77+version: 8.0 license: PublicDomain license-file: LICENSE author: sifmelcara@@ -17,7 +17,7 @@ . 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+ For shortcut keys, please visit <https://github.com/sifmelcara/pgdl> synopsis: pgdownloader @@ -30,7 +30,7 @@ main-is: Main.hs other-modules: NameAlgo, Chkcfg, FetchHtml, Getconfig, Log, RealWorld, PrsVid, Video, GenStat, - SortVid, CrtInf, AskScene+ CrtInf, AskScene, UI build-depends: base == 4.*, process, directory, bytestring, tagsoup, network-uri,
src/GenStat.hs view
@@ -19,7 +19,7 @@ where spc :: Int -> T.Text spc i = T.replicate i " " -genStat (Folder _ _ date) = do+genStat (Folder _ _ date) = return $ T.concat [ spc 3 , date , spc 5
src/Main.hs view
@@ -12,14 +12,14 @@ import GenStat import CrtInf import AskScene+import UI -import Data.IORef-import Data.Maybe+import qualified Data.Text as T+import Data.Ord import Control.Applicative import Control.Concurrent import Control.Monad import System.Exit-import System.Environment import Graphics.Vty import Graphics.Vty.Widgets.All@@ -31,147 +31,133 @@ c <- newCollection - lst <- newList 3+ tmpLst <- newList 3 -- the main list will display on screen - diskrd <- readVid+ diskV <- 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- -- if user want to search a video, then don't load cache to the screen -- forM_ diskV $ \v -> addToList lst v =<< plainText (beaut v)+ forM_ diskV $ \v -> addToList tmpLst v =<< plainText (beaut v) -- add disk videos to list - lfg <- newFocusGroup- addToFocusGroup lfg lst+ tmpLfg <- newFocusGroup+ addToFocusGroup tmpLfg tmpLst statBar <- plainText waitingBar -- the state bar show in the bottom setNormalAttribute statBar (black `on` green) - ui <- centered =<< hFixed 80 =<< vBox lst statBar+ tmpUi <- centered =<< hFixed 80 =<< vBox tmpLst statBar -- ui consists of a list and a state bar- chgls <- addToCollection c ui lfg+ addToCollection c tmpUi tmpLfg+ (dlg, dfcg) <- newAskScene dui <- centered =<< hFixed 50 (sceneWidget dlg) chgdl <- addToCollection c dui dfcg - - -- four button in ask scene's action- onScePlay dlg $ \_ -> do- Just (_, (itm, _)) <- getSelected lst- justPlay itm- onSceDown dlg $ \_ -> do- Just (_, (itm, _)) <- getSelected lst- playVid itm- onSceQuit dlg $ const exitSuccess- onSceRemv dlg $ \_ -> do- Just (_, (itm, _)) <- getSelected lst- 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 -> do- chgls -- return to the list- return True- KUp -> do- scrollUp lst- chgInf- return True- KDown -> do- scrollDown lst- chgInf- return True- _ -> return False--- onKeyPressed lst $ \_ key _ -> case key of- KRight -> do- chgInf- return True- _ -> return False-- lfg `onKeyPressed` tryExit+ tmpLfg `onKeyPressed` tryExit dfcg `onKeyPressed` tryExit ifsfg `onKeyPressed` tryExit + -- colorDecide tmpLst+ -- let's download video from internet ! schedule $ do forkIO $ do- rd <- prsHtm <$> fetchHtml+ vdlst <- prsHtm <$> fetchHtml -- prsHtm :: Text -> [Video (whether video or folder)]-- let vdlst = search rd args- when (length vdlst < 1) $ error "no search result found (or it's empty)."-- Just (_, (oldItm, _)) <- getSelected lst- -- store the location before page refresh+ 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 () - clearList lst- forM_ vdlst $ \v -> addToList lst v =<< plainText (beaut v) -- 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 - listFindFirst lst oldItm >>= \case- Just ind -> setSelected lst ind- Nothing -> return ()+ colorDecide lst - onSelectionChange lst $ \sle -> case sle of- 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 ()+ -- four button in ask scene's action+ onScePlay dlg $ \_ -> do+ Just (_, (itm, _)) <- getSelected lst+ justPlay itm+ onSceDown dlg $ \_ -> do+ Just (_, (itm, _)) <- getSelected lst+ playVid itm+ onSceQuit dlg $ const exitSuccess+ onSceRemv dlg $ \_ -> do+ Just (_, (itm, _)) <- getSelected lst+ removeVid itm onSelectionChange lst $ \sle -> case sle of SelectionOn _ itm _ -> setText statBar =<< genStat itm -- refresh state bar after any scroll _ -> 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 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++ 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!" - push- clearList lst - forM_ ctnt $ \v -> addToList lst v =<< plainText (beaut v) + setVList vlst ctnt return () onKeyPressed lst $ \_ key _ -> case key of@@ -186,37 +172,26 @@ return True KLeft -> do -- return to the old list- pop+ backVList vlst return True KChar 's' -> do- push+ -- filter the videos by the focused video 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 ()+ filterVList vlst (isAlike itm) return True+ KChar 'n' -> do+ -- sort videos by their name+ sortVList vlst (comparing getName) + return True+ KChar '/' -> do+ chgky+ return True _ -> return False - when (null args) $ void . forkIO . writeVid $ vdlst- -- only write cache when user didn't search video- 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-
src/NameAlgo.hs view
@@ -6,6 +6,9 @@ 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].... )@@ -68,11 +71,45 @@ 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+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/PrsVid.hs view
@@ -3,14 +3,16 @@ module PrsVid where import Video-import SortVid+import NameAlgo import Network.HTTP.Base import Text.HTML.TagSoup import qualified Data.Text as T prsHtm :: T.Text -> [Video]-prsHtm t = sortVid $ (prsVid t) ++ (prsFld t)+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) .
− src/SortVid.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module SortVid (sortVid) where--import Video--import qualified Data.Text as T-import Data.List-import Data.Function--sortVid :: [Video] -> [Video]-sortVid = sortBy cmpv--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/UI.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module UI where++import Video+import RealWorld+import NameAlgo++import Control.Monad+import System.Exit+import Graphics.Vty+import Graphics.Vty.Widgets.All+import Data.IORef+import Data.List++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+ storeState vl+ setListVideos wl . filter ok =<< getListVideos wl++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+ _ -> return False++fex :: Video -> IO Bool+fex itm+ | isVid itm = downloaded $ vidName 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 = + onSelectionChange lst $ \sle -> case sle of+ SelectionOn _ itm _ -> 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+ _ -> return ()+