haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-11 19:58:28 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Overhaul to match latest Yesod scaffolding

Browse Source
This commit is contained in:
Michael Snoyman 2016-05-17 21:08:18 +03:00
parent b81ff2a59d
commit 1fbaf13574
24 changed files with 331 additions and 505 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

225
Application.hs
View File

@ -1,35 +1,41 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Application module Application
( makeApplication ( getApplicationDev
, getApplicationDev , appMain
, develMain
, makeFoundation , makeFoundation
, makeLogWare
-- * for DevelMain
, getApplicationRepl
, shutdownApp
-- * for GHCI
, handler
) where ) where
import Control.Monad.Logger (liftLoc)
import Language.Haskell.TH.Syntax (qLocation)
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Exception (catch)
import Data.WebsiteContent import Data.WebsiteContent
import Import hiding (catch) import Import hiding (catch)
import Language.Haskell.TH.Syntax (Loc(..)) import Network.Wai (Middleware, rawPathInfo)
import Network.Wai (Middleware, responseLBS, rawPathInfo) import Network.Wai.Handler.Warp (Settings, defaultSettings,
import Network.Wai.Logger (clockDateCacher) defaultShouldDisplayException,
runSettings, setHost,
setOnException, setPort, getPort)
import Network.Wai.Middleware.ForceSSL (forceSSL) import Network.Wai.Middleware.ForceSSL (forceSSL)
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
, Destination (Logger)
) )
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr)
import System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, fromLogStr) import Yesod.Core.Types (loggerSet)
import qualified System.Random.MWC as MWC import Yesod.Default.Config2
import Yesod.Core.Types (loggerSet, Logger (Logger))
import Yesod.Default.Config
import Yesod.Default.Handlers import Yesod.Default.Handlers
import Yesod.Default.Main
import Yesod.GitRepo import Yesod.GitRepo
import System.Process (rawSystem) import System.Process (rawSystem)
import Stackage.Database.Cron (loadFromS3) import Stackage.Database.Cron (loadFromS3)
import Control.AutoUpdate import Control.AutoUpdate
import qualified Echo
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Home import Handler.Home
@ -59,38 +65,21 @@ mkYesodDispatch "App" resourcesApp
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database -- place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- migrations handled by Yesod.
makeApplication :: Bool -- ^ Use Echo. makeApplication :: App -> IO Application
-> AppConfig DefaultEnv Extra -> IO (Application, LogFunc) makeApplication foundation = do
makeApplication echo@True conf = do logWare <- makeLogWare foundation
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
}
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation appPlain <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
middleware = forceSSL' conf . nicerExceptions . logWare . defaultMiddlewaresNoLogging
return (middleware app, logFunc)
forceSSL' :: AppConfig DefaultEnv Extra -> Middleware let middleware = forceSSL' (appSettings foundation)
forceSSL' ac app . logWare
| extraForceSsl $ appExtra ac = \req send -> . 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 -- Don't force SSL for tarballs, to provide 00-index.tar.gz and package
-- tarball access for cabal-install -- tarball access for cabal-install
if ".tar.gz" `isSuffixOf` rawPathInfo req if ".tar.gz" `isSuffixOf` rawPathInfo req
@ -98,29 +87,19 @@ forceSSL' ac app
else forceSSL app req send else forceSSL app req send
| otherwise = app | 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 -- | Loads up any necessary settings, creates your foundation datatype, and
-- performs some initialization. -- performs some initialization.
makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App makeFoundation :: AppSettings -> IO App
makeFoundation useEcho conf = do makeFoundation appSettings = do
let extra = appExtra conf -- Some basic initializations: HTTP connection manager, logger, and static
manager <- newManager -- subsite.
s <- staticSite appHttpManager <- newManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic appSettings then staticDevel else static)
(appStaticDir appSettings)
loggerSet' <- if useEcho appWebsiteContent <- if appDevDownload appSettings
then newFileLoggerSet defaultBufSize "/dev/null"
else newStdoutLoggerSet defaultBufSize
(getter, _) <- clockDateCacher
gen <- MWC.createSystemRandom
websiteContent' <- if extraDevDownload extra
then do then do
void $ rawSystem "git" void $ rawSystem "git"
[ "clone" [ "clone"
@ -132,41 +111,109 @@ makeFoundation useEcho conf = do
"master" "master"
loadWebsiteContent loadWebsiteContent
(stackageDatabase', refreshDB) <- loadFromS3 (extraDevDownload extra) manager (appStackageDatabase, refreshDB) <- loadFromS3 (appDevDownload appSettings) appHttpManager
-- Temporary workaround to force content updates regularly, until -- Temporary workaround to force content updates regularly, until
-- distribution of webhooks is handled via consul -- distribution of webhooks is handled via consul
void $ forkIO $ forever $ void $ do void $ forkIO $ forever $ void $ do
threadDelay $ 1000 * 1000 * 60 * 5 threadDelay $ 1000 * 1000 * 60 * 5
handleAny print refreshDB 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 { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes
, updateAction = getLatestMatcher manager , updateAction = getLatestMatcher appHttpManager
} }
hoogleLock <- newMVar () appHoogleLock <- 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
}
return foundation return App {..}
-- for yesod devel makeLogWare :: App -> IO Middleware
getApplicationDev :: Bool -> IO (Int, Application) makeLogWare foundation =
getApplicationDev useEcho = mkRequestLogger def
defaultDevelApp loader (fmap fst . makeApplication useEcho) { outputFormat =
where if appDetailedRequestLogging $ appSettings foundation
loader = Yesod.Default.Config.loadConfig (configSettings Development) then Detailed True
{ csParseExtra = parseExtra 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

107
Data/Slug.hs
View File

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

11
Data/Tag.hs
View File

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

46
Echo.hs
View File

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

51
Foundation.hs
View File

@ -1,45 +1,38 @@
module Foundation where module Foundation where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Data.Slug (HasGenIO (getGenIO))
import Data.WebsiteContent import Data.WebsiteContent
import Settings (widgetFile, Extra (..)) import Settings
import Settings.Development (development)
import Settings.StaticFiles import Settings.StaticFiles
import qualified System.Random.MWC as MWC
import Text.Blaze import Text.Blaze
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
import Types import Types
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import Yesod.Default.Config
import Yesod.AtomFeed import Yesod.AtomFeed
import Yesod.GitRepo import Yesod.GitRepo
import Stackage.Database import Stackage.Database
import qualified Yesod.Core.Unsafe as Unsafe
-- | The site argument for your application. This can be a good place to -- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data App = App data App = App
{ settings :: AppConfig DefaultEnv Extra { appSettings :: AppSettings
, getStatic :: Static -- ^ Settings for static file serving. , appStatic :: Static -- ^ Settings for static file serving.
, httpManager :: Manager , appHttpManager :: Manager
, appLogger :: Logger , appLogger :: Logger
, genIO :: MWC.GenIO , appWebsiteContent :: GitRepo WebsiteContent
, websiteContent :: GitRepo WebsiteContent , appStackageDatabase :: IO StackageDatabase
, stackageDatabase :: IO StackageDatabase , appLatestStackMatcher :: IO (Text -> Maybe Text)
, latestStackMatcher :: IO (Text -> Maybe Text)
-- ^ Give a pattern, get a URL -- ^ Give a pattern, get a URL
, appHoogleLock :: MVar () , appHoogleLock :: MVar ()
-- ^ Avoid concurrent Hoogle queries, see -- ^ Avoid concurrent Hoogle queries, see
-- https://github.com/fpco/stackage-server/issues/172 -- https://github.com/fpco/stackage-server/issues/172
} }
instance HasGenIO App where
getGenIO = genIO
instance HasHttpManager App where instance HasHttpManager App where
getHttpManager = httpManager getHttpManager = appHttpManager
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see: -- explanation of the syntax, please see:
@ -50,7 +43,8 @@ instance HasHttpManager App where
-- explanation for this split. -- explanation for this split.
mkYesodData "App" $(parseRoutesFile "config/routes") 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 :: Widget -> Handler Html
defaultLayoutNoContainer = defaultLayoutWithContainer False defaultLayoutNoContainer = defaultLayoutWithContainer False
@ -87,13 +81,14 @@ defaultLayoutWithContainer insideContainer widget = do
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod App where 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, -- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes -- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend makeSessionBackend _ = return Nothing
(120 * 60) -- 120 minutes
"config/client_session_key.aes"
defaultLayout = defaultLayoutWithContainer True defaultLayout = defaultLayoutWithContainer True
@ -130,8 +125,10 @@ instance Yesod App where
-- What messages should be logged. The following includes all messages when -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.
shouldLog _ "CLEANUP" _ = False shouldLog _ "CLEANUP" _ = False
shouldLog _ source level = shouldLog app _source level =
development || level == LevelWarn || level == LevelError || source == "CLEANUP" appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger = return . appLogger makeLogger = return . appLogger
@ -148,10 +145,6 @@ instance ToMarkup (Route App) where
instance RenderMessage App FormMessage where instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage 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 -- Note: previous versions of the scaffolding included a deliver function to
-- send emails. Unfortunately, there are too many different options for us to -- send emails. Unfortunately, there are too many different options for us to
-- give a reasonable default. Instead, the information is available on the -- 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 -- https://github.com/yesodweb/yesod/wiki/Sending-email
instance GetStackageDatabase Handler where instance GetStackageDatabase Handler where
getStackageDatabase = getYesod >>= liftIO . stackageDatabase getStackageDatabase = getYesod >>= liftIO . appStackageDatabase
instance GetStackageDatabase (WidgetT App IO) where instance GetStackageDatabase (WidgetT App IO) where
getStackageDatabase = getYesod >>= liftIO . stackageDatabase getStackageDatabase = getYesod >>= liftIO . appStackageDatabase

2
Handler/Download.hs
View File

@ -41,7 +41,7 @@ getDownloadGhcLinksR arch fileName = do
>=> stripSuffix "-links.yaml" >=> stripSuffix "-links.yaml"
>=> ghcMajorVersionFromText >=> ghcMajorVersionFromText
$ fileName $ fileName
ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . websiteContent ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . appWebsiteContent
case lookup (arch, ver) (ghcLinksMap ghcLinks) of case lookup (arch, ver) (ghcLinksMap ghcLinks) of
Just text -> return $ TypedContent yamlMimeType $ toContent text Just text -> return $ TypedContent yamlMimeType $ toContent text
Nothing -> notFound Nothing -> notFound

4
Handler/DownloadStack.hs
View File

@ -13,14 +13,14 @@ import Data.Monoid (First (..))
getDownloadStackListR :: Handler Html getDownloadStackListR :: Handler Html
getDownloadStackListR = do getDownloadStackListR = do
releases <- getYesod >>= fmap wcStackReleases . liftIO . grContent . websiteContent releases <- getYesod >>= fmap wcStackReleases . liftIO . grContent . appWebsiteContent
defaultLayout $ do defaultLayout $ do
setTitle "Download Stack" setTitle "Download Stack"
$(widgetFile "download-stack-list") $(widgetFile "download-stack-list")
getDownloadStackR :: Text -> Handler () getDownloadStackR :: Text -> Handler ()
getDownloadStackR pattern = do getDownloadStackR pattern = do
matcher <- getYesod >>= liftIO . latestStackMatcher matcher <- getYesod >>= liftIO . appLatestStackMatcher
maybe notFound redirect $ matcher pattern maybe notFound redirect $ matcher pattern
-- | Creates a function which will find the latest release for a given pattern. -- | Creates a function which will find the latest release for a given pattern.

2
Handler/Home.hs
View File

@ -30,7 +30,7 @@ getOlderReleasesR = contentHelper "Older Releases" wcOlderReleases
contentHelper :: Html -> (WebsiteContent -> Html) -> Handler Html contentHelper :: Html -> (WebsiteContent -> Html) -> Handler Html
contentHelper title accessor = do contentHelper title accessor = do
homepage <- getYesod >>= fmap accessor . liftIO . grContent . websiteContent homepage <- getYesod >>= fmap accessor . liftIO . grContent . appWebsiteContent
defaultLayout $ do defaultLayout $ do
setTitle title setTitle title
toWidget homepage toWidget homepage

2
Handler/Hoogle.hs
View File

@ -14,7 +14,7 @@ import qualified Stackage.Database.Cron as Cron
getHoogleDB :: SnapName -> Handler (Maybe FilePath) getHoogleDB :: SnapName -> Handler (Maybe FilePath)
getHoogleDB name = do getHoogleDB name = do
app <- getYesod app <- getYesod
liftIO $ Cron.getHoogleDB True (httpManager app) name liftIO $ Cron.getHoogleDB True (appHttpManager app) name
getHoogleR :: SnapName -> Handler Html getHoogleR :: SnapName -> Handler Html
getHoogleR name = do getHoogleR name = do

1
Import.hs
View File

@ -5,7 +5,6 @@ module Import
import ClassyPrelude.Yesod as Import import ClassyPrelude.Yesod as Import
import Foundation as Import import Foundation as Import
import Settings as Import import Settings as Import
import Settings.Development as Import
import Settings.StaticFiles as Import import Settings.StaticFiles as Import
import Types as Import import Types as Import
import Yesod.Auth as Import import Yesod.Auth as Import

139
Settings.hs
View File

@ -6,36 +6,75 @@
module Settings where module Settings where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Text.Shakespeare.Text (st) import Control.Exception (throw)
import Language.Haskell.TH.Syntax import Data.Aeson (Result (..), fromJSON, withObject, (.!=),
import Yesod.Default.Config (.:?))
import Yesod.Default.Util import Data.FileEmbed (embedFile)
import Data.Yaml import Data.Yaml (decodeEither')
import Settings.Development 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 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 , appDetailedRequestLogging :: Bool
-- path. The default value works properly with your scaffolded site. -- ^ Use detailed request logging system
staticDir :: String , appShouldLogAll :: Bool
staticDir = "static" -- ^ 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 instance FromJSON AppSettings where
-- value, this can simply be "static" appended to your application root. parseJSON = withObject "AppSettings" $ \o -> do
-- A powerful optimization can be serving static files from a separate let defaultDev =
-- domain name. This allows you to use a web server optimized for static #if DEVELOPMENT
-- files, more easily set expires and cache values, and avoid possibly True
-- costly transference of cookies on static files. For more information, #else
-- please see: False
-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain #endif
-- appStaticDir <- o .: "static-dir"
-- If you change the resource pattern for StaticR in Foundation.hs, you will appRoot <- (\t -> if null t then Nothing else Just t)
-- have to make a corresponding change here. <$> o .:? "approot" .!= ""
-- appHost <- fromString <$> o .: "host"
-- To see how this value is used, see urlRenderOverride in Foundation.hs appPort <- o .: "port"
staticRoot :: AppConfig DefaultEnv x -> Text appIpFromHeader <- o .: "ip-from-header"
staticRoot conf = [st|#{appRoot conf}/static|]
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 -- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings. -- 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 -- The rest of this file contains settings which rarely need changing by a
-- user. -- user.
widgetFile :: String -> Q Exp widgetFile :: String -> Q Exp
widgetFile = (if development then widgetFileReload widgetFile = (if appReloadTemplates compileTimeAppSettings
else widgetFileNoReload) then widgetFileReload
else widgetFileNoReload)
widgetFileSettings widgetFileSettings
data Extra = Extra -- | Raw bytes at compile time of @config/settings.yml@
{ extraDevDownload :: !Bool configSettingsYmlBS :: ByteString
-- ^ Controls how Git and database resources are downloaded (True means less downloading) configSettingsYmlBS = $(embedFile configSettingsYml)
, extraForceSsl :: !Bool
}
deriving Show
parseExtra :: DefaultEnv -> Object -> Parser Extra -- | @config/settings.yml@, parsed to a @Value@.
parseExtra _ o = Extra configSettingsYmlValue :: Value
<$> o .:? "dev-download" .!= False configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS
<*> o .: "force-ssl"
-- | 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

22
Settings/Development.hs
View File

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

45
Settings/StaticFiles.hs
View File

@ -1,35 +1,18 @@
module Settings.StaticFiles where module Settings.StaticFiles where
import Prelude (IO) import Settings (appStaticDir, compileTimeAppSettings)
import Yesod.Static import Yesod.Static (staticFiles)
import qualified Yesod.Static as Static
import Settings (staticDir)
import Settings.Development
import Language.Haskell.TH (Q, Exp, Name)
import Data.Default (def)
-- | use this to create your static file serving site -- This generates easy references to files in the static directory at compile time,
staticSite :: IO Static.Static -- giving you compile-time verification that referenced files exist.
staticSite = if development then Static.staticDevel staticDir -- Warning: any files added to your static directory during run-time can't be
else Static.static staticDir -- accessed this way. You'll have to use their FilePath or URL to access them.
-- | 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):
-- --
-- > $(combineStylesheets 'StaticR [style1_css, style2_css]) -- For example, to refer to @static/js/script.js@ via an identifier, you'd use:
--
combineStylesheets :: Name -> [Route Static] -> Q Exp -- js_script_js
combineStylesheets = combineStylesheets' development combineSettings --
-- If the identifier is not available, you may use:
combineScripts :: Name -> [Route Static] -> Q Exp --
combineScripts = combineScripts' development combineSettings -- StaticFile ["js", "script.js"] []
staticFiles (appStaticDir compileTimeAppSettings)

6
app/devel.hs Normal file
View File

@ -0,0 +1,6 @@
{-# LANGUAGE PackageImports #-}
import "stackage-server" Application (develMain)
import Prelude (IO)
main :: IO ()
main = develMain

14
app/main.hs
View File

@ -1,13 +1,5 @@
import Application (makeApplication) import Prelude (IO)
import Prelude (Bool(..), IO, elem, putStrLn) import Application (appMain)
import Settings (parseExtra)
import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMainLog)
import System.Environment (getArgs)
main :: IO () main :: IO ()
main = do main = appMain
args <- getArgs
if "--summary" `elem` args
then putStrLn "Run the server software for www.stackage.org"
else defaultMainLog (fromArgs parseExtra) (makeApplication False)

4
config/routes
View File

@ -1,7 +1,7 @@
!/#SnapshotBranch/*Texts OldSnapshotBranchR GET !/#SnapshotBranch/*Texts OldSnapshotBranchR GET
/static StaticR Static getStatic /static StaticR Static appStatic
/reload WebsiteContentR GitRepo-WebsiteContent websiteContent /reload WebsiteContentR GitRepo-WebsiteContent appWebsiteContent
/favicon.ico FaviconR GET /favicon.ico FaviconR GET
/robots.txt RobotsR GET /robots.txt RobotsR GET

37
config/settings.yml
View File

@ -1,20 +1,23 @@
Default: &defaults # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
host: "*4" # any IPv4 host # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
port: 3000
approot: "http://localhost:3000"
force-ssl: false
Development: static-dir: "_env:STATIC_DIR:static"
<<: *defaults host: "_env:HOST:*4" # any IPv4 host
dev-download: true 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: # Default behavior: determine the application root from the request headers.
<<: *defaults # Uncomment to set an explicit approot
approot: "_env:APPROOT:"
Staging: # Optional values with the following production defaults.
<<: *defaults # In development, they default to the inverse.
#
Production: # development: false
approot: "https://www.stackage.org" # detailed-logging: false
force-ssl: true # should-log-all: false
<<: *defaults # reload-templates: false
# mutable-static: false
# skip-combining: false
# force-ssl: true
# dev-download: false

1
config/test-settings.yml Normal file
View File

@ -0,0 +1 @@
{}

24
devel.hs
View File

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

8
stackage-server.cabal
View File

@ -15,12 +15,8 @@ library
exposed-modules: Application exposed-modules: Application
Foundation Foundation
Import Import
Echo
Settings Settings
Settings.StaticFiles Settings.StaticFiles
Settings.Development
Data.Slug
Data.Tag
Data.GhcLinks Data.GhcLinks
Data.WebsiteContent Data.WebsiteContent
Distribution.Package.ModuleForest Distribution.Package.ModuleForest
@ -181,6 +177,7 @@ library
, amazonka-core >= 1.3 && < 1.4 , amazonka-core >= 1.3 && < 1.4
, amazonka-s3 >= 1.3 && < 1.4 , amazonka-s3 >= 1.3 && < 1.4
, lens >= 4.13 && < 4.14 , lens >= 4.13 && < 4.14
, file-embed
executable stackage-server executable stackage-server
if flag(library-only) if flag(library-only)
@ -268,7 +265,8 @@ executable stackage-server-cron
test-suite test test-suite test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: main.hs main-is: Spec.hs
other-modules: TestImport
hs-source-dirs: test hs-source-dirs: test
ghc-options: -Wall ghc-options: -Wall

21
test/Data/SlugSpec.hs
View File

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

1
test/Spec.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

39
test/TestImport.hs
View File

@ -1,26 +1,21 @@
{-# LANGUAGE OverloadedStrings #-}
module TestImport module TestImport
( module Yesod.Test ( module TestImport
, module Model , module X
, module Foundation
, module Database.Persist
, runDB
, Spec
, Example
) where ) where
import Yesod.Test import Application (makeFoundation, makeLogWare)
import Database.Persist hiding (get) import ClassyPrelude as X
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool) import Foundation as X
import Control.Monad.IO.Class (liftIO) import Test.Hspec as X
import Yesod.Default.Config2 (ignoreEnv, loadYamlSettings)
import Yesod.Test as X
import Foundation withApp :: SpecWith (TestApp App) -> Spec
import Model withApp = before $ do
settings <- loadYamlSettings
type Spec = YesodSpec App ["config/test-settings.yml", "config/settings.yml"]
type Example = YesodExample App []
ignoreEnv
runDB :: SqlPersistM a -> Example a foundation <- makeFoundation settings
runDB query = do logWare <- liftIO $ makeLogWare foundation
pool <- fmap connPool getTestYesod return (foundation, logWare)
liftIO $ runSqlPersistMPool query pool

24
test/main.hs
View File

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