mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
Remove all social features
Motivation: these were the last things requiring a database. Once this is gone, it simplifies deployment dramatically. I'm also not sure that the social features were really worth keeping.
This commit is contained in:
Michael Snoyman
parent
bb01d34d8c
commit
768eaec573
@ -36,9 +36,6 @@ import qualified Echo
|
||||
-- Don't forget to add new modules to your cabal file!
|
||||
import Handler.Home
|
||||
import Handler.Snapshots
|
||||
import Handler.Profile
|
||||
import Handler.Email
|
||||
import Handler.ResetToken
|
||||
import Handler.StackageHome
|
||||
import Handler.StackageIndex
|
||||
import Handler.StackageSdist
|
||||
@ -46,8 +43,6 @@ import Handler.System
|
||||
import Handler.Haddock
|
||||
import Handler.Package
|
||||
import Handler.PackageList
|
||||
import Handler.Tag
|
||||
import Handler.BannedTags
|
||||
import Handler.Hoogle
|
||||
import Handler.BuildVersion
|
||||
import Handler.Sitemap
|
||||
@ -100,20 +95,12 @@ nicerExceptions app req send = catch (app req send) $ \e -> do
|
||||
send $ responseLBS status500 [("Content-Type", "text/plain")] $
|
||||
fromStrict $ encodeUtf8 text
|
||||
|
||||
getDbConf :: AppConfig DefaultEnv Extra -> IO Settings.PersistConf
|
||||
getDbConf conf =
|
||||
withYamlEnvironment "config/postgresql.yml" (appEnv conf)
|
||||
Database.Persist.loadConfig >>=
|
||||
Database.Persist.applyEnv
|
||||
|
||||
-- | Loads up any necessary settings, creates your foundation datatype, and
|
||||
-- performs some initialization.
|
||||
makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App
|
||||
makeFoundation useEcho conf = do
|
||||
manager <- newManager
|
||||
s <- staticSite
|
||||
dbconf <- getDbConf conf
|
||||
p <- Database.Persist.createPoolConfig dbconf
|
||||
|
||||
loggerSet' <- if useEcho
|
||||
then newFileLoggerSet defaultBufSize "/dev/null"
|
||||
@ -149,27 +136,13 @@ makeFoundation useEcho conf = do
|
||||
foundation = App
|
||||
{ settings = conf
|
||||
, getStatic = s
|
||||
, connPool = p
|
||||
, httpManager = manager
|
||||
, persistConfig = dbconf
|
||||
, appLogger = logger
|
||||
, genIO = gen
|
||||
, websiteContent = websiteContent'
|
||||
, stackageDatabase = stackageDatabase'
|
||||
}
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
when (lookup "STACKAGE_SKIP_MIGRATION" env /= Just "1") $
|
||||
runResourceT $
|
||||
flip runReaderT gen $
|
||||
flip runLoggingT (messageLoggerSource foundation logger) $
|
||||
flip (Database.Persist.runPool dbconf) p $ do
|
||||
runMigration migrateAll
|
||||
{-
|
||||
checkMigration 1 fixSnapSlugs
|
||||
checkMigration 2 setCorePackages
|
||||
-}
|
||||
|
||||
return foundation
|
||||
|
||||
-- for yesod devel
|
||||
@ -180,13 +153,3 @@ getApplicationDev useEcho =
|
||||
loader = Yesod.Default.Config.loadConfig (configSettings Development)
|
||||
{ csParseExtra = parseExtra
|
||||
}
|
||||
|
||||
_checkMigration :: MonadIO m
|
||||
=> Int
|
||||
-> ReaderT SqlBackend m ()
|
||||
-> ReaderT SqlBackend m ()
|
||||
_checkMigration num f = do
|
||||
eres <- insertBy $ Migration num
|
||||
case eres of
|
||||
Left _ -> return ()
|
||||
Right _ -> f
|
||||
|
||||
116
Foundation.hs
116
Foundation.hs
@ -1,13 +1,12 @@
|
||||
module Foundation where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug)
|
||||
import Data.Slug (HasGenIO (getGenIO), randomSlug, Slug)
|
||||
import Data.WebsiteContent
|
||||
import qualified Database.Persist
|
||||
import Database.Persist.Sql (PersistentSqlException (Couldn'tGetSQLConnection))
|
||||
import Model
|
||||
import qualified Settings
|
||||
import Settings (widgetFile, Extra (..), GoogleAuth (..))
|
||||
import Settings (widgetFile, Extra (..))
|
||||
import Settings.Development (development)
|
||||
import Settings.StaticFiles
|
||||
import qualified System.Random.MWC as MWC
|
||||
@ -29,9 +28,7 @@ import Stackage.Database
|
||||
data App = App
|
||||
{ settings :: AppConfig DefaultEnv Extra
|
||||
, getStatic :: Static -- ^ Settings for static file serving.
|
||||
, connPool :: Database.Persist.PersistConfigPool Settings.PersistConf -- ^ Database connection pool.
|
||||
, httpManager :: Manager
|
||||
, persistConfig :: Settings.PersistConf
|
||||
, appLogger :: Logger
|
||||
, genIO :: MWC.GenIO
|
||||
, websiteContent :: GitRepo WebsiteContent
|
||||
@ -44,9 +41,6 @@ instance HasGenIO App where
|
||||
instance HasHttpManager App where
|
||||
getHttpManager = httpManager
|
||||
|
||||
instance HasHackageRoot App where
|
||||
getHackageRoot = hackageRoot . appExtra . settings
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
-- http://www.yesodweb.com/book/routing-and-handlers
|
||||
@ -64,9 +58,6 @@ defaultLayoutNoContainer = defaultLayoutWithContainer False
|
||||
defaultLayoutWithContainer :: Bool -> Widget -> Handler Html
|
||||
defaultLayoutWithContainer insideContainer widget = do
|
||||
mmsg <- getMessage
|
||||
muser <- catch maybeAuth $ \e -> case e of
|
||||
Couldn'tGetSQLConnection -> return Nothing
|
||||
_ -> throwM e
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
@ -118,9 +109,6 @@ instance Yesod App where
|
||||
Just $ uncurry (joinPath y "") $ renderRoute route
|
||||
urlRenderOverride _ _ = Nothing
|
||||
|
||||
-- The page to be redirected to when authentication is required.
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
|
||||
{- Temporarily disable to allow for horizontal scaling
|
||||
-- This function creates static content files in the static folder
|
||||
-- and names them based on a hash of their content. This allows
|
||||
@ -152,108 +140,8 @@ instance ToMarkup (Route App) where
|
||||
toMarkup c =
|
||||
case c of
|
||||
AllSnapshotsR{} -> "Snapshots"
|
||||
AuthR (LoginR{}) -> "Login"
|
||||
_ -> ""
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist App where
|
||||
type YesodPersistBackend App = SqlBackend
|
||||
runDB = defaultRunDB persistConfig connPool
|
||||
instance YesodPersistRunner App where
|
||||
getDBRunner = defaultGetDBRunner connPool
|
||||
|
||||
instance YesodAuth App where
|
||||
type AuthId App = UserId
|
||||
|
||||
-- Where to send a user after successful login
|
||||
loginDest _ = HomeR
|
||||
-- Where to send a user after logout
|
||||
logoutDest _ = HomeR
|
||||
|
||||
redirectToReferer _ = True
|
||||
|
||||
getAuthId creds = do
|
||||
muid <- maybeAuthId
|
||||
join $ runDB $ case muid of
|
||||
Nothing -> do
|
||||
x <- getBy $ UniqueEmail $ credsIdent creds
|
||||
case x of
|
||||
Just (Entity _ email) -> return $ return $ Just $ emailUser email
|
||||
Nothing -> do
|
||||
handle' <- getHandle (0 :: Int)
|
||||
token <- getToken
|
||||
userid <- insert User
|
||||
{ userHandle = handle'
|
||||
, userDisplay = credsIdent creds
|
||||
, userToken = token
|
||||
}
|
||||
insert_ Email
|
||||
{ emailEmail = credsIdent creds
|
||||
, emailUser = userid
|
||||
}
|
||||
return $ return $ Just userid
|
||||
Just uid -> do
|
||||
memail <- getBy $ UniqueEmail $ credsIdent creds
|
||||
case memail of
|
||||
Nothing -> do
|
||||
insert_ Email
|
||||
{ emailEmail = credsIdent creds
|
||||
, emailUser = uid
|
||||
}
|
||||
return $ do
|
||||
setMessage $ toHtml $ concat
|
||||
[ "Email address "
|
||||
, credsIdent creds
|
||||
, " added to your account."
|
||||
]
|
||||
redirect ProfileR
|
||||
Just (Entity _ email)
|
||||
| emailUser email == uid -> return $ do
|
||||
setMessage $ toHtml $ concat
|
||||
[ "The email address "
|
||||
, credsIdent creds
|
||||
, " is already part of your account"
|
||||
]
|
||||
redirect ProfileR
|
||||
| otherwise -> invalidArgs $ return $ concat
|
||||
[ "The email address "
|
||||
, credsIdent creds
|
||||
, " is already associated with a different account."
|
||||
]
|
||||
where
|
||||
handleBase = takeWhile (/= '@') (credsIdent creds)
|
||||
getHandle cnt | cnt > 50 = error "Could not get a unique slug"
|
||||
getHandle cnt = do
|
||||
slug <- lift $ safeMakeSlug handleBase (cnt > 0)
|
||||
muser <- getBy $ UniqueHandle slug
|
||||
case muser of
|
||||
Nothing -> return slug
|
||||
Just _ -> getHandle (cnt + 1)
|
||||
|
||||
-- You can add other plugins like BrowserID, email or OAuth here
|
||||
authPlugins app =
|
||||
authBrowserId def : google
|
||||
where
|
||||
google =
|
||||
case googleAuth $ appExtra $ settings app of
|
||||
Nothing -> []
|
||||
Just GoogleAuth {..} -> [authGoogleEmail gaClientId gaClientSecret]
|
||||
|
||||
authHttpManager = httpManager
|
||||
instance YesodAuthPersist App
|
||||
|
||||
getToken :: YesodDB App Slug
|
||||
getToken =
|
||||
go (0 :: Int)
|
||||
where
|
||||
go cnt | cnt > 50 = error "Could not get a unique token"
|
||||
go cnt = do
|
||||
slug <- lift $ randomSlug 25
|
||||
muser <- getBy $ UniqueToken slug
|
||||
case muser of
|
||||
Nothing -> return slug
|
||||
Just _ -> go (cnt + 1)
|
||||
|
||||
-- This instance is required to use forms. You can modify renderMessage to
|
||||
-- achieve customized and internationalized form validation messages.
|
||||
instance RenderMessage App FormMessage where
|
||||
|
||||
@ -1,14 +0,0 @@
|
||||
module Handler.Email where
|
||||
|
||||
import Import
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
deleteEmailR :: EmailId -> Handler ()
|
||||
deleteEmailR eid = do
|
||||
Entity uid _ <- requireAuth
|
||||
cnt <- runDB $ deleteWhereCount [EmailUser ==. uid, EmailId ==. eid]
|
||||
setMessage $
|
||||
if cnt > 0
|
||||
then "Email address deleted"
|
||||
else "No matching email address found"
|
||||
redirect ProfileR
|
||||
@ -5,10 +5,6 @@
|
||||
module Handler.Package
|
||||
( getPackageR
|
||||
, getPackageSnapshotsR
|
||||
, postPackageLikeR
|
||||
, postPackageUnlikeR
|
||||
, postPackageTagR
|
||||
, postPackageUntagR
|
||||
, packagePage
|
||||
) where
|
||||
|
||||
@ -39,13 +35,6 @@ packagePage mversion pname = do
|
||||
let pname' = toPathPiece pname
|
||||
(deprecated, inFavourOf) <- getDeprecated pname'
|
||||
latests <- getLatests pname'
|
||||
muid <- maybeAuthId
|
||||
(nLikes, liked) <- runDB $ do
|
||||
nLikes <- count [LikePackage ==. pname]
|
||||
let getLiked uid = (>0) <$> count [LikePackage ==. pname, LikeVoter ==. uid]
|
||||
liked <- maybe (return False) getLiked muid
|
||||
|
||||
return (nLikes, liked)
|
||||
deps' <- getDeps pname'
|
||||
revdeps' <- getRevDeps pname'
|
||||
Entity _ package <- getPackage pname' >>= maybe notFound return
|
||||
@ -65,14 +54,6 @@ packagePage mversion pname = do
|
||||
let ixInFavourOf = zip [0::Int ..] inFavourOf
|
||||
displayedVersion = maybe (packageLatest package) (toPathPiece . snd) mversion
|
||||
|
||||
myTags <- maybe (return []) (runDB . user'sTagsOf pname) muid
|
||||
tags <- fmap (map (\(v,count') -> (v,count',any (==v) myTags)))
|
||||
(runDB (packageTags pname))
|
||||
|
||||
let likeTitle = if liked
|
||||
then "You liked this!"
|
||||
else "I like this!" :: Text
|
||||
|
||||
let homepage = case T.strip (packageHomepage package) of
|
||||
x | null x -> Nothing
|
||||
| otherwise -> Just x
|
||||
@ -94,32 +75,6 @@ packagePage mversion pname = do
|
||||
$(widgetFile "package")
|
||||
where enumerate = zip [0::Int ..]
|
||||
|
||||
-- | Get tags of the given package.
|
||||
packageTags :: PackageName -> YesodDB App [(Slug,Int)]
|
||||
packageTags pn =
|
||||
fmap (map boilerplate)
|
||||
(E.select
|
||||
(E.from (\(t `E.LeftOuterJoin` bt) -> do
|
||||
E.on $ t E.^. TagTag E.==. bt E.^. BannedTagTag
|
||||
E.where_
|
||||
$ (t ^. TagPackage E.==. E.val pn) E.&&.
|
||||
(E.isNothing $ E.just $ bt E.^. BannedTagTag)
|
||||
E.groupBy (t ^. TagTag)
|
||||
E.orderBy [E.asc (t ^. TagTag)]
|
||||
return (t ^. TagTag,E.count (t ^. TagTag)))))
|
||||
where boilerplate (E.Value a,E.Value b) = (a,b)
|
||||
|
||||
-- | Get tags of the package by the user.
|
||||
user'sTagsOf :: PackageName -> UserId -> YesodDB App [Slug]
|
||||
user'sTagsOf pn uid =
|
||||
fmap (map (\(E.Value v) -> v))
|
||||
(E.select
|
||||
(E.from (\t ->
|
||||
do E.where_ (t ^. TagPackage E.==. E.val pn E.&&.
|
||||
t ^. TagVoter E.==. E.val uid)
|
||||
E.orderBy [E.asc (t ^. TagTag)]
|
||||
return (t ^. TagTag))))
|
||||
|
||||
-- | An identifier specified in a package. Because this field has
|
||||
-- quite liberal requirements, we often encounter various forms. A
|
||||
-- name, a name and email, just an email, or maybe nothing at all.
|
||||
@ -211,47 +166,6 @@ parseChunk chunk =
|
||||
renderEmail :: EmailAddress -> Text
|
||||
renderEmail = T.decodeUtf8 . toByteString
|
||||
|
||||
postPackageLikeR :: PackageName -> Handler ()
|
||||
postPackageLikeR packageName = maybeAuthId >>= \muid -> case muid of
|
||||
Nothing -> return ()
|
||||
Just uid -> runDB $ P.insert_ $ Like packageName uid
|
||||
|
||||
postPackageUnlikeR :: PackageName -> Handler ()
|
||||
postPackageUnlikeR name = maybeAuthId >>= \muid -> case muid of
|
||||
Nothing -> return ()
|
||||
Just uid -> runDB $ P.deleteWhere [LikePackage ==. name, LikeVoter ==. uid]
|
||||
|
||||
postPackageTagR :: PackageName -> Handler ()
|
||||
postPackageTagR packageName =
|
||||
maybeAuthId >>=
|
||||
\muid ->
|
||||
case muid of
|
||||
Nothing -> return ()
|
||||
Just uid ->
|
||||
do mtag <- lookupPostParam "slug"
|
||||
case mtag of
|
||||
Just tag ->
|
||||
do slug <- mkTag tag
|
||||
void (runDB (P.insert (Tag packageName slug uid)))
|
||||
Nothing -> error "Need a slug"
|
||||
|
||||
postPackageUntagR :: PackageName -> Handler ()
|
||||
postPackageUntagR packageName =
|
||||
maybeAuthId >>=
|
||||
\muid ->
|
||||
case muid of
|
||||
Nothing -> return ()
|
||||
Just uid ->
|
||||
do mtag <- lookupPostParam "slug"
|
||||
case mtag of
|
||||
Just tag ->
|
||||
do slug <- mkTag tag
|
||||
void (runDB (P.deleteWhere
|
||||
[TagPackage ==. packageName
|
||||
,TagTag ==. slug
|
||||
,TagVoter ==. uid]))
|
||||
Nothing -> error "Need a slug"
|
||||
|
||||
getPackageSnapshotsR :: PackageName -> Handler Html
|
||||
getPackageSnapshotsR pn =
|
||||
do snapshots <- getSnapshotsForPackage $ toPathPiece pn
|
||||
|
||||
@ -1,30 +0,0 @@
|
||||
module Handler.Profile where
|
||||
|
||||
import Import
|
||||
import Data.Slug (slugField)
|
||||
|
||||
userForm :: User -> Form User
|
||||
userForm user = renderBootstrap2 $ User
|
||||
<$> areq slugField "User handle"
|
||||
{ fsTooltip = Just "Used for URLs"
|
||||
} (Just $ userHandle user)
|
||||
<*> areq textField "Display name" (Just $ userDisplay user)
|
||||
<*> pure (userToken user)
|
||||
|
||||
getProfileR :: Handler Html
|
||||
getProfileR = do
|
||||
Entity uid user <- requireAuth
|
||||
((result, userWidget), enctype) <- runFormPost $ userForm user
|
||||
case result of
|
||||
FormSuccess user' -> do
|
||||
runDB $ replace uid user'
|
||||
setMessage "Profile updated"
|
||||
redirect ProfileR
|
||||
_ -> return ()
|
||||
emails <- runDB $ selectList [EmailUser ==. uid] [Asc EmailEmail]
|
||||
defaultLayout $ do
|
||||
setTitle "Your Profile"
|
||||
$(widgetFile "profile")
|
||||
|
||||
putProfileR :: Handler Html
|
||||
putProfileR = getProfileR
|
||||
@ -1,12 +0,0 @@
|
||||
module Handler.ResetToken where
|
||||
|
||||
import Import
|
||||
|
||||
postResetTokenR :: Handler ()
|
||||
postResetTokenR = do
|
||||
Entity uid _ <- requireAuth
|
||||
runDB $ do
|
||||
token <- getToken
|
||||
update uid [UserToken =. token]
|
||||
setMessage "Token updated"
|
||||
redirect ProfileR
|
||||
@ -20,23 +20,21 @@ getSitemapR = sitemap $ do
|
||||
priority 0.7 $ AllSnapshotsR
|
||||
priority 0.7 $ PackageListR
|
||||
|
||||
priority 0.6 $ TagListR
|
||||
priority 0.6 $ AuthorsR
|
||||
priority 0.6 $ InstallR
|
||||
priority 0.6 $ OlderReleasesR
|
||||
|
||||
{- FIXME
|
||||
runDBSource $ do
|
||||
--selectAll $= ltsSitemaps
|
||||
return () $= snapshotSitemaps -- FIXME
|
||||
return () $= packageMetadataSitemaps -- FIXME
|
||||
selectAll $= tagSitemaps
|
||||
|
||||
|
||||
selectAll :: (PersistEntity val, PersistEntityBackend val ~ YesodPersistBackend App)
|
||||
=> Source (YesodDB App) val
|
||||
selectAll = selectSource [] [] $= CL.map entityVal
|
||||
|
||||
{- FIXME
|
||||
clNub :: (Monad m, Eq a) => Conduit a m a
|
||||
clNub = evalStateC [] $ awaitForever $ \a -> do
|
||||
seen <- State.get
|
||||
@ -83,11 +81,6 @@ packageMetadataSitemaps = awaitForever go
|
||||
where
|
||||
url' floc = url $ floc $ PackageName $ packageName m
|
||||
|
||||
tagSitemaps :: SitemapFor Tag
|
||||
tagSitemaps = awaitForever go
|
||||
where
|
||||
go t = url $ TagR $ tagTag t
|
||||
|
||||
|
||||
priority :: Double -> Route App -> Sitemap
|
||||
priority p loc = yield $ SitemapUrl
|
||||
|
||||
@ -1,39 +0,0 @@
|
||||
module Handler.Tag where
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Data.Slug (Slug, unSlug)
|
||||
import Import
|
||||
import Stackage.Database
|
||||
|
||||
getTagListR :: Handler Html
|
||||
getTagListR = do
|
||||
tags <- fmap (zip [0::Int ..] . (map (\(E.Value v,E.Value i) -> (v,i::Int)))) $ runDB $
|
||||
E.select $ E.from $ \(tag `E.LeftOuterJoin` bt) -> do
|
||||
E.groupBy (tag E.^. TagTag)
|
||||
E.orderBy [E.desc (E.count (tag E.^. TagTag) :: E.SqlExpr (E.Value Int))]
|
||||
E.on $ tag E.^. TagTag E.==. bt E.^. BannedTagTag
|
||||
E.where_ $ E.isNothing $ E.just $ bt E.^. BannedTagTag
|
||||
return (tag E.^. TagTag, E.count (tag E.^. TagTag))
|
||||
defaultLayout $ do
|
||||
setTitle "Stackage tags"
|
||||
$(widgetFile "tag-list")
|
||||
|
||||
getTagR :: Slug -> Handler Html
|
||||
getTagR tagSlug = do
|
||||
-- FIXME arguably: check if this tag is banned. Leaving it as displayed for
|
||||
-- now, since someone needs to go out of their way to find it.
|
||||
packages' <- runDB $ E.select $ E.from $ \tag -> do
|
||||
E.groupBy (tag E.^. TagPackage)
|
||||
E.where_ $ tag E.^. TagTag E.==. E.val tagSlug
|
||||
E.orderBy [E.asc $ tag E.^. TagPackage]
|
||||
return $ tag E.^. TagPackage
|
||||
packages <- fmap catMaybes $ forM packages' $ \(E.Value pname) -> do
|
||||
mp <- getPackage $ toPathPiece pname
|
||||
return $ case mp of
|
||||
Nothing -> Nothing
|
||||
Just (Entity _ p) -> Just (pname, strip $ packageSynopsis p)
|
||||
let tag = unSlug tagSlug
|
||||
defaultLayout $ do
|
||||
setTitle $ "Stackage tag"
|
||||
$(widgetFile "tag")
|
||||
where strip x = fromMaybe x (stripSuffix "." x)
|
||||
15
Import.hs
15
Import.hs
@ -4,7 +4,6 @@ module Import
|
||||
|
||||
import ClassyPrelude.Yesod as Import
|
||||
import Foundation as Import
|
||||
import Model as Import
|
||||
import Settings as Import
|
||||
import Settings.Development as Import
|
||||
import Settings.StaticFiles as Import
|
||||
@ -15,20 +14,6 @@ import Data.WebsiteContent as Import (WebsiteContent (..))
|
||||
import Data.Text.Read (decimal)
|
||||
import Stackage.Database (SnapName)
|
||||
|
||||
requireAuthIdOrToken :: Handler UserId
|
||||
requireAuthIdOrToken = do
|
||||
mtoken <- lookupHeader "authorization"
|
||||
case decodeUtf8 <$> mtoken of
|
||||
Nothing -> requireAuthId
|
||||
Just token -> do
|
||||
case mkSlug token of
|
||||
Nothing -> invalidArgs ["Invalid token: " ++ token]
|
||||
Just token' -> do
|
||||
muser <- runDB $ getBy $ UniqueToken token'
|
||||
case muser of
|
||||
Nothing -> invalidArgs ["Unknown token: " ++ token]
|
||||
Just (Entity uid _) -> return uid
|
||||
|
||||
parseLtsPair :: Text -> Maybe (Int, Int)
|
||||
parseLtsPair t1 = do
|
||||
(x, t2) <- either (const Nothing) Just $ decimal t1
|
||||
|
||||
13
Model.hs
13
Model.hs
@ -1,13 +0,0 @@
|
||||
module Model where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Database.Persist.Quasi
|
||||
import Data.Slug (Slug)
|
||||
import Types
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
-- http://www.yesodweb.com/book/persistent/
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
|
||||
$(persistFileWith lowerCaseSettings "config/models")
|
||||
46
Settings.hs
46
Settings.hs
@ -8,17 +8,11 @@ module Settings where
|
||||
import ClassyPrelude.Yesod
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Database.Persist.Postgresql (PostgresConf)
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Util
|
||||
import Data.Yaml
|
||||
import Settings.Development
|
||||
import Text.Hamlet
|
||||
import Data.Aeson (withText, withObject)
|
||||
import Types
|
||||
|
||||
-- | Which Persistent backend this site is using.
|
||||
type PersistConf = PostgresConf
|
||||
|
||||
-- Static setting below. Changing these requires a recompile
|
||||
|
||||
@ -65,45 +59,7 @@ widgetFile = (if development then widgetFileReload
|
||||
widgetFileSettings
|
||||
|
||||
data Extra = Extra
|
||||
{ storeConfig :: !BlobStoreConfig
|
||||
, hackageRoot :: !HackageRoot
|
||||
, adminUsers :: !(HashSet Text)
|
||||
, googleAuth :: !(Maybe GoogleAuth)
|
||||
}
|
||||
deriving Show
|
||||
|
||||
parseExtra :: DefaultEnv -> Object -> Parser Extra
|
||||
parseExtra _ o = Extra
|
||||
<$> o .: "blob-store"
|
||||
<*> (HackageRoot <$> o .: "hackage-root")
|
||||
<*> o .:? "admin-users" .!= mempty
|
||||
<*> o .:? "google-auth"
|
||||
|
||||
data BlobStoreConfig = BSCFile !FilePath
|
||||
| BSCAWS !FilePath !Text !Text !Text !Text
|
||||
deriving Show
|
||||
|
||||
instance FromJSON BlobStoreConfig where
|
||||
parseJSON v = file v <|> aws v
|
||||
where
|
||||
file = withText "BlobStoreConfig" $ \t ->
|
||||
case () of
|
||||
()
|
||||
| Just root <- stripPrefix "file:" t -> return $ BSCFile $ fpFromText root
|
||||
| otherwise -> fail $ "Invalid BlobStoreConfig: " ++ show t
|
||||
aws = withObject "BlobStoreConfig" $ \o -> BSCAWS
|
||||
<$> (fpFromText <$> (o .: "local"))
|
||||
<*> o .: "access"
|
||||
<*> o .: "secret"
|
||||
<*> o .: "bucket"
|
||||
<*> o .:? "prefix" .!= ""
|
||||
|
||||
data GoogleAuth = GoogleAuth
|
||||
{ gaClientId :: !Text
|
||||
, gaClientSecret :: !Text
|
||||
}
|
||||
deriving Show
|
||||
instance FromJSON GoogleAuth where
|
||||
parseJSON = withObject "GoogleAuth" $ \o -> GoogleAuth
|
||||
<$> o .: "client-id"
|
||||
<*> o .: "client-secret"
|
||||
parseExtra _ _ = pure Extra
|
||||
|
||||
8
Types.hs
8
Types.hs
@ -64,14 +64,6 @@ newtype HoogleVersion = HoogleVersion Text
|
||||
currentHoogleVersion :: HoogleVersion
|
||||
currentHoogleVersion = HoogleVersion VERSION_hoogle
|
||||
|
||||
newtype HackageRoot = HackageRoot { unHackageRoot :: Text }
|
||||
deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)
|
||||
|
||||
class HasHackageRoot a where
|
||||
getHackageRoot :: a -> HackageRoot
|
||||
instance HasHackageRoot HackageRoot where
|
||||
getHackageRoot = id
|
||||
|
||||
data UnpackStatus = USReady
|
||||
| USBusy
|
||||
| USFailed !Text
|
||||
|
||||
@ -1,35 +0,0 @@
|
||||
User
|
||||
handle Slug
|
||||
display Text
|
||||
token Slug
|
||||
UniqueHandle handle
|
||||
UniqueToken token
|
||||
deriving Typeable
|
||||
|
||||
Email
|
||||
email Text
|
||||
user UserId
|
||||
UniqueEmail email
|
||||
|
||||
Verkey
|
||||
email Text
|
||||
verkey Text
|
||||
|
||||
Tag
|
||||
package PackageName
|
||||
tag Slug
|
||||
voter UserId
|
||||
UniqueTagPackageVoter package tag voter
|
||||
|
||||
Like
|
||||
package PackageName
|
||||
voter UserId
|
||||
UniqueLikePackageVoter package voter
|
||||
|
||||
BannedTag
|
||||
tag Slug
|
||||
UniqueBannedTag tag
|
||||
|
||||
Migration
|
||||
num Int
|
||||
UniqueMigration num
|
||||
@ -1,24 +0,0 @@
|
||||
Default: &defaults
|
||||
user: stackage_server
|
||||
password: stackage-server
|
||||
host: localhost
|
||||
port: 5432
|
||||
database: stackage_server
|
||||
poolsize: 10
|
||||
|
||||
Development:
|
||||
<<: *defaults
|
||||
|
||||
Testing:
|
||||
database: stackage_server_test
|
||||
<<: *defaults
|
||||
|
||||
Staging:
|
||||
database: stackage_server_staging
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
Production:
|
||||
database: stackage_server_production
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
@ -1,7 +1,6 @@
|
||||
!/#LtsMajor/*Texts OldLtsMajorR GET
|
||||
|
||||
/static StaticR Static getStatic
|
||||
/auth AuthR Auth getAuth
|
||||
/reload WebsiteContentR GitRepo-WebsiteContent websiteContent
|
||||
|
||||
/favicon.ico FaviconR GET
|
||||
@ -10,9 +9,6 @@
|
||||
|
||||
/ HomeR GET
|
||||
/snapshots AllSnapshotsR GET
|
||||
/profile ProfileR GET PUT
|
||||
/email/#EmailId EmailR DELETE
|
||||
/reset-token ResetTokenR POST
|
||||
|
||||
/snapshot/#Text/*Texts OldSnapshotR GET
|
||||
|
||||
@ -33,13 +29,6 @@
|
||||
/package/#PackageName PackageR GET
|
||||
/package/#PackageName/snapshots PackageSnapshotsR GET
|
||||
/package PackageListR GET
|
||||
/package/#PackageName/like PackageLikeR POST
|
||||
/package/#PackageName/unlike PackageUnlikeR POST
|
||||
/package/#PackageName/tag PackageTagR POST
|
||||
/package/#PackageName/untag PackageUntagR POST
|
||||
/tags TagListR GET
|
||||
/tag/#Slug TagR GET
|
||||
/banned-tags BannedTagsR GET PUT
|
||||
|
||||
/lts/*Texts OldLtsR GET
|
||||
/nightly/*Texts OldNightlyR GET
|
||||
|
||||
@ -15,7 +15,6 @@ library
|
||||
exposed-modules: Application
|
||||
Foundation
|
||||
Import
|
||||
Model
|
||||
Echo
|
||||
Settings
|
||||
Settings.StaticFiles
|
||||
@ -34,9 +33,6 @@ library
|
||||
|
||||
Handler.Home
|
||||
Handler.Snapshots
|
||||
Handler.Profile
|
||||
Handler.Email
|
||||
Handler.ResetToken
|
||||
Handler.StackageHome
|
||||
Handler.StackageIndex
|
||||
Handler.StackageSdist
|
||||
@ -45,8 +41,6 @@ library
|
||||
Handler.Hoogle
|
||||
Handler.Package
|
||||
Handler.PackageList
|
||||
Handler.Tag
|
||||
Handler.BannedTags
|
||||
Handler.BuildVersion
|
||||
Handler.Sitemap
|
||||
Handler.BuildPlan
|
||||
@ -119,7 +113,6 @@ library
|
||||
, mtl >= 2.1
|
||||
, mwc-random >= 0.13
|
||||
, persistent >= 1.3.1
|
||||
, persistent-postgresql >= 1.3
|
||||
, persistent-template >= 1.3
|
||||
, resourcet >= 1.1.2
|
||||
, shakespeare >= 2.0
|
||||
|
||||
@ -1,6 +0,0 @@
|
||||
<div .container>
|
||||
<h1>Banned Tags
|
||||
<a href=@{TagListR}>List of viewable tags
|
||||
<form method=post action=@{BannedTagsR}?_method=PUT enctype=#{enctype}>
|
||||
^{widget}
|
||||
<button .btn>Update banned tags
|
||||
@ -1,4 +0,0 @@
|
||||
textarea {
|
||||
width: 500px;
|
||||
height: 400px;
|
||||
}
|
||||
@ -20,32 +20,16 @@
|
||||
$nothing
|
||||
<li>
|
||||
<a href=@{route}>#{route}
|
||||
$maybe Entity _ user <- muser
|
||||
<li>
|
||||
<a href=@{ProfileR} .user-handle>
|
||||
#{userDisplay user} (#{userHandle user})
|
||||
<li>
|
||||
<a href=@{AuthR LogoutR}>Logout
|
||||
$nothing
|
||||
<li>
|
||||
<a href=@{AuthR LoginR}>Login
|
||||
|
||||
$maybe msg <- mmsg
|
||||
<div .container>
|
||||
<div .alert .alter-info>#{msg}
|
||||
|
||||
$case cur
|
||||
$of Just (AuthR _)
|
||||
<div .container>
|
||||
<h1>Authorization
|
||||
<p>Please login with an authorization method below:
|
||||
^{widget}
|
||||
$of _
|
||||
$if insideContainer
|
||||
<div .container>
|
||||
^{widget}
|
||||
$else
|
||||
^{widget}
|
||||
$if insideContainer
|
||||
<div .container>
|
||||
^{widget}
|
||||
$else
|
||||
^{widget}
|
||||
|
||||
<div .footer>
|
||||
<div .container>
|
||||
|
||||
@ -39,33 +39,6 @@ $newline never
|
||||
|
||||
<div .row>
|
||||
<div .span12>
|
||||
<div .social>
|
||||
<span .likes>
|
||||
<span #likes>
|
||||
#{nLikes}
|
||||
<span #like-or-likes>
|
||||
\ #{format (plural "like" "likes") nLikes} #
|
||||
<i .fa :liked:.fa-thumbs-up :not liked:.fa-thumbs-o-up #like title="#{likeTitle}">
|
||||
<span .tags>
|
||||
$if null tags
|
||||
<span .no-tags>
|
||||
No tags yet. #
|
||||
$forall (tag,count,tagged) <- tags
|
||||
<span .tag>
|
||||
<a href=@{TagR tag} .tag-name>
|
||||
#{tag} #
|
||||
<a .tag-count .tag-toggle data-slug=#{tag} :tagged:.tagged title="Add/remove vote for: #{tag}">
|
||||
#{count}
|
||||
, #
|
||||
<i #add-tag class="fa fa-plus-square" title="Show/hide tag form">
|
||||
<form #add-tag-form .hidden>
|
||||
<p>
|
||||
<strong>Add tag
|
||||
<div .input-append>
|
||||
<input type="text" id="new-tag">
|
||||
<input type="submit" .btn #add-form-btn value="Confirm">
|
||||
<p #tag-msg .alert .alert-error style="display:none">
|
||||
|
||||
<div .authorship>
|
||||
<span .license>
|
||||
<a href="">
|
||||
|
||||
@ -1,151 +0,0 @@
|
||||
$(function(){
|
||||
var loggedIn = $('.user-handle').length > 0;
|
||||
var tags = Object.create(null);
|
||||
|
||||
function toggleClick(){
|
||||
if (!loggedIn) {
|
||||
login();
|
||||
return false;
|
||||
}
|
||||
|
||||
var $this = $(this);
|
||||
var normalized = $this.data('slug');
|
||||
var upvote = !$this.hasClass('tagged');
|
||||
$this.text($this.text() * 1 + (upvote? 1 : -1));
|
||||
$this.toggleClass('tagged');
|
||||
if (upvote)
|
||||
$.ajax({
|
||||
method: 'POST',
|
||||
url: '@{PackageTagR pn}',
|
||||
data: {slug:normalized}
|
||||
});
|
||||
else
|
||||
$.ajax({
|
||||
method: 'POST',
|
||||
url: '@{PackageUntagR pn}',
|
||||
data: {slug:normalized}
|
||||
});
|
||||
}
|
||||
|
||||
|
||||
$('.tags').find('.tag').each(function(){
|
||||
tags[$(this).find('.tag-name').text()] = true;
|
||||
});
|
||||
$('.expanding').each(function(){
|
||||
var $this = $(this);
|
||||
if ($this.height() > 300) {
|
||||
$this.addClass('collapsed');
|
||||
$this.find('.bottom-gradient').click(function(){
|
||||
$this.removeClass('collapsed');
|
||||
});
|
||||
}
|
||||
});
|
||||
$('#like').click(function(){
|
||||
var $this = $(this);
|
||||
|
||||
if (loggedIn) {
|
||||
var action = 'like';
|
||||
if ($this.hasClass('fa-thumbs-up')) {
|
||||
action = 'unlike';
|
||||
}
|
||||
|
||||
$this.toggleClass('fa-thumbs-up');
|
||||
$this.toggleClass('fa-thumbs-o-up');
|
||||
|
||||
$likes = $('#likes');
|
||||
nLikes = parseInt($likes.text(), 10);
|
||||
|
||||
if (action == 'like') {
|
||||
$this.attr('title','You liked this!');
|
||||
nLikes += 1;
|
||||
$.post("@{PackageLikeR pn}");
|
||||
} else {
|
||||
$this.attr('title','You disliked this.');
|
||||
nLikes -= 1;
|
||||
$.post("@{PackageUnlikeR pn}");
|
||||
}
|
||||
|
||||
$likes.text(nLikes);
|
||||
$('#like-or-likes').text(nLikes == 1 ? ' like ' : ' likes ');
|
||||
|
||||
} else {
|
||||
login();
|
||||
}
|
||||
});
|
||||
$('.tag-toggle').click(toggleClick);
|
||||
$('#add-tag').click(function(){
|
||||
if (!loggedIn) login();
|
||||
$('#add-tag-form').toggleClass('hidden');
|
||||
$('#new-tag').focus();
|
||||
});
|
||||
$('#new-tag').change(function(){
|
||||
$('#add-form-btn').val('Confirm');
|
||||
$('#tag-msg').hide();
|
||||
});
|
||||
$('#new-tag').keypress(function(){
|
||||
$('#add-form-btn').val('Confirm');
|
||||
});
|
||||
$('#add-tag-form').submit(function(){
|
||||
try {
|
||||
var candidate = $('#new-tag').val();
|
||||
var normalized = candidate
|
||||
.replace(/[^a-zA-Z0-9-.]/g,'-')
|
||||
.replace(/-+/g,'-')
|
||||
.replace(/^-/,'')
|
||||
.replace(/-$/,'')
|
||||
.toLowerCase();
|
||||
if (candidate !== normalized) {
|
||||
$('#new-tag').val(normalized);
|
||||
$('#add-form-btn').val('Done');
|
||||
} else {
|
||||
$.ajax({
|
||||
method: 'POST',
|
||||
url: '@{PackageTagR pn}',
|
||||
data: {slug:normalized},
|
||||
success: function(){
|
||||
|
||||
$('.no-tags').remove();
|
||||
|
||||
$('#new-tag').val('');
|
||||
$('#add-form-btn').val('Confirm');
|
||||
|
||||
if (!tags[normalized]) {
|
||||
var tag = $('<span><a></a></span>');
|
||||
tag.find('a').text(normalized + ' ').attr('href','/tag/' + normalized);
|
||||
$('.tags').prepend(', ');
|
||||
var count = $('<a>1</a>')
|
||||
.addClass('tag-count')
|
||||
.addClass('tag-toggle')
|
||||
.addClass('tagged')
|
||||
.data('slug',normalized)
|
||||
.attr('title','Add/remove vote for: ' + normalized)
|
||||
.click(toggleClick);
|
||||
$('.tags').prepend(count);
|
||||
$('.tags').prepend(tag);
|
||||
}
|
||||
|
||||
tags[normalized] = true;
|
||||
},
|
||||
error: function(err){
|
||||
$('#tag-msg').text("Couldn't add that tag").show();
|
||||
}
|
||||
});
|
||||
}
|
||||
} finally {
|
||||
return false;
|
||||
}
|
||||
});
|
||||
});
|
||||
|
||||
// Workaround for missing functionality in IE 8 and earlier.
|
||||
if( Object.create === undefined ) {
|
||||
Object.create = function( o ) {
|
||||
function F(){}
|
||||
F.prototype = o;
|
||||
return new F();
|
||||
};
|
||||
}
|
||||
|
||||
function login(){
|
||||
window.location.href = '@{AuthR LoginR}';
|
||||
}
|
||||
@ -1,33 +0,0 @@
|
||||
<div .container>
|
||||
<h1>
|
||||
Profile
|
||||
<div .row>
|
||||
<div .span12>
|
||||
<h2>Email addresses
|
||||
$if length emails <= 1
|
||||
$forall Entity _ email <- emails
|
||||
<p>#{emailEmail email}
|
||||
$else
|
||||
<ul>
|
||||
$forall Entity eid email <- emails
|
||||
<li .email>
|
||||
#{emailEmail email}
|
||||
<form method=post action=@{EmailR eid}?_method=DELETE>
|
||||
<button .btn>Remove
|
||||
|
||||
<p>
|
||||
<a href=@{AuthR LoginR}>Add another email address.
|
||||
|
||||
<h2>Profile
|
||||
|
||||
<form method=post action=@{ProfileR}?_method=PUT enctype=#{enctype} role=form>
|
||||
<div .form-group>
|
||||
^{userWidget}
|
||||
<button .btn>Update
|
||||
|
||||
<h2>Security token
|
||||
|
||||
<p>
|
||||
Your security token is #{userToken user}.
|
||||
<form method=post action=@{ResetTokenR}>
|
||||
<button>Reset token
|
||||
@ -1,13 +0,0 @@
|
||||
.email > form {
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
#aliases {
|
||||
display: block;
|
||||
width: 400px;
|
||||
height: 200px;
|
||||
}
|
||||
|
||||
h2 {
|
||||
font-size: 30px !important;
|
||||
}
|
||||
@ -1,11 +0,0 @@
|
||||
$newline never
|
||||
<div .container>
|
||||
<h1>Tags
|
||||
<p .tags>
|
||||
$forall (i,(tag,count)) <- tags
|
||||
$if i /= 0
|
||||
, #
|
||||
<span .tag>
|
||||
<a href=@{TagR tag}>
|
||||
#{tag} #
|
||||
<span .count>(#{count})
|
||||
@ -1,16 +0,0 @@
|
||||
.tags > li {
|
||||
list-style-type: none;
|
||||
}
|
||||
|
||||
.tags {
|
||||
margin: 1em 0 0 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
h1 {
|
||||
margin-bottom: 0.5em;
|
||||
}
|
||||
|
||||
.count {
|
||||
color: #666;
|
||||
}
|
||||
@ -1,21 +0,0 @@
|
||||
$newline never
|
||||
|
||||
<div .container>
|
||||
<h1>
|
||||
Tag: #{tag} (
|
||||
<a href=@{TagListR}>
|
||||
all tags
|
||||
)
|
||||
<div .packages>
|
||||
<table .table>
|
||||
<thead>
|
||||
<th>Package
|
||||
<th>Synopsis
|
||||
<tbody>
|
||||
$forall (name,synopsis) <- packages
|
||||
<tr>
|
||||
<td>
|
||||
<a href=@{PackageR name}>
|
||||
#{name}
|
||||
<td>
|
||||
#{synopsis}
|
||||
@ -1,12 +0,0 @@
|
||||
.packages > li {
|
||||
list-style-type: none;
|
||||
}
|
||||
|
||||
.packages {
|
||||
margin: 1em 0 0 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
h1 {
|
||||
margin-bottom: 0.5em;
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user