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