diff --git a/pgdl.cabal b/pgdl.cabal --- a/pgdl.cabal +++ b/pgdl.cabal @@ -1,6 +1,6 @@ name: pgdl -version: 7.0 +version: 7.3 license: PublicDomain license-file: LICENSE author: sifmelcara @@ -25,14 +25,16 @@ 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 - build-depends: base == 4.* , split, process, - directory, http-conduit >= 2.0.0, bytestring, - transformers, resourcet, tagsoup, + other-modules: Beaut, Chkcfg, FetchHtml, Getconfig, Log, + PlayVid, PrsVid, Search, Video, GenStat, + TestExist, GenName, 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, binary >= 0.7.0.0, Cabal + filepath, Cabal ghc-options: -threaded -O2 default-language: Haskell2010 + diff --git a/src/AskScene.hs b/src/AskScene.hs new file mode 100644 --- /dev/null +++ b/src/AskScene.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module AskScene where + +import Graphics.Vty.Widgets.All +import Graphics.Vty.Input.Events + +import qualified Data.Text as T +import Control.Monad + +data AskScene = AskScene { sceneWidget :: Widget (Bordered Padded) + , playHand :: Handlers AskScene + , downHand :: Handlers AskScene + , quitHand :: Handlers AskScene + } + +newAskScene :: IO (AskScene, Widget FocusGroup) +newAskScene = do + playB <- newButton "No" + downB <- newButton "Yes" + quitB <- newButton "Quit" + buttonBox <- (mkwIO playB) <++> (mkwIO downB) <++> (mkwIO quitB) + b <- do + bx <- (plainText " Download it again?") <--> (return buttonBox) + setBoxSpacing bx 1 + withPadding (padAll 1) bx + fg <- newFocusGroup + mapM_ (addToFocusGroup fg . buttonWidget) [playB, downB, quitB] + ui <- withBorderedLabel "File Exists!" =<< bordered b + [phs, dhs, qhs] <- replicateM 3 newHandlers + let sce = AskScene { sceneWidget = ui + , playHand = phs + , downHand = dhs + , quitHand = qhs + } + onButtonPressed playB $ \_ -> + fireEvent sce (return . playHand) sce + onButtonPressed downB $ \_ -> + fireEvent sce (return . downHand) sce + onButtonPressed quitB $ \_ -> + fireEvent sce (return . quitHand) sce + setFocusGroupNextKey fg KRight [] + setFocusGroupPrevKey fg KLeft [] + return (sce, fg) + where mkwIO = return . buttonWidget + +onScePlay :: AskScene -> Handler AskScene -> IO () +onScePlay = addHandler (return . playHand) + +onSceDown :: AskScene -> Handler AskScene -> IO () +onSceDown = addHandler (return . downHand) + +onSceQuit :: AskScene -> Handler AskScene -> IO () +onSceQuit = addHandler (return . quitHand) + + + diff --git a/src/Chkcfg.hs b/src/Chkcfg.hs --- a/src/Chkcfg.hs +++ b/src/Chkcfg.hs @@ -1,5 +1,5 @@ -module Chkcfg where +module Chkcfg (chkcfg) where import System.Directory import System.FilePath @@ -18,6 +18,8 @@ "# password = \"mypassw\" ", "# servpath = \"example.org/videodir/\" ", "# localdir = \"/home/jack/Downloads/\" ", + "", + "# username and localdir is optional.", "", "username = \"\"", "password = \"\"", diff --git a/src/CrtInf.hs b/src/CrtInf.hs new file mode 100644 --- /dev/null +++ b/src/CrtInf.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CrtInf where + +import Video + +import qualified Data.Text as T + +crtInfPg :: Video -> T.Text +crtInfPg vid = T.unlines ["", "", + "File name: " `app` (spl . vidName) vid, + "File size: " `app` vidSize vid, + "File date: " `app` vidDate vid, + "File link: " `app` (spl . vidLink) vid + ] + where app = T.append + spl = T.intercalate "\n" . T.chunksOf 60 + + + diff --git a/src/FetchHtml.hs b/src/FetchHtml.hs --- a/src/FetchHtml.hs +++ b/src/FetchHtml.hs @@ -4,31 +4,20 @@ import Getconfig -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource +import Network.HTTP +import Network.URI import Data.Text.Encoding +import Data.ByteString import Data.Maybe -import Network.HTTP.Conduit - import qualified Data.Text as T -import qualified Data.ByteString.Lazy.Char8 as LC -genReq :: IO Request -genReq = do - username <- getUsername - password <- getPassword - servpath <- getServpath - case username of - "" -> return $ fromJust . parseUrl $ "http://" ++ T.unpack servpath - _ -> return $ applyBasicAuth (tob username) (tob password) . fromJust . parseUrl $ "http://" ++ T.unpack servpath - where tob = encodeUtf8 - fetchHtml :: IO T.Text fetchHtml = do - rq <- genReq - runResourceT $ do - mgr <- liftIO $ newManager conduitManagerSettings - res <- httpLbs rq mgr - return . decodeUtf8 . LC.toStrict $ responseBody res - + usrn <- getUsername + usrp <- getPassword + servp <- getServpath + let uri = "http://" ++ usrn ++ ":" ++ usrp ++ "@" ++ servp + res <- simpleHTTP . mkRequest GET . fromJust . parseURI $ uri + cnt <- getResponseBody res + return $ decodeUtf8 cnt diff --git a/src/Getconfig.hs b/src/Getconfig.hs --- a/src/Getconfig.hs +++ b/src/Getconfig.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Configurator as C -getConfig :: IO (T.Text, T.Text, T.Text, T.Text) +getConfig :: IO (String, String, String, String) getConfig = do config <- C.load [C.Required "$(HOME)/.pgdl"] username <- C.lookup config "username" diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -5,31 +5,24 @@ import Video -import Control.Applicative -import Control.Monad -import Data.Binary -import Data.Either import System.Directory import System.FilePath import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Lazy as B +import qualified Data.Text.IO as T -instance Binary T.Text where - put = put . T.encodeUtf8 - get = T.decodeUtf8 <$> get +encVid :: [Video] -> T.Text +encVid vs = T.intercalate "\n" $ map vidName vs -instance Binary Video where - put vid = put $ vidName vid - get = get >>= \name -> return $ Video name "" "" "" +decVid :: T.Text -> [Video] +decVid = map (\t -> Video t "" "" "") . T.lines logname = ".pgdl.cache" writeVid :: [Video] -> IO () writeVid vs = do hdir <- getHomeDirectory - B.writeFile (hdir logname) $ encode vs + T.writeFile (hdir logname) $ encVid vs readVid :: IO [Video] readVid = do @@ -37,11 +30,10 @@ let absdir = hdir logname doesFileExist absdir >>= \case True -> do - dat <- B.readFile (hdir logname) - let res = decodeOrFail dat - case res of - Right (_, _, vs) -> return vs - _ -> return dlnVid + dat <- T.readFile (hdir logname) + return $ decVid dat False -> return dlnVid - where dlnVid = [Video "Downloading..." "" "" ""] + +dlnVid = [Video "Downloading..." "" "" ""] + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -11,6 +11,8 @@ import Log import TestExist import GenStat +import CrtInf +import AskScene import Control.Applicative import Control.Concurrent @@ -32,7 +34,8 @@ lst <- newList 3 diskrd <- readVid - diskV <- search diskrd <$> getArgs + args <- getArgs + let diskV = if null args then diskrd else dlnVid forM_ diskV $ \v -> addToList lst v =<< plainText (beaut v) lfg <- newFocusGroup addToFocusGroup lfg lst @@ -44,23 +47,21 @@ chgls <- addToCollection c ui lfg - (dlg, dfcg) <- do - wg <- plainText "redownload it?" - newDialog wg "File Exists!" - dui <- centered =<< hFixed 30 (dialogWidget dlg) + (dlg, dfcg) <- newAskScene + dui <- centered =<< hFixed 50 (sceneWidget dlg) chgdl <- addToCollection c dui dfcg - setFocusGroupNextKey dfcg KRight [] - setFocusGroupPrevKey dfcg KLeft [] dfcg `onKeyPressed` tryExit lfg `onKeyPressed` tryExit - dlg `onDialogCancel` const exitSuccess - onDialogAccept dlg $ \_ -> do + onScePlay dlg $ \_ -> do Just (_, (itm, _)) <- getSelected lst + justPlay itm + onSceDown dlg $ \_ -> do + Just (_, (itm, _)) <- getSelected lst playVid itm - + onSceQuit dlg $ const exitSuccess ifsfg <- newFocusGroup onKeyPressed ifsfg $ \_ key _ -> case key of KLeft -> chgls >> return True @@ -121,15 +122,5 @@ KChar 'q' -> exitSuccess _ -> return False - -crtInfPg :: Video -> T.Text -crtInfPg vid = T.unlines ["", "", - "File name: " `app` (spl . vidName) vid, - "File size: " `app` vidSize vid, - "File date: " `app` vidDate vid, - "File link: " `app` (spl . vidLink) vid - ] - where app = T.append - spl = T.intercalate "\n" . T.chunksOf 60 diff --git a/src/PlayVid.hs b/src/PlayVid.hs --- a/src/PlayVid.hs +++ b/src/PlayVid.hs @@ -16,10 +16,10 @@ playVid :: Video -> IO () playVid vid = do - username <- fmap T.unpack getUsername - password <- fmap T.unpack getPassword - servpath <- fmap T.unpack getServpath - localdir <- fmap T.unpack getLocaldir + username <- getUsername + password <- getPassword + servpath <- getServpath + localdir <- getLocaldir let localloc = localdir vn fex <- doesFileExist localdir @@ -41,5 +41,21 @@ where vn = T.unpack . vidName $ vid vu = T.unpack . vidLink $ vid addq s = "\"" ++ s ++ "\"" + +justPlay :: Video -> IO () +justPlay vid = do + servpath <- getServpath + 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 ++ "\"" + + + diff --git a/src/Search.hs b/src/Search.hs --- a/src/Search.hs +++ b/src/Search.hs @@ -9,8 +9,7 @@ import qualified Data.Text as T search :: [Video] -> [String] -> [Video] -search vlst param = foldl (\vs ps -> filter (targ ps . vidName) vs) vlst pt - where pt = map T.pack param - targ = T.isInfixOf `on` T.toUpper - +search vids par = filter pred vids + where pred v = all (\tar -> (T.pack tar) `T.isInfixOf` name) par + where name = vidName v diff --git a/src/TestExist.hs b/src/TestExist.hs --- a/src/TestExist.hs +++ b/src/TestExist.hs @@ -13,6 +13,6 @@ downloaded :: T.Text -> IO Bool downloaded t = do lcd <- getLocaldir - doesFileExist $ (combine `on` T.unpack) lcd t + doesFileExist $ lcd (T.unpack t)