From 18fdfd978041945c70b75241cb6e7238366436d7 Mon Sep 17 00:00:00 2001 From: depsterr Date: Sun, 4 Jul 2021 17:04:39 +0200 Subject: [PATCH] first working version --- src/Clients.hs | 33 ------------------ src/Helpers.hs | 6 ++-- src/Main.hs | 46 +++++++++++-------------- src/Templates/Index.hs | 4 +-- src/Templates/Loading.hs | 25 -------------- src/YTDL.hs | 72 ++++++++++++++++++++++++---------------- todo | 7 ++-- viddl.cabal | 19 +++++++---- 8 files changed, 84 insertions(+), 128 deletions(-) delete mode 100644 src/Clients.hs delete mode 100644 src/Templates/Loading.hs diff --git a/src/Clients.hs b/src/Clients.hs deleted file mode 100644 index 74aee34..0000000 --- a/src/Clients.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Clients where - -import Control.Monad (replicateM) -import System.Random (randomRIO) -import qualified Database.Redis as R -import qualified Data.ByteString.Char8 as BC - -idIsFree :: BC.ByteString -> R.Connection -> IO Bool -idIsFree id rConn = do - response <- R.runRedis rConn (R.get id) - pure $ case response of - (Left _) -> False -- maybe error here? look into what causes this more - (Right x) -> - case x of - (Just _) -> True - _ -> False - -genClientId :: IO String -genClientId = replicateM 8 (randomRIO ('a', 'z')) - --- todo: config file -maxClients :: Int -maxClients = 100 - -getClients :: IO Int -getClients = undefined - -acceptingClients :: IO Bool -acceptingClients = do - clients <- getClients - pure $ clients < maxClients diff --git a/src/Helpers.hs b/src/Helpers.hs index 8d9de32..7d666f6 100644 --- a/src/Helpers.hs +++ b/src/Helpers.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} + module Helpers where import YTDL import qualified Data.Text.Lazy as TL import Network.URI (parseURI) -getRes :: String -> Maybe Resolution +getRes :: TL.Text -> Maybe Resolution getRes ("144p") = Just P144 getRes ("240p") = Just P240 getRes ("360p") = Just P360 @@ -16,7 +18,7 @@ getRes ("audio") = Just Audio getRes _ = Nothing isRes :: TL.Text -> Bool -isRes res = case getRes (TL.unpack res) of +isRes res = case getRes res of (Just _) -> True _ -> False diff --git a/src/Main.hs b/src/Main.hs index 91add33..3d5a504 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,46 +3,40 @@ module Main where import Templates.Index -import Templates.Loading import Templates.Error import YTDL -import Clients import Helpers import Control.Monad.IO.Class -import qualified Database.Redis as R import qualified Data.Text.Lazy as TL import Web.Scotty --- todo ReaderT -app :: R.Connection -> ScottyM () -app rConn = do - get "/" $ do - html indexPage +safeDownloadAction :: ActionM () +safeDownloadAction = downloadAction `rescue` (html . errorPage) - post "/" $ do +downloadAction :: ActionM () +downloadAction = do url <- param "url" res <- param "resolution" if (isURL url) && (isRes res) then do - queueOK <- liftIO acceptingClients - if queueOK - then do - html loadingPage - -- set redis stuff and id here - -- redirect $ TL.pack $ '/':id - else - html $ errorPage "Too many clients right now. Try again later!" - else + let (Just res') = getRes res -- safe cause we checked with isRes + ytdlRes <- liftIO $ ytdl (TL.unpack url) res' + case ytdlRes of + (Right filePath) -> do + setHeader "content-type" "video/mp4" + file filePath + (Left err) -> html $ errorPage (TL.pack err) + -- liftIO $ ytdlClean ident + else html $ errorPage "Invalid input!" - get "/:id" $ do - -- grab id and process video if not already done - id <- param "id" - html id +-- todo ReaderT +app :: ScottyM () +app = do + get "/" $ html indexPage + get "/video.mp4" safeDownloadAction + get "/audio.mp3" safeDownloadAction main :: IO () -main = do - -- todo: parse connection config - rConn <- R.connect R.defaultConnectInfo - scotty 3000 (app rConn) +main = scotty 3000 app diff --git a/src/Templates/Index.hs b/src/Templates/Index.hs index 856e1dc..da3b731 100644 --- a/src/Templates/Index.hs +++ b/src/Templates/Index.hs @@ -22,7 +22,7 @@ indexPage = [r|

Video download

-
+

diff --git a/src/Templates/Loading.hs b/src/Templates/Loading.hs deleted file mode 100644 index cea05ca..0000000 --- a/src/Templates/Loading.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Templates.Loading (loadingPage) where - -import qualified Data.Text.Lazy as TL -import Text.RawString.QQ - -loadingPage :: TL.Text -loadingPage = [r| - - - - - viddl - - -
-

viddl

-

Your request is being processed... Please wait...

-
-

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

-
- -|] diff --git a/src/YTDL.hs b/src/YTDL.hs index d2b1083..4e481fe 100644 --- a/src/YTDL.hs +++ b/src/YTDL.hs @@ -1,5 +1,8 @@ -module YTDL (downloadVideo, downloadAudio, Resolution(..), ytdl) where +module YTDL (Resolution(..), ytdl) where +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 @@ -30,38 +33,49 @@ resToArgs (P1080) = wrapResString "1080" resToArgs (PMAX) = ["-f", "bestvideo[ext=mp4]+bestaudio[ext=m4a]/mp4"] resToArgs (Audio) = ["-x", "--audio-format", "mp3"] -downloadVideo :: String -> String -> Resolution -> IO (Either String FilePath) -downloadVideo client url res = ytdl client url res - -downloadAudio :: String -> String -> IO (Either String FilePath) -downloadAudio client url = ytdl client url Audio - -ytdl :: String -> String -> Resolution -> IO (Either String FilePath) -ytdl client url res = do +ytdl :: String -> Resolution -> IO (Either String FilePath) +ytdl url res = do 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/", client] - let fileName = concat [dir, "/", client, ext] - createDirectoryIfMissing True dir + let dir = concat [tmpdir, "/viddl/", ident] + let fileName = concat [dir, "/", ident, ext] - ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) - { std_out = CreatePipe - , std_err = CreatePipe } + -- todo: implement file locking for deleting and uploading file + processed <- doesFileExist fileName + if processed + then do + putStrLn $ "Returning existing ident " <> ident + pure (Right fileName) + else do + putStrLn $ "Processing new ident " <> ident - case ytdlProc of - (_, _, Just herr, ph) -> do - err <- hGetContents herr - exitCode <- waitForProcess ph - case exitCode of - ExitSuccess -> do - exists <- doesFileExist fileName - if exists - then pure (Right fileName) - else do - removeDirectory dir - pure (Left "An unknown error prevented the output file from being created") + createDirectoryIfMissing True dir - (ExitFailure status) -> pure (Left (concat ["execution failed with status ", show status, ": ", err])) + ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url])) + { std_out = CreatePipe + , std_err = CreatePipe } - _ -> pure (Left "Unable to create ytdlProcess for downloading video") + case ytdlProc of + (_, _, Just herr, ph) -> do + err <- hGetContents herr + exitCode <- waitForProcess ph + case exitCode of + ExitSuccess -> do + exists <- 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 + pure (Right fileName) + else do + 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])) + + _ -> pure (Left "Unable to create ytdlProcess for downloading video") diff --git a/todo b/todo index ee4abf2..131fce8 100644 --- a/todo +++ b/todo @@ -1,5 +1,2 @@ -bindings to python youtube-dl library, avoid invoking it as a program at all costs - -configuration for scotty and redis, and some variables in the program - -maybe add some basic editing functionality eventually (ffmpeg?) +configuration for scotty +cache results somehow diff --git a/viddl.cabal b/viddl.cabal index 71e11a0..14e11f7 100644 --- a/viddl.cabal +++ b/viddl.cabal @@ -14,32 +14,39 @@ build-type: Simple library exposed-modules: Templates.Index - , Templates.Loading , Templates.Error , YTDL - , Clients , Helpers ghc-options: -Wall -O2 build-depends: base ^>=4.14.1.0 , scotty - , hedis - , transformers , text , raw-strings-qq , network-uri , directory , process , bytestring - , random + , pureMD5 + , utf8-string hs-source-dirs: src default-language: Haskell2010 executable viddl main-is: Main.hs + other-modules: Templates.Index + , Templates.Error + , Helpers + , YTDL ghc-options: -Wall -O2 build-depends: base ^>=4.14.1.0 , scotty - , hedis , text + , raw-strings-qq + , network-uri + , directory + , process + , bytestring + , pureMD5 + , utf8-string hs-source-dirs: src default-language: Haskell2010