diff --git a/pgdl.cabal b/pgdl.cabal --- a/pgdl.cabal +++ b/pgdl.cabal @@ -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 -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 diff --git a/src/AskScene.hs b/src/AskScene.hs --- a/src/AskScene.hs +++ b/src/AskScene.hs @@ -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 diff --git a/src/GenStat.hs b/src/GenStat.hs --- a/src/GenStat.hs +++ b/src/GenStat.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 - } - diff --git a/src/Pgdl.hs b/src/Pgdl.hs new file mode 100644 --- /dev/null +++ b/src/Pgdl.hs @@ -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 + } + diff --git a/src/RealWorld.hs b/src/RealWorld.hs --- a/src/RealWorld.hs +++ b/src/RealWorld.hs @@ -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" diff --git a/src/UI.hs b/src/UI.hs --- a/src/UI.hs +++ b/src/UI.hs @@ -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