mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
/lts and /nightly routes are set up
This commit is contained in:
Michael Snoyman
parent
8c90ad02d3
commit
529f9483cd
@ -1,7 +1,15 @@
|
||||
module Handler.Alias where
|
||||
module Handler.Alias
|
||||
( handleAliasR
|
||||
, getLtsR
|
||||
, getNightlyR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Data.Slug (Slug)
|
||||
import Data.Text.Read (decimal)
|
||||
import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR)
|
||||
import Handler.StackageIndex (getStackageIndexR, getStackageBundleR)
|
||||
import Handler.StackageSdist (getStackageSdistR)
|
||||
|
||||
handleAliasR :: Slug -> Slug -> [Text] -> Handler ()
|
||||
handleAliasR user name pieces = do
|
||||
@ -13,3 +21,66 @@ handleAliasR user name pieces = do
|
||||
case parseRoute ("stackage" : toPathPiece setid : pieces, []) of
|
||||
Nothing -> notFound
|
||||
Just route -> redirect (route :: Route App)
|
||||
|
||||
parseLtsPair :: Text -> Maybe (Int, Int)
|
||||
parseLtsPair t1 = do
|
||||
(x, t2) <- either (const Nothing) Just $ decimal t1
|
||||
t3 <- stripPrefix "." t2
|
||||
(y, "") <- either (const Nothing) Just $ decimal t3
|
||||
Just (x, y)
|
||||
|
||||
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
|
||||
StackageBundleR -> getStackageBundleR slug >>= sendResponse
|
||||
StackageSdistR pnv -> getStackageSdistR slug pnv >>= sendResponse
|
||||
_ -> notFound
|
||||
|
||||
@ -45,7 +45,7 @@ getUploadHaddockR slug0 = do
|
||||
master <- getYesod
|
||||
void $ liftIO $ forkIO $ haddockUnpacker master True ident
|
||||
setMessage "Haddocks uploaded"
|
||||
redirect $ StackageHomeR slug
|
||||
redirect $ SnapshotR slug StackageHomeR
|
||||
_ -> defaultLayout $ do
|
||||
setTitle "Upload Haddocks"
|
||||
$(widgetFile "upload-haddock")
|
||||
|
||||
@ -53,11 +53,11 @@ getHomeR = do
|
||||
#{asHtml title}
|
||||
<td>
|
||||
$maybe ex <- mex
|
||||
<a href=@{StackageHomeR ex}>exclusive
|
||||
<a href=@{SnapshotR ex StackageHomeR}>exclusive
|
||||
$if isJust mex && isJust min'
|
||||
<td>
|
||||
$maybe in <- min'
|
||||
<a href=@{StackageHomeR in}>inclusive
|
||||
<a href=@{SnapshotR in StackageHomeR}>inclusive
|
||||
|]
|
||||
where
|
||||
name suffix = concat ["unstable-", short, "-", suffix]
|
||||
|
||||
@ -125,7 +125,7 @@ putUploadStackageR = do
|
||||
|
||||
setAlias
|
||||
|
||||
done "Stackage created" $ StackageHomeR slug
|
||||
done "Stackage created" $ SnapshotR slug StackageHomeR
|
||||
else do
|
||||
done "Error creating index file" ProfileR
|
||||
|
||||
|
||||
@ -99,3 +99,15 @@ BannedTag
|
||||
Migration
|
||||
num Int
|
||||
UniqueMigration num
|
||||
|
||||
Nightly
|
||||
day Day
|
||||
ghcVersion Text
|
||||
stackage StackageId
|
||||
UniqueNightly day
|
||||
|
||||
Lts
|
||||
major Int
|
||||
minor Int
|
||||
stackage StackageId
|
||||
UniqueLts major minor
|
||||
|
||||
@ -15,12 +15,13 @@
|
||||
|
||||
/stackage/#PackageSetIdent/*Texts OldStackageR GET
|
||||
|
||||
/snapshot/#SnapSlug StackageHomeR GET
|
||||
/snapshot/#SnapSlug/metadata StackageMetadataR GET
|
||||
/snapshot/#SnapSlug/cabal.config StackageCabalConfigR GET
|
||||
/snapshot/#SnapSlug/00-index.tar.gz StackageIndexR GET
|
||||
/snapshot/#SnapSlug/bundle StackageBundleR GET
|
||||
/snapshot/#SnapSlug/package/#PackageNameVersion StackageSdistR GET
|
||||
/snapshot/#SnapSlug SnapshotR:
|
||||
/ StackageHomeR GET
|
||||
/metadata StackageMetadataR GET
|
||||
/cabal.config StackageCabalConfigR GET
|
||||
/00-index.tar.gz StackageIndexR GET
|
||||
/bundle StackageBundleR GET
|
||||
/package/#PackageNameVersion StackageSdistR GET
|
||||
|
||||
/hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET
|
||||
/hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET
|
||||
@ -39,3 +40,6 @@
|
||||
/tags TagListR GET
|
||||
/tag/#Slug TagR GET
|
||||
/banned-tags BannedTagsR GET PUT
|
||||
|
||||
/lts/*Texts LtsR GET
|
||||
/nightly/*Texts NightlyR GET
|
||||
|
||||
@ -8,7 +8,7 @@
|
||||
$forall (ident, title, _uploaded, display, handle) <- stackages
|
||||
<li>
|
||||
<strong>
|
||||
<a href=@{StackageHomeR ident}>
|
||||
<a href=@{SnapshotR ident StackageHomeR}>
|
||||
#{title}
|
||||
<p>
|
||||
#{display} (#{handle})
|
||||
|
||||
@ -131,7 +131,7 @@ $newline never
|
||||
<td>
|
||||
#{version}
|
||||
<td>
|
||||
<a href=@{StackageHomeR slug}>#{fromMaybe title $ stripSuffix ", exclusive" title}
|
||||
<a href=@{SnapshotR slug StackageHomeR}>#{fromMaybe title $ stripSuffix ", exclusive" title}
|
||||
|
||||
<div .markdown-container .readme-container>
|
||||
<div .container>
|
||||
|
||||
@ -7,15 +7,15 @@ $newline never
|
||||
$if hasBundle
|
||||
<span .separator>
|
||||
<span>
|
||||
<a href=@{StackageMetadataR slug} title="View metadata on this snapshot, such as package versions">
|
||||
<a href=@{SnapshotR slug StackageMetadataR} title="View metadata on this snapshot, such as package versions">
|
||||
\Metadata
|
||||
<span .separator>
|
||||
<span>
|
||||
<a href=@{StackageBundleR slug} title="This is useful for making modifications to an existing snapshot">
|
||||
<a href=@{SnapshotR slug StackageBundleR} title="This is useful for making modifications to an existing snapshot">
|
||||
\Bundle
|
||||
<span .separator>
|
||||
<span>
|
||||
<a href=@{StackageCabalConfigR slug} title="If you want to stick with upstream Hackage but get a stable package set">
|
||||
<a href=@{SnapshotR slug StackageCabalConfigR} title="If you want to stick with upstream Hackage but get a stable package set">
|
||||
\cabal.config
|
||||
$if stackageHasHaddocks stackage
|
||||
<span .separator>
|
||||
@ -28,7 +28,7 @@ $newline never
|
||||
.
|
||||
<p>
|
||||
<pre>
|
||||
remote-repo: stackage-#{slug}:@{StackageHomeR slug}
|
||||
remote-repo: stackage-#{slug}:@{SnapshotR slug StackageHomeR}
|
||||
$maybe _ <- minclusive
|
||||
<p>
|
||||
<a href="https://github.com/fpco/stackage/wiki/Stackage-Server-FAQ#whats-the-difference-between-inclusive-and-exclusive-snapshots">What's the difference between inclusive and exclusive snapshots?</a>
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
<h1>Upload Haddocks
|
||||
|
||||
<p>
|
||||
<a href=@{StackageHomeR slug}>Return to snapshot
|
||||
<a href=@{SnapshotR slug StackageHomeR}>Return to snapshot
|
||||
|
||||
$if stackageHasHaddocks
|
||||
<div .alert .alert-warning>You have already uploaded Haddocks. Uploading again will delete the old contents.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user