mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-02-18 22:05:48 +01:00
Delete a whole bunch of stuff, nothing works
This commit is contained in:
Michael Snoyman
parent
06c5059392
commit
d956b074c0
143
Application.hs
143
Application.hs
@ -11,9 +11,6 @@ import Control.Concurrent (forkIO, threadDelay)
|
|||||||
import Control.Exception (catch)
|
import Control.Exception (catch)
|
||||||
import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr)
|
import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr)
|
||||||
import Data.BlobStore (fileStore, cachedS3Store)
|
import Data.BlobStore (fileStore, cachedS3Store)
|
||||||
import Data.Hackage
|
|
||||||
import Data.Hackage.DeprecationInfo
|
|
||||||
import Data.Unpacking (newDocUnpacker, createHoogleDatabases)
|
|
||||||
import Data.WebsiteContent
|
import Data.WebsiteContent
|
||||||
import Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO)
|
import Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO)
|
||||||
import Data.Streaming.Network (bindPortTCP)
|
import Data.Streaming.Network (bindPortTCP)
|
||||||
@ -53,28 +50,21 @@ import Handler.Snapshots
|
|||||||
import Handler.Profile
|
import Handler.Profile
|
||||||
import Handler.Email
|
import Handler.Email
|
||||||
import Handler.ResetToken
|
import Handler.ResetToken
|
||||||
import Handler.UploadStackage
|
|
||||||
import Handler.StackageHome
|
import Handler.StackageHome
|
||||||
import Handler.StackageIndex
|
import Handler.StackageIndex
|
||||||
import Handler.StackageSdist
|
import Handler.StackageSdist
|
||||||
import Handler.Aliases
|
|
||||||
import Handler.Alias
|
|
||||||
import Handler.Progress
|
|
||||||
import Handler.System
|
import Handler.System
|
||||||
import Handler.Haddock
|
import Handler.Haddock
|
||||||
import Handler.Package
|
import Handler.Package
|
||||||
import Handler.PackageList
|
import Handler.PackageList
|
||||||
import Handler.CompressorStatus
|
|
||||||
import Handler.Tag
|
import Handler.Tag
|
||||||
import Handler.BannedTags
|
import Handler.BannedTags
|
||||||
import Handler.RefreshDeprecated
|
|
||||||
import Handler.UploadV2
|
|
||||||
import Handler.Hoogle
|
import Handler.Hoogle
|
||||||
import Handler.BuildVersion
|
import Handler.BuildVersion
|
||||||
import Handler.PackageCounts
|
|
||||||
import Handler.Sitemap
|
import Handler.Sitemap
|
||||||
import Handler.BuildPlan
|
import Handler.BuildPlan
|
||||||
import Handler.Download
|
import Handler.Download
|
||||||
|
import Handler.OldLinks
|
||||||
|
|
||||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||||
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
||||||
@ -157,9 +147,6 @@ makeFoundation useEcho conf = do
|
|||||||
|
|
||||||
blobStore' <- loadBlobStore manager conf
|
blobStore' <- loadBlobStore manager conf
|
||||||
|
|
||||||
let haddockRootDir' = "/tmp/stackage-server-haddocks2"
|
|
||||||
widgetCache' <- newIORef mempty
|
|
||||||
|
|
||||||
websiteContent' <- if development
|
websiteContent' <- if development
|
||||||
then do
|
then do
|
||||||
void $ rawSystem "git"
|
void $ rawSystem "git"
|
||||||
@ -182,7 +169,6 @@ makeFoundation useEcho conf = do
|
|||||||
|
|
||||||
let runDB' :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a
|
let runDB' :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a
|
||||||
runDB' = flip (Database.Persist.runPool dbconf) p
|
runDB' = flip (Database.Persist.runPool dbconf) p
|
||||||
docUnpacker <- newDocUnpacker haddockRootDir' blobStore' runDB'
|
|
||||||
|
|
||||||
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
let logger = Yesod.Core.Types.Logger loggerSet' getter
|
||||||
foundation = App
|
foundation = App
|
||||||
@ -194,9 +180,6 @@ makeFoundation useEcho conf = do
|
|||||||
, appLogger = logger
|
, appLogger = logger
|
||||||
, genIO = gen
|
, genIO = gen
|
||||||
, blobStore = blobStore'
|
, blobStore = blobStore'
|
||||||
, haddockRootDir = haddockRootDir'
|
|
||||||
, appDocUnpacker = docUnpacker
|
|
||||||
, widgetCache = widgetCache'
|
|
||||||
, websiteContent = websiteContent'
|
, websiteContent = websiteContent'
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -209,27 +192,16 @@ makeFoundation useEcho conf = do
|
|||||||
flip runLoggingT (messageLoggerSource foundation logger) $
|
flip runLoggingT (messageLoggerSource foundation logger) $
|
||||||
flip (Database.Persist.runPool dbconf) p $ do
|
flip (Database.Persist.runPool dbconf) p $ do
|
||||||
runMigration migrateAll
|
runMigration migrateAll
|
||||||
|
{-
|
||||||
checkMigration 1 fixSnapSlugs
|
checkMigration 1 fixSnapSlugs
|
||||||
checkMigration 2 setCorePackages
|
checkMigration 2 setCorePackages
|
||||||
|
-}
|
||||||
|
|
||||||
|
|
||||||
let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0"
|
let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0"
|
||||||
hoogleGen = lookup "STACKAGE_HOOGLE_GEN" env /= Just "0"
|
hoogleGen = lookup "STACKAGE_HOOGLE_GEN" env /= Just "0"
|
||||||
forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
|
forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
|
||||||
loadCabalFiles' = appLoadCabalFiles updateDB forceUpdate foundation dbconf p
|
|
||||||
|
|
||||||
-- Start the cabal file loader
|
|
||||||
ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
|
|
||||||
$logInfoS "CLEANUP" "Cleaning up /tmp"
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
runResourceT $ sourceDirectory "/tmp" $$ mapM_C (cleanupTemp now)
|
|
||||||
$logInfoS "CLEANUP" "Cleaning up complete"
|
|
||||||
|
|
||||||
loadCabalFiles'
|
|
||||||
|
|
||||||
when hoogleGen $ liftIO $ createHoogleDatabases blobStore' runDB' putStrLn urlRender'
|
|
||||||
|
|
||||||
liftIO $ threadDelay $ 30 * 60 * 1000000
|
|
||||||
return foundation
|
return foundation
|
||||||
where ifRunCabalLoader m =
|
where ifRunCabalLoader m =
|
||||||
if cabalFileLoader
|
if cabalFileLoader
|
||||||
@ -255,6 +227,8 @@ cabalLoaderMain = do
|
|||||||
void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
|
void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
|
||||||
error $ "cabal loader process already running, exiting"
|
error $ "cabal loader process already running, exiting"
|
||||||
|
|
||||||
|
error "cabalLoaderMain"
|
||||||
|
{- FIXME
|
||||||
conf <- fromArgs parseExtra
|
conf <- fromArgs parseExtra
|
||||||
dbconf <- getDbConf conf
|
dbconf <- getDbConf conf
|
||||||
pool <- Database.Persist.createPoolConfig dbconf
|
pool <- Database.Persist.createPoolConfig dbconf
|
||||||
@ -297,77 +271,7 @@ cabalLoaderMain = do
|
|||||||
logFunc loc src level str
|
logFunc loc src level str
|
||||||
| level > LevelDebug = S.hPutStr stdout $ fromLogStr $ defaultLogStr loc src level str
|
| level > LevelDebug = S.hPutStr stdout $ fromLogStr $ defaultLogStr loc src level str
|
||||||
| otherwise = return ()
|
| otherwise = return ()
|
||||||
|
-}
|
||||||
appLoadCabalFiles :: ( PersistConfig c
|
|
||||||
, PersistConfigBackend c ~ SqlPersistT
|
|
||||||
, HasHackageRoot env
|
|
||||||
, HasBlobStore env StoreKey
|
|
||||||
, HasHttpManager env
|
|
||||||
)
|
|
||||||
=> Bool -- ^ update database?
|
|
||||||
-> Bool -- ^ force update?
|
|
||||||
-> env
|
|
||||||
-> c
|
|
||||||
-> PersistConfigPool c
|
|
||||||
-> LoggingT IO ()
|
|
||||||
appLoadCabalFiles updateDB forceUpdate env dbconf p = do
|
|
||||||
eres <- tryAny $ flip runReaderT env $ do
|
|
||||||
let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
|
|
||||||
-> ReaderT env (LoggingT IO) a
|
|
||||||
runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p
|
|
||||||
|
|
||||||
$logInfo "Updating deprecation tags"
|
|
||||||
loadDeprecationInfo >>= \ei -> case ei of
|
|
||||||
Left e -> $logError (pack e)
|
|
||||||
Right info -> runDB' $ do
|
|
||||||
deleteWhere ([] :: [Filter Deprecated])
|
|
||||||
insertMany_ (deprecations info)
|
|
||||||
deleteWhere ([] :: [Filter Suggested])
|
|
||||||
insertMany_ (suggestions info)
|
|
||||||
$logInfo "Finished updating deprecation tags"
|
|
||||||
|
|
||||||
let toMDPair (E.Value name, E.Value version, E.Value hash') =
|
|
||||||
(name, (version, hash'))
|
|
||||||
metadata0 <- fmap (mapFromList . map toMDPair)
|
|
||||||
$ runDB' $ E.select $ E.from $ \m -> return
|
|
||||||
( m E.^. MetadataName
|
|
||||||
, m E.^. MetadataVersion
|
|
||||||
, m E.^. MetadataHash
|
|
||||||
)
|
|
||||||
UploadState _ newMD <- loadCabalFiles updateDB forceUpdate metadata0
|
|
||||||
$logInfo $ "Updating metadatas: " ++ tshow (length newMD)
|
|
||||||
runDB' $ do
|
|
||||||
let newMD' = toList newMD
|
|
||||||
deleteWhere [MetadataName <-. map metadataName newMD']
|
|
||||||
insertMany_ newMD'
|
|
||||||
forM_ newMD' $ \md -> do
|
|
||||||
deleteWhere [DependencyUser ==. metadataName md]
|
|
||||||
insertMany_ $ flip map (metadataDeps md) $ \dep ->
|
|
||||||
Dependency (PackageName dep) (metadataName md)
|
|
||||||
|
|
||||||
case eres of
|
|
||||||
Left e -> $logError $ tshow e
|
|
||||||
Right () -> return ()
|
|
||||||
|
|
||||||
cleanupTemp :: UTCTime -> FilePath -> ResourceT (LoggingT IO) ()
|
|
||||||
cleanupTemp now fp
|
|
||||||
| any (`isPrefixOf` name) prefixes = handleAny ($logError . tshow) $ do
|
|
||||||
modified <- liftIO $ getModified fp
|
|
||||||
if (diffUTCTime now modified > 60 * 60)
|
|
||||||
then do
|
|
||||||
$logInfoS "CLEANUP" $ "Removing temp directory: " ++ fpToText fp
|
|
||||||
liftIO $ removeTree fp
|
|
||||||
$logInfoS "CLEANUP" $ "Temp directory deleted: " ++ fpToText fp
|
|
||||||
else $logInfoS "CLEANUP" $ "Ignoring recent entry: " ++ fpToText fp
|
|
||||||
| otherwise = $logInfoS "CLEANUP" $ "Ignoring unmatched path: " ++ fpToText fp
|
|
||||||
where
|
|
||||||
name = fpToText $ filename fp
|
|
||||||
prefixes = asVector $ pack
|
|
||||||
[ "hackage-index"
|
|
||||||
, "createview"
|
|
||||||
, "build00index."
|
|
||||||
, "newindex"
|
|
||||||
]
|
|
||||||
|
|
||||||
-- for yesod devel
|
-- for yesod devel
|
||||||
getApplicationDev :: Bool -> IO (Int, Application)
|
getApplicationDev :: Bool -> IO (Int, Application)
|
||||||
@ -387,38 +291,3 @@ checkMigration num f = do
|
|||||||
case eres of
|
case eres of
|
||||||
Left _ -> return ()
|
Left _ -> return ()
|
||||||
Right _ -> f
|
Right _ -> f
|
||||||
|
|
||||||
fixSnapSlugs :: (MonadResource m, HasGenIO env, MonadReader env m)
|
|
||||||
=> ReaderT SqlBackend m ()
|
|
||||||
fixSnapSlugs =
|
|
||||||
selectSource [] [Asc StackageUploaded] $$ mapM_C go
|
|
||||||
where
|
|
||||||
go (Entity sid Stackage {..}) =
|
|
||||||
loop (1 :: Int)
|
|
||||||
where
|
|
||||||
base = T.replace "haskell platform" "hp"
|
|
||||||
$ T.replace "stackage build for " ""
|
|
||||||
$ toLower stackageTitle
|
|
||||||
loop 50 = error "fixSnapSlugs can't find a good slug"
|
|
||||||
loop i = do
|
|
||||||
slug' <- lift $ safeMakeSlug base $ if i == 1 then False else True
|
|
||||||
let slug = SnapSlug slug'
|
|
||||||
ms <- getBy $ UniqueSnapshot slug
|
|
||||||
case ms of
|
|
||||||
Nothing -> update sid [StackageSlug =. slug]
|
|
||||||
Just _ -> loop (i + 1)
|
|
||||||
|
|
||||||
setCorePackages :: MonadIO m => ReaderT SqlBackend m ()
|
|
||||||
setCorePackages =
|
|
||||||
updateWhere
|
|
||||||
[ PackageName' <-. defaultCorePackages
|
|
||||||
, PackageCore ==. Nothing
|
|
||||||
]
|
|
||||||
[PackageCore =. Just True]
|
|
||||||
where
|
|
||||||
defaultCorePackages = map PackageName $ words =<<
|
|
||||||
[ "ghc hoopl bytestring unix haskeline Cabal base time xhtml"
|
|
||||||
, "haskell98 hpc filepath process array integer-gmp bin-package-db"
|
|
||||||
, "containers haskell2010 binary ghc-prim old-time old-locale rts"
|
|
||||||
, "terminfo transformers deepseq pretty template-haskell directory"
|
|
||||||
]
|
|
||||||
|
|||||||
379
Data/Hackage.hs
379
Data/Hackage.hs
@ -1,379 +0,0 @@
|
|||||||
module Data.Hackage
|
|
||||||
( loadCabalFiles
|
|
||||||
, sourceHackageSdist
|
|
||||||
, UploadState (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import ClassyPrelude.Yesod hiding (get)
|
|
||||||
import Types
|
|
||||||
import Data.BlobStore
|
|
||||||
import Data.Conduit.Lazy (MonadActive (..), lazyConsume)
|
|
||||||
import qualified Codec.Archive.Tar as Tar
|
|
||||||
import Control.Monad.Logger (runNoLoggingT)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Conduit.Zlib (ungzip)
|
|
||||||
import System.IO.Temp (withSystemTempFile)
|
|
||||||
import System.IO (IOMode (ReadMode), openBinaryFile)
|
|
||||||
import Model (Metadata (..))
|
|
||||||
import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
|
|
||||||
import qualified Distribution.PackageDescription as PD
|
|
||||||
import qualified Distribution.Package as PD
|
|
||||||
import Control.Monad.State.Strict (put, get, execStateT, MonadState)
|
|
||||||
import Crypto.Hash.Conduit (sinkHash)
|
|
||||||
import Crypto.Hash (Digest, SHA256)
|
|
||||||
import Data.Byteable (toBytes)
|
|
||||||
import Distribution.Text (display)
|
|
||||||
import Text.Markdown (Markdown (Markdown))
|
|
||||||
import qualified Data.Traversable as T
|
|
||||||
import qualified Data.Version
|
|
||||||
import Text.ParserCombinators.ReadP (readP_to_S)
|
|
||||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
|
||||||
import Text.Blaze.Html (unsafeByteString)
|
|
||||||
import qualified Text.Blaze.Html5 as H
|
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
|
||||||
import qualified Documentation.Haddock.Parser as Haddock
|
|
||||||
import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..))
|
|
||||||
import qualified Data.HashMap.Lazy as HM
|
|
||||||
|
|
||||||
loadCabalFiles :: ( MonadActive m
|
|
||||||
, MonadBaseControl IO m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasHttpManager env
|
|
||||||
, HasBlobStore env StoreKey
|
|
||||||
, HasHackageRoot env
|
|
||||||
, MonadLogger m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
|
||||||
=> Bool -- ^ do the database updating
|
|
||||||
-> Bool -- ^ force updates regardless of hash value?
|
|
||||||
-> HashMap PackageName (Version, ByteString)
|
|
||||||
-> m (UploadState Metadata)
|
|
||||||
loadCabalFiles dbUpdates forceUpdate metadata0 = (>>= T.mapM liftIO) $ flip execStateT (UploadState metadata1 mempty) $ do
|
|
||||||
HackageRoot root <- liftM getHackageRoot ask
|
|
||||||
$logDebug $ "Entering loadCabalFiles, root == " ++ root
|
|
||||||
req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
|
|
||||||
withSystemTempFile "hackage-index" $ \tempIndex handleOut -> do
|
|
||||||
$logDebug $ "Requesting: " ++ tshow req
|
|
||||||
withResponse req $ \res -> responseBody res $$ sinkHandle handleOut
|
|
||||||
liftIO $ hClose handleOut
|
|
||||||
withBinaryFile tempIndex ReadMode $ \handleIn -> do
|
|
||||||
bss <- lazyConsume $ sourceHandle handleIn $= ungzip
|
|
||||||
tarSource (Tar.read $ fromChunks bss)
|
|
||||||
$$ parMapMC 32 go
|
|
||||||
=$ scanlC (\x _ -> x + 1) (0 :: Int)
|
|
||||||
=$ filterC ((== 0) . (`mod` 1000))
|
|
||||||
=$ mapM_C (\i -> $logInfo $ "Processing cabal file #" ++ tshow i)
|
|
||||||
$logInfo "Finished processing cabal files"
|
|
||||||
where
|
|
||||||
metadata1 = flip fmap metadata0 $ \(v, h) -> MetaSig
|
|
||||||
v
|
|
||||||
(fromMaybe (pack [0, 0, 0]) $ readVersion v)
|
|
||||||
h
|
|
||||||
withBinaryFile fp mode = bracket (liftIO $ openBinaryFile fp mode) (liftIO . hClose)
|
|
||||||
|
|
||||||
go entry = do
|
|
||||||
case Tar.entryContent entry of
|
|
||||||
Tar.NormalFile lbs _
|
|
||||||
| Just (name, version) <- parseFilePath (Tar.entryPath entry) -> do
|
|
||||||
let key = HackageCabal name version
|
|
||||||
-- It's not longer sufficient to simply check if the cabal
|
|
||||||
-- file exists, since Hackage now allows updating in place.
|
|
||||||
-- Instead, we have to check if it matches what we have
|
|
||||||
-- and, if not, update it.
|
|
||||||
store <- liftM getBlobStore ask
|
|
||||||
newDigest :: Digest SHA256 <- sourceLazy lbs $$ sinkHash
|
|
||||||
toStore <- withAcquire (storeRead' store key) $ \mcurr ->
|
|
||||||
case mcurr of
|
|
||||||
Nothing -> return True
|
|
||||||
Just curr -> do
|
|
||||||
-- Check if it matches. This is cheaper than
|
|
||||||
-- always writing, since it can take advantage
|
|
||||||
-- of the local filesystem cache and not go to
|
|
||||||
-- S3 each time.
|
|
||||||
currDigest <- curr $$ sinkHash
|
|
||||||
return $! currDigest /= newDigest
|
|
||||||
when toStore $ withAcquire (storeWrite' store key) $ \sink ->
|
|
||||||
sourceLazy lbs $$ sink
|
|
||||||
when dbUpdates $ do
|
|
||||||
case readVersion version of
|
|
||||||
Nothing -> return ()
|
|
||||||
Just dataVersion -> setMetadata
|
|
||||||
forceUpdate
|
|
||||||
name
|
|
||||||
version
|
|
||||||
dataVersion
|
|
||||||
(toBytes newDigest)
|
|
||||||
(parsePackageDescription $ unpack $ decodeUtf8 lbs)
|
|
||||||
_ -> return ()
|
|
||||||
|
|
||||||
readVersion :: Version -> Maybe (UVector Int)
|
|
||||||
readVersion v =
|
|
||||||
case filter (null . snd) $ readP_to_S Data.Version.parseVersion . unpack . unVersion $ v of
|
|
||||||
(dv, _):_ -> Just $ pack $ Data.Version.versionBranch dv
|
|
||||||
[] -> Nothing
|
|
||||||
|
|
||||||
tarSource :: (Exception e, MonadThrow m)
|
|
||||||
=> Tar.Entries e
|
|
||||||
-> Producer m Tar.Entry
|
|
||||||
tarSource Tar.Done = return ()
|
|
||||||
tarSource (Tar.Fail e) = throwM e
|
|
||||||
tarSource (Tar.Next e es) = yield e >> tarSource es
|
|
||||||
|
|
||||||
data UploadState md = UploadState
|
|
||||||
{ usMetadata :: !(HashMap PackageName MetaSig)
|
|
||||||
, usMetaChanges :: (HashMap PackageName md)
|
|
||||||
}
|
|
||||||
deriving (Functor, Foldable, Traversable)
|
|
||||||
|
|
||||||
data MetaSig = MetaSig
|
|
||||||
{-# UNPACK #-} !Version
|
|
||||||
{-# UNPACK #-} !(UVector Int) -- versionBranch
|
|
||||||
{-# UNPACK #-} !ByteString -- hash
|
|
||||||
|
|
||||||
setMetadata :: ( MonadBaseControl IO m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadReader env m
|
|
||||||
, MonadState (UploadState (IO Metadata)) m
|
|
||||||
, HasHttpManager env
|
|
||||||
, MonadLogger m
|
|
||||||
, MonadActive m
|
|
||||||
, HasBlobStore env StoreKey
|
|
||||||
, HasHackageRoot env
|
|
||||||
)
|
|
||||||
=> Bool -- ^ force update?
|
|
||||||
-> PackageName
|
|
||||||
-> Version
|
|
||||||
-> UVector Int -- ^ versionBranch
|
|
||||||
-> ByteString
|
|
||||||
-> ParseResult PD.GenericPackageDescription
|
|
||||||
-> m ()
|
|
||||||
setMetadata forceUpdate name version dataVersion hash' gpdRes = do
|
|
||||||
UploadState mdMap mdChanges <- get
|
|
||||||
let toUpdate =
|
|
||||||
case lookup name mdMap of
|
|
||||||
Just (MetaSig _currVersion currDataVersion currHash) ->
|
|
||||||
case compare currDataVersion dataVersion of
|
|
||||||
LT -> True
|
|
||||||
GT -> False
|
|
||||||
EQ -> currHash /= hash' || forceUpdate
|
|
||||||
Nothing -> True
|
|
||||||
if toUpdate
|
|
||||||
then case gpdRes of
|
|
||||||
ParseOk _ gpd -> do
|
|
||||||
!md <- getMetadata name version hash' gpd
|
|
||||||
put $! UploadState
|
|
||||||
(insertMap name (MetaSig version dataVersion hash') mdMap)
|
|
||||||
(HM.insert name md mdChanges)
|
|
||||||
_ -> return ()
|
|
||||||
else return ()
|
|
||||||
|
|
||||||
getMetadata :: ( MonadActive m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadBaseControl IO m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasBlobStore env StoreKey
|
|
||||||
, HasHackageRoot env
|
|
||||||
, HasHttpManager env
|
|
||||||
, MonadLogger m
|
|
||||||
)
|
|
||||||
=> PackageName
|
|
||||||
-> Version
|
|
||||||
-> ByteString
|
|
||||||
-> PD.GenericPackageDescription
|
|
||||||
-> m (IO Metadata)
|
|
||||||
getMetadata name version hash' gpd = do
|
|
||||||
let pd = PD.packageDescription gpd
|
|
||||||
env <- ask
|
|
||||||
return $ liftIO $ runNoLoggingT $ flip runReaderT env $ do
|
|
||||||
(mreadme, mchangelog, mlicenseContent) <-
|
|
||||||
grabExtraFiles name version
|
|
||||||
#if MIN_VERSION_Cabal(1, 20, 0)
|
|
||||||
$ PD.licenseFiles pd
|
|
||||||
#else
|
|
||||||
[PD.licenseFile pd]
|
|
||||||
#endif
|
|
||||||
let collapseHtml = unsafeByteString . toStrict . renderHtml
|
|
||||||
return Metadata
|
|
||||||
{ metadataName = name
|
|
||||||
, metadataVersion = version
|
|
||||||
, metadataHash = hash'
|
|
||||||
, metadataDeps = setToList
|
|
||||||
$ asSet
|
|
||||||
$ concat
|
|
||||||
[ foldMap goTree $ PD.condLibrary gpd
|
|
||||||
, foldMap (goTree . snd) $ PD.condExecutables gpd
|
|
||||||
]
|
|
||||||
, metadataAuthor = pack $ PD.author pd
|
|
||||||
, metadataMaintainer = pack $ PD.maintainer pd
|
|
||||||
, metadataLicenseName = pack $ display $ PD.license pd
|
|
||||||
, metadataHomepage = pack $ PD.homepage pd
|
|
||||||
, metadataBugReports = pack $ PD.bugReports pd
|
|
||||||
, metadataSynopsis = pack $ PD.synopsis pd
|
|
||||||
, metadataSourceRepo = mapMaybe showSourceRepo $ PD.sourceRepos pd
|
|
||||||
, metadataCategory = pack $ PD.category pd
|
|
||||||
, metadataLibrary = isJust $ PD.library pd
|
|
||||||
, metadataExes = length $ PD.executables pd
|
|
||||||
, metadataTestSuites = length $ PD.testSuites pd
|
|
||||||
, metadataBenchmarks = length $ PD.benchmarks pd
|
|
||||||
, metadataReadme = collapseHtml $ fromMaybe
|
|
||||||
(hToHtml . Haddock.toRegular . Haddock.parseParas $ PD.description pd)
|
|
||||||
mreadme
|
|
||||||
, metadataChangelog = collapseHtml <$> mchangelog
|
|
||||||
, metadataLicenseContent = collapseHtml <$> mlicenseContent
|
|
||||||
}
|
|
||||||
where
|
|
||||||
goTree (PD.CondNode _ deps comps) = concatMap goDep deps ++ concatMap goComp comps
|
|
||||||
goDep (PD.Dependency (PD.PackageName n) _) = singletonSet $ pack n
|
|
||||||
goComp (_, tree, mtree) = goTree tree ++ maybe mempty goTree mtree
|
|
||||||
|
|
||||||
-- | Convert a Haddock doc to HTML.
|
|
||||||
hToHtml :: DocH String String -> Html
|
|
||||||
hToHtml =
|
|
||||||
go
|
|
||||||
where
|
|
||||||
go :: DocH String String -> Html
|
|
||||||
go DocEmpty = mempty
|
|
||||||
go (DocAppend x y) = go x ++ go y
|
|
||||||
go (DocString x) = toHtml x
|
|
||||||
go (DocParagraph x) = H.p $ go x
|
|
||||||
go (DocIdentifier s) = H.code $ toHtml s
|
|
||||||
go (DocIdentifierUnchecked s) = H.code $ toHtml s
|
|
||||||
go (DocModule s) = H.code $ toHtml s
|
|
||||||
go (DocWarning x) = H.span H.! A.class_ "warning" $ go x
|
|
||||||
go (DocEmphasis x) = H.em $ go x
|
|
||||||
go (DocMonospaced x) = H.code $ go x
|
|
||||||
go (DocBold x) = H.strong $ go x
|
|
||||||
go (DocUnorderedList xs) = H.ul $ foldMap (H.li . go) xs
|
|
||||||
go (DocOrderedList xs) = H.ol $ foldMap (H.li . go) xs
|
|
||||||
go (DocDefList xs) = H.dl $ flip foldMap xs $ \(x, y) ->
|
|
||||||
H.dt (go x) ++ H.dd (go y)
|
|
||||||
go (DocCodeBlock x) = H.pre $ H.code $ go x
|
|
||||||
go (DocHyperlink (Hyperlink url mlabel)) =
|
|
||||||
H.a H.! A.href (H.toValue url) $ toHtml label
|
|
||||||
where
|
|
||||||
label = fromMaybe url mlabel
|
|
||||||
go (DocPic (Picture url mtitle)) =
|
|
||||||
H.img H.! A.src (H.toValue url) H.! A.title (H.toValue $ fromMaybe mempty mtitle)
|
|
||||||
go (DocAName s) = H.div H.! A.id (H.toValue s) $ mempty
|
|
||||||
go (DocProperty s) = H.pre $ H.code $ toHtml s
|
|
||||||
go (DocExamples es) = flip foldMap es $ \(Example exp' ress) ->
|
|
||||||
H.div H.! A.class_ "example" $ do
|
|
||||||
H.pre H.! A.class_ "expression" $ H.code $ toHtml exp'
|
|
||||||
flip foldMap ress $ \res ->
|
|
||||||
H.pre H.! A.class_ "result" $ H.code $ toHtml res
|
|
||||||
go (DocHeader (Header level content)) =
|
|
||||||
wrapper level $ go content
|
|
||||||
where
|
|
||||||
wrapper 1 = H.h1
|
|
||||||
wrapper 2 = H.h2
|
|
||||||
wrapper 3 = H.h3
|
|
||||||
wrapper 4 = H.h4
|
|
||||||
wrapper 5 = H.h5
|
|
||||||
wrapper _ = H.h6
|
|
||||||
|
|
||||||
showSourceRepo :: PD.SourceRepo -> Maybe Text
|
|
||||||
showSourceRepo = fmap pack . PD.repoLocation
|
|
||||||
|
|
||||||
grabExtraFiles :: ( MonadActive m
|
|
||||||
, MonadIO m
|
|
||||||
, MonadBaseControl IO m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasBlobStore env StoreKey
|
|
||||||
, HasHackageRoot env
|
|
||||||
, HasHttpManager env
|
|
||||||
, MonadLogger m
|
|
||||||
)
|
|
||||||
=> PackageName
|
|
||||||
-> Version
|
|
||||||
-> [String] -- ^ license files
|
|
||||||
-> m (Maybe Html, Maybe Html, Maybe Html) -- ^ README, changelog, license
|
|
||||||
grabExtraFiles name version lfiles = runResourceT $ do
|
|
||||||
msrc <- sourceHackageSdist name version
|
|
||||||
handle (\(_ :: Tar.FormatError) -> return (Nothing,Nothing,Nothing)) $
|
|
||||||
case msrc of
|
|
||||||
Nothing -> return mempty
|
|
||||||
Just src -> do
|
|
||||||
bss <- lazyConsume $ src $= ungzip
|
|
||||||
tarSource (Tar.read $ fromChunks bss) $$ foldlC go mempty
|
|
||||||
where
|
|
||||||
go trip@(mreadme, mchangelog, mlicense) entry =
|
|
||||||
case Tar.entryContent entry of
|
|
||||||
Tar.NormalFile lbs _ ->
|
|
||||||
let name' = drop 1 $ dropWhile (/= '/') $ Tar.entryPath entry in
|
|
||||||
case toLower name' of
|
|
||||||
"readme.md" -> (md lbs, mchangelog, mlicense)
|
|
||||||
"readme" -> (txt lbs, mchangelog, mlicense)
|
|
||||||
"readme.txt" -> (txt lbs, mchangelog, mlicense)
|
|
||||||
"changelog.md" -> (mreadme, md lbs, mlicense)
|
|
||||||
"changelog" -> (mreadme, txt lbs, mlicense)
|
|
||||||
"changelog.txt" -> (mreadme, txt lbs, mlicense)
|
|
||||||
"changes.md" -> (mreadme, md lbs, mlicense)
|
|
||||||
"changes" -> (mreadme, txt lbs, mlicense)
|
|
||||||
"changes.txt" -> (mreadme, txt lbs, mlicense)
|
|
||||||
_ | name' `elem` lfiles -> (mreadme, mchangelog, txt lbs)
|
|
||||||
_ -> trip
|
|
||||||
_ -> trip
|
|
||||||
|
|
||||||
md = wrapClass "markdown" . Markdown . decodeUtf8
|
|
||||||
txt = wrapClass "plain-text" . Textarea . toStrict . decodeUtf8
|
|
||||||
|
|
||||||
wrapClass clazz inner = Just $ H.div H.! A.class_ clazz $ toHtml inner
|
|
||||||
|
|
||||||
parseFilePath :: String -> Maybe (PackageName, Version)
|
|
||||||
parseFilePath s =
|
|
||||||
case filter (not . null) $ T.split (== '/') $ pack s of
|
|
||||||
(name:version:_) -> Just (PackageName name, Version version)
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
sourceHackageSdist :: ( MonadIO m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadBaseControl IO m
|
|
||||||
, MonadResource m
|
|
||||||
, MonadReader env m
|
|
||||||
, HasHttpManager env
|
|
||||||
, HasHackageRoot env
|
|
||||||
, HasBlobStore env StoreKey
|
|
||||||
, MonadLogger m
|
|
||||||
)
|
|
||||||
=> PackageName
|
|
||||||
-> Version
|
|
||||||
-> m (Maybe (Source m ByteString))
|
|
||||||
sourceHackageSdist name version = do
|
|
||||||
let key = HackageSdist name version
|
|
||||||
msrc1 <- storeRead key
|
|
||||||
case msrc1 of
|
|
||||||
Just src -> return $ Just src
|
|
||||||
Nothing -> do
|
|
||||||
HackageRoot root <- liftM getHackageRoot ask
|
|
||||||
let url = concat
|
|
||||||
[ root
|
|
||||||
, "/package/"
|
|
||||||
, toPathPiece name
|
|
||||||
, "-"
|
|
||||||
, toPathPiece version
|
|
||||||
, ".tar.gz"
|
|
||||||
]
|
|
||||||
req' <- parseUrl $ unpack url
|
|
||||||
let req = req' { checkStatus = \_ _ _ -> Nothing }
|
|
||||||
$logDebug $ "Requesting: " ++ tshow req
|
|
||||||
exists <- withResponse req $ \res ->
|
|
||||||
if responseStatus res == status200
|
|
||||||
then do
|
|
||||||
responseBody res $$ storeWrite key
|
|
||||||
return True
|
|
||||||
else return False
|
|
||||||
if exists
|
|
||||||
then storeRead key
|
|
||||||
else return Nothing
|
|
||||||
|
|
||||||
-- FIXME put in conduit-combinators
|
|
||||||
parMapMC :: (MonadIO m, MonadBaseControl IO m)
|
|
||||||
=> Int
|
|
||||||
-> (i -> m o)
|
|
||||||
-> Conduit i m o
|
|
||||||
parMapMC _ = mapMC
|
|
||||||
@ -1,58 +0,0 @@
|
|||||||
-- | Transforms http://hackage.haskell.org/packages/deprecated.json
|
|
||||||
-- into model data to be stored in the database.
|
|
||||||
module Data.Hackage.DeprecationInfo
|
|
||||||
( HackageDeprecationInfo(..)
|
|
||||||
, loadDeprecationInfo
|
|
||||||
) where
|
|
||||||
|
|
||||||
import ClassyPrelude.Yesod
|
|
||||||
import Data.Aeson as Aeson
|
|
||||||
import Model
|
|
||||||
import Types
|
|
||||||
|
|
||||||
data HackageDeprecationInfo = HackageDeprecationInfo {
|
|
||||||
deprecations :: [Deprecated],
|
|
||||||
suggestions :: [Suggested]
|
|
||||||
}
|
|
||||||
|
|
||||||
instance FromJSON HackageDeprecationInfo where
|
|
||||||
parseJSON j = do
|
|
||||||
deprecationRecords <- parseJSON j
|
|
||||||
return $ HackageDeprecationInfo {
|
|
||||||
deprecations = map toDeprecated deprecationRecords,
|
|
||||||
suggestions = concatMap toSuggestions deprecationRecords
|
|
||||||
}
|
|
||||||
|
|
||||||
data DeprecationRecord = DeprecationRecord {
|
|
||||||
_deprecatedPackage :: PackageName,
|
|
||||||
_deprecatedInFavourOf :: [PackageName]
|
|
||||||
}
|
|
||||||
|
|
||||||
instance FromJSON DeprecationRecord where
|
|
||||||
parseJSON = withObject "DeprecationRecord" $ \obj -> do
|
|
||||||
package <- PackageName <$> (obj .: "deprecated-package")
|
|
||||||
inFavourOf <- map PackageName <$> (obj .: "in-favour-of")
|
|
||||||
return $ DeprecationRecord package inFavourOf
|
|
||||||
|
|
||||||
toDeprecated :: DeprecationRecord -> Deprecated
|
|
||||||
toDeprecated (DeprecationRecord deprecated _) = Deprecated deprecated
|
|
||||||
|
|
||||||
toSuggestions :: DeprecationRecord -> [Suggested]
|
|
||||||
toSuggestions (DeprecationRecord deprecated inFavourOf) =
|
|
||||||
map toSuggestion inFavourOf
|
|
||||||
where
|
|
||||||
toSuggestion favoured = Suggested {
|
|
||||||
suggestedPackage = favoured,
|
|
||||||
suggestedInsteadOf = deprecated
|
|
||||||
}
|
|
||||||
|
|
||||||
loadDeprecationInfo ::
|
|
||||||
( HasHttpManager env
|
|
||||||
, MonadReader env m
|
|
||||||
, MonadThrow m
|
|
||||||
, MonadIO m)
|
|
||||||
=> m (Either String HackageDeprecationInfo)
|
|
||||||
loadDeprecationInfo = do
|
|
||||||
req <- parseUrl "http://hackage.haskell.org/packages/deprecated.json"
|
|
||||||
res <- httpLbs req
|
|
||||||
return $! Aeson.eitherDecode (responseBody res)
|
|
||||||
@ -1,504 +0,0 @@
|
|||||||
-- | Code for unpacking documentation bundles, building the Hoogle databases,
|
|
||||||
-- and compressing/deduping contents.
|
|
||||||
module Data.Unpacking
|
|
||||||
( newDocUnpacker
|
|
||||||
, getHoogleDB
|
|
||||||
, makeHoogle
|
|
||||||
, createHoogleDatabases
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Async
|
|
||||||
import Data.Conduit.Process
|
|
||||||
import Import hiding (runDB)
|
|
||||||
import Data.BlobStore
|
|
||||||
import Handler.Haddock
|
|
||||||
import Filesystem (createTree, isFile, removeTree, isDirectory, listDirectory, removeDirectory, removeFile, rename)
|
|
||||||
import System.Posix.Files (createLink)
|
|
||||||
import Crypto.Hash.Conduit (sinkHash)
|
|
||||||
import Control.Concurrent (forkIO)
|
|
||||||
import Control.Monad.Trans.Resource (allocate, release)
|
|
||||||
import Data.Char (isAlpha)
|
|
||||||
import qualified Hoogle
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Yaml as Y
|
|
||||||
import System.IO (IOMode (ReadMode), withBinaryFile, openBinaryFile)
|
|
||||||
import System.IO.Temp (withSystemTempFile, withTempFile, withSystemTempDirectory)
|
|
||||||
import System.Exit (ExitCode (ExitSuccess))
|
|
||||||
import qualified Filesystem.Path.CurrentOS as F
|
|
||||||
import Data.Conduit.Zlib (gzip, ungzip)
|
|
||||||
import qualified Data.ByteString.Base16 as B16
|
|
||||||
import Data.Byteable (toBytes)
|
|
||||||
import Crypto.Hash (Digest, SHA1)
|
|
||||||
|
|
||||||
newDocUnpacker
|
|
||||||
:: FilePath -- ^ haddock root
|
|
||||||
-> BlobStore StoreKey
|
|
||||||
-> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a)
|
|
||||||
-> IO DocUnpacker
|
|
||||||
newDocUnpacker root store runDB = do
|
|
||||||
createDirs dirs
|
|
||||||
|
|
||||||
statusMapVar <- newTVarIO $ asMap mempty
|
|
||||||
messageVar <- newTVarIO "Inactive"
|
|
||||||
workChan <- atomically newTChan
|
|
||||||
|
|
||||||
let requestDocs forceUnpack ent = atomically $ do
|
|
||||||
var <- newTVar USBusy
|
|
||||||
modifyTVar statusMapVar
|
|
||||||
$ insertMap (stackageSlug $ entityVal ent) var
|
|
||||||
writeTChan workChan (forceUnpack, ent, var)
|
|
||||||
|
|
||||||
forkForever $ unpackWorker dirs runDB store messageVar workChan
|
|
||||||
|
|
||||||
return DocUnpacker
|
|
||||||
{ duRequestDocs = \ent -> do
|
|
||||||
m <- readTVarIO statusMapVar
|
|
||||||
case lookup (stackageSlug $ entityVal ent) m of
|
|
||||||
Nothing -> do
|
|
||||||
b <- isUnpacked dirs (entityVal ent)
|
|
||||||
if b
|
|
||||||
then return USReady
|
|
||||||
else do
|
|
||||||
requestDocs False ent
|
|
||||||
return USBusy
|
|
||||||
Just us -> readTVarIO us
|
|
||||||
, duGetStatus = readTVarIO messageVar
|
|
||||||
, duForceReload = \ent -> do
|
|
||||||
atomically $ modifyTVar statusMapVar
|
|
||||||
$ deleteMap (stackageSlug $ entityVal ent)
|
|
||||||
requestDocs True ent
|
|
||||||
}
|
|
||||||
where
|
|
||||||
dirs = mkDirs root
|
|
||||||
|
|
||||||
createDirs :: Dirs -> IO ()
|
|
||||||
createDirs dirs = do
|
|
||||||
createTree $ dirCacheRoot dirs
|
|
||||||
createTree $ dirRawRoot dirs
|
|
||||||
createTree $ dirGzRoot dirs
|
|
||||||
createTree $ dirHoogleRoot dirs
|
|
||||||
|
|
||||||
-- | Check for the presence of file system artifacts indicating that the docs
|
|
||||||
-- have been unpacked.
|
|
||||||
isUnpacked :: Dirs -> Stackage -> IO Bool
|
|
||||||
isUnpacked dirs stackage = isFile $ completeUnpackFile dirs stackage
|
|
||||||
|
|
||||||
defaultHooDest :: Dirs -> Stackage -> FilePath
|
|
||||||
defaultHooDest dirs stackage = dirHoogleFp dirs (stackageIdent stackage)
|
|
||||||
["default-" ++ VERSION_hoogle ++ ".hoo"]
|
|
||||||
|
|
||||||
forkForever :: IO () -> IO ()
|
|
||||||
forkForever inner = mask $ \restore ->
|
|
||||||
void $ forkIO $ forever $ handleAny print $ restore $ forever inner
|
|
||||||
|
|
||||||
unpackWorker
|
|
||||||
:: Dirs
|
|
||||||
-> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a)
|
|
||||||
-> BlobStore StoreKey
|
|
||||||
-> TVar Text
|
|
||||||
-> TChan (Bool, Entity Stackage, TVar UnpackStatus)
|
|
||||||
-> IO ()
|
|
||||||
unpackWorker dirs runDB store messageVar workChan = do
|
|
||||||
let say' = atomically . writeTVar messageVar
|
|
||||||
say' "Running the compressor"
|
|
||||||
let shouldStop = fmap not $ atomically $ isEmptyTChan workChan
|
|
||||||
handleAny print $ runCompressor shouldStop say' dirs
|
|
||||||
|
|
||||||
say' "Waiting for new work item"
|
|
||||||
(forceUnpack, ent, resVar) <- atomically $ readTChan workChan
|
|
||||||
shouldUnpack <-
|
|
||||||
if forceUnpack
|
|
||||||
then return True
|
|
||||||
else not <$> isUnpacked dirs (entityVal ent)
|
|
||||||
|
|
||||||
let say msg = atomically $ writeTVar messageVar $ concat
|
|
||||||
[ toPathPiece (stackageSlug $ entityVal ent)
|
|
||||||
, ": "
|
|
||||||
, msg
|
|
||||||
]
|
|
||||||
|
|
||||||
when shouldUnpack $ do
|
|
||||||
say "Beginning of processing"
|
|
||||||
|
|
||||||
-- As soon as the raw unpack is complete, start serving docs
|
|
||||||
let onRawComplete = atomically $ writeTVar resVar USReady
|
|
||||||
|
|
||||||
eres <- tryAny $ unpacker dirs runDB store say onRawComplete ent
|
|
||||||
atomically $ writeTVar resVar $ case eres of
|
|
||||||
Left e -> USFailed $ tshow e
|
|
||||||
Right () -> USReady
|
|
||||||
|
|
||||||
removeTreeIfExists :: FilePath -> IO ()
|
|
||||||
removeTreeIfExists fp = whenM (isDirectory fp) (removeTree fp)
|
|
||||||
|
|
||||||
unpackRawDocsTo
|
|
||||||
:: BlobStore StoreKey
|
|
||||||
-> PackageSetIdent
|
|
||||||
-> (Text -> IO ())
|
|
||||||
-> FilePath
|
|
||||||
-> IO ()
|
|
||||||
unpackRawDocsTo store ident say destdir =
|
|
||||||
withSystemTempFile "haddock-bundle.tar.xz" $ \tempfp temph -> do
|
|
||||||
say "Downloading raw doc tarball"
|
|
||||||
withAcquire (storeRead' store (HaddockBundle ident)) $ \msrc ->
|
|
||||||
case msrc of
|
|
||||||
Nothing -> error "No haddocks exist for that snapshot"
|
|
||||||
Just src -> src $$ sinkHandle temph
|
|
||||||
hClose temph
|
|
||||||
|
|
||||||
createTree destdir
|
|
||||||
say "Unpacking tarball"
|
|
||||||
(ClosedStream, out, err, cph) <- streamingProcess (proc "tar" ["xf", tempfp])
|
|
||||||
{ cwd = Just $ fpToString destdir
|
|
||||||
}
|
|
||||||
(ec, out', err') <- liftIO $ runConcurrently $ (,,)
|
|
||||||
<$> Concurrently (waitForStreamingProcess cph)
|
|
||||||
<*> Concurrently (out $$ foldC)
|
|
||||||
<*> Concurrently (err $$ foldC)
|
|
||||||
unless (ec == ExitSuccess) $ throwM
|
|
||||||
$ HaddockBundleUnpackException ec out' err'
|
|
||||||
|
|
||||||
data HaddockBundleUnpackException = HaddockBundleUnpackException
|
|
||||||
!ExitCode
|
|
||||||
!ByteString
|
|
||||||
!ByteString
|
|
||||||
deriving (Show, Typeable)
|
|
||||||
instance Exception HaddockBundleUnpackException
|
|
||||||
|
|
||||||
unpacker
|
|
||||||
:: Dirs
|
|
||||||
-> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a)
|
|
||||||
-> BlobStore StoreKey
|
|
||||||
-> (Text -> IO ())
|
|
||||||
-> IO () -- ^ onRawComplete
|
|
||||||
-> Entity Stackage
|
|
||||||
-> IO ()
|
|
||||||
unpacker dirs runDB store say onRawComplete (Entity sid stackage@Stackage {..}) = do
|
|
||||||
say "Removing old directories, if they exist"
|
|
||||||
removeTreeIfExists $ dirRawIdent dirs stackageIdent
|
|
||||||
removeTreeIfExists $ dirGzIdent dirs stackageIdent
|
|
||||||
removeTreeIfExists $ dirHoogleIdent dirs stackageIdent
|
|
||||||
|
|
||||||
let destdir = dirRawIdent dirs stackageIdent
|
|
||||||
unpackRawDocsTo store stackageIdent say destdir
|
|
||||||
onRawComplete
|
|
||||||
|
|
||||||
createTree $ dirHoogleIdent dirs stackageIdent
|
|
||||||
|
|
||||||
-- Determine which packages have documentation and update the
|
|
||||||
-- database appropriately
|
|
||||||
say "Updating database for available documentation"
|
|
||||||
runResourceT $ runDB $ do
|
|
||||||
updateWhere
|
|
||||||
[PackageStackage ==. sid]
|
|
||||||
[PackageHasHaddocks =. False]
|
|
||||||
sourceDirectory destdir $$ mapM_C (\fp -> do
|
|
||||||
let mnv = nameAndVersionFromPath fp
|
|
||||||
forM_ mnv $ \(name, version) -> updateWhere
|
|
||||||
[ PackageStackage ==. sid
|
|
||||||
, PackageName' ==. PackageName name
|
|
||||||
, PackageVersion ==. Version version
|
|
||||||
]
|
|
||||||
[PackageHasHaddocks =. True]
|
|
||||||
)
|
|
||||||
|
|
||||||
say "Unpack complete"
|
|
||||||
let completeFP = completeUnpackFile dirs stackage
|
|
||||||
liftIO $ do
|
|
||||||
createTree $ F.parent completeFP
|
|
||||||
writeFile completeFP ("Complete" :: ByteString)
|
|
||||||
|
|
||||||
completeUnpackFile :: Dirs -> Stackage -> FilePath
|
|
||||||
completeUnpackFile dirs stackage =
|
|
||||||
dirGzIdent dirs (stackageIdent stackage) </> "unpack-complete"
|
|
||||||
|
|
||||||
-- | Get the path to the Hoogle database, downloading from persistent storage
|
|
||||||
-- if necessary. This function will /not/ generate a new database, and
|
|
||||||
-- therefore is safe to run on a live web server.
|
|
||||||
getHoogleDB :: Dirs
|
|
||||||
-> Stackage
|
|
||||||
-> Handler (Maybe FilePath)
|
|
||||||
getHoogleDB dirs stackage = do
|
|
||||||
exists <- liftIO $ isFile fp
|
|
||||||
if exists
|
|
||||||
then return $ Just fp
|
|
||||||
else do
|
|
||||||
msrc <- storeRead key
|
|
||||||
case msrc of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just src -> do
|
|
||||||
liftIO $ createTree $ F.parent fp
|
|
||||||
let tmpfp = fp <.> "tmp" -- FIXME add something random
|
|
||||||
src $$ ungzip =$ sinkFile tmpfp
|
|
||||||
liftIO $ rename tmpfp fp
|
|
||||||
return $ Just fp
|
|
||||||
where
|
|
||||||
fp = defaultHooDest dirs stackage
|
|
||||||
key = HoogleDB (stackageIdent stackage) $ HoogleVersion VERSION_hoogle
|
|
||||||
|
|
||||||
-- | Make sure that the last 5 LTS and last 5 Nightly releases all have Hoogle
|
|
||||||
-- databases available.
|
|
||||||
createHoogleDatabases
|
|
||||||
:: BlobStore StoreKey
|
|
||||||
-> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a)
|
|
||||||
-> (Text -> IO ())
|
|
||||||
-> (Route App -> [(Text, Text)] -> Text)
|
|
||||||
-> IO ()
|
|
||||||
createHoogleDatabases store runDB say urlRender = do
|
|
||||||
stackages <- runDB $ do
|
|
||||||
sids <- (++)
|
|
||||||
<$> fmap (map $ ltsStackage . entityVal)
|
|
||||||
(selectList [] [Desc LtsMajor, Desc LtsMinor, LimitTo 5])
|
|
||||||
<*> fmap (map $ nightlyStackage . entityVal)
|
|
||||||
(selectList [] [Desc NightlyDay, LimitTo 5])
|
|
||||||
catMaybes <$> mapM get sids
|
|
||||||
forM_ stackages $ \stackage -> do
|
|
||||||
let say' x = say $ concat
|
|
||||||
[ toPathPiece $ stackageSlug stackage
|
|
||||||
, ": "
|
|
||||||
, x
|
|
||||||
]
|
|
||||||
handleAny (say' . tshow) $ makeHoogle store say' urlRender stackage
|
|
||||||
|
|
||||||
-- | Either download the Hoogle database from persistent storage, or create it.
|
|
||||||
makeHoogle
|
|
||||||
:: BlobStore StoreKey
|
|
||||||
-> (Text -> IO ())
|
|
||||||
-> (Route App -> [(Text, Text)] -> Text)
|
|
||||||
-> Stackage
|
|
||||||
-> IO ()
|
|
||||||
makeHoogle store say urlRender stackage = do
|
|
||||||
say "Making hoogle database"
|
|
||||||
exists <- storeExists' store hoogleKey
|
|
||||||
if exists
|
|
||||||
then say "Hoogle database already exists, skipping"
|
|
||||||
else do
|
|
||||||
say "Generating Hoogle database"
|
|
||||||
generate
|
|
||||||
where
|
|
||||||
ident = stackageIdent stackage
|
|
||||||
hoogleKey = HoogleDB ident $ HoogleVersion VERSION_hoogle
|
|
||||||
|
|
||||||
generate = withSystemTempDirectory "hoogle-database-gen" $ \hoogletemp' -> do
|
|
||||||
let hoogletemp = fpFromString hoogletemp'
|
|
||||||
rawdocs = hoogletemp </> "rawdocs"
|
|
||||||
|
|
||||||
unpackRawDocsTo store ident say rawdocs
|
|
||||||
|
|
||||||
say "Copying Hoogle text files to temp directory"
|
|
||||||
runResourceT $ copyHoogleTextFiles say rawdocs hoogletemp
|
|
||||||
say "Creating Hoogle database"
|
|
||||||
withSystemTempFile "default.hoo" $ \dstFP' dstH -> do
|
|
||||||
let dstFP = fpFromString dstFP'
|
|
||||||
hClose dstH
|
|
||||||
createHoogleDb say dstFP stackage hoogletemp urlRender
|
|
||||||
say "Uploading database to persistent storage"
|
|
||||||
withAcquire (storeWrite' store hoogleKey) $ \sink ->
|
|
||||||
runResourceT $ sourceFile dstFP $$ gzip =$ sink
|
|
||||||
|
|
||||||
runCompressor :: IO Bool -- ^ should stop early?
|
|
||||||
-> (Text -> IO ()) -> Dirs -> IO ()
|
|
||||||
runCompressor shouldStop say dirs =
|
|
||||||
handle (\EarlyStop -> return ()) $ runResourceT $ goDir $ dirRawRoot dirs
|
|
||||||
where
|
|
||||||
goDir dir = do
|
|
||||||
liftIO $ whenM shouldStop $ do
|
|
||||||
say "Stopping compressor early"
|
|
||||||
throwIO EarlyStop
|
|
||||||
liftIO $ say $ "Compressing directory: " ++ fpToText dir
|
|
||||||
sourceDirectory dir $$ mapM_C goFP
|
|
||||||
liftIO $ void $ tryIO $ removeDirectory dir
|
|
||||||
|
|
||||||
goFP fp = do
|
|
||||||
e <- liftIO $ isFile fp
|
|
||||||
if e
|
|
||||||
then liftIO $ do
|
|
||||||
liftIO $ say $ "Compressing file: " ++ fpToText fp
|
|
||||||
handle (print . asSomeException)
|
|
||||||
$ gzipHash dirs suffix
|
|
||||||
else goDir fp
|
|
||||||
where
|
|
||||||
Just suffix = F.stripPrefix (dirRawRoot dirs </> "") fp
|
|
||||||
|
|
||||||
data EarlyStop = EarlyStop
|
|
||||||
deriving (Show, Typeable)
|
|
||||||
instance Exception EarlyStop
|
|
||||||
|
|
||||||
-- Procedure is to:
|
|
||||||
--
|
|
||||||
-- * Gzip the src file to a temp file, and get a hash of the gzipped contents
|
|
||||||
-- * If that hash doesn't exist in the cache, move the new file to the cache
|
|
||||||
-- * Create a hard link from dst to the file in the cache
|
|
||||||
-- * Delete src
|
|
||||||
gzipHash :: Dirs
|
|
||||||
-> FilePath -- ^ suffix
|
|
||||||
-> IO ()
|
|
||||||
gzipHash dirs suffix = do
|
|
||||||
withTempFile (fpToString $ dirCacheRoot dirs) "haddock-file.gz" $ \tempfp temph -> do
|
|
||||||
digest <- withBinaryFile (fpToString src) ReadMode $ \inh ->
|
|
||||||
sourceHandle inh
|
|
||||||
$= gzip
|
|
||||||
$$ (getZipSink $
|
|
||||||
ZipSink (sinkHandle temph) *>
|
|
||||||
ZipSink sinkHash)
|
|
||||||
hClose temph
|
|
||||||
let fpcache = dirCacheFp dirs digest
|
|
||||||
unlessM (isFile fpcache) $ do
|
|
||||||
createTree $ F.parent fpcache
|
|
||||||
rename (fpFromString tempfp) fpcache
|
|
||||||
createTree $ F.parent dst
|
|
||||||
createLink (fpToString fpcache) (fpToString dst)
|
|
||||||
removeFile src
|
|
||||||
where
|
|
||||||
src = dirRawRoot dirs </> suffix
|
|
||||||
dst = dirGzRoot dirs </> suffix
|
|
||||||
|
|
||||||
dirCacheFp :: Dirs -> Digest SHA1 -> FilePath
|
|
||||||
dirCacheFp dirs digest =
|
|
||||||
dirCacheRoot dirs </> fpFromText x </> fpFromText y <.> "gz"
|
|
||||||
where
|
|
||||||
name = decodeUtf8 $ B16.encode $ toBytes digest
|
|
||||||
(x, y) = splitAt 2 name
|
|
||||||
|
|
||||||
copyHoogleTextFiles :: (Text -> IO ()) -- ^ log
|
|
||||||
-> FilePath -- ^ raw unpacked Haddock files
|
|
||||||
-> FilePath -- ^ temporary work directory
|
|
||||||
-> ResourceT IO ()
|
|
||||||
copyHoogleTextFiles say raw tmp = do
|
|
||||||
let tmptext = tmp </> "text"
|
|
||||||
liftIO $ createTree tmptext
|
|
||||||
sourceDirectory raw $$ mapM_C (\fp ->
|
|
||||||
forM_ (nameAndVersionFromPath fp) $ \(name, version) -> do
|
|
||||||
let src = fp </> fpFromText name <.> "txt"
|
|
||||||
dst = tmptext </> fpFromText (name ++ "-" ++ version)
|
|
||||||
exists <- liftIO $ isFile src
|
|
||||||
if exists
|
|
||||||
then sourceFile src $$ (sinkFile dst :: Sink ByteString (ResourceT IO) ())
|
|
||||||
else liftIO $ appendHoogleErrors say $ HoogleErrors
|
|
||||||
{ packageName = name
|
|
||||||
, packageVersion = version
|
|
||||||
, errors = ["No textual Hoogle DB (use \"cabal haddock --hoogle\")"]
|
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
createHoogleDb :: (Text -> IO ())
|
|
||||||
-> FilePath -- ^ default.hoo output location
|
|
||||||
-> Stackage
|
|
||||||
-> FilePath -- ^ temp directory
|
|
||||||
-> (Route App -> [(Text, Text)] -> Text)
|
|
||||||
-> IO ()
|
|
||||||
createHoogleDb say dstDefaultHoo stackage tmpdir urlRender = do
|
|
||||||
let tmpbin = tmpdir </> "binary"
|
|
||||||
createTree tmpbin
|
|
||||||
eres <- tryAny $ runResourceT $ do
|
|
||||||
-- Create hoogle binary databases for each package.
|
|
||||||
sourceDirectory (tmpdir </> "text") $$ mapM_C
|
|
||||||
( \fp -> do
|
|
||||||
(releaseKey, srcH) <- allocate (openBinaryFile (fpToString fp) ReadMode) hClose
|
|
||||||
forM_ (nameAndVersionFromPath fp) $ \(name, version) -> liftIO $ do
|
|
||||||
say $ concat
|
|
||||||
[ "Creating Hoogle database for: "
|
|
||||||
, name
|
|
||||||
, "-"
|
|
||||||
, version
|
|
||||||
]
|
|
||||||
src <- unpack . decodeUtf8 . asLByteString <$> hGetContents srcH
|
|
||||||
let -- Preprocess the haddock-generated manifest file.
|
|
||||||
src' = unlines $ haddockHacks (Just (unpack docsUrl)) $ lines src
|
|
||||||
docsUrl = urlRender (HaddockR (stackageSlug stackage) urlPieces) []
|
|
||||||
urlPieces = [name <> "-" <> version, "index.html"]
|
|
||||||
-- Compute the filepath of the resulting hoogle
|
|
||||||
-- database.
|
|
||||||
out = fpToString $ tmpbin </> fpFromText base
|
|
||||||
base = name <> "-" <> version <> ".hoo"
|
|
||||||
errs <- Hoogle.createDatabase "" Hoogle.Haskell [] src' out
|
|
||||||
when (not $ null errs) $ do
|
|
||||||
-- TODO: remove this printing once errors are yielded
|
|
||||||
-- to the user.
|
|
||||||
putStrLn $ concat
|
|
||||||
[ base
|
|
||||||
, " Hoogle errors: "
|
|
||||||
, tshow errs
|
|
||||||
]
|
|
||||||
appendHoogleErrors say $ HoogleErrors
|
|
||||||
{ packageName = name
|
|
||||||
, packageVersion = version
|
|
||||||
, errors = map show errs
|
|
||||||
}
|
|
||||||
release releaseKey
|
|
||||||
)
|
|
||||||
-- Merge the individual binary databases into one big database.
|
|
||||||
liftIO $ do
|
|
||||||
say "Merging all Hoogle databases"
|
|
||||||
dbs <- listDirectory tmpbin
|
|
||||||
Hoogle.mergeDatabase
|
|
||||||
(map fpToString dbs)
|
|
||||||
(fpToString dstDefaultHoo)
|
|
||||||
case eres of
|
|
||||||
Right () -> return ()
|
|
||||||
Left err -> liftIO $ appendHoogleErrors say $ HoogleErrors
|
|
||||||
{ packageName = "Exception thrown while building hoogle DB"
|
|
||||||
, packageVersion = ""
|
|
||||||
, errors = [show err]
|
|
||||||
}
|
|
||||||
|
|
||||||
data HoogleErrors = HoogleErrors
|
|
||||||
{ packageName :: Text
|
|
||||||
, packageVersion :: Text
|
|
||||||
, errors :: [String]
|
|
||||||
} deriving (Generic)
|
|
||||||
|
|
||||||
instance ToJSON HoogleErrors where
|
|
||||||
instance FromJSON HoogleErrors where
|
|
||||||
|
|
||||||
-- Appends hoogle errors to a log file. By encoding within a single
|
|
||||||
-- list, the resulting file can be decoded as [HoogleErrors].
|
|
||||||
appendHoogleErrors :: (Text -> IO ()) -> HoogleErrors -> IO ()
|
|
||||||
appendHoogleErrors say errs = say $ decodeUtf8 $ Y.encode [errs]
|
|
||||||
|
|
||||||
nameAndVersionFromPath :: FilePath -> Maybe (Text, Text)
|
|
||||||
nameAndVersionFromPath fp =
|
|
||||||
(\name -> (name, version)) <$> stripSuffix "-" name'
|
|
||||||
where
|
|
||||||
(name', version) = T.breakOnEnd "-" $ fpToText $ filename fp
|
|
||||||
|
|
||||||
---------------------------------------------------------------------
|
|
||||||
-- HADDOCK HACKS
|
|
||||||
-- (Copied from hoogle-4.2.36/src/Recipe/Haddock.hs)
|
|
||||||
-- Modifications:
|
|
||||||
-- 1) Some name qualification
|
|
||||||
-- 2) Explicit type sig due to polymorphic elem
|
|
||||||
-- 3) Fixed an unused binding warning
|
|
||||||
|
|
||||||
-- Eliminate @version
|
|
||||||
-- Change :*: to (:*:), Haddock bug
|
|
||||||
-- Change !!Int to !Int, Haddock bug
|
|
||||||
-- Change instance [overlap ok] to instance, Haddock bug
|
|
||||||
-- Change instance [incoherent] to instance, Haddock bug
|
|
||||||
-- Change instance [safe] to instance, Haddock bug
|
|
||||||
-- Change !Int to Int, HSE bug
|
|
||||||
-- Drop {-# UNPACK #-}, Haddock bug
|
|
||||||
-- Drop everything after where, Haddock bug
|
|
||||||
|
|
||||||
haddockHacks :: Maybe Hoogle.URL -> [String] -> [String]
|
|
||||||
haddockHacks loc src = maybe id haddockPackageUrl loc (translate src)
|
|
||||||
where
|
|
||||||
translate :: [String] -> [String]
|
|
||||||
translate = map (unwords . g . map f . words) . filter (not . isPrefixOf "@version ")
|
|
||||||
|
|
||||||
f "::" = "::"
|
|
||||||
f (':':xs) = "(:" ++ xs ++ ")"
|
|
||||||
f ('!':'!':x:xs) | isAlpha x = xs
|
|
||||||
f ('!':x:xs) | isAlpha x || x `elem` ("[(" :: String) = x:xs
|
|
||||||
f x | x `elem` ["[overlap","ok]","[incoherent]","[safe]"] = ""
|
|
||||||
f x | x `elem` ["{-#","UNPACK","#-}"] = ""
|
|
||||||
f x = x
|
|
||||||
|
|
||||||
g ("where":_) = []
|
|
||||||
g (x:xs) = x : g xs
|
|
||||||
g [] = []
|
|
||||||
|
|
||||||
haddockPackageUrl :: Hoogle.URL -> [String] -> [String]
|
|
||||||
haddockPackageUrl x = concatMap f
|
|
||||||
where f y | "@package " `isPrefixOf` y = ["@url " ++ x, y]
|
|
||||||
| otherwise = [y]
|
|
||||||
@ -18,7 +18,7 @@ import Types
|
|||||||
import Yesod.Auth
|
import Yesod.Auth
|
||||||
import Yesod.Auth.BrowserId
|
import Yesod.Auth.BrowserId
|
||||||
import Yesod.Auth.GoogleEmail2 (authGoogleEmail)
|
import Yesod.Auth.GoogleEmail2 (authGoogleEmail)
|
||||||
import Yesod.Core.Types (Logger, GWData)
|
import Yesod.Core.Types (Logger)
|
||||||
import Yesod.Default.Config
|
import Yesod.Default.Config
|
||||||
import Yesod.GitRepo
|
import Yesod.GitRepo
|
||||||
|
|
||||||
@ -35,25 +35,9 @@ data App = App
|
|||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
, genIO :: MWC.GenIO
|
, genIO :: MWC.GenIO
|
||||||
, blobStore :: BlobStore StoreKey
|
, blobStore :: BlobStore StoreKey
|
||||||
, haddockRootDir :: FilePath
|
|
||||||
, appDocUnpacker :: DocUnpacker
|
|
||||||
-- ^ We have a dedicated thread so that (1) we don't try to unpack too many
|
|
||||||
-- things at once, (2) we never unpack the same thing twice at the same
|
|
||||||
-- time, and (3) so that even if the client connection dies, we finish the
|
|
||||||
-- unpack job.
|
|
||||||
, widgetCache :: IORef (HashMap Text (UTCTime, GWData (Route App)))
|
|
||||||
, websiteContent :: GitRepo WebsiteContent
|
, websiteContent :: GitRepo WebsiteContent
|
||||||
}
|
}
|
||||||
|
|
||||||
data DocUnpacker = DocUnpacker
|
|
||||||
{ duRequestDocs :: Entity Stackage -> IO UnpackStatus
|
|
||||||
, duGetStatus :: IO Text
|
|
||||||
, duForceReload :: Entity Stackage -> IO ()
|
|
||||||
}
|
|
||||||
|
|
||||||
data Progress = ProgressWorking !Text
|
|
||||||
| ProgressDone !Text !(Route App)
|
|
||||||
|
|
||||||
instance HasBlobStore App StoreKey where
|
instance HasBlobStore App StoreKey where
|
||||||
getBlobStore = blobStore
|
getBlobStore = blobStore
|
||||||
|
|
||||||
@ -75,8 +59,6 @@ instance HasHackageRoot App where
|
|||||||
-- explanation for this split.
|
-- explanation for this split.
|
||||||
mkYesodData "App" $(parseRoutesFile "config/routes")
|
mkYesodData "App" $(parseRoutesFile "config/routes")
|
||||||
|
|
||||||
deriving instance Show Progress
|
|
||||||
|
|
||||||
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
|
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
|
||||||
|
|
||||||
defaultLayoutNoContainer :: Widget -> Handler Html
|
defaultLayoutNoContainer :: Widget -> Handler Html
|
||||||
@ -167,16 +149,12 @@ instance Yesod App where
|
|||||||
|
|
||||||
makeLogger = return . appLogger
|
makeLogger = return . appLogger
|
||||||
|
|
||||||
maximumContentLength _ (Just UploadStackageR) = Just 50000000
|
|
||||||
maximumContentLength _ (Just UploadHaddockR{}) = Just 100000000
|
|
||||||
maximumContentLength _ (Just UploadV2R) = Just 100000000
|
|
||||||
maximumContentLength _ _ = Just 2000000
|
maximumContentLength _ _ = Just 2000000
|
||||||
|
|
||||||
instance ToMarkup (Route App) where
|
instance ToMarkup (Route App) where
|
||||||
toMarkup c =
|
toMarkup c =
|
||||||
case c of
|
case c of
|
||||||
AllSnapshotsR{} -> "Snapshots"
|
AllSnapshotsR{} -> "Snapshots"
|
||||||
UploadStackageR{} -> "Upload"
|
|
||||||
AuthR (LoginR{}) -> "Login"
|
AuthR (LoginR{}) -> "Login"
|
||||||
_ -> ""
|
_ -> ""
|
||||||
|
|
||||||
|
|||||||
@ -1,86 +0,0 @@
|
|||||||
module Handler.Alias
|
|
||||||
( handleAliasR
|
|
||||||
, getLtsR
|
|
||||||
, getNightlyR
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
import Data.Slug (Slug)
|
|
||||||
import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR, getSnapshotPackagesR, getDocsR)
|
|
||||||
import Handler.StackageIndex (getStackageIndexR)
|
|
||||||
import Handler.StackageSdist (getStackageSdistR)
|
|
||||||
import Handler.Hoogle (getHoogleR, getHoogleDatabaseR)
|
|
||||||
import Handler.BuildPlan (getBuildPlanR)
|
|
||||||
import Handler.Download (getGhcMajorVersionR)
|
|
||||||
|
|
||||||
handleAliasR :: Slug -> Slug -> [Text] -> Handler ()
|
|
||||||
handleAliasR user name pieces = do
|
|
||||||
$logDebug $ tshow (user, name, pieces)
|
|
||||||
Entity _ (Alias _ _ setid) <- runDB $ do
|
|
||||||
Entity uid _ <- getBy404 $ UniqueHandle user
|
|
||||||
getBy404 $ UniqueAlias uid name
|
|
||||||
$logDebug $ "setid: " ++ tshow (setid, pieces)
|
|
||||||
case parseRoute ("stackage" : toPathPiece setid : pieces, []) of
|
|
||||||
Nothing -> notFound
|
|
||||||
Just route -> redirect (route :: Route App)
|
|
||||||
|
|
||||||
getLtsR :: [Text] -> Handler ()
|
|
||||||
getLtsR pieces0 =
|
|
||||||
case pieces0 of
|
|
||||||
[] -> go []
|
|
||||||
piece:pieces'
|
|
||||||
| Just (x, y) <- parseLtsPair piece -> goXY x y pieces'
|
|
||||||
| Just x <- fromPathPiece piece -> goX x pieces'
|
|
||||||
| otherwise -> go pieces0
|
|
||||||
where
|
|
||||||
go pieces = do
|
|
||||||
mlts <- runDB $ selectFirst [] [Desc LtsMajor, Desc LtsMinor]
|
|
||||||
case mlts of
|
|
||||||
Nothing -> notFound
|
|
||||||
Just (Entity _ (Lts _ _ sid)) -> goSid sid pieces
|
|
||||||
|
|
||||||
goX x pieces = do
|
|
||||||
mlts <- runDB $ selectFirst [LtsMajor ==. x] [Desc LtsMinor]
|
|
||||||
case mlts of
|
|
||||||
Nothing -> notFound
|
|
||||||
Just (Entity _ (Lts _ _ sid)) -> goSid sid pieces
|
|
||||||
|
|
||||||
goXY x y pieces = do
|
|
||||||
Entity _ (Lts _ _ sid) <- runDB $ getBy404 $ UniqueLts x y
|
|
||||||
goSid sid pieces
|
|
||||||
|
|
||||||
getNightlyR :: [Text] -> Handler ()
|
|
||||||
getNightlyR pieces0 =
|
|
||||||
case pieces0 of
|
|
||||||
[] -> go []
|
|
||||||
piece:pieces'
|
|
||||||
| Just day <- fromPathPiece piece -> goDay day pieces'
|
|
||||||
| otherwise -> go pieces0
|
|
||||||
where
|
|
||||||
go pieces = do
|
|
||||||
mn <- runDB $ selectFirst [] [Desc NightlyDay]
|
|
||||||
case mn of
|
|
||||||
Nothing -> notFound
|
|
||||||
Just (Entity _ (Nightly _ _ sid)) -> goSid sid pieces
|
|
||||||
goDay day pieces = do
|
|
||||||
Entity _ (Nightly _ _ sid) <- runDB $ getBy404 $ UniqueNightly day
|
|
||||||
goSid sid pieces
|
|
||||||
|
|
||||||
goSid :: StackageId -> [Text] -> Handler ()
|
|
||||||
goSid sid pieces = do
|
|
||||||
s <- runDB $ get404 sid
|
|
||||||
case parseRoute ("snapshot" : toPathPiece (stackageSlug s) : pieces, []) of
|
|
||||||
Just (SnapshotR slug sr) ->
|
|
||||||
case sr of
|
|
||||||
StackageHomeR -> getStackageHomeR slug >>= sendResponse
|
|
||||||
StackageMetadataR -> getStackageMetadataR slug >>= sendResponse
|
|
||||||
StackageCabalConfigR -> getStackageCabalConfigR slug >>= sendResponse
|
|
||||||
StackageIndexR -> getStackageIndexR slug >>= sendResponse
|
|
||||||
StackageSdistR pnv -> getStackageSdistR slug pnv >>= sendResponse
|
|
||||||
SnapshotPackagesR -> getSnapshotPackagesR slug >>= sendResponse
|
|
||||||
DocsR -> getDocsR slug >>= sendResponse
|
|
||||||
HoogleR -> getHoogleR slug >>= sendResponse
|
|
||||||
HoogleDatabaseR -> getHoogleDatabaseR slug >>= sendResponse
|
|
||||||
BuildPlanR -> getBuildPlanR slug >>= sendResponse
|
|
||||||
GhcMajorVersionR -> getGhcMajorVersionR slug >>= sendResponse
|
|
||||||
_ -> notFound
|
|
||||||
@ -1,23 +0,0 @@
|
|||||||
module Handler.Aliases where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
import Data.Text (strip)
|
|
||||||
|
|
||||||
putAliasesR :: Handler ()
|
|
||||||
putAliasesR = do
|
|
||||||
uid <- requireAuthId
|
|
||||||
aliasesText <- runInputPost $ ireq textField "aliases"
|
|
||||||
aliases <- mapM (parseAlias uid) $ lines aliasesText
|
|
||||||
runDB $ do
|
|
||||||
deleteWhere [AliasUser ==. uid]
|
|
||||||
mapM_ insert_ aliases
|
|
||||||
setMessage "Aliases updated"
|
|
||||||
redirect ProfileR
|
|
||||||
|
|
||||||
parseAlias :: UserId -> Text -> Handler Alias
|
|
||||||
parseAlias uid t = maybe (invalidArgs ["Invalid alias: " ++ t]) return $ do
|
|
||||||
name <- fromPathPiece x
|
|
||||||
setid <- fromPathPiece y
|
|
||||||
return $ Alias uid name setid
|
|
||||||
where
|
|
||||||
(strip -> x, (strip . drop 1) -> y) = break (== ':') t
|
|
||||||
@ -1,14 +0,0 @@
|
|||||||
module Handler.CompressorStatus where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
|
|
||||||
getCompressorStatusR :: Handler Html
|
|
||||||
getCompressorStatusR = do
|
|
||||||
status <- getYesod >>= liftIO . duGetStatus . appDocUnpacker
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "Compressor thread status"
|
|
||||||
[whamlet|
|
|
||||||
<div .container>
|
|
||||||
<h1>Compressor thread status
|
|
||||||
<p>#{status}
|
|
||||||
|]
|
|
||||||
@ -36,6 +36,7 @@ getDownloadR = defaultLayout $ do
|
|||||||
setTitle "Download"
|
setTitle "Download"
|
||||||
$(widgetFile "download")
|
$(widgetFile "download")
|
||||||
|
|
||||||
|
{- FIXME
|
||||||
ltsMajorVersions :: YesodDB App [Lts]
|
ltsMajorVersions :: YesodDB App [Lts]
|
||||||
ltsMajorVersions =
|
ltsMajorVersions =
|
||||||
(dropOldMinors . map entityVal)
|
(dropOldMinors . map entityVal)
|
||||||
@ -47,12 +48,15 @@ dropOldMinors (l@(Lts x _ _):rest) =
|
|||||||
l : dropOldMinors (dropWhile sameMinor rest)
|
l : dropOldMinors (dropWhile sameMinor rest)
|
||||||
where
|
where
|
||||||
sameMinor (Lts y _ _) = x == y
|
sameMinor (Lts y _ _) = x == y
|
||||||
|
-}
|
||||||
|
|
||||||
getDownloadSnapshotsJsonR :: Handler Value
|
getDownloadSnapshotsJsonR :: Handler Value
|
||||||
getDownloadSnapshotsJsonR = getDownloadLtsSnapshotsJsonR
|
getDownloadSnapshotsJsonR = getDownloadLtsSnapshotsJsonR
|
||||||
|
|
||||||
getDownloadLtsSnapshotsJsonR :: Handler Value
|
getDownloadLtsSnapshotsJsonR :: Handler Value
|
||||||
getDownloadLtsSnapshotsJsonR = do
|
getDownloadLtsSnapshotsJsonR = do
|
||||||
|
error "getDownloadLtsSnapshotsJsonR"
|
||||||
|
{-
|
||||||
(mlatestNightly, ltses) <- runDB $ (,)
|
(mlatestNightly, ltses) <- runDB $ (,)
|
||||||
<$> getLatestNightly
|
<$> getLatestNightly
|
||||||
<*> ltsMajorVersions
|
<*> ltsMajorVersions
|
||||||
@ -82,11 +86,15 @@ ghcMajorVersionText snapshot
|
|||||||
= ghcMajorVersionToText
|
= ghcMajorVersionToText
|
||||||
$ fromMaybe (GhcMajorVersion 7 8)
|
$ fromMaybe (GhcMajorVersion 7 8)
|
||||||
$ stackageGhcMajorVersion snapshot
|
$ stackageGhcMajorVersion snapshot
|
||||||
|
-}
|
||||||
|
|
||||||
getGhcMajorVersionR :: SnapSlug -> Handler Text
|
getGhcMajorVersionR :: SnapSlug -> Handler Text
|
||||||
getGhcMajorVersionR slug = do
|
getGhcMajorVersionR _slug = do
|
||||||
|
error "getGhcMajorVersionR"
|
||||||
|
{-
|
||||||
snapshot <- runDB $ getBy404 $ UniqueSnapshot slug
|
snapshot <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
return $ ghcMajorVersionText $ entityVal snapshot
|
return $ ghcMajorVersionText $ entityVal snapshot
|
||||||
|
-}
|
||||||
|
|
||||||
getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent
|
getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent
|
||||||
getDownloadGhcLinksR arch fileName = do
|
getDownloadGhcLinksR arch fileName = do
|
||||||
|
|||||||
@ -1,15 +1,5 @@
|
|||||||
module Handler.Haddock
|
module Handler.Haddock
|
||||||
( getUploadHaddockR
|
( getHaddockR
|
||||||
, putUploadHaddockR
|
|
||||||
, getHaddockR
|
|
||||||
, getUploadDocMapR
|
|
||||||
, putUploadDocMapR
|
|
||||||
-- Exported for use in Handler.Hoogle
|
|
||||||
, Dirs (..), getDirs, dirHoogleFp, mkDirs
|
|
||||||
, dirRawIdent
|
|
||||||
, dirGzIdent
|
|
||||||
, dirHoogleIdent
|
|
||||||
, createCompressor
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Concurrent (forkIO)
|
import Control.Concurrent (forkIO)
|
||||||
@ -31,269 +21,8 @@ import System.IO (IOMode (ReadMode), withBinaryFile)
|
|||||||
import System.IO.Temp (withTempFile)
|
import System.IO.Temp (withTempFile)
|
||||||
import System.Posix.Files (createLink)
|
import System.Posix.Files (createLink)
|
||||||
|
|
||||||
form :: Form FileInfo
|
|
||||||
form = renderDivs $ areq fileField "tarball containing docs"
|
|
||||||
{ fsName = Just "tarball"
|
|
||||||
} Nothing
|
|
||||||
|
|
||||||
getUploadHaddockR, putUploadHaddockR :: Text -> Handler Html
|
|
||||||
getUploadHaddockR slug0 = do
|
|
||||||
uid <- requireAuthIdOrToken
|
|
||||||
stackageEnt@(Entity sid Stackage {..}) <- runDB $ do
|
|
||||||
-- Provide fallback for old URLs
|
|
||||||
ment <- getBy $ UniqueStackage $ PackageSetIdent slug0
|
|
||||||
case ment of
|
|
||||||
Just ent -> return ent
|
|
||||||
Nothing -> do
|
|
||||||
slug <- maybe notFound return $ fromPathPiece slug0
|
|
||||||
getBy404 $ UniqueSnapshot slug
|
|
||||||
let ident = stackageIdent
|
|
||||||
slug = stackageSlug
|
|
||||||
unless (uid == stackageUser) $ permissionDenied "You do not control this snapshot"
|
|
||||||
((res, widget), enctype) <- runFormPostNoToken form
|
|
||||||
case res of
|
|
||||||
FormSuccess fileInfo -> do
|
|
||||||
fileSource fileInfo $$ storeWrite (HaddockBundle ident)
|
|
||||||
runDB $ update sid [StackageHasHaddocks =. True]
|
|
||||||
master <- getYesod
|
|
||||||
liftIO $ duForceReload (appDocUnpacker master) stackageEnt
|
|
||||||
setMessage "Haddocks uploaded"
|
|
||||||
redirect $ SnapshotR slug StackageHomeR
|
|
||||||
_ -> defaultLayout $ do
|
|
||||||
setTitle "Upload Haddocks"
|
|
||||||
$(widgetFile "upload-haddock")
|
|
||||||
|
|
||||||
putUploadHaddockR = getUploadHaddockR
|
|
||||||
|
|
||||||
getHaddockR :: SnapSlug -> [Text] -> Handler ()
|
getHaddockR :: SnapSlug -> [Text] -> Handler ()
|
||||||
getHaddockR slug rest = do
|
getHaddockR slug rest = redirect $ concat
|
||||||
stackageEnt <- runDB $ do
|
$ "http://haddock.stackage.org/"
|
||||||
onS3 <- fmap isJust $ getBy $ UniqueDocsOnS3 slug
|
: toPathPiece slug
|
||||||
when onS3 $ redirect $ concat
|
: map (cons '/') rest
|
||||||
$ "http://haddock.stackage.org/"
|
|
||||||
: toPathPiece slug
|
|
||||||
: map (cons '/') rest
|
|
||||||
ment <- getBy $ UniqueSnapshot slug
|
|
||||||
case ment of
|
|
||||||
Just ent -> do
|
|
||||||
case rest of
|
|
||||||
[pkgver] -> tryContentsRedirect ent pkgver
|
|
||||||
[pkgver, "index.html"] -> tryContentsRedirect ent pkgver
|
|
||||||
_ -> return ()
|
|
||||||
return ent
|
|
||||||
Nothing -> do
|
|
||||||
Entity _ stackage <- getBy404
|
|
||||||
$ UniqueStackage
|
|
||||||
$ PackageSetIdent
|
|
||||||
$ toPathPiece slug
|
|
||||||
redirectWith status301 $ HaddockR (stackageSlug stackage) rest
|
|
||||||
mapM_ sanitize rest
|
|
||||||
dirs <- getDirs
|
|
||||||
requireDocs stackageEnt
|
|
||||||
|
|
||||||
let ident = stackageIdent (entityVal stackageEnt)
|
|
||||||
rawfp = dirRawFp dirs ident rest
|
|
||||||
gzfp = dirGzFp dirs ident rest
|
|
||||||
mime = defaultMimeLookup $ fpToText $ filename rawfp
|
|
||||||
|
|
||||||
whenM (liftIO $ isDirectory rawfp)
|
|
||||||
$ redirect $ HaddockR slug $ rest ++ ["index.html"]
|
|
||||||
whenM (liftIO $ isDirectory gzfp)
|
|
||||||
$ redirect $ HaddockR slug $ rest ++ ["index.html"]
|
|
||||||
|
|
||||||
whenM (liftIO $ isFile gzfp) $ do
|
|
||||||
addHeader "Content-Encoding" "gzip"
|
|
||||||
sendFile mime $ fpToString gzfp
|
|
||||||
|
|
||||||
-- Note: There's a small race window here, where the compressor thread
|
|
||||||
-- could pull the rug out from under us. We can work around this by opening
|
|
||||||
-- the file and, if that fails, try the compressed version again.
|
|
||||||
whenM (liftIO $ isFile rawfp) $ sendFile mime $ fpToString rawfp
|
|
||||||
|
|
||||||
notFound
|
|
||||||
where
|
|
||||||
sanitize p
|
|
||||||
| ("/" `isInfixOf` p) || p `member` (asHashSet $ setFromList ["", ".", ".."]) =
|
|
||||||
permissionDenied "Invalid request"
|
|
||||||
| otherwise = return ()
|
|
||||||
|
|
||||||
-- | Try to redirect to the snapshot's package page instead of the
|
|
||||||
-- Haddock-generated HTML.
|
|
||||||
tryContentsRedirect :: Entity Stackage -> Text -> YesodDB App ()
|
|
||||||
tryContentsRedirect (Entity sid Stackage {..}) pkgver = do
|
|
||||||
mdocs <- selectFirst
|
|
||||||
[ DocsName ==. name
|
|
||||||
, DocsVersion ==. version
|
|
||||||
, DocsSnapshot ==. Just sid
|
|
||||||
]
|
|
||||||
[]
|
|
||||||
forM_ mdocs $ const
|
|
||||||
$ redirect
|
|
||||||
$ SnapshotR stackageSlug
|
|
||||||
$ StackageSdistR
|
|
||||||
$ PNVNameVersion name version
|
|
||||||
where
|
|
||||||
(PackageName . dropDash -> name, Version -> version) = T.breakOnEnd "-" pkgver
|
|
||||||
|
|
||||||
dropDash :: Text -> Text
|
|
||||||
dropDash t = fromMaybe t $ stripSuffix "-" t
|
|
||||||
|
|
||||||
createCompressor
|
|
||||||
:: Dirs
|
|
||||||
-> IO (IORef Text, IO ()) -- ^ action to kick off compressor again
|
|
||||||
createCompressor dirs = do
|
|
||||||
baton <- newMVar ()
|
|
||||||
status <- newIORef "Compressor is idle"
|
|
||||||
mask_ $ void $ forkIO $ (finallyE $ \e -> writeIORef status $ "Compressor thread exited: " ++ tshow e) $ forever $ do
|
|
||||||
writeIORef status "Waiting for signal to start compressing"
|
|
||||||
takeMVar baton
|
|
||||||
writeIORef status "Received signal, traversing directories"
|
|
||||||
let rawRoot = dirRawRoot dirs
|
|
||||||
whenM (isDirectory rawRoot) $ runResourceT $ goDir status rawRoot
|
|
||||||
return (status, void $ tryPutMVar baton ())
|
|
||||||
where
|
|
||||||
finallyE f g = mask $ \restore -> do
|
|
||||||
restore g `catch` \e -> do
|
|
||||||
() <- f $ Just (e :: SomeException)
|
|
||||||
() <- throwIO e
|
|
||||||
return ()
|
|
||||||
f Nothing
|
|
||||||
goDir status dir = do
|
|
||||||
writeIORef status $ "Compressing directory: " ++ fpToText dir
|
|
||||||
sourceDirectory dir $$ mapM_C (goFP status)
|
|
||||||
liftIO $ void $ tryIO $ removeDirectory dir
|
|
||||||
|
|
||||||
goFP status fp = do
|
|
||||||
e <- liftIO $ isFile fp
|
|
||||||
if e
|
|
||||||
then liftIO $ do
|
|
||||||
writeIORef status $ "Compressing file: " ++ fpToText fp
|
|
||||||
handle (print . asSomeException)
|
|
||||||
$ gzipHash dirs suffix
|
|
||||||
else goDir status fp
|
|
||||||
where
|
|
||||||
Just suffix = F.stripPrefix (dirRawRoot dirs </> "") fp
|
|
||||||
|
|
||||||
-- Procedure is to:
|
|
||||||
--
|
|
||||||
-- * Gzip the src file to a temp file, and get a hash of the gzipped contents
|
|
||||||
-- * If that hash doesn't exist in the cache, move the new file to the cache
|
|
||||||
-- * Create a hard link from dst to the file in the cache
|
|
||||||
-- * Delete src
|
|
||||||
gzipHash :: Dirs
|
|
||||||
-> FilePath -- ^ suffix
|
|
||||||
-> IO ()
|
|
||||||
gzipHash dirs suffix = do
|
|
||||||
withTempFile (fpToString $ dirCacheRoot dirs) "haddock-file.gz" $ \tempfp temph -> do
|
|
||||||
digest <- withBinaryFile (fpToString src) ReadMode $ \inh ->
|
|
||||||
sourceHandle inh
|
|
||||||
$= gzip
|
|
||||||
$$ (getZipSink $
|
|
||||||
ZipSink (sinkHandle temph) *>
|
|
||||||
ZipSink sinkHash)
|
|
||||||
hClose temph
|
|
||||||
let fpcache = dirCacheFp dirs digest
|
|
||||||
unlessM (isFile fpcache) $ do
|
|
||||||
createTree $ F.parent fpcache
|
|
||||||
rename (fpFromString tempfp) fpcache
|
|
||||||
createTree $ F.parent dst
|
|
||||||
createLink (fpToString fpcache) (fpToString dst)
|
|
||||||
removeFile src
|
|
||||||
where
|
|
||||||
src = dirRawRoot dirs </> suffix
|
|
||||||
dst = dirGzRoot dirs </> suffix
|
|
||||||
|
|
||||||
data Dirs = Dirs
|
|
||||||
{ dirRawRoot :: !FilePath
|
|
||||||
, dirGzRoot :: !FilePath
|
|
||||||
, dirCacheRoot :: !FilePath
|
|
||||||
, dirHoogleRoot :: !FilePath
|
|
||||||
}
|
|
||||||
|
|
||||||
getDirs :: Handler Dirs
|
|
||||||
getDirs = mkDirs . haddockRootDir <$> getYesod
|
|
||||||
|
|
||||||
mkDirs :: FilePath -> Dirs
|
|
||||||
mkDirs dir = Dirs
|
|
||||||
{ dirRawRoot = dir </> "idents-raw"
|
|
||||||
, dirGzRoot = dir </> "idents-gz"
|
|
||||||
, dirCacheRoot = dir </> "cachedir"
|
|
||||||
, dirHoogleRoot = dir </> "hoogle"
|
|
||||||
}
|
|
||||||
|
|
||||||
dirGzIdent, dirRawIdent, dirHoogleIdent :: Dirs -> PackageSetIdent -> FilePath
|
|
||||||
dirGzIdent dirs ident = dirGzRoot dirs </> fpFromText (toPathPiece ident)
|
|
||||||
dirRawIdent dirs ident = dirRawRoot dirs </> fpFromText (toPathPiece ident)
|
|
||||||
dirHoogleIdent dirs ident = dirHoogleRoot dirs </> fpFromText (toPathPiece ident)
|
|
||||||
|
|
||||||
dirGzFp, dirRawFp, dirHoogleFp :: Dirs -> PackageSetIdent -> [Text] -> FilePath
|
|
||||||
dirGzFp dirs ident rest = dirGzIdent dirs ident </> mconcat (map fpFromText rest)
|
|
||||||
dirRawFp dirs ident rest = dirRawIdent dirs ident </> mconcat (map fpFromText rest)
|
|
||||||
dirHoogleFp dirs ident rest = dirHoogleIdent dirs ident </> mconcat (map fpFromText rest)
|
|
||||||
|
|
||||||
dirCacheFp :: Dirs -> Digest SHA1 -> FilePath
|
|
||||||
dirCacheFp dirs digest =
|
|
||||||
dirCacheRoot dirs </> fpFromText x </> fpFromText y <.> "gz"
|
|
||||||
where
|
|
||||||
name = decodeUtf8 $ B16.encode $ toBytes digest
|
|
||||||
(x, y) = splitAt 2 name
|
|
||||||
|
|
||||||
data DocInfo = DocInfo Version (Map Text [Text])
|
|
||||||
instance FromJSON DocInfo where
|
|
||||||
parseJSON = withObject "DocInfo" $ \o -> DocInfo
|
|
||||||
<$> (Version <$> o .: "version")
|
|
||||||
<*> o .: "modules"
|
|
||||||
|
|
||||||
getUploadDocMapR :: Handler Html
|
|
||||||
getUploadDocMapR = do
|
|
||||||
uid <- requireAuthIdOrToken
|
|
||||||
user <- runDB $ get404 uid
|
|
||||||
extra <- getExtra
|
|
||||||
when (unSlug (userHandle user) `notMember` adminUsers extra)
|
|
||||||
$ permissionDenied "Must be an administrator"
|
|
||||||
|
|
||||||
((res, widget), enctype) <- runFormPostNoToken $ renderDivs $ (,)
|
|
||||||
<$> areq
|
|
||||||
fileField
|
|
||||||
"YAML file with map" { fsName = Just "docmap" }
|
|
||||||
Nothing
|
|
||||||
<*> areq textField "Stackage ID" { fsName = Just "snapshot" } Nothing
|
|
||||||
case res of
|
|
||||||
FormSuccess (fi, snapshot) -> do
|
|
||||||
Entity sid stackage <- runDB $ do
|
|
||||||
ment <- getBy $ UniqueStackage $ PackageSetIdent snapshot
|
|
||||||
case ment of
|
|
||||||
Just ent -> return ent
|
|
||||||
Nothing -> do
|
|
||||||
slug <- maybe notFound return $ fromPathPiece snapshot
|
|
||||||
getBy404 $ UniqueSnapshot slug
|
|
||||||
unless (stackageHasHaddocks stackage) $ invalidArgs $ return
|
|
||||||
"Cannot use a snapshot without docs for a docmap"
|
|
||||||
bs <- fileSource fi $$ foldC
|
|
||||||
case Y.decodeEither bs of
|
|
||||||
Left e -> invalidArgs [pack e]
|
|
||||||
Right m0 -> do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
render <- getUrlRender
|
|
||||||
runDB $ forM_ (mapToList $ asMap m0) $ \(package, DocInfo version ms) -> do
|
|
||||||
did <- insert Docs
|
|
||||||
{ docsName = PackageName package
|
|
||||||
, docsVersion = version
|
|
||||||
, docsUploaded = now
|
|
||||||
, docsSnapshot = Just sid
|
|
||||||
}
|
|
||||||
forM_ (mapToList ms) $ \(name, pieces) -> do
|
|
||||||
let url = render $ HaddockR (stackageSlug stackage) pieces
|
|
||||||
insert_ $ Module did name url
|
|
||||||
setMessage "Doc map complete"
|
|
||||||
redirect UploadDocMapR
|
|
||||||
_ -> defaultLayout $ do
|
|
||||||
setTitle "Upload doc map"
|
|
||||||
[whamlet|
|
|
||||||
<form method=post action=?_method=PUT enctype=#{enctype}>
|
|
||||||
^{widget}
|
|
||||||
<input type=submit .btn value="Set document map">
|
|
||||||
|]
|
|
||||||
|
|
||||||
putUploadDocMapR :: Handler Html
|
|
||||||
putUploadDocMapR = getUploadDocMapR
|
|
||||||
|
|||||||
@ -1,5 +1,10 @@
|
|||||||
{-# LANGUAGE TupleSections, OverloadedStrings #-}
|
{-# LANGUAGE TupleSections, OverloadedStrings #-}
|
||||||
module Handler.Home where
|
module Handler.Home
|
||||||
|
( getHomeR
|
||||||
|
, getAuthorsR
|
||||||
|
, getInstallR
|
||||||
|
, getOlderReleasesR
|
||||||
|
) where
|
||||||
|
|
||||||
import Data.Slug
|
import Data.Slug
|
||||||
import Database.Esqueleto as E hiding (isNothing)
|
import Database.Esqueleto as E hiding (isNothing)
|
||||||
@ -31,51 +36,3 @@ contentHelper title accessor = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle title
|
setTitle title
|
||||||
toWidget homepage
|
toWidget homepage
|
||||||
|
|
||||||
-- FIXME remove this and switch to above getHomeR' when new homepage is ready
|
|
||||||
getHomeR' :: Handler Html
|
|
||||||
getHomeR' = do
|
|
||||||
windowsLatest <- linkFor "unstable-ghc78hp-inclusive"
|
|
||||||
restLatest <- linkFor "unstable-ghc78-inclusive"
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "Stackage Server"
|
|
||||||
$(combineStylesheets 'StaticR
|
|
||||||
[ css_bootstrap_modified_css
|
|
||||||
, css_bootstrap_responsive_modified_css
|
|
||||||
])
|
|
||||||
$(widgetFile "homepage")
|
|
||||||
where
|
|
||||||
linkFor name =
|
|
||||||
do slug <- mkSlug name
|
|
||||||
fpcomplete <- mkSlug "fpcomplete"
|
|
||||||
selecting (\(alias, user, stackage) ->
|
|
||||||
do where_ $
|
|
||||||
alias ^. AliasName ==. val slug &&.
|
|
||||||
alias ^. AliasUser ==. user ^. UserId &&.
|
|
||||||
user ^. UserHandle ==. val fpcomplete &&.
|
|
||||||
alias ^. AliasTarget ==. stackage ^. StackageIdent
|
|
||||||
return (stackage ^. StackageSlug))
|
|
||||||
where selecting =
|
|
||||||
fmap (fmap unValue . listToMaybe) .
|
|
||||||
runDB .
|
|
||||||
select .
|
|
||||||
from
|
|
||||||
|
|
||||||
addSnapshot title short = do
|
|
||||||
mex <- handlerToWidget $ linkFor $ name "exclusive"
|
|
||||||
min' <- handlerToWidget $ linkFor $ name "inclusive"
|
|
||||||
when (isJust mex || isJust min')
|
|
||||||
[whamlet|
|
|
||||||
<tr>
|
|
||||||
<td>
|
|
||||||
#{asHtml title}
|
|
||||||
<td>
|
|
||||||
$maybe ex <- mex
|
|
||||||
<a href=@{SnapshotR ex StackageHomeR}>exclusive
|
|
||||||
$if isJust mex && isJust min'
|
|
||||||
<td>
|
|
||||||
$maybe in <- min'
|
|
||||||
<a href=@{SnapshotR in StackageHomeR}>inclusive
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
name suffix = concat ["unstable-", short, "-", suffix]
|
|
||||||
|
|||||||
@ -6,14 +6,14 @@ import Control.Spoon (spoon)
|
|||||||
import Data.Data (Data (..))
|
import Data.Data (Data (..))
|
||||||
import Data.Slug (SnapSlug)
|
import Data.Slug (SnapSlug)
|
||||||
import Data.Text.Read (decimal)
|
import Data.Text.Read (decimal)
|
||||||
import Data.Unpacking (getHoogleDB)
|
|
||||||
import Handler.Haddock (getDirs)
|
|
||||||
import qualified Hoogle
|
import qualified Hoogle
|
||||||
import Import
|
import Import
|
||||||
import Text.Blaze.Html (preEscapedToHtml)
|
import Text.Blaze.Html (preEscapedToHtml)
|
||||||
|
|
||||||
getHoogleR :: SnapSlug -> Handler Html
|
getHoogleR :: SnapSlug -> Handler Html
|
||||||
getHoogleR slug = do
|
getHoogleR slug = do
|
||||||
|
error "getHoogleR"
|
||||||
|
{- FIXME
|
||||||
dirs <- getDirs
|
dirs <- getDirs
|
||||||
mquery <- lookupGetParam "q"
|
mquery <- lookupGetParam "q"
|
||||||
mpage <- lookupGetParam "page"
|
mpage <- lookupGetParam "page"
|
||||||
@ -52,9 +52,12 @@ getHoogleR slug = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle "Hoogle Search"
|
setTitle "Hoogle Search"
|
||||||
$(widgetFile "hoogle")
|
$(widgetFile "hoogle")
|
||||||
|
-}
|
||||||
|
|
||||||
getHoogleDatabaseR :: SnapSlug -> Handler Html
|
getHoogleDatabaseR :: SnapSlug -> Handler Html
|
||||||
getHoogleDatabaseR slug = do
|
getHoogleDatabaseR slug = do
|
||||||
|
error "getHoogleDatabaseR"
|
||||||
|
{-
|
||||||
dirs <- getDirs
|
dirs <- getDirs
|
||||||
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
mdatabasePath <- getHoogleDB dirs stackage
|
mdatabasePath <- getHoogleDB dirs stackage
|
||||||
@ -167,3 +170,4 @@ runHoogleQuery heDatabase HoogleQueryInput {..} =
|
|||||||
modu' = ModuleLink moduname modu
|
modu' = ModuleLink moduname modu
|
||||||
return $ asMap $ singletonMap pkg' [modu']
|
return $ asMap $ singletonMap pkg' [modu']
|
||||||
getPkgModPair _ = Nothing
|
getPkgModPair _ = Nothing
|
||||||
|
-}
|
||||||
|
|||||||
12
Handler/OldLinks.hs
Normal file
12
Handler/OldLinks.hs
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
module Handler.OldLinks
|
||||||
|
( getLtsR
|
||||||
|
, getNightlyR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
getLtsR :: [Text] -> Handler ()
|
||||||
|
getLtsR foo = return ()
|
||||||
|
|
||||||
|
getNightlyR :: [Text] -> Handler ()
|
||||||
|
getNightlyR foo = return ()
|
||||||
@ -2,7 +2,14 @@
|
|||||||
|
|
||||||
-- | Lists the package page similar to Hackage.
|
-- | Lists the package page similar to Hackage.
|
||||||
|
|
||||||
module Handler.Package where
|
module Handler.Package
|
||||||
|
( getPackageR
|
||||||
|
, getPackageSnapshotsR
|
||||||
|
, postPackageLikeR
|
||||||
|
, postPackageUnlikeR
|
||||||
|
, postPackageTagR
|
||||||
|
, postPackageUntagR
|
||||||
|
) where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Slug
|
import Data.Slug
|
||||||
@ -22,6 +29,8 @@ import Text.Email.Validate
|
|||||||
-- | Page metadata package.
|
-- | Page metadata package.
|
||||||
getPackageR :: PackageName -> Handler Html
|
getPackageR :: PackageName -> Handler Html
|
||||||
getPackageR pn =
|
getPackageR pn =
|
||||||
|
error "getPackageR"
|
||||||
|
{-
|
||||||
packagePage pn Nothing (selectFirst [DocsName ==. pn] [Desc DocsUploaded])
|
packagePage pn Nothing (selectFirst [DocsName ==. pn] [Desc DocsUploaded])
|
||||||
|
|
||||||
packagePage :: PackageName
|
packagePage :: PackageName
|
||||||
@ -266,6 +275,7 @@ renderEmail = T.decodeUtf8 . toByteString
|
|||||||
-- | Format a number with commas nicely.
|
-- | Format a number with commas nicely.
|
||||||
formatNum :: Int -> Text
|
formatNum :: Int -> Text
|
||||||
formatNum = sformat commas
|
formatNum = sformat commas
|
||||||
|
-}
|
||||||
|
|
||||||
postPackageLikeR :: PackageName -> Handler ()
|
postPackageLikeR :: PackageName -> Handler ()
|
||||||
postPackageLikeR packageName = maybeAuthId >>= \muid -> case muid of
|
postPackageLikeR packageName = maybeAuthId >>= \muid -> case muid of
|
||||||
@ -309,7 +319,8 @@ postPackageUntagR packageName =
|
|||||||
Nothing -> error "Need a slug"
|
Nothing -> error "Need a slug"
|
||||||
|
|
||||||
getPackageSnapshotsR :: PackageName -> Handler Html
|
getPackageSnapshotsR :: PackageName -> Handler Html
|
||||||
getPackageSnapshotsR pn =
|
getPackageSnapshotsR pn = error "getPackageSnapshotsR"
|
||||||
|
{-
|
||||||
do let haddocksLink ident version =
|
do let haddocksLink ident version =
|
||||||
HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
|
HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
|
||||||
snapshots <- (runDB .
|
snapshots <- (runDB .
|
||||||
@ -335,3 +346,4 @@ getPackageSnapshotsR pn =
|
|||||||
,fromMaybe title (stripPrefix "Stackage build for " title)
|
,fromMaybe title (stripPrefix "Stackage build for " title)
|
||||||
,ident
|
,ident
|
||||||
,hasHaddocks)
|
,hasHaddocks)
|
||||||
|
-}
|
||||||
|
|||||||
@ -1,39 +0,0 @@
|
|||||||
module Handler.PackageCounts
|
|
||||||
( getPackageCountsR
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Import hiding (Value (..), groupBy, (==.))
|
|
||||||
import Data.Slug (mkSlug)
|
|
||||||
import Database.Esqueleto
|
|
||||||
|
|
||||||
data Count = Count
|
|
||||||
{ name :: Text
|
|
||||||
, date :: Day
|
|
||||||
, packages :: Int
|
|
||||||
}
|
|
||||||
|
|
||||||
toCount :: (Value Text, Value UTCTime, Value Int) -> Count
|
|
||||||
toCount (Value x, Value y, Value z) =
|
|
||||||
Count x (utctDay y) z
|
|
||||||
|
|
||||||
getPackageCountsR :: Handler Html
|
|
||||||
getPackageCountsR = do
|
|
||||||
admins <- adminUsers <$> getExtra
|
|
||||||
counts <- runDB $ do
|
|
||||||
let slugs = mapMaybe mkSlug $ setToList admins
|
|
||||||
adminUids <- selectKeysList [UserHandle <-. slugs] []
|
|
||||||
fmap (map toCount) $ select $ from $ \(s, p) -> do
|
|
||||||
where_ $
|
|
||||||
(not_ $ s ^. StackageTitle `like` val "%inclusive") &&.
|
|
||||||
(s ^. StackageId ==. p ^. PackageStackage) &&.
|
|
||||||
(s ^. StackageUser `in_` valList adminUids)
|
|
||||||
groupBy (s ^. StackageTitle, s ^. StackageUploaded)
|
|
||||||
orderBy [desc $ s ^. StackageUploaded]
|
|
||||||
return
|
|
||||||
( s ^. StackageTitle
|
|
||||||
, s ^. StackageUploaded
|
|
||||||
, countRows
|
|
||||||
)
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "Package counts"
|
|
||||||
$(widgetFile "package-counts")
|
|
||||||
@ -9,6 +9,8 @@ import Import
|
|||||||
-- FIXME maybe just redirect to the LTS or nightly package list
|
-- FIXME maybe just redirect to the LTS or nightly package list
|
||||||
getPackageListR :: Handler Html
|
getPackageListR :: Handler Html
|
||||||
getPackageListR = defaultLayout $ do
|
getPackageListR = defaultLayout $ do
|
||||||
|
error "getPackageListR"
|
||||||
|
{-
|
||||||
setTitle "Package list"
|
setTitle "Package list"
|
||||||
cachedWidget (20 * 60) "package-list" $ do
|
cachedWidget (20 * 60) "package-list" $ do
|
||||||
let clean (x, y) =
|
let clean (x, y) =
|
||||||
@ -47,3 +49,4 @@ cachedWidget _diff _key widget = do
|
|||||||
atomicModifyIORef' ref $ \m -> (insertMap key (addUTCTime diff now, gw) m, ())
|
atomicModifyIORef' ref $ \m -> (insertMap key (addUTCTime diff now, gw) m, ())
|
||||||
return ((), gw)
|
return ((), gw)
|
||||||
-}
|
-}
|
||||||
|
-}
|
||||||
|
|||||||
@ -21,19 +21,10 @@ getProfileR = do
|
|||||||
setMessage "Profile updated"
|
setMessage "Profile updated"
|
||||||
redirect ProfileR
|
redirect ProfileR
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
(emails, aliases) <- runDB $ (,)
|
emails <- runDB $ selectList [EmailUser ==. uid] [Asc EmailEmail]
|
||||||
<$> selectList [EmailUser ==. uid] [Asc EmailEmail]
|
|
||||||
<*> selectList [AliasUser ==. uid] [Asc AliasName]
|
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle "Your Profile"
|
setTitle "Your Profile"
|
||||||
$(widgetFile "profile")
|
$(widgetFile "profile")
|
||||||
|
|
||||||
aliasToText :: Entity Alias -> Text
|
|
||||||
aliasToText (Entity _ (Alias _ name target)) = concat
|
|
||||||
[ toPathPiece name
|
|
||||||
, ": "
|
|
||||||
, toPathPiece target
|
|
||||||
]
|
|
||||||
|
|
||||||
putProfileR :: Handler Html
|
putProfileR :: Handler Html
|
||||||
putProfileR = getProfileR
|
putProfileR = getProfileR
|
||||||
|
|||||||
@ -1,15 +0,0 @@
|
|||||||
module Handler.Progress where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
|
|
||||||
getProgressR :: UploadProgressId -> Handler Html
|
|
||||||
getProgressR key = do
|
|
||||||
UploadProgress text mdest <- runDB $ get404 key
|
|
||||||
case mdest of
|
|
||||||
Nothing -> defaultLayout $ do
|
|
||||||
addHeader "Refresh" "1"
|
|
||||||
setTitle "Working..."
|
|
||||||
[whamlet|<p>#{text}|]
|
|
||||||
Just url -> do
|
|
||||||
setMessage $ toHtml text
|
|
||||||
redirect url
|
|
||||||
@ -1,20 +0,0 @@
|
|||||||
module Handler.RefreshDeprecated where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
import qualified Data.Aeson as Aeson
|
|
||||||
import Network.HTTP.Conduit (simpleHttp)
|
|
||||||
import Data.Hackage.DeprecationInfo
|
|
||||||
|
|
||||||
getRefreshDeprecatedR :: Handler Html
|
|
||||||
getRefreshDeprecatedR = do
|
|
||||||
bs <- simpleHttp "http://hackage.haskell.org/packages/deprecated.json"
|
|
||||||
case Aeson.decode bs of
|
|
||||||
Nothing -> return "Failed to parse"
|
|
||||||
Just info -> do
|
|
||||||
runDB $ do
|
|
||||||
deleteWhere ([] :: [Filter Deprecated])
|
|
||||||
insertMany_ (deprecations info)
|
|
||||||
runDB $ do
|
|
||||||
deleteWhere ([] :: [Filter Suggested])
|
|
||||||
insertMany_ (suggestions info)
|
|
||||||
return "Done"
|
|
||||||
@ -10,6 +10,8 @@ type Sitemap = forall m. Monad m => Producer m (SitemapUrl (Route App))
|
|||||||
|
|
||||||
getSitemapR :: Handler TypedContent
|
getSitemapR :: Handler TypedContent
|
||||||
getSitemapR = sitemap $ do
|
getSitemapR = sitemap $ do
|
||||||
|
error "getSitemapR"
|
||||||
|
{- FIXME
|
||||||
priority 1.0 $ HomeR
|
priority 1.0 $ HomeR
|
||||||
|
|
||||||
priority 0.9 $ LtsR []
|
priority 0.9 $ LtsR []
|
||||||
@ -105,3 +107,4 @@ url loc = yield $ SitemapUrl
|
|||||||
, sitemapChangeFreq = Nothing
|
, sitemapChangeFreq = Nothing
|
||||||
, sitemapPriority = Nothing
|
, sitemapPriority = Nothing
|
||||||
}
|
}
|
||||||
|
-}
|
||||||
|
|||||||
@ -20,6 +20,8 @@ snapshotsPerPage = 50
|
|||||||
-- inclined, or create a single monolithic file.
|
-- inclined, or create a single monolithic file.
|
||||||
getAllSnapshotsR :: Handler Html
|
getAllSnapshotsR :: Handler Html
|
||||||
getAllSnapshotsR = do
|
getAllSnapshotsR = do
|
||||||
|
error "getAllSnapshotsR"
|
||||||
|
{-
|
||||||
now' <- liftIO getCurrentTime
|
now' <- liftIO getCurrentTime
|
||||||
currentPageMay <- lookupGetParam "page"
|
currentPageMay <- lookupGetParam "page"
|
||||||
let currentPage :: Int
|
let currentPage :: Int
|
||||||
@ -51,3 +53,4 @@ getAllSnapshotsR = do
|
|||||||
let (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle') = c
|
let (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle') = c
|
||||||
in (ident,title,format (diff True) (diffUTCTime uploaded now'),display,handle')
|
in (ident,title,format (diff True) (diffUTCTime uploaded now'),display,handle')
|
||||||
groupUp now' (c, rs) = (c, (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now')) rs)
|
groupUp now' (c, rs) = (c, (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now')) rs)
|
||||||
|
-}
|
||||||
|
|||||||
@ -1,23 +1,24 @@
|
|||||||
module Handler.StackageHome where
|
module Handler.StackageHome
|
||||||
|
( getStackageHomeR
|
||||||
|
, getStackageCabalConfigR
|
||||||
|
, getDocsR
|
||||||
|
, getSnapshotPackagesR
|
||||||
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Data.Time (FormatTime)
|
import Data.Time (FormatTime)
|
||||||
import Data.Slug (SnapSlug)
|
import Data.Slug (SnapSlug)
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
import Handler.PackageList (cachedWidget)
|
|
||||||
|
|
||||||
getStackageHomeR :: SnapSlug -> Handler Html
|
getStackageHomeR :: SnapSlug -> Handler Html
|
||||||
getStackageHomeR slug = do
|
getStackageHomeR slug = do
|
||||||
|
error "getStackageHomeR"
|
||||||
|
{-
|
||||||
stackage <- runDB $ do
|
stackage <- runDB $ do
|
||||||
Entity _ stackage <- getBy404 $ UniqueSnapshot slug
|
Entity _ stackage <- getBy404 $ UniqueSnapshot slug
|
||||||
return stackage
|
return stackage
|
||||||
|
|
||||||
let minclusive =
|
let minclusive = Just False
|
||||||
if "inclusive" `isSuffixOf` stackageTitle stackage
|
|
||||||
then Just True
|
|
||||||
else if "exclusive" `isSuffixOf` stackageTitle stackage
|
|
||||||
then Just False
|
|
||||||
else Nothing
|
|
||||||
base = maybe 0 (const 1) minclusive :: Int
|
base = maybe 0 (const 1) minclusive :: Int
|
||||||
hoogleForm =
|
hoogleForm =
|
||||||
let queryText = "" :: Text
|
let queryText = "" :: Text
|
||||||
@ -26,78 +27,53 @@ getStackageHomeR slug = do
|
|||||||
Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle $ toHtml $ stackageTitle stackage
|
setTitle $ toHtml $ stackageTitle stackage
|
||||||
cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
|
let maxPackages = 5000
|
||||||
let maxPackages = 5000
|
(packageListClipped, packages') <- handlerToWidget $ runDB $ do
|
||||||
(packageListClipped, packages') <- handlerToWidget $ runDB $ do
|
packages' <- E.select $ E.from $ \(m,p) -> do
|
||||||
packages' <- E.select $ E.from $ \(m,p) -> do
|
E.where_ $
|
||||||
E.where_ $
|
(m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
|
||||||
(m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
|
(p E.^. PackageStackage E.==. E.val sid)
|
||||||
(p E.^. PackageStackage E.==. E.val sid)
|
E.orderBy [E.asc $ m E.^. MetadataName]
|
||||||
E.orderBy [E.asc $ m E.^. MetadataName]
|
E.groupBy ( m E.^. MetadataName
|
||||||
E.groupBy ( m E.^. MetadataName
|
, m E.^. MetadataSynopsis
|
||||||
, m E.^. MetadataSynopsis
|
)
|
||||||
)
|
E.limit maxPackages
|
||||||
E.limit maxPackages
|
return
|
||||||
return
|
( m E.^. MetadataName
|
||||||
( m E.^. MetadataName
|
, m E.^. MetadataSynopsis
|
||||||
, m E.^. MetadataSynopsis
|
, E.max_ (p E.^. PackageVersion)
|
||||||
, E.max_ (p E.^. PackageVersion)
|
, E.max_ $ E.case_
|
||||||
, E.max_ $ E.case_
|
[ ( p E.^. PackageHasHaddocks
|
||||||
[ ( p E.^. PackageHasHaddocks
|
, p E.^. PackageVersion
|
||||||
, p E.^. PackageVersion
|
)
|
||||||
)
|
|
||||||
]
|
|
||||||
(E.val (Version ""))
|
|
||||||
)
|
|
||||||
packageCount <- count [PackageStackage ==. sid]
|
|
||||||
let packageListClipped = packageCount > maxPackages
|
|
||||||
return (packageListClipped, packages')
|
|
||||||
let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
|
|
||||||
( E.unValue name
|
|
||||||
, fmap unVersion $ E.unValue latestVersion
|
|
||||||
, strip $ E.unValue syn
|
|
||||||
, (<$> mversion) $ \version -> HaddockR slug $ return $ concat
|
|
||||||
[ toPathPiece $ E.unValue name
|
|
||||||
, "-"
|
|
||||||
, version
|
|
||||||
]
|
]
|
||||||
|
(E.val (Version ""))
|
||||||
)
|
)
|
||||||
forceNotNull (E.Value Nothing) = Nothing
|
packageCount <- count [PackageStackage ==. sid]
|
||||||
forceNotNull (E.Value (Just (Version v)))
|
let packageListClipped = packageCount > maxPackages
|
||||||
| null v = Nothing
|
return (packageListClipped, packages')
|
||||||
| otherwise = Just v
|
let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
|
||||||
$(widgetFile "stackage-home")
|
( E.unValue name
|
||||||
|
, fmap unVersion $ E.unValue latestVersion
|
||||||
|
, strip $ E.unValue syn
|
||||||
|
, (<$> mversion) $ \version -> HaddockR slug $ return $ concat
|
||||||
|
[ toPathPiece $ E.unValue name
|
||||||
|
, "-"
|
||||||
|
, version
|
||||||
|
]
|
||||||
|
)
|
||||||
|
forceNotNull (E.Value Nothing) = Nothing
|
||||||
|
forceNotNull (E.Value (Just (Version v)))
|
||||||
|
| null v = Nothing
|
||||||
|
| otherwise = Just v
|
||||||
|
$(widgetFile "stackage-home")
|
||||||
where strip x = fromMaybe x (stripSuffix "." x)
|
where strip x = fromMaybe x (stripSuffix "." x)
|
||||||
|
-}
|
||||||
getStackageMetadataR :: SnapSlug -> Handler TypedContent
|
|
||||||
getStackageMetadataR slug = do
|
|
||||||
Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug
|
|
||||||
respondSourceDB typePlain $ do
|
|
||||||
sendChunkBS "Override packages\n"
|
|
||||||
sendChunkBS "=================\n"
|
|
||||||
stream sid True
|
|
||||||
sendChunkBS "\nPackages from Hackage\n"
|
|
||||||
sendChunkBS "=====================\n"
|
|
||||||
stream sid False
|
|
||||||
where
|
|
||||||
stream sid isOverwrite =
|
|
||||||
selectSource
|
|
||||||
[ PackageStackage ==. sid
|
|
||||||
, PackageOverwrite ==. isOverwrite
|
|
||||||
]
|
|
||||||
[ Asc PackageName'
|
|
||||||
, Asc PackageVersion
|
|
||||||
] $= mapC (Chunk . toBuilder . showPackage)
|
|
||||||
|
|
||||||
showPackage (Entity _ p) = concat
|
|
||||||
[ toPathPiece $ packageName' p
|
|
||||||
, "-"
|
|
||||||
, toPathPiece $ packageVersion p
|
|
||||||
, "\n"
|
|
||||||
]
|
|
||||||
|
|
||||||
getStackageCabalConfigR :: SnapSlug -> Handler TypedContent
|
getStackageCabalConfigR :: SnapSlug -> Handler TypedContent
|
||||||
getStackageCabalConfigR slug = do
|
getStackageCabalConfigR slug = do
|
||||||
|
error "getStackageCabalConfigR"
|
||||||
|
{-
|
||||||
Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
render <- getUrlRender
|
render <- getUrlRender
|
||||||
|
|
||||||
@ -175,19 +151,15 @@ getStackageCabalConfigR slug = do
|
|||||||
toBuilder (asText ",\n ") ++
|
toBuilder (asText ",\n ") ++
|
||||||
toBuilder (toPathPiece $ packageName' p) ++
|
toBuilder (toPathPiece $ packageName' p) ++
|
||||||
constraint p
|
constraint p
|
||||||
|
-}
|
||||||
|
|
||||||
yearMonthDay :: FormatTime t => t -> String
|
yearMonthDay :: FormatTime t => t -> String
|
||||||
yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"
|
yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"
|
||||||
|
|
||||||
getOldStackageR :: PackageSetIdent -> [Text] -> Handler ()
|
|
||||||
getOldStackageR ident pieces = do
|
|
||||||
Entity _ stackage <- runDB $ getBy404 $ UniqueStackage ident
|
|
||||||
case parseRoute ("snapshot" : toPathPiece (stackageSlug stackage) : pieces, []) of
|
|
||||||
Nothing -> notFound
|
|
||||||
Just route -> redirect (route :: Route App)
|
|
||||||
|
|
||||||
getSnapshotPackagesR :: SnapSlug -> Handler Html
|
getSnapshotPackagesR :: SnapSlug -> Handler Html
|
||||||
getSnapshotPackagesR slug = do
|
getSnapshotPackagesR slug = do
|
||||||
|
error "getSnapshotPackagesR"
|
||||||
|
{-
|
||||||
Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
|
setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
|
||||||
@ -227,9 +199,12 @@ getSnapshotPackagesR slug = do
|
|||||||
$(widgetFile "package-list")
|
$(widgetFile "package-list")
|
||||||
where strip x = fromMaybe x (stripSuffix "." x)
|
where strip x = fromMaybe x (stripSuffix "." x)
|
||||||
mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot")
|
mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot")
|
||||||
|
-}
|
||||||
|
|
||||||
getDocsR :: SnapSlug -> Handler Html
|
getDocsR :: SnapSlug -> Handler Html
|
||||||
getDocsR slug = do
|
getDocsR slug = do
|
||||||
|
error "getDocsR"
|
||||||
|
{-
|
||||||
Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle $ toHtml $ "Module list for " ++ toPathPiece slug
|
setTitle $ toHtml $ "Module list for " ++ toPathPiece slug
|
||||||
@ -254,3 +229,4 @@ getDocsR slug = do
|
|||||||
, E.unValue version
|
, E.unValue version
|
||||||
)
|
)
|
||||||
$(widgetFile "doc-list")
|
$(widgetFile "doc-list")
|
||||||
|
-}
|
||||||
|
|||||||
@ -6,6 +6,8 @@ import Data.Slug (SnapSlug)
|
|||||||
|
|
||||||
getStackageIndexR :: SnapSlug -> Handler TypedContent
|
getStackageIndexR :: SnapSlug -> Handler TypedContent
|
||||||
getStackageIndexR slug = do
|
getStackageIndexR slug = do
|
||||||
|
error "getStackageIndexR"
|
||||||
|
{-
|
||||||
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
let ident = stackageIdent stackage
|
let ident = stackageIdent stackage
|
||||||
msrc <- storeRead $ CabalIndex ident
|
msrc <- storeRead $ CabalIndex ident
|
||||||
@ -16,3 +18,4 @@ getStackageIndexR slug = do
|
|||||||
addHeader "content-disposition" "attachment; filename=\"00-index.tar.gz\""
|
addHeader "content-disposition" "attachment; filename=\"00-index.tar.gz\""
|
||||||
neverExpires
|
neverExpires
|
||||||
respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
|
respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
|
||||||
|
-}
|
||||||
|
|||||||
@ -1,16 +1,17 @@
|
|||||||
module Handler.StackageSdist where
|
module Handler.StackageSdist
|
||||||
|
( getStackageSdistR
|
||||||
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Data.BlobStore
|
import Data.BlobStore
|
||||||
import Data.Hackage
|
|
||||||
import Data.Slug (SnapSlug)
|
import Data.Slug (SnapSlug)
|
||||||
import Handler.Package (packagePage)
|
|
||||||
|
|
||||||
getStackageSdistR :: SnapSlug -> PackageNameVersion -> Handler TypedContent
|
getStackageSdistR :: SnapSlug -> PackageNameVersion -> Handler TypedContent
|
||||||
getStackageSdistR slug (PNVTarball name version) = do
|
getStackageSdistR slug (PNVTarball name version) = do
|
||||||
|
error "getStackageSdistR"
|
||||||
|
{-
|
||||||
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
|
||||||
let ident = stackageIdent stackage
|
let ident = stackageIdent stackage
|
||||||
addDownload (Just ident) name version
|
|
||||||
msrc1 <- storeRead (CustomSdist ident name version)
|
msrc1 <- storeRead (CustomSdist ident name version)
|
||||||
msrc <-
|
msrc <-
|
||||||
case msrc1 of
|
case msrc1 of
|
||||||
@ -38,6 +39,7 @@ getStackageSdistR slug (PNVName name) = runDB $ do
|
|||||||
redirect $ SnapshotR slug
|
redirect $ SnapshotR slug
|
||||||
$ StackageSdistR
|
$ StackageSdistR
|
||||||
$ PNVNameVersion name packageVersion
|
$ PNVNameVersion name packageVersion
|
||||||
|
{- FIXME
|
||||||
getStackageSdistR slug (PNVNameVersion name version) = packagePage
|
getStackageSdistR slug (PNVNameVersion name version) = packagePage
|
||||||
name (Just version)
|
name (Just version)
|
||||||
(do
|
(do
|
||||||
@ -54,12 +56,5 @@ getStackageSdistR slug (PNVNameVersion name version) = packagePage
|
|||||||
, [DocsName ==. name]
|
, [DocsName ==. name]
|
||||||
]
|
]
|
||||||
) >>= sendResponse
|
) >>= sendResponse
|
||||||
|
-}
|
||||||
addDownload :: Maybe PackageSetIdent
|
-}
|
||||||
-> PackageName
|
|
||||||
-> Version
|
|
||||||
-> Handler ()
|
|
||||||
addDownload downloadIdent downloadPackage downloadVersion = do
|
|
||||||
downloadUserAgent <- fmap decodeUtf8 <$> lookupHeader "user-agent"
|
|
||||||
downloadTimestamp <- liftIO getCurrentTime
|
|
||||||
runDB $ insert_ Download {..}
|
|
||||||
|
|||||||
@ -20,6 +20,8 @@ getTagListR = do
|
|||||||
|
|
||||||
getTagR :: Slug -> Handler Html
|
getTagR :: Slug -> Handler Html
|
||||||
getTagR tagSlug = do
|
getTagR tagSlug = do
|
||||||
|
error "getTagR"
|
||||||
|
{-
|
||||||
-- FIXME arguably: check if this tag is banned. Leaving it as displayed for
|
-- 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.
|
-- now, since someone needs to go out of their way to find it.
|
||||||
packages <- fmap (map (\(E.Value t,E.Value s) -> (t,strip s))) $ runDB $
|
packages <- fmap (map (\(E.Value t,E.Value s) -> (t,strip s))) $ runDB $
|
||||||
@ -33,3 +35,4 @@ getTagR tagSlug = do
|
|||||||
setTitle $ "Stackage tag"
|
setTitle $ "Stackage tag"
|
||||||
$(widgetFile "tag")
|
$(widgetFile "tag")
|
||||||
where strip x = fromMaybe x (stripSuffix "." x)
|
where strip x = fromMaybe x (stripSuffix "." x)
|
||||||
|
-}
|
||||||
|
|||||||
@ -1,351 +0,0 @@
|
|||||||
module Handler.UploadStackage where
|
|
||||||
|
|
||||||
import Import hiding (catch, get, update)
|
|
||||||
import qualified Import
|
|
||||||
import System.IO.Temp (withSystemTempFile, withSystemTempDirectory, openBinaryTempFile)
|
|
||||||
import Crypto.Hash.Conduit (sinkHash)
|
|
||||||
import Crypto.Hash (Digest, SHA1)
|
|
||||||
import Data.Byteable (toBytes)
|
|
||||||
import qualified Data.ByteString.Base16 as B16
|
|
||||||
import Data.Conduit.Zlib (gzip, ungzip)
|
|
||||||
import qualified Codec.Archive.Tar as Tar
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Filesystem.Path (splitExtension)
|
|
||||||
import Data.BlobStore
|
|
||||||
import Filesystem (createTree)
|
|
||||||
import Control.Monad.State.Strict (execStateT, get, put, modify)
|
|
||||||
import qualified Codec.Compression.GZip as GZip
|
|
||||||
import Control.Monad.Trans.Resource (allocate)
|
|
||||||
import System.Directory (removeFile, getTemporaryDirectory)
|
|
||||||
import System.Process (runProcess, waitForProcess)
|
|
||||||
import System.Exit (ExitCode (ExitSuccess))
|
|
||||||
import Data.Slug (mkSlug, SnapSlug (..), safeMakeSlug, unSlug)
|
|
||||||
import Control.Debounce
|
|
||||||
|
|
||||||
fileKey :: Text
|
|
||||||
fileKey = "stackage"
|
|
||||||
|
|
||||||
slugKey :: Text
|
|
||||||
slugKey = "slug"
|
|
||||||
|
|
||||||
getUploadStackageR :: Handler Html
|
|
||||||
getUploadStackageR = do
|
|
||||||
_ <- requireAuth
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "Upload"
|
|
||||||
$(widgetFile "upload-stackage")
|
|
||||||
|
|
||||||
putUploadStackageR :: Handler TypedContent
|
|
||||||
putUploadStackageR = do
|
|
||||||
uid <- requireAuthIdOrToken
|
|
||||||
|
|
||||||
-- Only admin users can use slugs starting with "lts" and "nightly",
|
|
||||||
-- enforce that here
|
|
||||||
muser <- runDB $ Import.get uid
|
|
||||||
extra <- getExtra
|
|
||||||
let isAdmin =
|
|
||||||
case muser of
|
|
||||||
Nothing -> False
|
|
||||||
Just user -> unSlug (userHandle user) `member` adminUsers extra
|
|
||||||
allowedSlug Nothing = Nothing
|
|
||||||
allowedSlug (Just t)
|
|
||||||
| isAdmin = Just t
|
|
||||||
| "lts" `isPrefixOf` t = Nothing
|
|
||||||
| "nightly" `isPrefixOf` t = Nothing
|
|
||||||
| otherwise = Just t
|
|
||||||
|
|
||||||
mfile <- lookupFile fileKey
|
|
||||||
mslug0 <- allowedSlug <$> lookupPostParam slugKey
|
|
||||||
case mfile of
|
|
||||||
Nothing -> invalidArgs ["Upload missing"]
|
|
||||||
Just file -> do
|
|
||||||
malias <- lookupPostParam "alias"
|
|
||||||
mlts <- lookupPostParam "lts"
|
|
||||||
mnightly <- lookupPostParam "nightly"
|
|
||||||
|
|
||||||
tempDir <- liftIO getTemporaryDirectory
|
|
||||||
(_releaseKey, (fp, handleOut)) <- allocate
|
|
||||||
(openBinaryTempFile tempDir "upload-stackage.")
|
|
||||||
(\(fp, h) -> hClose h `finally` removeFile fp)
|
|
||||||
digest <- fileSource file
|
|
||||||
$$ getZipSink (ZipSink sinkHash <* ZipSink (ungzip =$ sinkHandle handleOut))
|
|
||||||
liftIO $ hClose handleOut
|
|
||||||
|
|
||||||
let bs = toBytes (digest :: Digest SHA1)
|
|
||||||
ident = PackageSetIdent $ decodeUtf8 $ B16.encode bs
|
|
||||||
|
|
||||||
-- Check for duplicates
|
|
||||||
mstackage <- runDB $ getBy $ UniqueStackage ident
|
|
||||||
when (isJust mstackage) $ invalidArgs ["Stackage already exists"]
|
|
||||||
|
|
||||||
app <- getYesod
|
|
||||||
let initProgress = UploadProgress "Upload starting" Nothing
|
|
||||||
key <- runDB $ insert initProgress
|
|
||||||
|
|
||||||
-- We don't want to be writing progress updates to the database too
|
|
||||||
-- frequently, so let's just do it once per second at most.
|
|
||||||
-- Debounce to the rescue!
|
|
||||||
statusRef <- newIORef initProgress
|
|
||||||
writeToDB <- liftIO $ mkDebounce defaultDebounceSettings
|
|
||||||
{ debounceAction = do
|
|
||||||
up <- readIORef statusRef
|
|
||||||
runPool (persistConfig app) (replace key up) (connPool app)
|
|
||||||
}
|
|
||||||
|
|
||||||
let updateHelper :: MonadBase IO m => UploadProgress -> m ()
|
|
||||||
updateHelper p = do
|
|
||||||
writeIORef statusRef p
|
|
||||||
liftBase writeToDB
|
|
||||||
update :: MonadBase IO m => Text -> m ()
|
|
||||||
update msg = updateHelper (UploadProgress msg Nothing)
|
|
||||||
done msg route = do
|
|
||||||
render <- getUrlRender
|
|
||||||
updateHelper (UploadProgress msg $ Just $ render route)
|
|
||||||
onExc e = done ("Exception occurred: " ++ tshow e) ProfileR
|
|
||||||
setAlias = do
|
|
||||||
forM_ (malias >>= mkSlug) $ \alias -> do
|
|
||||||
deleteWhere [AliasUser ==. uid, AliasName ==. alias]
|
|
||||||
insert_ Alias
|
|
||||||
{ aliasUser = uid
|
|
||||||
, aliasName = alias
|
|
||||||
, aliasTarget = ident
|
|
||||||
}
|
|
||||||
whenAdmin = when isAdmin
|
|
||||||
setLts sid = forM_ mlts
|
|
||||||
$ \lts -> whenAdmin
|
|
||||||
$ forM_ (parseLtsPair lts) $ \(major, minor) -> do
|
|
||||||
mx <- getBy $ UniqueLts major minor
|
|
||||||
when (isNothing mx) $ insert_ $ Lts major minor sid
|
|
||||||
setNightly sid = forM_ mnightly $ \nightly -> whenAdmin $ do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
let day = utctDay now
|
|
||||||
mx <- getBy $ UniqueNightly day
|
|
||||||
when (isNothing mx) $ insert_ Nightly
|
|
||||||
{ nightlyDay = day
|
|
||||||
, nightlyGhcVersion = nightly
|
|
||||||
, nightlyStackage = sid
|
|
||||||
}
|
|
||||||
|
|
||||||
update "Starting"
|
|
||||||
|
|
||||||
forkHandler onExc $ do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
baseSlug <- fmap SnapSlug $ mkSlug $ fromMaybe (tshow $ utctDay now) mslug0
|
|
||||||
let initial = Stackage
|
|
||||||
{ stackageUser = uid
|
|
||||||
, stackageIdent = ident
|
|
||||||
, stackageUploaded = now
|
|
||||||
, stackageTitle = "Untitled Stackage"
|
|
||||||
, stackageDesc = "No description provided"
|
|
||||||
, stackageHasHaddocks = False
|
|
||||||
, stackageSlug = baseSlug
|
|
||||||
, stackageGhcMajorVersion = Nothing -- Assumption: this file is deprecated
|
|
||||||
}
|
|
||||||
|
|
||||||
-- Evil lazy I/O thanks to tar package
|
|
||||||
lbs <- readFile $ fpFromString fp
|
|
||||||
withSystemTempDirectory "build00index." $ \dir -> do
|
|
||||||
LoopState _ stackage files _ contents cores <- execStateT (loop isAdmin update (Tar.read lbs)) LoopState
|
|
||||||
{ lsRoot = fpFromString dir
|
|
||||||
, lsStackage = initial
|
|
||||||
, lsFiles = mempty
|
|
||||||
, lsIdent = ident
|
|
||||||
, lsContents = []
|
|
||||||
, lsCores = mempty
|
|
||||||
}
|
|
||||||
withSystemTempFile "newindex" $ \fp' h -> do
|
|
||||||
ec <- liftIO $ do
|
|
||||||
hClose h
|
|
||||||
let args = "cfz"
|
|
||||||
: fp'
|
|
||||||
: map fpToString (setToList files)
|
|
||||||
ph <- runProcess "tar" args (Just dir) Nothing Nothing Nothing Nothing
|
|
||||||
waitForProcess ph
|
|
||||||
if ec == ExitSuccess
|
|
||||||
then do
|
|
||||||
sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
|
|
||||||
sourceFile (fpFromString fp) $$ gzip =$ storeWrite (SnapshotBundle ident)
|
|
||||||
slug <- runDB $ do
|
|
||||||
slug <- getUniqueSlug $ stackageSlug stackage
|
|
||||||
sid <- insert stackage { stackageSlug = slug}
|
|
||||||
forM_ contents $ \(name, version, overwrite) -> insert_ Package
|
|
||||||
{ packageStackage = sid
|
|
||||||
, packageName' = name
|
|
||||||
, packageVersion = version
|
|
||||||
, packageOverwrite = overwrite
|
|
||||||
, packageHasHaddocks = False
|
|
||||||
, packageCore = Just $ name `member` cores
|
|
||||||
}
|
|
||||||
|
|
||||||
setAlias
|
|
||||||
setLts sid
|
|
||||||
setNightly sid
|
|
||||||
|
|
||||||
return slug
|
|
||||||
|
|
||||||
done "Stackage created" $ SnapshotR slug StackageHomeR
|
|
||||||
else done "Error creating index file" ProfileR
|
|
||||||
|
|
||||||
addHeader "X-Stackage-Ident" $ toPathPiece ident
|
|
||||||
redirect $ ProgressR key
|
|
||||||
where
|
|
||||||
loop _ update Tar.Done = update "Finished processing files"
|
|
||||||
loop _ _ (Tar.Fail e) = throwM e
|
|
||||||
loop isAdmin update (Tar.Next entry entries) = do
|
|
||||||
addEntry isAdmin update entry
|
|
||||||
loop isAdmin update entries
|
|
||||||
|
|
||||||
addEntry isAdmin update entry = do
|
|
||||||
_ <- update $ "Processing file: " ++ pack (Tar.entryPath entry)
|
|
||||||
case Tar.entryContent entry of
|
|
||||||
Tar.NormalFile lbs _ ->
|
|
||||||
case filename $ fpFromString $ Tar.entryPath entry of
|
|
||||||
"desc" -> do
|
|
||||||
$logDebug $ "desc: " ++ tshow lbs
|
|
||||||
let (title, drop 1 -> desc) = break (== '\n')
|
|
||||||
$ decodeUtf8
|
|
||||||
$ toStrict lbs
|
|
||||||
ls <- get
|
|
||||||
put ls
|
|
||||||
{ lsStackage = (lsStackage ls)
|
|
||||||
{ stackageTitle = title
|
|
||||||
, stackageDesc = desc
|
|
||||||
}
|
|
||||||
}
|
|
||||||
"slug" -> do
|
|
||||||
let t = decodeUtf8 $ toStrict lbs
|
|
||||||
when (isAdmin || not ("lts" `isPrefixOf` t || "nightly" `isPrefixOf` t)) $ do
|
|
||||||
slug <- safeMakeSlug t False
|
|
||||||
ls <- get
|
|
||||||
put ls { lsStackage = (lsStackage ls) { stackageSlug = SnapSlug slug } }
|
|
||||||
"hackage" -> forM_ (lines $ decodeUtf8 $ toStrict lbs) $ \line ->
|
|
||||||
case parseName line of
|
|
||||||
Just (name, version) -> do
|
|
||||||
$logDebug $ "hackage: " ++ tshow (name, version)
|
|
||||||
_ <- update $ concat
|
|
||||||
[ "Adding Hackage package: "
|
|
||||||
, toPathPiece name
|
|
||||||
, "-"
|
|
||||||
, toPathPiece version
|
|
||||||
]
|
|
||||||
msrc <- storeRead (HackageCabal name version)
|
|
||||||
case msrc of
|
|
||||||
Nothing | name == "base" -> return () -- workaround in case base isn't uploaded to Hackage
|
|
||||||
Nothing -> invalidArgs ["Unknown Hackage name/version: " ++ tshow (name, version)]
|
|
||||||
Just src -> addFile False name version src
|
|
||||||
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
"core" -> forM_ (lines $ decodeUtf8 $ toStrict lbs) $ \name ->
|
|
||||||
modify $ \ls -> ls
|
|
||||||
{ lsCores = insertSet (PackageName name)
|
|
||||||
$ lsCores ls
|
|
||||||
}
|
|
||||||
|
|
||||||
fp | (base1, Just "gz") <- splitExtension fp
|
|
||||||
, (fpToText -> base, Just "tar") <- splitExtension base1 -> do
|
|
||||||
ident <- lsIdent <$> get
|
|
||||||
_ <- update $ concat
|
|
||||||
[ "Extracting cabal file for custom tarball: "
|
|
||||||
, base
|
|
||||||
]
|
|
||||||
(name, version, cabalLBS) <- extractCabal lbs base
|
|
||||||
sourceLazy lbs $$ storeWrite (CustomSdist ident name version)
|
|
||||||
addFile True name version $ sourceLazy cabalLBS
|
|
||||||
_ -> return ()
|
|
||||||
_ -> return ()
|
|
||||||
where
|
|
||||||
addFile isOverride name version src = do
|
|
||||||
ls <- get
|
|
||||||
when (isOverride || fp `notMember` lsFiles ls) $ do
|
|
||||||
let fp' = lsRoot ls </> fp
|
|
||||||
liftIO $ createTree $ directory fp'
|
|
||||||
src $$ sinkFile fp'
|
|
||||||
put ls
|
|
||||||
{ lsFiles = insertSet fp $ lsFiles ls
|
|
||||||
, lsContents
|
|
||||||
= (name, version, isOverride)
|
|
||||||
: lsContents ls
|
|
||||||
}
|
|
||||||
where
|
|
||||||
fp = mkFP name version
|
|
||||||
|
|
||||||
mkFP name version
|
|
||||||
= fpFromText (toPathPiece name)
|
|
||||||
</> fpFromText (toPathPiece version)
|
|
||||||
</> fpFromText (concat
|
|
||||||
[ toPathPiece name
|
|
||||||
, "-"
|
|
||||||
, toPathPiece version
|
|
||||||
, ".cabal"
|
|
||||||
])
|
|
||||||
|
|
||||||
parseName t =
|
|
||||||
case T.breakOnEnd "-" t of
|
|
||||||
("", _) -> Nothing
|
|
||||||
(_, "") -> Nothing
|
|
||||||
(T.init -> name, version) -> Just (PackageName name, Version version)
|
|
||||||
|
|
||||||
data LoopState = LoopState
|
|
||||||
{ lsRoot :: !FilePath
|
|
||||||
, lsStackage :: !Stackage
|
|
||||||
, lsFiles :: !(Set FilePath)
|
|
||||||
, lsIdent :: !PackageSetIdent
|
|
||||||
|
|
||||||
, lsContents :: ![(PackageName, Version, IsOverride)] -- FIXME use SnocVector when ready
|
|
||||||
, lsCores :: !(Set PackageName) -- ^ core packages
|
|
||||||
}
|
|
||||||
|
|
||||||
type IsOverride = Bool
|
|
||||||
|
|
||||||
extractCabal :: (MonadLogger m, MonadThrow m)
|
|
||||||
=> LByteString
|
|
||||||
-> Text -- ^ basename
|
|
||||||
-> m (PackageName, Version, LByteString)
|
|
||||||
extractCabal lbs basename' =
|
|
||||||
loop $ Tar.read $ GZip.decompress lbs
|
|
||||||
where
|
|
||||||
loop Tar.Done = error $ "extractCabal: cabal file missing for " ++ unpack basename'
|
|
||||||
loop (Tar.Fail e) = throwM e
|
|
||||||
loop (Tar.Next e es) = do
|
|
||||||
$logDebug $ pack $ Tar.entryPath e
|
|
||||||
case Tar.entryContent e of
|
|
||||||
Tar.NormalFile lbs' _
|
|
||||||
| Just (name, version) <- parseNameVersion (pack $ Tar.entryPath e)
|
|
||||||
-> return (name, version, lbs')
|
|
||||||
_ -> loop es
|
|
||||||
|
|
||||||
parseNameVersion t = do
|
|
||||||
[dir, filename'] <- Just $ T.splitOn "/" t
|
|
||||||
let (name', version) = T.breakOnEnd "-" dir
|
|
||||||
name <- stripSuffix "-" name'
|
|
||||||
guard $ name ++ ".cabal" == filename'
|
|
||||||
return (PackageName name, Version version)
|
|
||||||
|
|
||||||
-- | Get a unique version of the given slug by appending random numbers to the
|
|
||||||
-- end.
|
|
||||||
getUniqueSlug :: MonadIO m => SnapSlug -> ReaderT SqlBackend m SnapSlug
|
|
||||||
getUniqueSlug base =
|
|
||||||
loop Nothing
|
|
||||||
where
|
|
||||||
loop msuffix = do
|
|
||||||
slug <- checkSlug $ addSuffix msuffix
|
|
||||||
ment <- getBy $ UniqueSnapshot slug
|
|
||||||
case ment of
|
|
||||||
Nothing -> return slug
|
|
||||||
Just _ ->
|
|
||||||
case msuffix of
|
|
||||||
Nothing -> loop $ Just (1 :: Int)
|
|
||||||
Just i
|
|
||||||
| i > 50 -> error "No unique slug found"
|
|
||||||
| otherwise -> loop $ Just $ i + 1
|
|
||||||
|
|
||||||
txt = toPathPiece base
|
|
||||||
|
|
||||||
addSuffix Nothing = txt
|
|
||||||
addSuffix (Just i) = txt ++ pack ('-' : show i)
|
|
||||||
|
|
||||||
checkSlug slug =
|
|
||||||
case fromPathPiece slug of
|
|
||||||
Nothing -> error $ "Invalid snapshot slug: " ++ unpack slug
|
|
||||||
Just s -> return s
|
|
||||||
@ -1,296 +0,0 @@
|
|||||||
module Handler.UploadV2
|
|
||||||
( putUploadV2R
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
import Data.BlobStore
|
|
||||||
import Control.Concurrent.Lifted (threadDelay)
|
|
||||||
import Data.Slug (unSlug, mkSlug, SnapSlug (..))
|
|
||||||
import Control.Monad.Trans.Resource (allocate)
|
|
||||||
import System.Directory (removeFile, getTemporaryDirectory)
|
|
||||||
import System.IO.Temp (openBinaryTempFile, withSystemTempDirectory, withSystemTempFile)
|
|
||||||
import Crypto.Hash.Conduit (sinkHash)
|
|
||||||
import Crypto.Hash (Digest, SHA1)
|
|
||||||
import Data.Byteable (toBytes)
|
|
||||||
import qualified Data.ByteString.Base16 as B16
|
|
||||||
import System.Timeout.Lifted (timeout)
|
|
||||||
import Control.Concurrent.Async (async, cancel, waitCatchSTM)
|
|
||||||
import Yesod.Core.Types (HandlerT (..))
|
|
||||||
import Stackage.Types
|
|
||||||
import Filesystem (createTree)
|
|
||||||
import Filesystem.Path (parent)
|
|
||||||
import Data.Conduit.Process
|
|
||||||
import Data.Yaml (decodeEither')
|
|
||||||
import Distribution.Version (versionBranch)
|
|
||||||
|
|
||||||
putUploadV2R :: Handler TypedContent
|
|
||||||
putUploadV2R = do
|
|
||||||
uid <- requireAuthIdOrToken
|
|
||||||
user <- runDB $ get404 uid
|
|
||||||
extra <- getExtra
|
|
||||||
when (unSlug (userHandle user) `notMember` adminUsers extra)
|
|
||||||
$ permissionDenied "Only admins can upload V2 bundles"
|
|
||||||
|
|
||||||
tempDir <- liftIO getTemporaryDirectory
|
|
||||||
(_releaseKey, (bundleFP, bundleHOut)) <- allocate
|
|
||||||
(openBinaryTempFile tempDir "upload.stackage2")
|
|
||||||
(\(fp, h) -> hClose h `finally` removeFile fp)
|
|
||||||
digest <- rawRequestBody $$ getZipSink
|
|
||||||
(ZipSink (sinkHandle bundleHOut) *>
|
|
||||||
ZipSink sinkHash)
|
|
||||||
liftIO $ hClose bundleHOut
|
|
||||||
|
|
||||||
let digestBS = toBytes (digest :: Digest SHA1)
|
|
||||||
ident = PackageSetIdent $ decodeUtf8 $ B16.encode digestBS
|
|
||||||
|
|
||||||
mstackage <- runDB $ getBy $ UniqueStackage ident
|
|
||||||
when (isJust mstackage) $ invalidArgs ["Bundle already uploaded"]
|
|
||||||
|
|
||||||
status <- liftIO $ newTVarIO ""
|
|
||||||
|
|
||||||
let cont text = do
|
|
||||||
sendChunkBS "CONT: "
|
|
||||||
sendChunkText text
|
|
||||||
sendChunkBS "\n"
|
|
||||||
sendFlush
|
|
||||||
|
|
||||||
-- Grab the internal HandlerT state to perform magic
|
|
||||||
hd <- HandlerT return
|
|
||||||
worker <- fmap snd $ flip allocate cancel $ async $ flip unHandlerT hd
|
|
||||||
$ doUpload status uid ident (fpFromString bundleFP)
|
|
||||||
|
|
||||||
respondSource "text/plain" $ do
|
|
||||||
let displayStatus prev = do
|
|
||||||
memsg <- liftIO $ timeout 20000000 $ atomically $ (do
|
|
||||||
msg <- readTVar status
|
|
||||||
checkSTM (msg /= prev)
|
|
||||||
return (Right msg)) <|> (Left <$> waitCatchSTM worker)
|
|
||||||
case memsg of
|
|
||||||
Nothing -> do
|
|
||||||
cont "Still working"
|
|
||||||
displayStatus prev
|
|
||||||
Just (Left (Left e)) -> do
|
|
||||||
sendChunkText "FAILURE: "
|
|
||||||
sendChunkText $ tshow e
|
|
||||||
sendChunkText "\n"
|
|
||||||
Just (Left (Right t)) -> do
|
|
||||||
sendChunkText "SUCCESS: "
|
|
||||||
sendChunkText t
|
|
||||||
sendChunkText "\n"
|
|
||||||
Just (Right t) -> do
|
|
||||||
cont t
|
|
||||||
displayStatus t
|
|
||||||
displayStatus ""
|
|
||||||
|
|
||||||
doUpload :: TVar Text
|
|
||||||
-> UserId
|
|
||||||
-> PackageSetIdent
|
|
||||||
-> FilePath -- ^ temporary bundle file
|
|
||||||
-> Handler Text
|
|
||||||
doUpload status uid ident bundleFP = do
|
|
||||||
say $ "Uploading to persistent storage with ident " ++ toPathPiece ident
|
|
||||||
sourceFile bundleFP $$ storeWrite (HaddockBundle ident)
|
|
||||||
threadDelay 1000000 -- FIXME remove
|
|
||||||
|
|
||||||
say $ "Unpacking bundle"
|
|
||||||
|
|
||||||
(siType, siPlan, siDocMap :: DocMap) <-
|
|
||||||
withSystemTempDirectory "uploadv2" $ \dir' -> do
|
|
||||||
let dir = fpFromString dir'
|
|
||||||
withCheckedProcess
|
|
||||||
(proc "tar" ["xf", fpToString bundleFP])
|
|
||||||
{ cwd = Just dir'
|
|
||||||
} $ \ClosedStream ClosedStream ClosedStream -> return ()
|
|
||||||
|
|
||||||
let maxFileSize = 1024 * 1024 * 5
|
|
||||||
yaml :: FromJSON a => FilePath -> Handler a
|
|
||||||
yaml fp = do
|
|
||||||
say $ "Parsing " ++ fpToText fp
|
|
||||||
bs <- sourceFile (dir </> fp) $$ takeCE maxFileSize =$ foldC
|
|
||||||
either throwM return $ decodeEither' bs
|
|
||||||
|
|
||||||
(,,)
|
|
||||||
<$> yaml "build-type.yaml"
|
|
||||||
<*> yaml "build-plan.yaml"
|
|
||||||
<*> yaml "docs-map.yaml"
|
|
||||||
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
|
|
||||||
let theSiGhcVersion = siGhcVersion $ bpSystemInfo siPlan
|
|
||||||
ghcVersion = display theSiGhcVersion
|
|
||||||
ghcMajorVersionMay = case versionBranch theSiGhcVersion of
|
|
||||||
(a:b:_) -> Just (GhcMajorVersion a b)
|
|
||||||
_ -> Nothing
|
|
||||||
slug' <-
|
|
||||||
case siType of
|
|
||||||
STNightly -> invalidArgs ["No longer support STNightly, use STNightly2"]
|
|
||||||
STNightly2 day -> return $ "nightly-" ++ tshow day
|
|
||||||
STLTS major minor -> return $ concat
|
|
||||||
[ "lts-"
|
|
||||||
, tshow major
|
|
||||||
, "."
|
|
||||||
, tshow minor
|
|
||||||
]
|
|
||||||
title <-
|
|
||||||
case siType of
|
|
||||||
STNightly -> invalidArgs ["No longer support STNightly, use STNightly2"]
|
|
||||||
STNightly2 day -> return $ concat
|
|
||||||
[ "Stackage Nightly "
|
|
||||||
, tshow day
|
|
||||||
, ", GHC "
|
|
||||||
, ghcVersion
|
|
||||||
]
|
|
||||||
STLTS major minor -> return $ concat
|
|
||||||
[ "LTS Haskell "
|
|
||||||
, tshow major
|
|
||||||
, "."
|
|
||||||
, tshow minor
|
|
||||||
, ", GHC "
|
|
||||||
, ghcVersion
|
|
||||||
]
|
|
||||||
|
|
||||||
slug <- do
|
|
||||||
slug2 <- mkSlug slug'
|
|
||||||
when (slug' /= unSlug slug2) $ error $ "Slug not available: " ++ show slug'
|
|
||||||
return $ SnapSlug slug2
|
|
||||||
|
|
||||||
mexisting <- runDB $ getBy $ UniqueSnapshot slug
|
|
||||||
route <- case mexisting of
|
|
||||||
Just _ -> do
|
|
||||||
say "Snapshot already exists"
|
|
||||||
return $ SnapshotR slug StackageHomeR
|
|
||||||
Nothing -> finishUpload
|
|
||||||
title ident ghcVersion ghcMajorVersionMay slug now siType siPlan siDocMap
|
|
||||||
uid say
|
|
||||||
render <- getUrlRender
|
|
||||||
return $ render route
|
|
||||||
where
|
|
||||||
say = atomically . writeTVar status
|
|
||||||
|
|
||||||
finishUpload
|
|
||||||
:: Text
|
|
||||||
-> PackageSetIdent
|
|
||||||
-> Text
|
|
||||||
-> Maybe GhcMajorVersion
|
|
||||||
-> SnapSlug
|
|
||||||
-> UTCTime
|
|
||||||
-> SnapshotType
|
|
||||||
-> BuildPlan
|
|
||||||
-> Map Text PackageDocs
|
|
||||||
-> UserId
|
|
||||||
-> (Text -> Handler ())
|
|
||||||
-> Handler (Route App)
|
|
||||||
finishUpload
|
|
||||||
title ident ghcVersion ghcMajorVersionMay slug now siType siPlan siDocMap
|
|
||||||
uid say = do
|
|
||||||
say "Creating index tarball"
|
|
||||||
withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do
|
|
||||||
files <- forM (mapToList $ fmap ppVersion $ bpPackages siPlan) $ \(name', version') -> do
|
|
||||||
let mpair = (,)
|
|
||||||
<$> fromPathPiece (display name')
|
|
||||||
<*> fromPathPiece (display version')
|
|
||||||
(name, version) <-
|
|
||||||
case mpair of
|
|
||||||
Nothing -> error $ "Could not parse: " ++ show (name', version')
|
|
||||||
Just pair -> return pair
|
|
||||||
|
|
||||||
msrc <- storeRead (HackageCabal name version)
|
|
||||||
src <-
|
|
||||||
case msrc of
|
|
||||||
Nothing -> error $ "Cabal file not found for: " ++ show (name, version)
|
|
||||||
Just src -> return src
|
|
||||||
|
|
||||||
let fp' = fpFromText (toPathPiece name)
|
|
||||||
</> fpFromText (toPathPiece version)
|
|
||||||
</> fpFromText (concat
|
|
||||||
[ toPathPiece name
|
|
||||||
, "-"
|
|
||||||
, toPathPiece version
|
|
||||||
, ".cabal"
|
|
||||||
])
|
|
||||||
let fp = dir </> fp'
|
|
||||||
|
|
||||||
liftIO $ createTree $ parent fp
|
|
||||||
src $$ sinkFile fp
|
|
||||||
return $ fpToString fp'
|
|
||||||
|
|
||||||
withSystemTempFile "newindex.v2" $ \fp' h -> do
|
|
||||||
liftIO $ do
|
|
||||||
hClose h
|
|
||||||
let args = "cfz"
|
|
||||||
: fp'
|
|
||||||
: files
|
|
||||||
cp = (proc "tar" args) { cwd = Just $ fpToString dir }
|
|
||||||
withCheckedProcess cp $ \ClosedStream Inherited Inherited ->
|
|
||||||
return ()
|
|
||||||
sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
|
|
||||||
|
|
||||||
say $ "Attempting: " ++ tshow (slug, title)
|
|
||||||
sid <- runDB $ do
|
|
||||||
sid <- insert Stackage
|
|
||||||
{ stackageUser = uid
|
|
||||||
, stackageIdent = ident
|
|
||||||
, stackageSlug = slug
|
|
||||||
, stackageUploaded = now
|
|
||||||
, stackageTitle = title
|
|
||||||
, stackageDesc = ""
|
|
||||||
, stackageHasHaddocks = True
|
|
||||||
, stackageGhcMajorVersion = ghcMajorVersionMay
|
|
||||||
}
|
|
||||||
case siType of
|
|
||||||
STNightly -> invalidArgs ["No longer support STNightly, use STNightly2"]
|
|
||||||
STNightly2 day -> insert_ Nightly
|
|
||||||
{ nightlyDay = day
|
|
||||||
, nightlyGhcVersion = ghcVersion
|
|
||||||
, nightlyStackage = sid
|
|
||||||
}
|
|
||||||
STLTS major minor -> insert_ Lts
|
|
||||||
{ ltsMajor = major
|
|
||||||
, ltsMinor = minor
|
|
||||||
, ltsStackage = sid
|
|
||||||
}
|
|
||||||
|
|
||||||
let cores, nonCores :: Map PackageName Version
|
|
||||||
cores = mapKeysWith const (PackageName . display)
|
|
||||||
$ fmap (Version . display)
|
|
||||||
$ siCorePackages
|
|
||||||
$ bpSystemInfo siPlan
|
|
||||||
nonCores
|
|
||||||
= mapKeysWith const (PackageName . display)
|
|
||||||
$ fmap (Version . display . ppVersion)
|
|
||||||
$ bpPackages siPlan
|
|
||||||
forM_ (mapToList $ cores ++ nonCores) $ \(name, version) -> do
|
|
||||||
let PackageName nameT = name
|
|
||||||
insert_ Package
|
|
||||||
{ packageStackage = sid
|
|
||||||
, packageName' = name
|
|
||||||
, packageVersion = version
|
|
||||||
, packageHasHaddocks = nameT `member` siDocMap
|
|
||||||
, packageOverwrite = False
|
|
||||||
, packageCore = Just $ name `member` cores
|
|
||||||
}
|
|
||||||
return sid
|
|
||||||
|
|
||||||
say $ concat
|
|
||||||
[ "New snapshot with ID "
|
|
||||||
, toPathPiece sid
|
|
||||||
, " and slug "
|
|
||||||
, toPathPiece slug
|
|
||||||
, " created"
|
|
||||||
]
|
|
||||||
|
|
||||||
render <- getUrlRender
|
|
||||||
|
|
||||||
say "Updating docmap"
|
|
||||||
runDB $ forM_ (mapToList siDocMap) $ \(package, PackageDocs version ms) -> do
|
|
||||||
did <- insert Docs
|
|
||||||
{ docsName = PackageName package
|
|
||||||
, docsVersion = Version version
|
|
||||||
, docsUploaded = now
|
|
||||||
, docsSnapshot = Just sid
|
|
||||||
}
|
|
||||||
forM_ (mapToList ms) $ \(name, pieces) -> do
|
|
||||||
let url = render $ HaddockR slug pieces
|
|
||||||
insert_ $ Module did name url
|
|
||||||
|
|
||||||
return $ SnapshotR slug StackageHomeR
|
|
||||||
25
Import.hs
25
Import.hs
@ -34,28 +34,3 @@ parseLtsPair t1 = do
|
|||||||
t3 <- stripPrefix "." t2
|
t3 <- stripPrefix "." t2
|
||||||
(y, "") <- either (const Nothing) Just $ decimal t3
|
(y, "") <- either (const Nothing) Just $ decimal t3
|
||||||
Just (x, y)
|
Just (x, y)
|
||||||
|
|
||||||
requireDocs :: Entity Stackage -> Handler ()
|
|
||||||
requireDocs stackageEnt = do
|
|
||||||
master <- getYesod
|
|
||||||
status <- liftIO $ duRequestDocs (appDocUnpacker master) stackageEnt
|
|
||||||
case status of
|
|
||||||
USReady -> return ()
|
|
||||||
USBusy -> (>>= sendResponse) $ defaultLayout $ do
|
|
||||||
setTitle "Docs unpacking, please wait"
|
|
||||||
addHeader "Refresh" "1"
|
|
||||||
msg <- liftIO $ duGetStatus $ appDocUnpacker master
|
|
||||||
[whamlet|
|
|
||||||
<div .container>
|
|
||||||
<p>Docs are currently being unpacked, please wait.
|
|
||||||
<p>This page will automatically reload every second.
|
|
||||||
<p>Current status: #{msg}
|
|
||||||
|]
|
|
||||||
USFailed e -> do
|
|
||||||
$logWarn $ "Docs not available: " ++ tshow
|
|
||||||
( stackageSlug $ entityVal stackageEnt
|
|
||||||
, e
|
|
||||||
)
|
|
||||||
invalidArgs
|
|
||||||
[ "Docs not available: " ++ e
|
|
||||||
]
|
|
||||||
|
|||||||
103
config/models
103
config/models
@ -15,36 +15,6 @@ Verkey
|
|||||||
email Text
|
email Text
|
||||||
verkey Text
|
verkey Text
|
||||||
|
|
||||||
DocsOnS3
|
|
||||||
slug SnapSlug
|
|
||||||
UniqueDocsOnS3 slug
|
|
||||||
|
|
||||||
Stackage
|
|
||||||
user UserId
|
|
||||||
ident PackageSetIdent
|
|
||||||
slug SnapSlug default="md5((random())::text)"
|
|
||||||
uploaded UTCTime
|
|
||||||
title Text
|
|
||||||
desc Text
|
|
||||||
hasHaddocks Bool default=false
|
|
||||||
ghcMajorVersion GhcMajorVersion Maybe
|
|
||||||
UniqueStackage ident
|
|
||||||
UniqueSnapshot slug
|
|
||||||
|
|
||||||
Alias
|
|
||||||
user UserId
|
|
||||||
name Slug
|
|
||||||
target PackageSetIdent
|
|
||||||
UniqueAlias user name
|
|
||||||
|
|
||||||
Package
|
|
||||||
stackage StackageId
|
|
||||||
name' PackageName sql=name
|
|
||||||
version Version
|
|
||||||
hasHaddocks Bool default=true
|
|
||||||
overwrite Bool
|
|
||||||
core Bool Maybe -- use Maybe to speed up migration
|
|
||||||
|
|
||||||
Tag
|
Tag
|
||||||
package PackageName
|
package PackageName
|
||||||
tag Slug
|
tag Slug
|
||||||
@ -56,54 +26,6 @@ Like
|
|||||||
voter UserId
|
voter UserId
|
||||||
UniqueLikePackageVoter package voter
|
UniqueLikePackageVoter package voter
|
||||||
|
|
||||||
Download
|
|
||||||
ident PackageSetIdent Maybe
|
|
||||||
view Text Maybe MigrationOnly
|
|
||||||
timestamp UTCTime
|
|
||||||
package PackageName
|
|
||||||
version Version
|
|
||||||
userAgent Text Maybe
|
|
||||||
|
|
||||||
Metadata
|
|
||||||
name PackageName
|
|
||||||
version Version
|
|
||||||
hash ByteString
|
|
||||||
deps [Text]
|
|
||||||
author Text
|
|
||||||
maintainer Text
|
|
||||||
licenseName Text
|
|
||||||
homepage Text
|
|
||||||
bugReports Text
|
|
||||||
synopsis Text
|
|
||||||
sourceRepo [Text]
|
|
||||||
category Text
|
|
||||||
library Bool
|
|
||||||
exes Int
|
|
||||||
testSuites Int
|
|
||||||
benchmarks Int
|
|
||||||
|
|
||||||
readme Html
|
|
||||||
changelog Html Maybe
|
|
||||||
licenseContent Html Maybe
|
|
||||||
|
|
||||||
UniqueMetadata name
|
|
||||||
|
|
||||||
Docs
|
|
||||||
name PackageName
|
|
||||||
version Version
|
|
||||||
uploaded UTCTime
|
|
||||||
snapshot StackageId Maybe
|
|
||||||
Module
|
|
||||||
docs DocsId
|
|
||||||
name Text
|
|
||||||
url Text
|
|
||||||
UniqueModule docs name
|
|
||||||
|
|
||||||
Dependency
|
|
||||||
dep PackageName
|
|
||||||
user PackageName
|
|
||||||
UniqueDependency dep user
|
|
||||||
|
|
||||||
BannedTag
|
BannedTag
|
||||||
tag Slug
|
tag Slug
|
||||||
UniqueBannedTag tag
|
UniqueBannedTag tag
|
||||||
@ -111,28 +33,3 @@ BannedTag
|
|||||||
Migration
|
Migration
|
||||||
num Int
|
num Int
|
||||||
UniqueMigration num
|
UniqueMigration num
|
||||||
|
|
||||||
Nightly
|
|
||||||
day Day
|
|
||||||
ghcVersion Text
|
|
||||||
stackage StackageId
|
|
||||||
UniqueNightly day
|
|
||||||
|
|
||||||
Lts
|
|
||||||
major Int
|
|
||||||
minor Int
|
|
||||||
stackage StackageId
|
|
||||||
UniqueLts major minor
|
|
||||||
|
|
||||||
Deprecated
|
|
||||||
package PackageName
|
|
||||||
UniqueDeprecated package
|
|
||||||
|
|
||||||
Suggested
|
|
||||||
package PackageName
|
|
||||||
insteadOf PackageName
|
|
||||||
UniqueSuggested package insteadOf
|
|
||||||
|
|
||||||
UploadProgress
|
|
||||||
message Text
|
|
||||||
dest Text Maybe
|
|
||||||
|
|||||||
@ -11,15 +11,9 @@
|
|||||||
/profile ProfileR GET PUT
|
/profile ProfileR GET PUT
|
||||||
/email/#EmailId EmailR DELETE
|
/email/#EmailId EmailR DELETE
|
||||||
/reset-token ResetTokenR POST
|
/reset-token ResetTokenR POST
|
||||||
/upload UploadStackageR GET PUT
|
|
||||||
/upload-haddock/#Text UploadHaddockR GET PUT
|
|
||||||
/upload-doc-map UploadDocMapR GET PUT
|
|
||||||
|
|
||||||
/stackage/#PackageSetIdent/*Texts OldStackageR GET
|
|
||||||
|
|
||||||
/snapshot/#SnapSlug SnapshotR:
|
/snapshot/#SnapSlug SnapshotR:
|
||||||
/ StackageHomeR GET
|
/ StackageHomeR GET
|
||||||
/metadata StackageMetadataR GET
|
|
||||||
/cabal.config StackageCabalConfigR GET
|
/cabal.config StackageCabalConfigR GET
|
||||||
/00-index.tar.gz StackageIndexR GET
|
/00-index.tar.gz StackageIndexR GET
|
||||||
/package/#PackageNameVersion StackageSdistR GET
|
/package/#PackageNameVersion StackageSdistR GET
|
||||||
@ -30,15 +24,11 @@
|
|||||||
/build-plan BuildPlanR GET
|
/build-plan BuildPlanR GET
|
||||||
/ghc-major-version GhcMajorVersionR GET
|
/ghc-major-version GhcMajorVersionR GET
|
||||||
|
|
||||||
/aliases AliasesR PUT
|
|
||||||
/alias/#Slug/#Slug/*Texts AliasR
|
|
||||||
/progress/#UploadProgressId ProgressR GET
|
|
||||||
/system SystemR GET
|
/system SystemR GET
|
||||||
/haddock/#SnapSlug/*Texts HaddockR GET
|
/haddock/#SnapSlug/*Texts HaddockR GET
|
||||||
/package/#PackageName PackageR GET
|
/package/#PackageName PackageR GET
|
||||||
/package/#PackageName/snapshots PackageSnapshotsR GET
|
/package/#PackageName/snapshots PackageSnapshotsR GET
|
||||||
/package PackageListR GET
|
/package PackageListR GET
|
||||||
/compressor-status CompressorStatusR GET
|
|
||||||
/package/#PackageName/like PackageLikeR POST
|
/package/#PackageName/like PackageLikeR POST
|
||||||
/package/#PackageName/unlike PackageUnlikeR POST
|
/package/#PackageName/unlike PackageUnlikeR POST
|
||||||
/package/#PackageName/tag PackageTagR POST
|
/package/#PackageName/tag PackageTagR POST
|
||||||
@ -54,10 +44,7 @@
|
|||||||
/install InstallR GET
|
/install InstallR GET
|
||||||
/older-releases OlderReleasesR GET
|
/older-releases OlderReleasesR GET
|
||||||
|
|
||||||
/refresh-deprecated RefreshDeprecatedR GET
|
|
||||||
/upload2 UploadV2R PUT
|
|
||||||
/build-version BuildVersionR GET
|
/build-version BuildVersionR GET
|
||||||
/package-counts PackageCountsR GET
|
|
||||||
|
|
||||||
/download DownloadR GET
|
/download DownloadR GET
|
||||||
/download/snapshots.json DownloadSnapshotsJsonR GET
|
/download/snapshots.json DownloadSnapshotsJsonR GET
|
||||||
|
|||||||
@ -24,38 +24,28 @@ library
|
|||||||
Data.Tag
|
Data.Tag
|
||||||
Data.BlobStore
|
Data.BlobStore
|
||||||
Data.GhcLinks
|
Data.GhcLinks
|
||||||
Data.Hackage
|
|
||||||
Data.Hackage.DeprecationInfo
|
|
||||||
Data.WebsiteContent
|
Data.WebsiteContent
|
||||||
Data.Unpacking
|
|
||||||
Types
|
Types
|
||||||
Handler.Home
|
Handler.Home
|
||||||
Handler.Snapshots
|
Handler.Snapshots
|
||||||
Handler.Profile
|
Handler.Profile
|
||||||
Handler.Email
|
Handler.Email
|
||||||
Handler.ResetToken
|
Handler.ResetToken
|
||||||
Handler.UploadStackage
|
|
||||||
Handler.StackageHome
|
Handler.StackageHome
|
||||||
Handler.StackageIndex
|
Handler.StackageIndex
|
||||||
Handler.StackageSdist
|
Handler.StackageSdist
|
||||||
Handler.Aliases
|
|
||||||
Handler.Alias
|
|
||||||
Handler.Progress
|
|
||||||
Handler.System
|
Handler.System
|
||||||
Handler.Haddock
|
Handler.Haddock
|
||||||
Handler.Hoogle
|
Handler.Hoogle
|
||||||
Handler.Package
|
Handler.Package
|
||||||
Handler.PackageList
|
Handler.PackageList
|
||||||
Handler.CompressorStatus
|
|
||||||
Handler.Tag
|
Handler.Tag
|
||||||
Handler.BannedTags
|
Handler.BannedTags
|
||||||
Handler.RefreshDeprecated
|
|
||||||
Handler.UploadV2
|
|
||||||
Handler.BuildVersion
|
Handler.BuildVersion
|
||||||
Handler.PackageCounts
|
|
||||||
Handler.Sitemap
|
Handler.Sitemap
|
||||||
Handler.BuildPlan
|
Handler.BuildPlan
|
||||||
Handler.Download
|
Handler.Download
|
||||||
|
Handler.OldLinks
|
||||||
|
|
||||||
if flag(dev) || flag(library-only)
|
if flag(dev) || flag(library-only)
|
||||||
cpp-options: -DDEVELOPMENT
|
cpp-options: -DDEVELOPMENT
|
||||||
|
|||||||
@ -9,7 +9,7 @@
|
|||||||
<img src="/static/img/stackage.png" title="FP Complete">
|
<img src="/static/img/stackage.png" title="FP Complete">
|
||||||
<div class="nav-collapse collapse">
|
<div class="nav-collapse collapse">
|
||||||
<ul class="nav">
|
<ul class="nav">
|
||||||
$forall route <- [AllSnapshotsR,UploadStackageR]
|
$forall route <- [AllSnapshotsR]
|
||||||
$maybe current <- cur
|
$maybe current <- cur
|
||||||
$if route == current
|
$if route == current
|
||||||
<li .active>
|
<li .active>
|
||||||
|
|||||||
@ -25,21 +25,6 @@
|
|||||||
^{userWidget}
|
^{userWidget}
|
||||||
<button .btn>Update
|
<button .btn>Update
|
||||||
|
|
||||||
<h2>Aliases
|
|
||||||
|
|
||||||
<form method=post action=@{AliasesR}?_method=PUT>
|
|
||||||
Format: alias name, package set ID
|
|
||||||
<textarea #aliases name=aliases>#{unlines $ map aliasToText aliases}
|
|
||||||
<button .btn>Update
|
|
||||||
|
|
||||||
$if not $ null aliases
|
|
||||||
<dl>
|
|
||||||
$forall Entity _ alias <- aliases
|
|
||||||
<dt>#{aliasName alias}
|
|
||||||
<dd>
|
|
||||||
$with url <- AliasR (userHandle user) (aliasName alias) []
|
|
||||||
<a href=@{url}>@{url}
|
|
||||||
|
|
||||||
<h2>Security token
|
<h2>Security token
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user