diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,3 +13,15 @@ cabal update
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 + diff --git a/pgdl.cabal b/pgdl.cabal --- a/pgdl.cabal +++ b/pgdl.cabal @@ -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 - diff --git a/src/Beaut.hs b/src/Beaut.hs deleted file mode 100644 --- a/src/Beaut.hs +++ /dev/null @@ -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 - - diff --git a/src/CrtInf.hs b/src/CrtInf.hs --- a/src/CrtInf.hs +++ b/src/CrtInf.hs @@ -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" diff --git a/src/GenName.hs b/src/GenName.hs deleted file mode 100644 --- a/src/GenName.hs +++ /dev/null @@ -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 - diff --git a/src/GenStat.hs b/src/GenStat.hs --- a/src/GenStat.hs +++ b/src/GenStat.hs @@ -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 diff --git a/src/Getconfig.hs b/src/Getconfig.hs --- a/src/Getconfig.hs +++ b/src/Getconfig.hs @@ -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)." diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/NameAlgo.hs b/src/NameAlgo.hs new file mode 100644 --- /dev/null +++ b/src/NameAlgo.hs @@ -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 + diff --git a/src/PlayVid.hs b/src/PlayVid.hs deleted file mode 100644 --- a/src/PlayVid.hs +++ /dev/null @@ -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 - - - diff --git a/src/PrsVid.hs b/src/PrsVid.hs --- a/src/PrsVid.hs +++ b/src/PrsVid.hs @@ -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 diff --git a/src/RealWorld.hs b/src/RealWorld.hs new file mode 100644 --- /dev/null +++ b/src/RealWorld.hs @@ -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 + diff --git a/src/Search.hs b/src/Search.hs deleted file mode 100644 --- a/src/Search.hs +++ /dev/null @@ -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 - diff --git a/src/TestExist.hs b/src/TestExist.hs deleted file mode 100644 --- a/src/TestExist.hs +++ /dev/null @@ -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 - - diff --git a/src/Video.hs b/src/Video.hs --- a/src/Video.hs +++ b/src/Video.hs @@ -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