Merge branch 'ip-streaming'

Application.hs

@@ -64,6 +64,7 @@ mkYesodDispatch "UIApp" resourcesUIApp
 -- migrations handled by Yesod.
 makeApplication :: AppConfig BitloveEnv Extra -> IO Application
 makeApplication conf = do
+    let servedVhosts = extraServedVhosts $ appExtra conf
     dbconf <- withYamlEnvironment
               "config/postgresql.yml"
               (appEnv conf)
@@ -72,10 +73,10 @@ makeApplication conf = do
     trackerPool <- makeDBPool dbconf
     tracked <- newTracked
     foundation <- makeUIFoundation conf uiPool tracked
-    tracker <- makeTrackerApp trackerPool tracked >>=
+    tracker <- makeTrackerApp conf trackerPool tracked >>=
                fmap ignoreAccept . toWaiAppPlain
     stats <- statsMiddleware (appEnv conf) trackerPool
-    ui <- enforceVhost . stats . gzip def . autohead . etagMiddleware . ignoreAccept <$>
+    ui <- enforceVhost servedVhosts . stats . gzip def . autohead . etagMiddleware . ignoreAccept <$>
           toWaiAppPlain foundation
     return $ measureDuration $ anyApp [tracker, ui]
   where
@@ -100,8 +101,8 @@ makeApplication conf = do
     anyApp [] =
         \_req respond ->
             respond $ ResponseBuilder (Status 404 "Not found") [] mempty
-    enforceVhost :: Middleware
-    enforceVhost app req respond =
+    enforceVhost :: [BC.ByteString] -> Middleware
+    enforceVhost servedVhosts app req respond =
         let proceed = app req respond
             getRedirectResponse location = respond $
                                 ResponseBuilder (Status 301 "Wrong vhost")
@@ -111,11 +112,12 @@ makeApplication conf = do
              Nothing ->
                  proceed
              Just vhost
-                 | any (`BC.isPrefixOf` vhost) ["localhost", "bitlove.org", "api.bitlove.org"] ->
+                 | any (`BC.isPrefixOf` vhost) servedVhosts ->
                      proceed
              Just _ ->
                  getRedirectResponse $
-                 "https://bitlove.org" `BC.append` rawPathInfo req
+                 let approot = encodeUtf8 $ appRoot conf
+                 in approot `BC.append` rawPathInfo req
     measureDuration :: Middleware
     measureDuration app req respond =
         do cpu1 <- getCPUTime

Benc.hs

@@ -1,6 +1,7 @@
 module Benc (BValue(..), toBuilder, parseBenc) where
 
 import Prelude hiding (take, takeWhile)
+import Control.Monad (void)
 import Data.List (sort)
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy.Char8 as LBC
@@ -51,31 +52,32 @@ toBuilder (BDict xs) =
 bencoding :: Parser BValue
 bencoding =
     integer <|> string <|> list <|> dict
-    where integer =
-              do char 'i'
+    where char_ = void . char
+          integer =
+              do char_ 'i'
                  sign <- takeWhile (== '-')
                  digits <- takeWhile1 isDigit
-                 char 'e'
+                 char_ 'e'
                  return $
                    BInt $ read $
                    (BC.unpack sign) ++ (BC.unpack digits)
           string =
               do len <- read <$> BC.unpack <$> takeWhile1 isDigit
-                 char ':'
+                 char_ ':'
                  BString <$>
                    LBC.fromChunks <$>
                    (: []) <$>
                    take len
           list =
-              do char 'l'
-                 BList <$> manyTill bencoding (char 'e')
+              do char_ 'l'
+                 BList <$> manyTill bencoding (char_ 'e')
           dict =
-              do char 'd'
+              do char_ 'd'
                  map <- manyTill (do
                                    k <- bencoding
                                    v <- bencoding
                                    return (k, v)
-                                 ) (char 'e')
+                                 ) (char_ 'e')
                  map `seq`
                      return $ BDict map
 

Handler/Auth.hs

@@ -3,6 +3,7 @@ module Handler.Auth where
 
 import Prelude
 import Yesod hiding (returnJson)
+import Yesod.Default.Config (appExtra)
 import Crypto.HMAC
 import Crypto.Hash.CryptoAPI (SHA1)
 import Data.ByteString (ByteString)
@@ -72,9 +73,8 @@ postSignupR = do
         Left e ->
             sendError e
         Right token ->
-            do activateLink <- ("https://bitlove.org" `T.append`) `fmap`
-                               ($ ActivateR token) `fmap`
-                               getUrlRender
+            do activateLink <- ($ ActivateR token) <$>
+                               getFullUrlRender
                sendMail username email "Welcome to Bitlove" $
                         TLE.encodeUtf8 [stext|
 Welcome to Bitlove!
@@ -86,6 +86,11 @@ Thanks for sharing
     The Bitlove Team
     |]
 
+  contactMail <- extraContactMail .
+                 appExtra .
+                 settings <$>
+                 getYesod
+
   case sent of
     True ->
         defaultLayout $ do
@@ -101,7 +106,7 @@ Thanks for sharing
               toWidget [hamlet|$newline always
                         <h2>Sorry
                         <p>Sending mail failed. Please #
-                          <a href="mailto:mail@bitlove.org">contact support!
+                          <a href="mailto:#{contactMail}">contact support!
                         |]
     where validateUsername :: Text -> Bool
           validateUsername name = T.length name >= 3 &&
@@ -261,9 +266,8 @@ postReactivateR = do
                        False ->
                            return False
                        True  ->
-                           do activateLink <- ("https://bitlove.org" `T.append`) `fmap`
-                                              ($ ActivateR token) `fmap`
-                                              getUrlRender
+                           do activateLink <- ($ ActivateR token) <$>
+                                              getFullUrlRender
                               sendMail user email "Reactivate your Bitlove account" $
                                        TLE.encodeUtf8 [stext|
 Welcome back to Bitlove!
@@ -275,7 +279,12 @@ Thanks for sharing
     The Bitlove Team
     |]
                 ) True userTokens
-
+
+  contactMail <- extraContactMail .
+                 appExtra .
+                 settings <$>
+                 getYesod
+
   defaultLayout $ do
     setTitleI MsgTitleReactivate
     case sent of
@@ -288,7 +297,7 @@ Thanks for sharing
           toWidget [hamlet|$newline always
                     <h2>Sorry
                     <p>Sending mail failed. Please #
-                      <a href="mailto:mail@bitlove.org">contact support!
+                      <a href="mailto:#{contactMail}">contact support!
                     |]
       True ->
           toWidget [hamlet|$newline always
@@ -306,26 +315,30 @@ getLogoutR =
 
 -- returns whether this was successful
 sendMail :: UserName -> Text -> Text -> LBC.ByteString -> Handler Bool
-sendMail toUser toEmail subject body =
-    liftIO $
+sendMail toUser toEmail subject body = do
+  contactMail <- extraContactMail .
+                 appExtra .
+                 settings <$>
+                 getYesod
+
+  let send =
+        renderSendMail
+        Mail { mailFrom = Address (Just "Bitlove") contactMail
+             , mailTo = [Address (Just $ userName toUser) toEmail]
+             , mailCc = []
+             , mailBcc = []
+             , mailHeaders = [("Subject", subject)]
+             , mailParts = [
+                 [Part { partType = "text/plain"
+                       , partEncoding = None
+                       , partFilename = Nothing
+                       , partHeaders = []
+                       , partContent = body
+                       }]]
+             }
+  liftIO $
     E.catch (send >> return True) $
     \(E.ErrorCall _) -> return False
-  where send =
-            renderSendMail
-            Mail {
-              mailFrom = Address (Just "Bitlove.org") "mail@bitlove.org",
-              mailTo = [Address (Just $ userName toUser) toEmail],
-              mailCc = [],
-              mailBcc = [],
-              mailHeaders = [("Subject", subject)],
-              mailParts = [[Part {
-                              partType = "text/plain",
-                              partEncoding = None,
-                              partFilename = Nothing,
-                              partHeaders = [],
-                              partContent = body
-                            }]]
-            }
 
 returnJson :: (Monad m, a ~ Value) =>
               [(Text, a)] -> m RepJson

Handler/Browse.hs

@@ -5,11 +5,9 @@ import qualified Data.Text as T
 import Data.Maybe
 import Data.Foldable (Foldable)
 import Data.Time.Format
-import Network.HTTP.Types (parseQueryText)
 import Text.Blaze
 import Text.Blaze.Internal (MarkupM)
 import Text.Blaze.Html5 hiding (div, details, map, title)
-import Text.Blaze.Html5.Attributes hiding (item, min, max, id, title)
 import qualified Data.ByteString.Char8 as BC
 import Control.Monad
 import Settings.StaticFiles
@@ -450,7 +448,7 @@ renderItem item showOrigin = do
             <a href=@{UserR $ itemUser item}>#{userName $ itemUser item}
         $else
            <p class="homepage">
-             <a href="#{itemHomepage item}">#{itemHomepage item}
+             <a href="#{homepage}">#{homepage}
     $forall (d, scrape) <- downloadsAndScrapes
       <ul .download>
         <li .torrent>

Handler/ByEnclosureAPI.hs

@@ -12,7 +12,6 @@ import Data.Maybe (catMaybes)
 import System.IO.Unsafe
 
 import Import
-import Tracked
 
 getByEnclosureJson :: Handler RepJson
 getByEnclosureJson = do

Handler/Directory.hs

@@ -114,7 +114,7 @@ getDirectoryOpmlR = do
   return $ RepOpml $ toContent $
              [xhamlet|$newline always
 <opml version="2.0">
-  <head title="Bitlove.org directory"
+  <head title="Bitlove directory"
         ownerId="#{url DirectoryR}">
   <body>
     $forall es <- dir

Handler/TorrentFile.hs

@@ -4,12 +4,11 @@ import Prelude (head)
 import Data.Convertible (convert)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
-import qualified Data.Text as T
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy.Char8 as LBC
 import Yesod
+import Yesod.Default.Config (appExtra)
 import Blaze.ByteString.Builder
-import Network.URI (escapeURIString, isUnescapedInURIComponent)
 
 import Import
 import qualified Model as Model
@@ -50,13 +49,16 @@ getTorrentFile includeOtherWebseeds user slug (TorrentName name) = do
     Nothing ->
       notFound
     Just (buf, infoHash) -> do
-      seedUrl <- T.append "https://bitlove.org" <$>
-                 ($ WebSeedR (HexInfoHash infoHash) name) <$>
-                 getUrlRender
+      seedUrl <- ($ WebSeedR (HexInfoHash infoHash) name) <$>
+                 getFullUrlRender
       let seedUrls
             | includeOtherWebseeds = [seedUrl]
             | otherwise = []
-          mBuf = updateTorrent seedUrls buf
+      myTrackers <- map convert .
+                    extraTrackerURLs .
+                    appExtra . settings <$>
+                    getYesod
+      let mBuf = updateTorrent myTrackers seedUrls buf
       case mBuf of
         Just buf' ->
           return $ RepTorrent $ toContent buf'
@@ -72,8 +74,8 @@ getTorrentFile includeOtherWebseeds user slug (TorrentName name) = do
 -- * `announce` (BEP 3)
 -- * `announce-list` (BEP 12)
 -- * `url-list` (BEP 19)
-updateTorrent :: [Text] -> BC.ByteString -> Maybe Builder
-updateTorrent seedUrls buf = do
+updateTorrent :: [LBC.ByteString] -> [Text] -> BC.ByteString -> Maybe Builder
+updateTorrent myTrackers seedUrls buf = do
   BDict dict <- parseBenc buf
   let
     getList :: LBC.ByteString -> [BValue]
@@ -106,16 +108,11 @@ updateTorrent seedUrls buf = do
         ("announce", BString $ head myTrackers) :
         ("announce-list", BList $ map (BList . map BString) trackerList') :
         ("url-list", BList $ map BString urlList') :
-        filter (\(name, val) ->
-                  name /= "announce" &&
-                 name /= "announce-list" &&
-                 name /= "url-list"
+        filter (\(name, _val) ->
+                   name /= "announce" &&
+                   name /= "announce-list" &&
+                   name /= "url-list"
                ) dict
 
   return $ toBuilder $
     BDict dict'
-
-    where
-      myTrackers =
-        [ "http://t.bitlove.org/announce"
-        , "wss://t.bitlove.org/webtorrent-announce" ]

Handler/TorrentStats.hs

@@ -34,14 +34,9 @@ getTorrentStatsR user slug name statsPeriod stats = do
           baseJson = ["start" .= iso8601 zonedStart,
                       "stop" .= iso8601 zonedStop,
                       "interval" .= interval]
-          withStats :: (LocalTime -> LocalTime -> Int -> Transaction a)
-                     -> Handler a
-          -- |Can run one query
-          withStats f = withDB $
-                        f localStart localStop interval
           -- |Supplies `q` for multiple queries
-          withStats' :: (((LocalTime -> LocalTime -> Int -> Transaction a) -> IO a) -> IO b) -> Handler b
-          withStats' f = withDB $ \db ->
+          withStats :: (((LocalTime -> LocalTime -> Int -> Transaction a) -> IO a) -> IO b) -> Handler b
+          withStats f = withDB $ \db ->
                          f $ \f' ->
                          f' localStart localStop interval db
 
@@ -57,7 +52,7 @@ getTorrentStatsR user slug name statsPeriod stats = do
           canEdit' <- canEdit user
           urlRender <- getUrlRender
 
-          withStats' $ \q -> do
+          withStats $ \q -> do
             json <- mapM (\(key, name) ->
                             (key .=) <$>
                             counterToValue q name
@@ -81,12 +76,12 @@ getTorrentStatsR user slug name statsPeriod stats = do
               else return []
             return $ json ++ ownerJson ++ baseJson
         StatsTraffic ->
-          withStats' $ \q -> do
+          withStats $ \q -> do
           (++ baseJson) <$>
             mapM (counterToPair q)
             ["down", "up", "up_seeder", "down_w", "up_w", "up_seeder_w"]
         StatsSwarm ->
-          withStats' $ \q ->
+          withStats $ \q ->
           do let completeGauge vs =
                      completeGauge' $
                      case vs of