first working version

src/Clients.hs

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

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
 

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
+safeDownloadAction :: ActionM ()
-app :: R.Connection -> ScottyM ()
+safeDownloadAction = downloadAction `rescue` (html . errorPage)
-app rConn = do
-  get "/" $ do
-    html indexPage
 
-  post "/" $ do
+downloadAction :: ActionM ()
+downloadAction = do
     url <- param "url"
     res <- param "resolution"
     if (isURL url) && (isRes res)
       then do
-        queueOK <- liftIO acceptingClients
+        let (Just res') = getRes res -- safe cause we checked with isRes
-        if queueOK
+        ytdlRes <- liftIO $ ytdl (TL.unpack url) res'
-          then do
+        case ytdlRes of
-            html loadingPage
+          (Right filePath) -> do
-            -- set redis stuff and id here
+            setHeader "content-type" "video/mp4"
-            -- redirect $ TL.pack $ '/':id
+            file filePath
-          else
+          (Left err) -> html $ errorPage (TL.pack err)
-            html $ errorPage "Too many clients right now. Try again later!"
+        -- liftIO $ ytdlClean ident
-        else
+      else
         html $ errorPage "Invalid input!"
 
-  get "/:id" $ do
+-- todo ReaderT
-    -- grab id and process video if not already done
+app :: ScottyM ()
-    id <- param "id"
+app = do
-    html id
+  get "/" $ html indexPage
+  get "/video.mp4" safeDownloadAction
+  get "/audio.mp3" safeDownloadAction
 
 main :: IO ()
-main = do
+main = scotty 3000 app
-  -- todo: parse connection config
-  rConn <- R.connect R.defaultConnectInfo
-  scotty 3000 (app rConn)

src/Templates/Index.hs

@@ -22,7 +22,7 @@ indexPage = [r|
 			<tr>
 				<td valign="top">
 					<h2>Video download</h2>
-					<form method="post" action="/">
+					<form method="get" action="/video.mp4">
 						<input required name="url" type="text" placeholder="Enter url here"><br>
 						<label for="resolution">res</label>
 						<select required name="resolution">
@@ -39,7 +39,7 @@ indexPage = [r|
 				</td>
 				<td valign="top">
 					<h2>Audio only download</h2>
-					<form method="post" action="/">
+					<form method="get" action="/audio.mp3">
 						<input required name="url" type="text" placeholder="Enter url here"><br>
 						<input type="hidden" name="resolution" value="audio">
 						<input type="submit" value="Download">

src/Templates/Loading.hs

@@ -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|
-<!DOCTYPE html>
-<head>
-	<meta cherset="UTF-8">
-	<meta name="viewport" content="width=device-width, initial-scale=1.0">
-	<title>viddl</title>
-</head>
-<body>
-	<center>
-		<h1>viddl</h1>
-		<p>Your request is being processed... Please wait...</p>
-		<hr>
-		<p>viddl is free <a href="https://github.com/depsterr/viddl">open source</a> software and is powered by <a href="https://yt-dl.org/">youtube-dl</a>.</p>
-	</center>
-</body>
-|]

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)
+ytdl :: String -> Resolution -> IO (Either String FilePath)
-downloadVideo client url res = ytdl client url res
+ytdl url res = do
-
-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
   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 dir = concat [tmpdir, "/viddl/", ident]
-  let fileName = concat [dir, "/", client, ext]
+  let fileName = concat [dir, "/", ident, ext]
-  createDirectoryIfMissing True dir
 
-  ytdlProc <- createProcess (proc "youtube-dl" (resToArgs res <> ["-o", fileName, url]))
+  -- todo: implement file locking for deleting and uploading file
-    { std_out = CreatePipe
+  processed <- doesFileExist fileName
-    , std_err = CreatePipe }
+  if processed
+    then do
+      putStrLn $ "Returning existing ident " <> ident
+      pure (Right fileName)
+    else do
+      putStrLn $ "Processing new ident " <> ident
 
-  case ytdlProc of
+      createDirectoryIfMissing True dir
-    (_, _, 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")
 
-        (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")

todo

@@ -1,5 +1,2 @@
-bindings to python youtube-dl library, avoid invoking it as a program at all costs
+configuration for scotty
-
+cache results somehow
-configuration for scotty and redis, and some variables in the program
-
-maybe add some basic editing functionality eventually (ffmpeg?)

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