rachel/viddl
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge branch 'master' of githug.xyz:depsterr/viddl

Browse Source
This commit is contained in:
Rachel Lambda Samuelsson 2022-03-14 11:00:14 +01:00
commit d01d2b3b0f
7 changed files with 84 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Config.hs Normal file
View File

@ -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")

30
src/Helpers.hs
View File

@ -3,8 +3,26 @@
module Helpers where module Helpers where
import YTDL import YTDL
import Config
import Text.Read (readMaybe)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Network.URI (parseURI) 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 :: TL.Text -> Maybe Resolution
getRes ("144p") = Just P144 getRes ("144p") = Just P144
@ -22,7 +40,13 @@ isRes res = case getRes res of
(Just _) -> True (Just _) -> True
_ -> False _ -> False
-- ssrf paranoia
isOkPath :: String -> Bool
isOkPath p = not $ isIPv4address p || isIPv6address p || p == "localhost"
isURL :: TL.Text -> Bool isURL :: TL.Text -> Bool
isURL uri = case parseURI (TL.unpack uri) of isURL uri = case parseURI (TL.unpack uri) of
(Just _) -> True (Just u) -> case uriAuthority u of
_ -> False (Just (URIAuth _ p _)) -> isOkPath p
_ -> False
_ -> False

25
src/Main.hs
View File

@ -6,37 +6,46 @@ import Templates.Index
import Templates.Error import Templates.Error
import YTDL import YTDL
import Helpers 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 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) safeDownloadAction = downloadAction `rescue` (html . errorPage)
downloadAction :: ActionM () downloadAction :: Action ()
downloadAction = do downloadAction = do
url <- param "url" url <- param "url"
res <- param "resolution" res <- param "resolution"
if (isURL url) && (isRes res) if (isURL url) && (isRes res)
then do then do
let (Just res') = getRes res -- safe cause we checked with isRes 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 case ytdlRes of
(Right filePath) -> do (Right filePath) -> do
setHeader "content-type" "video/mp4" setHeader "content-type" "video/mp4"
file filePath file filePath
(Left err) -> html $ errorPage (TL.pack err) (Left err) -> html $ errorPage (TL.pack err)
-- liftIO $ ytdlClean ident
else else
html $ errorPage "Invalid input!" html $ errorPage "Invalid input!"
-- todo ReaderT -- todo ReaderT
app :: ScottyM () app :: Scotty ()
app = do app = do
get "/" $ html indexPage get "/" $ html indexPage
get "/video.mp4" safeDownloadAction get "/video.mp4" safeDownloadAction
get "/audio.mp3" safeDownloadAction get "/audio.mp3" safeDownloadAction
main :: IO () main :: IO ()
main = scotty 3000 app main = do
args <- getArgs
defCfg <- defConfig
cfg <- parseArgs defCfg args
scottyT (webPort cfg) (\(ReaderT ma) -> ma cfg) app

3
src/Templates/Error.hs
View File

@ -5,6 +5,7 @@ module Templates.Error (errorPage) where
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Text.RawString.QQ import Text.RawString.QQ
import Text.HTML.SanitizeXSS
errorPage :: TL.Text -> TL.Text errorPage :: TL.Text -> TL.Text
errorPage msg = [r| errorPage msg = [r|
@ -17,7 +18,7 @@ errorPage msg = [r|
<body> <body>
<center> <center>
<h1>viddl</h1> <h1>viddl</h1>
<p>|] <> msg <> [r|</p> <p>|] <> (TL.fromStrict (sanitize (TL.toStrict msg))) <> [r|</p>
<hr> <hr>
<p>viddl is free <a href="https://githug.xyz/depsterr/viddl">open source</a> software and is powered by <a href="https://yt-dl.org/">youtube-dl</a>.</p> <p>viddl is free <a href="https://githug.xyz/depsterr/viddl">open source</a> software and is powered by <a href="https://yt-dl.org/">youtube-dl</a>.</p>
</center> </center>

28
src/YTDL.hs
View File

@ -1,5 +1,8 @@
module YTDL (Resolution(..), ytdl) where module YTDL (Resolution(..), ytdl) where
import Config
import Control.Monad.Trans.Reader
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
import qualified Data.ByteString.Lazy.UTF8 as BCU import qualified Data.ByteString.Lazy.UTF8 as BCU
@ -21,7 +24,7 @@ data Resolution
wrapResString :: String -> [String] wrapResString :: String -> [String]
wrapResString str = ["-f", concat ["bestvideo[ext=mp4,height<=", str, 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 :: Resolution -> [String]
resToArgs (P144) = wrapResString "144" resToArgs (P144) = wrapResString "144"
@ -30,21 +33,22 @@ resToArgs (P360) = wrapResString "360"
resToArgs (P480) = wrapResString "480" resToArgs (P480) = wrapResString "480"
resToArgs (P720) = wrapResString "720" resToArgs (P720) = wrapResString "720"
resToArgs (P1080) = wrapResString "1080" 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"] resToArgs (Audio) = ["-x", "--audio-format", "mp3"]
ytdl :: String -> Resolution -> IO (Either String FilePath) extraYtdlArgs :: [String]
ytdl url res = do extraYtdlArgs = ["--no-playlist"]
ytdl :: String -> Resolution -> ReaderT ViddlConfig IO (Either String FilePath)
ytdl url res = ReaderT $ \cfg -> do
let ext = case res of { Audio -> ".mp3"; _ -> ".mp4" } let ext = case res of { Audio -> ".mp3"; _ -> ".mp4" }
let ident = show . md5 . BCU.fromString $ url <> show res let ident = show . md5 . BCU.fromString $ url <> show res
-- todo: config for path let dir = concat [dlDir cfg, "/", ident]
tmpdir <- getTemporaryDirectory
let dir = concat [tmpdir, "/viddl/", ident]
let fileName = concat [dir, "/", ident, ext] let fileName = concat [dir, "/", ident, ext]
-- todo: implement file locking for deleting and uploading file
processed <- doesFileExist fileName processed <- doesFileExist fileName
if processed if processed
then do then do
@ -55,13 +59,16 @@ ytdl url res = do
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) print (resToArgs res <> ["-o", fileName, url])
ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url] <> extraYtdlArgs))
{ std_out = CreatePipe { std_out = CreatePipe
, std_err = CreatePipe } , std_err = CreatePipe }
case ytdlProc of case ytdlProc of
(_, _, Just herr, ph) -> do (_, Just hout, Just herr, ph) -> do
err <- hGetContents herr err <- hGetContents herr
out <- hGetContents hout
exitCode <- waitForProcess ph exitCode <- waitForProcess ph
case exitCode of case exitCode of
ExitSuccess -> do ExitSuccess -> do
@ -69,7 +76,6 @@ ytdl url res = do
if exists if exists
then do then do
-- wait 5 minutes and then delete the directory -- wait 5 minutes and then delete the directory
-- todo: implement file locking for deleting and uploading file
_ <- forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir _ <- forkIO $ threadDelay 300000000 >> removeDirectoryRecursive dir
pure (Right fileName) pure (Right fileName)
else do else do

5
todo
View File

@ -1,2 +1,3 @@
configuration for scotty better config options (file?)
cache results somehow safer file deletion
queue system?

10
viddl.cabal
View File

@ -17,8 +17,9 @@ library
, Templates.Error , Templates.Error
, YTDL , YTDL
, Helpers , Helpers
, Config
ghc-options: -Wall -O2 -threaded ghc-options: -Wall -O2 -threaded
build-depends: base ^>=4.14.1.0 build-depends: base
, scotty , scotty
, text , text
, raw-strings-qq , raw-strings-qq
@ -28,6 +29,8 @@ library
, bytestring , bytestring
, pureMD5 , pureMD5
, utf8-string , utf8-string
, transformers
, xss-sanitize
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -37,8 +40,9 @@ executable viddl
, Templates.Error , Templates.Error
, Helpers , Helpers
, YTDL , YTDL
, Config
ghc-options: -Wall -O2 -threaded ghc-options: -Wall -O2 -threaded
build-depends: base ^>=4.14.1.0 build-depends: base
, scotty , scotty
, text , text
, raw-strings-qq , raw-strings-qq
@ -48,5 +52,7 @@ executable viddl
, bytestring , bytestring
, pureMD5 , pureMD5
, utf8-string , utf8-string
, transformers
, xss-sanitize
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010