Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
257 lines (237 sloc) 9.28 KB
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}
module Application
( makeApplication
, getApplicationDev
, makeUIFoundation
) where
import Import hiding (loadConfig)
import Settings
import Yesod.Default.Config
import Yesod.Default.Main
import Yesod.Default.Handlers hiding (getFaviconR)
import Network.HTTP.Conduit (newManager, tlsManagerSettings)
import Data.Pool
import qualified Database.PostgreSQL.LibPQ as PQ
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Network.Wai
import Network.Wai.Internal
import Network.HTTP.Types.Status
import System.CPUTime (getCPUTime)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import qualified Data.ByteString.Char8 as BC
--import Data.Monoid
import System.IO (stderr)
import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.Gzip
import Network.HTTP.Types
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Auth
import Handler.Browse
import Handler.Directory
import Handler.Edit
import Handler.TorrentFile
import Handler.TorrentStats
import Handler.MapFeed
import Handler.DownloadFeeds
import Handler.ByEnclosureAPI
import Handler.FeedLookupAPI
import Tracker (makeTrackerApp)
import Handler.Help
import Handler.Widget
import Handler.Thumbnails
import Handler.WebSeeder
import Handler.Impress
import Stats
import Tracked
-- This line actually creates our YesodSite instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see
-- the comments there for more details.
-- TODO: remove -fno-warn-name-shadowing
mkYesodDispatch "UIApp" resourcesUIApp
-- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database
-- 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)
parseDBConf
uiPool <- makeDBPool dbconf
trackerPool <- makeDBPool dbconf
tracked <- newTracked
foundation <- makeUIFoundation conf uiPool tracked
tracker <- makeTrackerApp conf trackerPool tracked >>=
fmap ignoreAccept . toWaiAppPlain
stats <- statsMiddleware (appEnv conf) trackerPool
ui <- enforceVhost servedVhosts . stats . gzip def . autohead . etagMiddleware . ignoreAccept <$>
toWaiAppPlain foundation
return $ measureDuration $ anyApp [tracker, ui]
where
anyApp [app] =
app
anyApp (app:apps) =
\req respond ->
app req $ \res ->
let tryNext =
case res of
ResponseFile (Status 404 _) _ _ _ ->
True
ResponseBuilder (Status 404 _) _ _ ->
True
ResponseStream (Status 404 _) _ _ ->
True
_ ->
False
in if tryNext
then anyApp apps req respond
else respond res
anyApp [] =
\_req respond ->
respond $ ResponseBuilder (Status 404 "Not found") [] mempty
enforceVhost :: [BC.ByteString] -> Middleware
enforceVhost servedVhosts app req respond =
let proceed = app req respond
getRedirectResponse location = respond $
ResponseBuilder (Status 301 "Wrong vhost")
[("Location", location)]
mempty
in case "Host" `lookup` requestHeaders req of
Nothing ->
proceed
Just vhost
| any (`BC.isPrefixOf` vhost) servedVhosts ->
proceed
Just _ ->
getRedirectResponse $
let approot = encodeUtf8 $ appRoot conf
in approot `BC.append` rawPathInfo req
measureDuration :: Middleware
measureDuration app req respond =
do cpu1 <- getCPUTime
utc1 <- getCurrentTime
app req $ \res ->
do cpu2 <- res `seq`
getCPUTime
utc2 <- getCurrentTime
a <- respond res
cpu3 <- getCPUTime
utc3 <- getCurrentTime
let remote = show $ remoteHost req
proxied = BC.unpack <$>
"X-Real-IP" `lookup` requestHeaders req
remote' = maybe remote ((remote ++ "/") ++) proxied
BC.hPutStrLn stderr $ BC.concat
[ "["
, BC.pack $ show (truncate $ (utc2 `diffUTCTime` utc1) * 1000 :: Int)
, "+"
, BC.pack $ show (truncate $ (utc3 `diffUTCTime` utc2) * 1000 :: Int)
, "ms real "
, BC.pack $ show ((cpu2 - cpu1) `div` 1000000000)
, "+"
, BC.pack $ show ((cpu3 - cpu2) `div` 1000000000)
, "ms cpu] "
, BC.pack remote'
, " "
, BC.pack $ show $ statusCode $ responseStatus res
, " "
, requestMethod req
, " "
, rawPathInfo req
]
return a
etagMiddleware app req respond =
do let reqETags =
"If-None-Match" `lookup` requestHeaders req
matches etag =
case (etag `BC.breakSubstring`) <$> reqETags of
Just (_, reqEtags')
| not (BC.null reqEtags') ->
True
_ ->
False
app req $ \res ->
do let may304 res s hs
| statusCode s == 200 &&
maybe False matches ("ETag" `lookup` hs) =
ResponseBuilder notModified304 hs mempty
| otherwise =
res
res' = case res of
ResponseFile s hs _ _ ->
may304 res s hs
ResponseBuilder s hs _ ->
may304 res s hs
ResponseStream s hs _ ->
may304 res s hs
raw -> raw
respond res'
-- | Ignore the "Accept:" header because Yesod is very strict
-- about typed content choice.
ignoreAccept :: Middleware
ignoreAccept app req = app req'
where requestHeaders' = requestHeaders req
removeHeader :: HeaderName -> RequestHeaders -> RequestHeaders
removeHeader name = filter ((name /=) . fst)
requestHeaders'' = removeHeader hAccept requestHeaders'
req' = req { requestHeaders = requestHeaders'' }
getApplicationDev :: IO (Int, Application)
getApplicationDev =
defaultDevelApp loader makeApplication
where
loader = loadConfig (configSettings Settings.Development)
{ csParseExtra = parseExtra
}
makeUIFoundation :: AppConfig BitloveEnv Extra -> DBPool -> Tracked -> IO UIApp
makeUIFoundation conf pool tracked = do
manager <- newManager tlsManagerSettings
s <- staticSite
return $ UIApp conf s pool manager tracked
parseDBConf :: Monad m =>
Value -> m [(String, String)]
parseDBConf = return . parse
where parse (Aeson.Object o) = do
(k, v) <- HashMap.toList o
let k' = T.unpack k
case v of
Aeson.String v' ->
return (k', T.unpack v')
(Aeson.Object _) ->
parse v
(Aeson.Number n) ->
return (k', show n)
_ ->
error ("Cannot parse: " ++ show v)
parse _ = error "Expected JSON object"
connectDB :: [(String, String)] -> IO PQ.Connection
connectDB dbconf = do
db <- PQ.connectdb $ encodeUtf8 conf
mMsg <- PQ.errorMessage db
case mMsg of
Just msg | not (BC.null msg) -> do
let msg' = T.unpack (decodeUtf8 msg)
BC.hPutStrLn stderr $ BC.pack $ "Error: " ++ msg'
PQ.finish db
error msg'
_ -> return db
where pqKeys = ["user", "password", "host", "port", "dbname", "hostaddr"]
dbconf' =
filter ((`elem` pqKeys) . fst) dbconf
conf = T.intercalate " " $ do
(k, v) <- dbconf'
return $ T.concat [T.pack k, "=", T.pack v]
makeDBPool :: [(String, String)] -> IO DBPool
makeDBPool dbconf =
let connect = connectDB dbconf
in createPool
(BC.hPutStrLn stderr "PQ.connect" >> connect)
(\db -> BC.hPutStrLn stderr "PQ.disconnect" >> PQ.finish db)
4 60 4
getFaviconR :: Handler ()
getFaviconR = sendFile "image/x-icon" "static/favicon.ico"