pgdl 8.1 → 8.2
raw patch · 7 files changed
+237/−217 lines, 7 files
Files
- pgdl.cabal +5/−5
- src/AskScene.hs +1/−1
- src/GenStat.hs +2/−2
- src/Main.hs +0/−200
- src/Pgdl.hs +203/−0
- src/RealWorld.hs +14/−8
- src/UI.hs +12/−1
pgdl.cabal view
@@ -1,6 +1,6 @@ name: pgdl-version: 8.1+version: 8.2 license: PublicDomain license-file: LICENSE author: sifmelcara@@ -9,8 +9,8 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10-description: a terminal user interface program that downloads a video from html and call vlc to play it immediately.- (Linux: vlc -f "video.mp4", MACOSX: open "video.mp4" -a vlc)+description: a terminal user interface program downloads video from nginx file index page and play it.+ (Linux: xdg-open "video.mp4", MACOSX: open "video.mp4") . Client: Only for Linux and MACOSX. Server: Only for nginx's file download page.@@ -19,7 +19,7 @@ . For shortcut keys, please visit <https://github.com/sifmelcara/pgdl> -synopsis: pgdownloader+synopsis: simply download a video from webpage and play it. source-repository head type: git@@ -27,7 +27,7 @@ executable pgdl hs-source-dirs: src- main-is: Main.hs+ main-is: Pgdl.hs other-modules: NameAlgo, Chkcfg, FetchHtml, Getconfig, Log, RealWorld, PrsVid, Video, GenStat, CrtInf, AskScene, UI
src/AskScene.hs view
@@ -18,7 +18,7 @@ newAskScene = do playB <- newButton "No" downB <- newButton "Yes"- quitB <- newButton "Quit"+ quitB <- newButton "Cancel" remvB <- newButton "Remov" buttonBox <- mkwIO playB <++> mkwIO downB <++> mkwIO quitB <++> mkwIO remvB b <- do
src/GenStat.hs view
@@ -9,8 +9,8 @@ import qualified Data.Text as T genStat :: Video -> IO T.Text-genStat (Video name _ size date) = do- st <- toStr $ downloaded name+genStat vid@(Video _ _ size date) = do+ st <- toStr $ downloaded vid return $ T.concat [ spc 3 , date , spc 5 , size , spc 20, st
− src/Main.hs
@@ -1,200 +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 System.Exit--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-- -- this function will show the focused item's information to user-- tmpLfg `onKeyPressed` tryExit- dfcg `onKeyPressed` tryExit- ifsfg `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 exitSuccess- 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 ()- -- 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!" - 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 '/' -> do- chgky- return True- _ -> return False-- return ()- return ()-- runUi c $ defaultContext { normalAttr = white `on` black - , focusAttr = black `on` blue- }-
+ src/Pgdl.hs view
@@ -0,0 +1,203 @@+{-# 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++ -- this function will show the focused item's information to user++ tmpLfg `onKeyPressed` tryExit+ dfcg `onKeyPressed` tryExit+ ifsfg `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 ()+ ++ 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!" + 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 '/' -> do+ chgky+ return True+ _ -> return False++ return ()+ return ()++ runUi c $ defaultContext { normalAttr = white `on` black + , focusAttr = black `on` blue+ }+
src/RealWorld.hs view
@@ -17,7 +17,10 @@ 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@@ -36,11 +39,10 @@ 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 &"+ OSX -> runCommand $ "open " ++ addq localloc ++ " "+ Linux -> runCommand $ "xdg-open " ++ addq localloc ++ " &>/dev/null &" _ -> error "OS unsupported!" return ()- -- exitSuccess where vn = T.unpack . vidName $ vid vu = T.unpack . vidLink $ vid addq :: String -> String@@ -48,11 +50,13 @@ 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 ++ " -a vlc"- Linux -> runCommand $ "nohup vlc -f " ++ addq localloc ++ " &>/dev/null &"+ OSX -> runCommand $ "open " ++ addq localloc ++ " "+ Linux -> runCommand $ "xdg-open " ++ addq localloc ++ " &>/dev/null &" _ -> error "OS unsupported!" return () -- exitSuccess@@ -70,8 +74,10 @@ where vn = T.unpack . vidName $ vid -- | determine whether a video is downloaded-downloaded :: T.Text -> IO Bool-downloaded t = do+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/UI.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module UI where @@ -40,6 +41,16 @@ 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@@ -76,7 +87,7 @@ fex :: Video -> IO Bool fex itm- | isVid itm = downloaded $ vidName itm+ | isVid itm = downloaded itm | otherwise = return False -- return the videos in the list