diff --git a/Application.hs b/Application.hs index fffe1b3..7a5c913 100644 --- a/Application.hs +++ b/Application.hs @@ -1,35 +1,41 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Application - ( makeApplication - , getApplicationDev + ( getApplicationDev + , appMain + , develMain , makeFoundation + , makeLogWare + -- * for DevelMain + , getApplicationRepl + , shutdownApp + -- * for GHCI + , handler ) where +import Control.Monad.Logger (liftLoc) +import Language.Haskell.TH.Syntax (qLocation) import Control.Concurrent (forkIO) -import Control.Exception (catch) import Data.WebsiteContent import Import hiding (catch) -import Language.Haskell.TH.Syntax (Loc(..)) -import Network.Wai (Middleware, responseLBS, rawPathInfo) -import Network.Wai.Logger (clockDateCacher) +import Network.Wai (Middleware, rawPathInfo) +import Network.Wai.Handler.Warp (Settings, defaultSettings, + defaultShouldDisplayException, + runSettings, setHost, + setOnException, setPort, getPort) import Network.Wai.Middleware.ForceSSL (forceSSL) import Network.Wai.Middleware.RequestLogger ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination + , Destination (Logger) ) -import qualified Network.Wai.Middleware.RequestLogger as RequestLogger -import System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, fromLogStr) -import qualified System.Random.MWC as MWC -import Yesod.Core.Types (loggerSet, Logger (Logger)) -import Yesod.Default.Config +import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr) +import Yesod.Core.Types (loggerSet) +import Yesod.Default.Config2 import Yesod.Default.Handlers -import Yesod.Default.Main import Yesod.GitRepo import System.Process (rawSystem) import Stackage.Database.Cron (loadFromS3) import Control.AutoUpdate -import qualified Echo - -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Handler.Home @@ -59,38 +65,21 @@ mkYesodDispatch "App" resourcesApp -- 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 :: Bool -- ^ Use Echo. - -> AppConfig DefaultEnv Extra -> IO (Application, LogFunc) -makeApplication echo@True conf = do - foundation <- makeFoundation echo conf - app <- toWaiAppPlain foundation - logWare <- mkRequestLogger def - { destination = RequestLogger.Callback (const (return ())) - } - Echo.clear - return (forceSSL' conf $ logWare (defaultMiddlewaresNoLogging app),logFunc) - where logFunc (Loc filename' _pkg _mod (line,_) _) source level str = - Echo.write (filename',line) (show source ++ ": " ++ show level ++ ": " ++ toStr str) - toStr = unpack . decodeUtf8 . fromLogStr -makeApplication echo@False conf = do - foundation <- makeFoundation echo conf - -- Initialize the logging middleware - logWare <- mkRequestLogger def - { outputFormat = - if development - then Detailed True - else Apache FromFallback - , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation - } +makeApplication :: App -> IO Application +makeApplication foundation = do + logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares - app <- toWaiAppPlain foundation - let logFunc = messageLoggerSource foundation (appLogger foundation) - middleware = forceSSL' conf . nicerExceptions . logWare . defaultMiddlewaresNoLogging - return (middleware app, logFunc) + appPlain <- toWaiAppPlain foundation -forceSSL' :: AppConfig DefaultEnv Extra -> Middleware -forceSSL' ac app - | extraForceSsl $ appExtra ac = \req send -> + let middleware = forceSSL' (appSettings foundation) + . logWare + . defaultMiddlewaresNoLogging + + return (middleware appPlain) + +forceSSL' :: AppSettings -> Middleware +forceSSL' settings app + | appForceSsl settings = \req send -> -- Don't force SSL for tarballs, to provide 00-index.tar.gz and package -- tarball access for cabal-install if ".tar.gz" `isSuffixOf` rawPathInfo req @@ -98,29 +87,19 @@ forceSSL' ac app else forceSSL app req send | otherwise = app -nicerExceptions :: Middleware -nicerExceptions app req send = catch (app req send) $ \e -> do - let text = "Exception thrown to Warp: " ++ tshow (e :: SomeException) - putStrLn text - send $ responseLBS status500 [("Content-Type", "text/plain")] $ - fromStrict $ encodeUtf8 text - -- | Loads up any necessary settings, creates your foundation datatype, and -- performs some initialization. -makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App -makeFoundation useEcho conf = do - let extra = appExtra conf - manager <- newManager - s <- staticSite +makeFoundation :: AppSettings -> IO App +makeFoundation appSettings = do + -- Some basic initializations: HTTP connection manager, logger, and static + -- subsite. + appHttpManager <- newManager + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + appStatic <- + (if appMutableStatic appSettings then staticDevel else static) + (appStaticDir appSettings) - loggerSet' <- if useEcho - then newFileLoggerSet defaultBufSize "/dev/null" - else newStdoutLoggerSet defaultBufSize - (getter, _) <- clockDateCacher - - gen <- MWC.createSystemRandom - - websiteContent' <- if extraDevDownload extra + appWebsiteContent <- if appDevDownload appSettings then do void $ rawSystem "git" [ "clone" @@ -132,41 +111,109 @@ makeFoundation useEcho conf = do "master" loadWebsiteContent - (stackageDatabase', refreshDB) <- loadFromS3 (extraDevDownload extra) manager + (appStackageDatabase, refreshDB) <- loadFromS3 (appDevDownload appSettings) appHttpManager -- Temporary workaround to force content updates regularly, until -- distribution of webhooks is handled via consul void $ forkIO $ forever $ void $ do threadDelay $ 1000 * 1000 * 60 * 5 handleAny print refreshDB - handleAny print $ grRefresh websiteContent' + handleAny print $ grRefresh appWebsiteContent - latestStackMatcher' <- mkAutoUpdate defaultUpdateSettings + appLatestStackMatcher <- mkAutoUpdate defaultUpdateSettings { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes - , updateAction = getLatestMatcher manager + , updateAction = getLatestMatcher appHttpManager } - hoogleLock <- newMVar () - let logger = Yesod.Core.Types.Logger loggerSet' getter - foundation = App - { settings = conf - , getStatic = s - , httpManager = manager - , appLogger = logger - , genIO = gen - , websiteContent = websiteContent' - , stackageDatabase = stackageDatabase' - , latestStackMatcher = latestStackMatcher' - , appHoogleLock = hoogleLock - } + appHoogleLock <- newMVar () - return foundation + return App {..} --- for yesod devel -getApplicationDev :: Bool -> IO (Int, Application) -getApplicationDev useEcho = - defaultDevelApp loader (fmap fst . makeApplication useEcho) - where - loader = Yesod.Default.Config.loadConfig (configSettings Development) - { csParseExtra = parseExtra +makeLogWare :: App -> IO Middleware +makeLogWare foundation = + mkRequestLogger def + { outputFormat = + if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else Apache + (if appIpFromHeader $ appSettings foundation + then FromFallback + else FromSocket) + , destination = Logger $ loggerSet $ appLogger foundation } + + +-- | Warp settings for the given foundation value. +warpSettings :: App -> Settings +warpSettings foundation = + setPort (appPort $ appSettings foundation) + $ setHost (appHost $ appSettings foundation) + $ setOnException (\_req e -> + when (defaultShouldDisplayException e) $ messageLoggerSource + foundation + (appLogger foundation) + $(qLocation >>= liftLoc) + "yesod" + LevelError + (toLogStr $ "Exception from Warp: " ++ show e)) + defaultSettings + +-- | For yesod devel, return the Warp settings and WAI Application. +getApplicationDev :: IO (Settings, Application) +getApplicationDev = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app <- makeApplication foundation + return (wsettings, app) + +getAppSettings :: IO AppSettings +getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + +-- | main function for use by yesod devel +develMain :: IO () +develMain = develMainHelper getApplicationDev + +-- | The @main@ function for an executable running this site. +appMain :: IO () +appMain = do + -- Get the settings from all relevant sources + settings <- loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + + -- allow environment variables to override + useEnv + + -- Generate the foundation from the settings + foundation <- makeFoundation settings + + -- Generate a WAI Application from the foundation + app <- makeApplication foundation + + -- Run the application with Warp + runSettings (warpSettings foundation) app + + +-------------------------------------------------------------- +-- Functions for DevelMain.hs (a way to run the app from GHCi) +-------------------------------------------------------------- +getApplicationRepl :: IO (Int, App, Application) +getApplicationRepl = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) + +shutdownApp :: App -> IO () +shutdownApp _ = return () + + +--------------------------------------------- +-- Functions for use in development with GHCi +--------------------------------------------- + +-- | Run a handler +handler :: Handler a -> IO a +handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h diff --git a/Data/Slug.hs b/Data/Slug.hs deleted file mode 100644 index 56e6c5b..0000000 --- a/Data/Slug.hs +++ /dev/null @@ -1,107 +0,0 @@ -module Data.Slug - ( Slug - , mkSlug - , mkSlugLen - , safeMakeSlug - , unSlug - , InvalidSlugException (..) - , HasGenIO (..) - , randomSlug - , slugField - ) where - -import ClassyPrelude.Yesod -import Database.Persist.Sql (PersistFieldSql (sqlType)) -import qualified System.Random.MWC as MWC -import Text.Blaze (ToMarkup) - -newtype Slug = Slug Text - deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, Ord, Hashable) -instance PersistFieldSql Slug where - sqlType = sqlType . liftM unSlug - -unSlug :: Slug -> Text -unSlug (Slug t) = t - -mkSlug :: MonadThrow m => Text -> m Slug -mkSlug t - | length t < minLen = throwM $ InvalidSlugException t "Too short" - | length t > maxLen = throwM $ InvalidSlugException t "Too long" - | any (not . validChar) t = throwM $ InvalidSlugException t "Contains invalid characters" - | "-" `isPrefixOf` t = throwM $ InvalidSlugException t "Must not start with a hyphen" - | otherwise = return $ Slug t - where - -mkSlugLen :: MonadThrow m => Int -> Int -> Text -> m Slug -mkSlugLen minLen' maxLen' t - | length t < minLen' = throwM $ InvalidSlugException t "Too short" - | length t > maxLen' = throwM $ InvalidSlugException t "Too long" - | any (not . validChar) t = throwM $ InvalidSlugException t "Contains invalid characters" - | "-" `isPrefixOf` t = throwM $ InvalidSlugException t "Must not start with a hyphen" - | otherwise = return $ Slug t - -minLen, maxLen :: Int -minLen = 3 -maxLen = 30 - -validChar :: Char -> Bool -validChar c = - ('A' <= c && c <= 'Z') || - ('a' <= c && c <= 'z') || - ('0' <= c && c <= '9') || - c == '.' || - c == '-' || - c == '_' - -data InvalidSlugException = InvalidSlugException !Text !Text - deriving (Show, Typeable) -instance Exception InvalidSlugException - -instance PathPiece Slug where - toPathPiece = unSlug - fromPathPiece = mkSlug - -class HasGenIO a where - getGenIO :: a -> MWC.GenIO -instance s ~ RealWorld => HasGenIO (MWC.Gen s) where - getGenIO = id - -safeMakeSlug :: (MonadIO m, MonadReader env m, HasGenIO env) - => Text - -> Bool -- ^ force some randomness? - -> m Slug -safeMakeSlug orig forceRandom - | needsRandom || forceRandom = do - gen <- liftM getGenIO ask - cs <- liftIO $ replicateM 3 $ MWC.uniformR (0, 61) gen - return $ Slug $ cleaned ++ pack ('_':map toChar cs) - | otherwise = return $ Slug cleaned - where - cleaned = take (maxLen - minLen - 1) $ dropWhile (== '-') $ filter validChar orig - needsRandom = length cleaned < minLen - -toChar :: Int -> Char -toChar i - | i < 26 = toEnum $ fromEnum 'A' + i - | i < 52 = toEnum $ fromEnum 'a' + i - 26 - | otherwise = toEnum $ fromEnum '0' + i - 52 - -randomSlug :: (MonadIO m, MonadReader env m, HasGenIO env) - => Int -- ^ length - -> m Slug -randomSlug (min maxLen . max minLen -> len) = do - gen <- liftM getGenIO ask - cs <- liftIO $ replicateM len $ MWC.uniformR (0, 61) gen - return $ Slug $ pack $ map toChar cs - -slugField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Slug -slugField = - checkMMap go unSlug textField - where - go = return . either (Left . tshow) Right . mkSlug - --- | Unique identifier for a snapshot. -newtype SnapSlug = SnapSlug { unSnapSlug :: Slug } - deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, PathPiece, Ord, Hashable) -instance PersistFieldSql SnapSlug where - sqlType = sqlType . liftM unSnapSlug diff --git a/Data/Tag.hs b/Data/Tag.hs deleted file mode 100644 index 8b0862f..0000000 --- a/Data/Tag.hs +++ /dev/null @@ -1,11 +0,0 @@ --- | A wrapper around the 'Slug' interface. - -module Data.Tag where - -import Control.Monad.Catch -import Data.Slug -import Data.Text - --- | Make a tag. -mkTag :: MonadThrow m => Text -> m Slug -mkTag = mkSlugLen 1 20 diff --git a/Echo.hs b/Echo.hs deleted file mode 100644 index c30320b..0000000 --- a/Echo.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | A quick and dirty way to echo a printf-style debugging message to --- a file from anywhere. --- --- To use from Emacs, run `tail -f /tmp/echo` with M-x grep. You can --- rename the buffer to *echo* or something. The grep-mode buffer has --- handy up/down keybindings that will open the file location for you --- and it supports results coming in live. So it's a perfect way to --- browse printf-style debugging logs. - -module Echo where - -import Control.Concurrent.MVar -import Control.Monad.Trans (MonadIO(..)) -import Data.Time -import Language.Haskell.TH -import Language.Haskell.TH.Lift -import Prelude -import System.IO.Unsafe - --- | God forgive me for my sins. -echoV :: MVar () -echoV = unsafePerformIO (newMVar ()) -{-# NOINLINE echoV #-} - --- | Echo something. -echo :: Q Exp -echo = [|write $(location >>= liftLoc) |] - --- | Grab the filename and line/col. -liftLoc :: Loc -> Q Exp -liftLoc (Loc filename _pkg _mod (line, _) _) = - [|($(lift filename) - ,$(lift line))|] - --- | Thread-safely (probably) write to the log. -write :: (MonadIO m) => (FilePath,Int) -> String -> m () -write (file,line) it = - liftIO (withMVar echoV (const (loggit))) - where loggit = - do now <- getCurrentTime - appendFile "/tmp/echo" (loc ++ ": " ++ fmt now ++ " " ++ it ++ "\n") - loc = file ++ ":" ++ show line - fmt = formatTime defaultTimeLocale "%T%Q" - -clear :: IO () -clear = writeFile "/tmp/echo" "" diff --git a/Foundation.hs b/Foundation.hs index 8687409..d46cf04 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -1,45 +1,38 @@ module Foundation where import ClassyPrelude.Yesod -import Data.Slug (HasGenIO (getGenIO)) import Data.WebsiteContent -import Settings (widgetFile, Extra (..)) -import Settings.Development (development) +import Settings import Settings.StaticFiles -import qualified System.Random.MWC as MWC import Text.Blaze import Text.Hamlet (hamletFile) import Types import Yesod.Core.Types (Logger) -import Yesod.Default.Config import Yesod.AtomFeed import Yesod.GitRepo import Stackage.Database +import qualified Yesod.Core.Unsafe as Unsafe -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have -- access to the data present here. data App = App - { settings :: AppConfig DefaultEnv Extra - , getStatic :: Static -- ^ Settings for static file serving. - , httpManager :: Manager + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appHttpManager :: Manager , appLogger :: Logger - , genIO :: MWC.GenIO - , websiteContent :: GitRepo WebsiteContent - , stackageDatabase :: IO StackageDatabase - , latestStackMatcher :: IO (Text -> Maybe Text) + , appWebsiteContent :: GitRepo WebsiteContent + , appStackageDatabase :: IO StackageDatabase + , appLatestStackMatcher :: IO (Text -> Maybe Text) -- ^ Give a pattern, get a URL , appHoogleLock :: MVar () -- ^ Avoid concurrent Hoogle queries, see -- https://github.com/fpco/stackage-server/issues/172 } -instance HasGenIO App where - getGenIO = genIO - instance HasHttpManager App where - getHttpManager = httpManager + getHttpManager = appHttpManager -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -50,7 +43,8 @@ instance HasHttpManager App where -- explanation for this split. mkYesodData "App" $(parseRoutesFile "config/routes") -type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) +unsafeHandler :: App -> Handler a -> IO a +unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger defaultLayoutNoContainer :: Widget -> Handler Html defaultLayoutNoContainer = defaultLayoutWithContainer False @@ -87,13 +81,14 @@ defaultLayoutWithContainer insideContainer widget = do -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod App where - approot = ApprootMaster $ appRoot . settings + approot = ApprootRequest $ \app req -> + case appRoot $ appSettings app of + Nothing -> getApprootText guessApproot app req + Just root -> root -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes - "config/client_session_key.aes" + makeSessionBackend _ = return Nothing defaultLayout = defaultLayoutWithContainer True @@ -130,8 +125,10 @@ instance Yesod App where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. shouldLog _ "CLEANUP" _ = False - shouldLog _ source level = - development || level == LevelWarn || level == LevelError || source == "CLEANUP" + shouldLog app _source level = + appShouldLogAll (appSettings app) + || level == LevelWarn + || level == LevelError makeLogger = return . appLogger @@ -148,10 +145,6 @@ instance ToMarkup (Route App) where instance RenderMessage App FormMessage where renderMessage _ _ = defaultFormMessage --- | Get the 'Extra' value, used to hold data from the settings.yml file. -getExtra :: Handler Extra -getExtra = fmap (appExtra . settings) getYesod - -- Note: previous versions of the scaffolding included a deliver function to -- send emails. Unfortunately, there are too many different options for us to -- give a reasonable default. Instead, the information is available on the @@ -160,6 +153,6 @@ getExtra = fmap (appExtra . settings) getYesod -- https://github.com/yesodweb/yesod/wiki/Sending-email instance GetStackageDatabase Handler where - getStackageDatabase = getYesod >>= liftIO . stackageDatabase + getStackageDatabase = getYesod >>= liftIO . appStackageDatabase instance GetStackageDatabase (WidgetT App IO) where - getStackageDatabase = getYesod >>= liftIO . stackageDatabase + getStackageDatabase = getYesod >>= liftIO . appStackageDatabase diff --git a/Handler/Download.hs b/Handler/Download.hs index 7dd5ceb..7b18f15 100644 --- a/Handler/Download.hs +++ b/Handler/Download.hs @@ -41,7 +41,7 @@ getDownloadGhcLinksR arch fileName = do >=> stripSuffix "-links.yaml" >=> ghcMajorVersionFromText $ fileName - ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . websiteContent + ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . appWebsiteContent case lookup (arch, ver) (ghcLinksMap ghcLinks) of Just text -> return $ TypedContent yamlMimeType $ toContent text Nothing -> notFound diff --git a/Handler/DownloadStack.hs b/Handler/DownloadStack.hs index cdad62b..35bafa4 100644 --- a/Handler/DownloadStack.hs +++ b/Handler/DownloadStack.hs @@ -13,14 +13,14 @@ import Data.Monoid (First (..)) getDownloadStackListR :: Handler Html getDownloadStackListR = do - releases <- getYesod >>= fmap wcStackReleases . liftIO . grContent . websiteContent + releases <- getYesod >>= fmap wcStackReleases . liftIO . grContent . appWebsiteContent defaultLayout $ do setTitle "Download Stack" $(widgetFile "download-stack-list") getDownloadStackR :: Text -> Handler () getDownloadStackR pattern = do - matcher <- getYesod >>= liftIO . latestStackMatcher + matcher <- getYesod >>= liftIO . appLatestStackMatcher maybe notFound redirect $ matcher pattern -- | Creates a function which will find the latest release for a given pattern. diff --git a/Handler/Home.hs b/Handler/Home.hs index 3191739..2f49738 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -30,7 +30,7 @@ getOlderReleasesR = contentHelper "Older Releases" wcOlderReleases contentHelper :: Html -> (WebsiteContent -> Html) -> Handler Html contentHelper title accessor = do - homepage <- getYesod >>= fmap accessor . liftIO . grContent . websiteContent + homepage <- getYesod >>= fmap accessor . liftIO . grContent . appWebsiteContent defaultLayout $ do setTitle title toWidget homepage diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index 5606a59..b73ec57 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -14,7 +14,7 @@ import qualified Stackage.Database.Cron as Cron getHoogleDB :: SnapName -> Handler (Maybe FilePath) getHoogleDB name = do app <- getYesod - liftIO $ Cron.getHoogleDB True (httpManager app) name + liftIO $ Cron.getHoogleDB True (appHttpManager app) name getHoogleR :: SnapName -> Handler Html getHoogleR name = do diff --git a/Import.hs b/Import.hs index 8eafce5..83d673e 100644 --- a/Import.hs +++ b/Import.hs @@ -5,7 +5,6 @@ module Import import ClassyPrelude.Yesod as Import import Foundation as Import import Settings as Import -import Settings.Development as Import import Settings.StaticFiles as Import import Types as Import import Yesod.Auth as Import diff --git a/Settings.hs b/Settings.hs index 0c9d94d..036df55 100644 --- a/Settings.hs +++ b/Settings.hs @@ -6,36 +6,75 @@ module Settings where import ClassyPrelude.Yesod -import Text.Shakespeare.Text (st) -import Language.Haskell.TH.Syntax -import Yesod.Default.Config -import Yesod.Default.Util -import Data.Yaml -import Settings.Development +import Control.Exception (throw) +import Data.Aeson (Result (..), fromJSON, withObject, (.!=), + (.:?)) +import Data.FileEmbed (embedFile) +import Data.Yaml (decodeEither') +import Language.Haskell.TH.Syntax (Exp, Name, Q) +import Network.Wai.Handler.Warp (HostPreference) +import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) +import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, + widgetFileReload, wfsHamletSettings) import Text.Hamlet --- Static setting below. Changing these requires a recompile +-- | Runtime settings to configure this application. These settings can be +-- loaded from various sources: defaults, environment variables, config files, +-- theoretically even a database. +data AppSettings = AppSettings + { appStaticDir :: String + -- ^ Directory from which to serve static files. + , appRoot :: Maybe Text + -- ^ Base for all generated URLs. If @Nothing@, determined + -- from the request headers. + , appHost :: HostPreference + -- ^ Host/interface the server should bind to. + , appPort :: Int + -- ^ Port to listen on + , appIpFromHeader :: Bool + -- ^ Get the IP address from the header when logging. Useful when sitting + -- behind a reverse proxy. --- | The location of static files on your system. This is a file system --- path. The default value works properly with your scaffolded site. -staticDir :: String -staticDir = "static" + , appDetailedRequestLogging :: Bool + -- ^ Use detailed request logging system + , appShouldLogAll :: Bool + -- ^ Should all log messages be displayed? + , appReloadTemplates :: Bool + -- ^ Use the reload version of templates + , appMutableStatic :: Bool + -- ^ Assume that files in the static dir may change after compilation + , appSkipCombining :: Bool + -- ^ Perform no stylesheet/script combining + , appForceSsl :: Bool + -- ^ Force redirect to SSL + , appDevDownload :: Bool + -- ^ Controls how Git and database resources are downloaded (True means less downloading) + } --- | The base URL for your static files. As you can see by the default --- value, this can simply be "static" appended to your application root. --- A powerful optimization can be serving static files from a separate --- domain name. This allows you to use a web server optimized for static --- files, more easily set expires and cache values, and avoid possibly --- costly transference of cookies on static files. For more information, --- please see: --- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain --- --- If you change the resource pattern for StaticR in Foundation.hs, you will --- have to make a corresponding change here. --- --- To see how this value is used, see urlRenderOverride in Foundation.hs -staticRoot :: AppConfig DefaultEnv x -> Text -staticRoot conf = [st|#{appRoot conf}/static|] +instance FromJSON AppSettings where + parseJSON = withObject "AppSettings" $ \o -> do + let defaultDev = +#if DEVELOPMENT + True +#else + False +#endif + appStaticDir <- o .: "static-dir" + appRoot <- (\t -> if null t then Nothing else Just t) + <$> o .:? "approot" .!= "" + appHost <- fromString <$> o .: "host" + appPort <- o .: "port" + appIpFromHeader <- o .: "ip-from-header" + + appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev + appShouldLogAll <- o .:? "should-log-all" .!= defaultDev + appReloadTemplates <- o .:? "reload-templates" .!= defaultDev + appMutableStatic <- o .:? "mutable-static" .!= defaultDev + appSkipCombining <- o .:? "skip-combining" .!= defaultDev + appForceSsl <- o .:? "force-ssl" .!= not defaultDev + appDevDownload <- o .:? "dev-download" .!= defaultDev + + return AppSettings {..} -- | Settings for 'widgetFile', such as which template languages to support and -- default Hamlet settings. @@ -50,22 +89,46 @@ widgetFileSettings = def } } +-- | How static files should be combined. +combineSettings :: CombineSettings +combineSettings = def + -- The rest of this file contains settings which rarely need changing by a -- user. widgetFile :: String -> Q Exp -widgetFile = (if development then widgetFileReload - else widgetFileNoReload) +widgetFile = (if appReloadTemplates compileTimeAppSettings + then widgetFileReload + else widgetFileNoReload) widgetFileSettings -data Extra = Extra - { extraDevDownload :: !Bool - -- ^ Controls how Git and database resources are downloaded (True means less downloading) - , extraForceSsl :: !Bool - } - deriving Show +-- | Raw bytes at compile time of @config/settings.yml@ +configSettingsYmlBS :: ByteString +configSettingsYmlBS = $(embedFile configSettingsYml) -parseExtra :: DefaultEnv -> Object -> Parser Extra -parseExtra _ o = Extra - <$> o .:? "dev-download" .!= False - <*> o .: "force-ssl" +-- | @config/settings.yml@, parsed to a @Value@. +configSettingsYmlValue :: Value +configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS + +-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. +compileTimeAppSettings :: AppSettings +compileTimeAppSettings = + case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of + Error e -> error e + Success settings -> settings + +-- The following two functions can be used to combine multiple CSS or JS files +-- at compile time to decrease the number of http requests. +-- Sample usage (inside a Widget): +-- +-- > $(combineStylesheets 'StaticR [style1_css, style2_css]) + +combineStylesheets :: Name -> [Route Static] -> Q Exp +combineStylesheets = combineStylesheets' + (appSkipCombining compileTimeAppSettings) + combineSettings + +combineScripts :: Name -> [Route Static] -> Q Exp +combineScripts = combineScripts' + (appSkipCombining compileTimeAppSettings) + combineSettings diff --git a/Settings/Development.hs b/Settings/Development.hs deleted file mode 100644 index b186280..0000000 --- a/Settings/Development.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Settings.Development where - -import Prelude - -development :: Bool -development = -#if DEVELOPMENT - True -#else - False -#endif - -cabalFileLoader :: Bool -cabalFileLoader = -#if INGHCI - False -#else - True -#endif - -production :: Bool -production = not development diff --git a/Settings/StaticFiles.hs b/Settings/StaticFiles.hs index cb37905..c8021d3 100644 --- a/Settings/StaticFiles.hs +++ b/Settings/StaticFiles.hs @@ -1,35 +1,18 @@ module Settings.StaticFiles where -import Prelude (IO) -import Yesod.Static -import qualified Yesod.Static as Static -import Settings (staticDir) -import Settings.Development -import Language.Haskell.TH (Q, Exp, Name) -import Data.Default (def) +import Settings (appStaticDir, compileTimeAppSettings) +import Yesod.Static (staticFiles) --- | use this to create your static file serving site -staticSite :: IO Static.Static -staticSite = if development then Static.staticDevel staticDir - else Static.static staticDir - --- | This generates easy references to files in the static directory at compile time, --- giving you compile-time verification that referenced files exist. --- Warning: any files added to your static directory during run-time can't be --- accessed this way. You'll have to use their FilePath or URL to access them. -$(staticFiles Settings.staticDir) - -combineSettings :: CombineSettings -combineSettings = def - --- The following two functions can be used to combine multiple CSS or JS files --- at compile time to decrease the number of http requests. --- Sample usage (inside a Widget): +-- This generates easy references to files in the static directory at compile time, +-- giving you compile-time verification that referenced files exist. +-- Warning: any files added to your static directory during run-time can't be +-- accessed this way. You'll have to use their FilePath or URL to access them. -- --- > $(combineStylesheets 'StaticR [style1_css, style2_css]) - -combineStylesheets :: Name -> [Route Static] -> Q Exp -combineStylesheets = combineStylesheets' development combineSettings - -combineScripts :: Name -> [Route Static] -> Q Exp -combineScripts = combineScripts' development combineSettings +-- For example, to refer to @static/js/script.js@ via an identifier, you'd use: +-- +-- js_script_js +-- +-- If the identifier is not available, you may use: +-- +-- StaticFile ["js", "script.js"] [] +staticFiles (appStaticDir compileTimeAppSettings) diff --git a/app/devel.hs b/app/devel.hs new file mode 100644 index 0000000..71b9912 --- /dev/null +++ b/app/devel.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +import "stackage-server" Application (develMain) +import Prelude (IO) + +main :: IO () +main = develMain diff --git a/app/main.hs b/app/main.hs index 8712dbf..4ffa93d 100644 --- a/app/main.hs +++ b/app/main.hs @@ -1,13 +1,5 @@ -import Application (makeApplication) -import Prelude (Bool(..), IO, elem, putStrLn) -import Settings (parseExtra) -import Yesod.Default.Config (fromArgs) -import Yesod.Default.Main (defaultMainLog) -import System.Environment (getArgs) +import Prelude (IO) +import Application (appMain) main :: IO () -main = do - args <- getArgs - if "--summary" `elem` args - then putStrLn "Run the server software for www.stackage.org" - else defaultMainLog (fromArgs parseExtra) (makeApplication False) +main = appMain diff --git a/config/routes b/config/routes index 576e308..f431a92 100644 --- a/config/routes +++ b/config/routes @@ -1,7 +1,7 @@ !/#SnapshotBranch/*Texts OldSnapshotBranchR GET -/static StaticR Static getStatic -/reload WebsiteContentR GitRepo-WebsiteContent websiteContent +/static StaticR Static appStatic +/reload WebsiteContentR GitRepo-WebsiteContent appWebsiteContent /favicon.ico FaviconR GET /robots.txt RobotsR GET diff --git a/config/settings.yml b/config/settings.yml index ea42883..3602563 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,20 +1,23 @@ -Default: &defaults - host: "*4" # any IPv4 host - port: 3000 - approot: "http://localhost:3000" - force-ssl: false +# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. +# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables -Development: - <<: *defaults - dev-download: true +static-dir: "_env:STATIC_DIR:static" +host: "_env:HOST:*4" # any IPv4 host +port: "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line. +ip-from-header: "_env:IP_FROM_HEADER:false" -Testing: - <<: *defaults +# Default behavior: determine the application root from the request headers. +# Uncomment to set an explicit approot +approot: "_env:APPROOT:" -Staging: - <<: *defaults - -Production: - approot: "https://www.stackage.org" - force-ssl: true - <<: *defaults +# Optional values with the following production defaults. +# In development, they default to the inverse. +# +# development: false +# detailed-logging: false +# should-log-all: false +# reload-templates: false +# mutable-static: false +# skip-combining: false +# force-ssl: true +# dev-download: false \ No newline at end of file diff --git a/config/test-settings.yml b/config/test-settings.yml new file mode 100644 index 0000000..0967ef4 --- /dev/null +++ b/config/test-settings.yml @@ -0,0 +1 @@ +{} diff --git a/devel.hs b/devel.hs deleted file mode 100644 index 9caae55..0000000 --- a/devel.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE PackageImports #-} -import "stackage-server" Application (getApplicationDev) -import Network.Wai.Handler.Warp - (runSettings, defaultSettings, setPort) -import Control.Concurrent (forkIO) -import System.Directory (doesFileExist, removeFile) -import System.Exit (exitSuccess) -import Control.Concurrent (threadDelay) - -main :: IO () -main = do - putStrLn "Starting devel application" - (port, app) <- getApplicationDev False - forkIO $ runSettings (setPort port defaultSettings) app - loop - -loop :: IO () -loop = do - threadDelay 100000 - e <- doesFileExist "yesod-devel/devel-terminate" - if e then terminateDevel else loop - -terminateDevel :: IO () -terminateDevel = exitSuccess diff --git a/stackage-server.cabal b/stackage-server.cabal index 2a8b85c..a2a2601 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -15,12 +15,8 @@ library exposed-modules: Application Foundation Import - Echo Settings Settings.StaticFiles - Settings.Development - Data.Slug - Data.Tag Data.GhcLinks Data.WebsiteContent Distribution.Package.ModuleForest @@ -181,6 +177,7 @@ library , amazonka-core >= 1.3 && < 1.4 , amazonka-s3 >= 1.3 && < 1.4 , lens >= 4.13 && < 4.14 + , file-embed executable stackage-server if flag(library-only) @@ -268,7 +265,8 @@ executable stackage-server-cron test-suite test type: exitcode-stdio-1.0 - main-is: main.hs + main-is: Spec.hs + other-modules: TestImport hs-source-dirs: test ghc-options: -Wall diff --git a/test/Data/SlugSpec.hs b/test/Data/SlugSpec.hs deleted file mode 100644 index b661236..0000000 --- a/test/Data/SlugSpec.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Data.SlugSpec where - -import Test.Hspec -import Test.Hspec.QuickCheck -import Data.Slug -import ClassyPrelude.Yesod -import qualified System.Random.MWC as MWC - -spec :: Spec -spec = describe "Data.Slug" $ do - prop "safeMakeSlug generates valid slugs" $ \(pack -> orig) -> do - gen <- MWC.createSystemRandom - slug <- runReaderT (safeMakeSlug orig False) gen - mkSlug (unSlug slug) `shouldBe` Just slug - prop "randomization works" $ \(pack -> orig) -> do - gen <- MWC.createSystemRandom - slug1 <- runReaderT (safeMakeSlug orig True) gen - slug2 <- runReaderT (safeMakeSlug orig True) gen - when (slug1 == slug2) $ error $ show (slug1, slug2) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImport.hs b/test/TestImport.hs index 2946b07..88e0618 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -1,26 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} module TestImport - ( module Yesod.Test - , module Model - , module Foundation - , module Database.Persist - , runDB - , Spec - , Example + ( module TestImport + , module X ) where -import Yesod.Test -import Database.Persist hiding (get) -import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool) -import Control.Monad.IO.Class (liftIO) +import Application (makeFoundation, makeLogWare) +import ClassyPrelude as X +import Foundation as X +import Test.Hspec as X +import Yesod.Default.Config2 (ignoreEnv, loadYamlSettings) +import Yesod.Test as X -import Foundation -import Model - -type Spec = YesodSpec App -type Example = YesodExample App - -runDB :: SqlPersistM a -> Example a -runDB query = do - pool <- fmap connPool getTestYesod - liftIO $ runSqlPersistMPool query pool +withApp :: SpecWith (TestApp App) -> Spec +withApp = before $ do + settings <- loadYamlSettings + ["config/test-settings.yml", "config/settings.yml"] + [] + ignoreEnv + foundation <- makeFoundation settings + logWare <- liftIO $ makeLogWare foundation + return (foundation, logWare) diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 index 35fc504..0000000 --- a/test/main.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Main where - -import Import -import Yesod.Default.Config -import Yesod.Test -import Test.Hspec (hspec) -import Application (makeFoundation) - -import qualified Data.SlugSpec - -main :: IO () -main = do - conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing) - { csParseExtra = parseExtra - } - foundation <- makeFoundation False conf - hspec $ do - Data.SlugSpec.spec - yesodSpec foundation $ do - return ()