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

switched to having templates in the source code

Browse Source
This commit is contained in:
Rachel Lambda Samuelsson 2021-06-27 12:26:52 +02:00
parent 84897aea9c
commit f4454e5612
5 changed files with 108 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
src/Main.hs
View File

@ -2,10 +2,15 @@
module Main where module Main where
import Templates.Index
import Templates.Loading
import Templates.Error
import Control.Monad.IO.Class
import qualified Database.Redis as R import qualified Database.Redis as R
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Web.Scotty import Web.Scotty
import System.Posix.Process (executeFile) import Network.URI (URI, parseURI)
data Resolution data Resolution
= P144 = P144
@ -16,46 +21,76 @@ data Resolution
| P1080 | P1080
| PMAX | PMAX
| PMIN | PMIN
| Audio
deriving (Eq, Show) deriving (Eq, Show)
getRes :: String -> Maybe Resolution getRes :: String -> Maybe Resolution
getRes ("144p") = P144 getRes ("144p") = Just P144
getRes ("240p") = P240 getRes ("240p") = Just P240
getRes ("360p") = P360 getRes ("360p") = Just P360
getRes ("480p") = P480 getRes ("480p") = Just P480
getRes ("720p") = P720 getRes ("720p") = Just P720
getRes ("1080p") = P1080 getRes ("1080p") = Just P1080
getRes ("min") = PMAX getRes ("min") = Just PMAX
getRes ("max") = PMIN getRes ("max") = Just PMIN
getRes ("audio") = Just Audio
getRes ("max") = Nothing
downloadVideo :: String -> Resolution -> IO Filepath isRes :: TL.Text -> Bool
isRes res = case getRes (TL.unpack res) of
(Just _) -> True
_ -> False
isURL :: TL.Text -> Bool
isURL uri = case parseURI (TL.unpack uri) of
(Just _) -> True
_ -> False
-- todo: config file
maxClients :: Int
maxClients = 100
getClients :: IO Int
getClients = undefined
acceptingClients :: IO Bool
acceptingClients = do
clients <- getClients
pure $ clients < maxClients
downloadVideo :: String -> Resolution -> IO FilePath
downloadVideo url res = do downloadVideo url res = do
undefined undefined
downloadAudio :: String -> IO Filepath downloadAudio :: String -> IO FilePath
downloadAudio url = do downloadAudio url = do
undefined undefined
getIndex :: IO String
getIndex = readFile "views/index.html"
app :: R.Connection -> ScottyM () app :: R.Connection -> ScottyM ()
app rConn = do app rConn = do
get "/" $ do get "/" $ do
setHeader "Content-Type" "text/html;charset=utf-8" html indexPage
file "views/index.html"
post "/" $ do post "/" $ do
setHeader "Content-Type" "text/html;charset=utf-8"
file "views/loading.html"
url <- param "url" url <- param "url"
res <- param "resolution" 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 -- set redis stuff and id here
redirect '/':id -- redirect $ TL.pack $ '/':id
else
html $ errorPage "Too many clients right now. Try again later!"
else
html $ errorPage "Invalid input!"
get "/:id" $ do get "/:id" $ do
-- grab id and process video if not already done -- grab id and process video if not already done
id <- param "id" id <- param "id"
html id
main :: IO () main :: IO ()
main = do main = do

25
src/Templates/Error.hs Normal file
View File

@ -0,0 +1,25 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Templates.Error (errorPage) where
import qualified Data.Text.Lazy as TL
import Text.RawString.QQ
errorPage :: TL.Text -> TL.Text
errorPage msg = [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>|] <> msg <> [r|</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>
|]

12
views/index.html → src/Templates/Index.hs
View File

@ -1,3 +1,13 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Templates.Index (indexPage) where
import qualified Data.Text.Lazy as TL
import Text.RawString.QQ
indexPage :: TL.Text
indexPage = [r|
<!DOCTYPE html> <!DOCTYPE html>
<head> <head>
<meta cherset="UTF-8"> <meta cherset="UTF-8">
@ -32,6 +42,7 @@
<h2>Audio only download</h2> <h2>Audio only download</h2>
<form method="post" action="/"> <form method="post" action="/">
<input required name="url" type="text" placeholder="Enter url here"><br> <input required name="url" type="text" placeholder="Enter url here"><br>
<input type="hidden" name="resolution" value="audio">
<input type="submit" value="Download"> <input type="submit" value="Download">
</form> </form>
</td> </td>
@ -41,3 +52,4 @@
<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> <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> </center>
</body> </body>
|]

11
views/loading.html → src/Templates/Loading.hs
View File

@ -1,3 +1,13 @@
{-# 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> <!DOCTYPE html>
<head> <head>
<meta cherset="UTF-8"> <meta cherset="UTF-8">
@ -12,3 +22,4 @@
<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> <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> </center>
</body> </body>
|]

6
viddl.cabal
View File

@ -15,7 +15,9 @@ extra-source-files: CHANGELOG.md
executable viddl executable viddl
main-is: Main.hs main-is: Main.hs
-- other-modules: other-modules: Templates.Index
, Templates.Loading
, Templates.Error
-- other-extensions: -- other-extensions:
ghc-options: -Wall -O2 ghc-options: -Wall -O2
build-depends: base ^>=4.14.1.0 build-depends: base ^>=4.14.1.0
@ -24,5 +26,7 @@ executable viddl
, transformers , transformers
, text , text
, unix , unix
, raw-strings-qq
, network-uri
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010