From c7f5d7f0c2590a118095093066d3fe3bf763bd78 Mon Sep 17 00:00:00 2001 From: depsterr Date: Sun, 4 Jul 2021 23:25:47 +0200 Subject: [PATCH 01/11] fixed bugs which arose from inconsistency between machines --- src/YTDL.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/YTDL.hs b/src/YTDL.hs index 4e481fe..fb4fdbb 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -21,7 +21,7 @@ data Resolution wrapResString :: String -> [String] wrapResString str = ["-f", concat ["bestvideo[ext=mp4,height<=", str, - "]+bestaudio[ext=m4a]/mp4[height<=", str, "]"]] + "]+bestaudio[ext=m4a]/mp4[height<=", str, "]"], "--merge-output-format", "mp4"] resToArgs :: Resolution -> [String] resToArgs (P144) = wrapResString "144" @@ -30,7 +30,7 @@ resToArgs (P360) = wrapResString "360" resToArgs (P480) = wrapResString "480" resToArgs (P720) = wrapResString "720" resToArgs (P1080) = wrapResString "1080" -resToArgs (PMAX) = ["-f", "bestvideo[ext=mp4]+bestaudio[ext=m4a]/mp4"] +resToArgs (PMAX) = ["-f", "bestvideo[ext=mp4]+bestaudio[ext=m4a]/mp4", "--merge-output-format", "mp4"] resToArgs (Audio) = ["-x", "--audio-format", "mp3"] ytdl :: String -> Resolution -> IO (Either String FilePath) @@ -55,13 +55,12 @@ ytdl url res = do createDirectoryIfMissing True dir + print (resToArgs res <> ["-o", fileName, url]) + ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) - { std_out = CreatePipe - , std_err = CreatePipe } case ytdlProc of - (_, _, Just herr, ph) -> do - err <- hGetContents herr + (_, _, _, ph) -> do exitCode <- waitForProcess ph case exitCode of ExitSuccess -> do @@ -73,9 +72,9 @@ ytdl url res = do _ <- forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir pure (Right fileName) else do - removeDirectoryRecursive dir + -- removeDirectoryRecursive dir pure (Left "An unknown error prevented the output file from being created") - (ExitFailure status) -> pure (Left (concat ["execution failed with status ", show status, ": ", err])) + (ExitFailure status) -> pure (Left ("execution failed with status " <> show status)) _ -> pure (Left "Unable to create ytdlProcess for downloading video") From 2ae1b60cae0d151a281eb9774d9b49e12dc49fc1 Mon Sep 17 00:00:00 2001 From: depsterr Date: Tue, 6 Jul 2021 14:55:56 +0200 Subject: [PATCH 02/11] did some anti ssrf stuff --- src/Helpers.hs | 12 +++++++++--- src/Main.hs | 1 - 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Helpers.hs b/src/Helpers.hs index 7d666f6..434db89 100644 --- a/src/Helpers.hs +++ b/src/Helpers.hs @@ -4,7 +4,7 @@ module Helpers where import YTDL import qualified Data.Text.Lazy as TL -import Network.URI (parseURI) +import Network.URI getRes :: TL.Text -> Maybe Resolution getRes ("144p") = Just P144 @@ -22,7 +22,13 @@ isRes res = case getRes res of (Just _) -> True _ -> False +-- ssrf paranoia +isOkPath :: String -> Bool +isOkPath p = not $ isIPv4address p || isIPv6address p || p == "localhost" + isURL :: TL.Text -> Bool isURL uri = case parseURI (TL.unpack uri) of - (Just _) -> True - _ -> False + (Just u) -> case uriAuthority u of + (Just (URIAuth _ p _)) -> isOkPath p + _ -> False + _ -> False diff --git a/src/Main.hs b/src/Main.hs index 3d5a504..19b0e53 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -27,7 +27,6 @@ downloadAction = do setHeader "content-type" "video/mp4" file filePath (Left err) -> html $ errorPage (TL.pack err) - -- liftIO $ ytdlClean ident else html $ errorPage "Invalid input!" From 319bee7ee6a5694722b08d259706fb3904d08e38 Mon Sep 17 00:00:00 2001 From: depsterr Date: Tue, 6 Jul 2021 16:25:55 +0200 Subject: [PATCH 03/11] made download directory configurable --- src/Config.hs | 10 ++++++++++ src/Helpers.hs | 18 ++++++++++++++++++ src/Main.hs | 24 +++++++++++++++++------- src/YTDL.hs | 33 +++++++++++++++++---------------- todo | 5 +++-- viddl.cabal | 4 ++++ 6 files changed, 69 insertions(+), 25 deletions(-) create mode 100644 src/Config.hs diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..c12cb08 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,10 @@ +module Config where + +import System.Directory + +data ViddlConfig = ViddlConfig + { webPort :: Int + , dlDir :: FilePath } + +defConfig :: IO ViddlConfig +defConfig = getTemporaryDirectory >>= pure . ViddlConfig 3000 . (<> "viddl") diff --git a/src/Helpers.hs b/src/Helpers.hs index 434db89..19b4589 100644 --- a/src/Helpers.hs +++ b/src/Helpers.hs @@ -3,8 +3,26 @@ module Helpers where import YTDL +import Config + +import Text.Read (readMaybe) import qualified Data.Text.Lazy as TL import Network.URI +import System.Exit + +parseArgs :: ViddlConfig -> [String] -> IO ViddlConfig +parseArgs _ ("-h":_) = exitHelp +parseArgs _ ("--help":_) = exitHelp +parseArgs cfg@(ViddlConfig _ d) ("-p":p':xs) = case (readMaybe p' :: Maybe Int) of + (Just p) -> parseArgs (ViddlConfig p d) xs + Nothing -> parseArgs cfg (p':xs) +parseArgs (ViddlConfig p _) ("-d":d:xs) = parseArgs (ViddlConfig p d) xs +parseArgs cfg (_:xs) = parseArgs cfg xs +parseArgs cfg [] = pure cfg + + +exitHelp :: IO a +exitHelp = putStrLn "viddl [-p port] [-d dir]" >> exitSuccess getRes :: TL.Text -> Maybe Resolution getRes ("144p") = Just P144 diff --git a/src/Main.hs b/src/Main.hs index 19b0e53..474eead 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,22 +6,28 @@ import Templates.Index import Templates.Error import YTDL import Helpers +import Config -import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class import qualified Data.Text.Lazy as TL -import Web.Scotty +import System.Environment +import Web.Scotty.Trans -safeDownloadAction :: ActionM () +type Scotty = ScottyT TL.Text (ReaderT ViddlConfig IO) +type Action = ActionT TL.Text (ReaderT ViddlConfig IO) + +safeDownloadAction :: Action () safeDownloadAction = downloadAction `rescue` (html . errorPage) -downloadAction :: ActionM () +downloadAction :: Action () downloadAction = do url <- param "url" res <- param "resolution" if (isURL url) && (isRes res) then do let (Just res') = getRes res -- safe cause we checked with isRes - ytdlRes <- liftIO $ ytdl (TL.unpack url) res' + ytdlRes <- lift $ ytdl (TL.unpack url) res' case ytdlRes of (Right filePath) -> do setHeader "content-type" "video/mp4" @@ -31,11 +37,15 @@ downloadAction = do html $ errorPage "Invalid input!" -- todo ReaderT -app :: ScottyM () +app :: Scotty () app = do get "/" $ html indexPage get "/video.mp4" safeDownloadAction get "/audio.mp3" safeDownloadAction main :: IO () -main = scotty 3000 app +main = do + args <- getArgs + defCfg <- defConfig + cfg <- parseArgs defCfg args + scottyT (webPort cfg) (\(ReaderT ma) -> ma cfg) app diff --git a/src/YTDL.hs b/src/YTDL.hs index fb4fdbb..5f4227e 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -1,12 +1,15 @@ module YTDL (Resolution(..), ytdl) where +import Config + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class import Control.Concurrent (forkIO, threadDelay) import Data.Digest.Pure.MD5 import qualified Data.ByteString.Lazy.UTF8 as BCU import System.Directory import System.Exit import System.Process -import System.IO data Resolution = P144 @@ -33,43 +36,41 @@ resToArgs (P1080) = wrapResString "1080" resToArgs (PMAX) = ["-f", "bestvideo[ext=mp4]+bestaudio[ext=m4a]/mp4", "--merge-output-format", "mp4"] resToArgs (Audio) = ["-x", "--audio-format", "mp3"] -ytdl :: String -> Resolution -> IO (Either String FilePath) +ytdl :: String -> Resolution -> ReaderT ViddlConfig IO (Either String FilePath) ytdl url res = do + cfg <- ask + let ext = case res of { Audio -> ".mp3"; _ -> ".mp4" } let ident = show . md5 . BCU.fromString $ url <> show res - -- todo: config for path - tmpdir <- getTemporaryDirectory - let dir = concat [tmpdir, "/viddl/", ident] + let dir = concat [dlDir cfg, "/", ident] let fileName = concat [dir, "/", ident, ext] - -- todo: implement file locking for deleting and uploading file - processed <- doesFileExist fileName + processed <- lift $ doesFileExist fileName if processed then do - putStrLn $ "Returning existing ident " <> ident + lift $ putStrLn $ "Returning existing ident " <> ident pure (Right fileName) else do - putStrLn $ "Processing new ident " <> ident + lift $ putStrLn $ "Processing new ident " <> ident - createDirectoryIfMissing True dir + lift $ createDirectoryIfMissing True dir - print (resToArgs res <> ["-o", fileName, url]) + lift $ print (resToArgs res <> ["-o", fileName, url]) - ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) + ytdlProc <- lift $ createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) case ytdlProc of (_, _, _, ph) -> do - exitCode <- waitForProcess ph + exitCode <- lift $ waitForProcess ph case exitCode of ExitSuccess -> do - exists <- doesFileExist fileName + exists <- lift $ doesFileExist fileName if exists then do -- wait 5 minutes and then delete the directory - -- todo: implement file locking for deleting and uploading file - _ <- forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir + _ <- lift $ forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir pure (Right fileName) else do -- removeDirectoryRecursive dir diff --git a/todo b/todo index 131fce8..9a2b614 100644 --- a/todo +++ b/todo @@ -1,2 +1,3 @@ -configuration for scotty -cache results somehow +better config options (file?) +safer file deletion +queue system? diff --git a/viddl.cabal b/viddl.cabal index a994d7b..0e4b015 100644 --- a/viddl.cabal +++ b/viddl.cabal @@ -17,6 +17,7 @@ library , Templates.Error , YTDL , Helpers + , Config ghc-options: -Wall -O2 -threaded build-depends: base ^>=4.14.1.0 , scotty @@ -28,6 +29,7 @@ library , bytestring , pureMD5 , utf8-string + , transformers hs-source-dirs: src default-language: Haskell2010 @@ -37,6 +39,7 @@ executable viddl , Templates.Error , Helpers , YTDL + , Config ghc-options: -Wall -O2 -threaded build-depends: base ^>=4.14.1.0 , scotty @@ -48,5 +51,6 @@ executable viddl , bytestring , pureMD5 , utf8-string + , transformers hs-source-dirs: src default-language: Haskell2010 From 9caf89817fd3830562f71f708b9060a28ee31143 Mon Sep 17 00:00:00 2001 From: depsterr Date: Tue, 6 Jul 2021 17:35:01 +0200 Subject: [PATCH 04/11] fix default dir --- src/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Config.hs b/src/Config.hs index c12cb08..5904c76 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -7,4 +7,4 @@ data ViddlConfig = ViddlConfig , dlDir :: FilePath } defConfig :: IO ViddlConfig -defConfig = getTemporaryDirectory >>= pure . ViddlConfig 3000 . (<> "viddl") +defConfig = getTemporaryDirectory >>= pure . ViddlConfig 3000 . (<> "/viddl") From d7e5230c077e86b5aa2c87d19d03aa3430846ce4 Mon Sep 17 00:00:00 2001 From: depsterr Date: Fri, 9 Jul 2021 18:16:55 +0200 Subject: [PATCH 05/11] made ytdl function way prettier --- src/YTDL.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/YTDL.hs b/src/YTDL.hs index 5f4227e..82a3810 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -3,7 +3,6 @@ module YTDL (Resolution(..), ytdl) where import Config import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class import Control.Concurrent (forkIO, threadDelay) import Data.Digest.Pure.MD5 import qualified Data.ByteString.Lazy.UTF8 as BCU @@ -37,8 +36,7 @@ resToArgs (PMAX) = ["-f", "bestvideo[ext=mp4]+bestaudio[ext=m4a]/mp4", "--merge resToArgs (Audio) = ["-x", "--audio-format", "mp3"] ytdl :: String -> Resolution -> ReaderT ViddlConfig IO (Either String FilePath) -ytdl url res = do - cfg <- ask +ytdl url res = ReaderT $ \cfg -> do let ext = case res of { Audio -> ".mp3"; _ -> ".mp4" } @@ -47,30 +45,30 @@ ytdl url res = do let dir = concat [dlDir cfg, "/", ident] let fileName = concat [dir, "/", ident, ext] - processed <- lift $ doesFileExist fileName + processed <- doesFileExist fileName if processed then do - lift $ putStrLn $ "Returning existing ident " <> ident + putStrLn $ "Returning existing ident " <> ident pure (Right fileName) else do - lift $ putStrLn $ "Processing new ident " <> ident + putStrLn $ "Processing new ident " <> ident - lift $ createDirectoryIfMissing True dir + createDirectoryIfMissing True dir - lift $ print (resToArgs res <> ["-o", fileName, url]) + print (resToArgs res <> ["-o", fileName, url]) - ytdlProc <- lift $ createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) + ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) case ytdlProc of (_, _, _, ph) -> do - exitCode <- lift $ waitForProcess ph + exitCode <- waitForProcess ph case exitCode of ExitSuccess -> do - exists <- lift $ doesFileExist fileName + exists <- doesFileExist fileName if exists then do -- wait 5 minutes and then delete the directory - _ <- lift $ forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir + _ <- forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir pure (Right fileName) else do -- removeDirectoryRecursive dir From 7d71df34896c584ae8979e7e9db1629f261f26eb Mon Sep 17 00:00:00 2001 From: depsterr Date: Fri, 9 Jul 2021 18:21:14 +0200 Subject: [PATCH 06/11] fixed some old code --- src/YTDL.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/YTDL.hs b/src/YTDL.hs index 82a3810..94b95b9 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -71,9 +71,7 @@ ytdl url res = ReaderT $ \cfg -> do _ <- forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir pure (Right fileName) else do - -- removeDirectoryRecursive dir + removeDirectoryRecursive dir pure (Left "An unknown error prevented the output file from being created") (ExitFailure status) -> pure (Left ("execution failed with status " <> show status)) - - _ -> pure (Left "Unable to create ytdlProcess for downloading video") From a6c32f4f32266bfabf16502c1bfc7149f0c44b76 Mon Sep 17 00:00:00 2001 From: depsterr Date: Fri, 9 Jul 2021 19:11:46 +0200 Subject: [PATCH 07/11] prevent issues when downloading playlists --- src/YTDL.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/YTDL.hs b/src/YTDL.hs index 94b95b9..70573e7 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -35,6 +35,9 @@ resToArgs (P1080) = wrapResString "1080" resToArgs (PMAX) = ["-f", "bestvideo[ext=mp4]+bestaudio[ext=m4a]/mp4", "--merge-output-format", "mp4"] resToArgs (Audio) = ["-x", "--audio-format", "mp3"] +extraYtdlArgs :: [String] +extraYtdlArgs = ["--no-playlist"] + ytdl :: String -> Resolution -> ReaderT ViddlConfig IO (Either String FilePath) ytdl url res = ReaderT $ \cfg -> do @@ -57,7 +60,7 @@ ytdl url res = ReaderT $ \cfg -> do print (resToArgs res <> ["-o", fileName, url]) - ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) + ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url] <> extraYtdlArgs)) case ytdlProc of (_, _, _, ph) -> do From 899e88fc7d0f7ea0066bc704ab568d30cb1b83a9 Mon Sep 17 00:00:00 2001 From: depsterr Date: Mon, 12 Jul 2021 17:14:21 +0200 Subject: [PATCH 08/11] used pipes to improve error messages --- src/Templates/Error.hs | 3 ++- src/YTDL.hs | 16 ++++++++++++++-- viddl.cabal | 2 ++ 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/src/Templates/Error.hs b/src/Templates/Error.hs index 64d36d5..0963992 100644 --- a/src/Templates/Error.hs +++ b/src/Templates/Error.hs @@ -5,6 +5,7 @@ module Templates.Error (errorPage) where import qualified Data.Text.Lazy as TL import Text.RawString.QQ +import Text.HTML.SanitizeXSS errorPage :: TL.Text -> TL.Text errorPage msg = [r| @@ -17,7 +18,7 @@ errorPage msg = [r|

viddl

-

|] <> msg <> [r|

+

|] <> (TL.fromStrict (sanitize (TL.toStrict msg))) <> [r|

viddl is free open source software and is powered by youtube-dl.

diff --git a/src/YTDL.hs b/src/YTDL.hs index 70573e7..d9ce528 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -9,6 +9,7 @@ import qualified Data.ByteString.Lazy.UTF8 as BCU import System.Directory import System.Exit import System.Process +import System.IO data Resolution = P144 @@ -61,9 +62,13 @@ ytdl url res = ReaderT $ \cfg -> do print (resToArgs res <> ["-o", fileName, url]) ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url] <> extraYtdlArgs)) + { std_out = CreatePipe + , std_err = CreatePipe } case ytdlProc of - (_, _, _, ph) -> do + (_, Just hout, Just herr, ph) -> do + err <- hGetContents herr + out <- hGetContents hout exitCode <- waitForProcess ph case exitCode of ExitSuccess -> do @@ -77,4 +82,11 @@ ytdl url res = ReaderT $ \cfg -> do removeDirectoryRecursive dir pure (Left "An unknown error prevented the output file from being created") - (ExitFailure status) -> pure (Left ("execution failed with status " <> show status)) + (ExitFailure status) -> pure (Left (concat ["execution failed with status '" + , show status + , "' 
"
+              , out, err
+              , "'
" + ])) + + _ -> pure (Left "Unable to spawn process for downloading") diff --git a/viddl.cabal b/viddl.cabal index 0e4b015..aeadcb8 100644 --- a/viddl.cabal +++ b/viddl.cabal @@ -30,6 +30,7 @@ library , pureMD5 , utf8-string , transformers + , xss-sanitize hs-source-dirs: src default-language: Haskell2010 @@ -52,5 +53,6 @@ executable viddl , pureMD5 , utf8-string , transformers + , xss-sanitize hs-source-dirs: src default-language: Haskell2010 From ff28ae4148aa74b16b59444e95a7cfd5c53368cd Mon Sep 17 00:00:00 2001 From: depsterr Date: Sat, 22 Jan 2022 13:49:23 +0100 Subject: [PATCH 09/11] relax base dependency --- viddl.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/viddl.cabal b/viddl.cabal index aeadcb8..65d70aa 100644 --- a/viddl.cabal +++ b/viddl.cabal @@ -19,7 +19,7 @@ library , Helpers , Config ghc-options: -Wall -O2 -threaded - build-depends: base ^>=4.14.1.0 + build-depends: base ^>=4 , scotty , text , raw-strings-qq From 0d872835a41d8163b999cc498d1e9757ed1eb09c Mon Sep 17 00:00:00 2001 From: depsterr Date: Sat, 22 Jan 2022 13:50:08 +0100 Subject: [PATCH 10/11] relax build depends --- viddl.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/viddl.cabal b/viddl.cabal index 65d70aa..e64f6d1 100644 --- a/viddl.cabal +++ b/viddl.cabal @@ -19,7 +19,7 @@ library , Helpers , Config ghc-options: -Wall -O2 -threaded - build-depends: base ^>=4 + build-depends: base , scotty , text , raw-strings-qq From a5623c6b6bb5da9238deab6fcfb5342b270c089f Mon Sep 17 00:00:00 2001 From: depsterr Date: Sat, 22 Jan 2022 13:52:51 +0100 Subject: [PATCH 11/11] actually hopefully made it so my server doesn't cry --- viddl.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/viddl.cabal b/viddl.cabal index e64f6d1..3528ae3 100644 --- a/viddl.cabal +++ b/viddl.cabal @@ -42,7 +42,7 @@ executable viddl , YTDL , Config ghc-options: -Wall -O2 -threaded - build-depends: base ^>=4.14.1.0 + build-depends: base , scotty , text , raw-strings-qq