pgdl 7.0 → 7.3
raw patch · 11 files changed
+146/−78 lines, 11 filesdep +network-uridep −binarydep −http-conduitdep −resourcet
Dependencies added: network-uri
Dependencies removed: binary, http-conduit, resourcet, split, transformers
Files
- pgdl.cabal +9/−7
- src/AskScene.hs +57/−0
- src/Chkcfg.hs +3/−1
- src/CrtInf.hs +20/−0
- src/FetchHtml.hs +10/−21
- src/Getconfig.hs +1/−1
- src/Log.hs +11/−19
- src/Main.hs +11/−20
- src/PlayVid.hs +20/−4
- src/Search.hs +3/−4
- src/TestExist.hs +1/−1
pgdl.cabal view
@@ -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+
+ src/AskScene.hs view
@@ -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)+++
src/Chkcfg.hs view
@@ -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 = \"\"",
+ src/CrtInf.hs view
@@ -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 +++
src/FetchHtml.hs view
@@ -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
src/Getconfig.hs view
@@ -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"
src/Log.hs view
@@ -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..." "" "" ""]+
src/Main.hs view
@@ -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
src/PlayVid.hs view
@@ -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 ++ "\""+ + +
src/Search.hs view
@@ -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
src/TestExist.hs view
@@ -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)